1 /******************************** -*- C -*- ****************************
2 *
3 * Byte code compiler.
4 *
5 *
6 ***********************************************************************/
7
8 /***********************************************************************
9 *
10 * Copyright 1988,89,90,91,92,94,95,99,2000,2001,2002,2003,2005,2006,2007,2008,2009
11 * Free Software Foundation, Inc.
12 * Written by Steve Byrne.
13 *
14 * This file is part of GNU Smalltalk.
15 *
16 * GNU Smalltalk is free software; you can redistribute it and/or modify it
17 * under the terms of the GNU General Public License as published by the Free
18 * Software Foundation; either version 2, or (at your option) any later
19 * version.
20 *
21 * Linking GNU Smalltalk statically or dynamically with other modules is
22 * making a combined work based on GNU Smalltalk. Thus, the terms and
23 * conditions of the GNU General Public License cover the whole
24 * combination.
25 *
26 * In addition, as a special exception, the Free Software Foundation
27 * give you permission to combine GNU Smalltalk with free software
28 * programs or libraries that are released under the GNU LGPL and with
29 * independent programs running under the GNU Smalltalk virtual machine.
30 *
31 * You may copy and distribute such a system following the terms of the
32 * GNU GPL for GNU Smalltalk and the licenses of the other code
33 * concerned, provided that you include the source code of that other
34 * code when and as the GNU GPL requires distribution of source code.
35 *
36 * Note that people who make modified versions of GNU Smalltalk are not
37 * obligated to grant this special exception for their modified
38 * versions; it is their choice whether to do so. The GNU General
39 * Public License gives permission to release a modified version without
40 * this exception; this exception also makes it possible to release a
41 * modified version which carries forward this exception.
42 *
43 * GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
44 * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
45 * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
46 * more details.
47 *
48 * You should have received a copy of the GNU General Public License along with
49 * GNU Smalltalk; see the file COPYING. If not, write to the Free Software
50 * Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
51 *
52 ***********************************************************************/
53
54 #include "gstpriv.h"
55
56 /* To do: extract the iterative solving of the loop jumps' size. */
57
58 /* Define this if you want declaration tracing to print the bytecodes
59 both *before* and *after* the optimizer is ran. Default behavior
60 is to print the bytecodes only after the optimization pass; usually
61 it is only needed to debug the optimizer -- when debugging the
62 compiler you should turn off optimization entirely (see NO_OPTIMIZE
63 in opt.c). */
64 /* #define PRINT_BEFORE_OPTIMIZATION */
65
66 /* Define this to verify the methods after they are compiled. This
67 is useless because anyway after an image is saved methods are
68 re-verified, but is a wonderful way of testing the compiler's
69 output for correctness. */
70 /* #define VERIFY_COMPILED_METHODS */
71
72 #define LITERAL_VEC_CHUNK_SIZE 32
73
74
75 typedef struct method_attributes
76 {
77 struct method_attributes *next;
78 int count;
79 OOP oop;
80 } method_attributes;
81
82
83 /* This holds whether the compiler should make the compiled methods
84 untrusted. */
85 mst_Boolean _gst_untrusted_methods = false;
86
87 /* These hold the compiler's notions of the current class for
88 compilations, and the current category that compiled methods are to
89 be placed into. */
90 OOP _gst_this_class = NULL;
91 OOP _gst_this_category = NULL;
92 static OOP this_method_category;
93
94 /* This holds the gst_compiled_method oop for the most recently
95 compiled method. It is only really valid after a compile: has been
96 done, but this is the only place that its used. */
97 OOP _gst_latest_compiled_method = NULL;
98
99 /* This flag controls whether byte codes are printed after
100 compilation. */
101 int _gst_declare_tracing = 0;
102
103 /* If true, the compilation of a set of methods will be skipped
104 completely; only syntax will be checked. Set by primitive, cleared
105 by grammar. */
106 mst_Boolean _gst_skip_compilation = false;
107
108 /* This is the value most recently returned by
109 _gst_execute_statements. It is used to communicate the returned
110 value past a _gst_parse_stream call, without pushing something on
111 the called context stack in the case of nested invocations of
112 _gst_prepare_execution_environment/_gst_finish_execution_environment.
113 Most often, the caller does not care about the returned value,
114 since it often is called from a radically different context. */
115 OOP _gst_last_returned_value = NULL;
116
117
118
119 /* Returns true if EXPR represents the symbol "super"; false if not. */
120 static mst_Boolean is_super (tree_node expr);
121
122 /* Returns true if OOP and CONSTEXPR represent the same literal value.
123 Primarily used by the compiler to store a single copy of duplicated
124 literals in a method. Can call itself in the case array
125 literals. */
126 static mst_Boolean equal_constant (OOP oop,
127 tree_node constExpr);
128
129
130 /* Special case compilation of a #timesRepeat: loop. EXPR is a node
131 for the entire keyword message send. Returns true if byte codes
132 were emitted, false if not. If the last argument to the message is
133 not a block expression, this routine cannot do its job, and so
134 returns false to indicate as much. */
135 static mst_Boolean compile_times_repeat (tree_node expr);
136
137 /* Special case compilation of a while loop whose selector is in
138 SELECTOR. EXPR is a node for the entire unary or keyword message
139 send. Returns true if byte codes were emitted, false if not. If
140 the last argument to the message is not a block expression, this
141 routine cannot do its job, and so returns false to indicate as
142 much. */
143 static mst_Boolean compile_while_loop (OOP selector,
144 tree_node expr);
145
146 /* Special case compilation of a 1-argument if (#ifTrue: or #ifFalse:)
147 whose selector is in SELECTOR; the default value for the absent
148 case is nil. EXPR is a node for the entire keyword message send.
149 Returns true if byte codes were emitted, false if not. If the last
150 argument to the message is not a block expression, this routine
151 cannot do its job, and so returns false to indicate as much. */
152 static mst_Boolean compile_if_statement (OOP selector,
153 tree_node expr);
154
155 /* Special case compilation of a #to:do: (if BY is NULL) or #to:by:do:
156 loop. The starting value for the iteration is given by TO, the block
157 is in BLOCK. Returns true if byte codes were emitted, false if
158 not. If the last argument to the message is not a block expression,
159 this routine cannot do its job, and so returns false to indicate as
160 much. */
161 static mst_Boolean compile_to_by_do (tree_node to,
162 tree_node by,
163 tree_node block);
164
165 /* Special case compilation of a #and: or #or: boolean operation; very
166 similar to compile_if_statement. EXPR is a node for the entire
167 keyword message send. Returns true if byte codes were emitted,
168 false if not. If the last argument to the message is not a block
169 expression, this routine cannot do its job, and so returns false to
170 indicate as much. */
171 static mst_Boolean compile_and_or_statement (OOP selector,
172 tree_node expr);
173
174 /* Special case compilation of a 2-argument if whose selector is in
175 SELECTOR. EXPR is a node for the entire keyword message send.
176 Returns true if byte codes were emitted, false if not. If the last
177 argument to the message is not a block expression, this routine
178 cannot do its job, and so returns false to indicate as much. */
179 static mst_Boolean compile_if_true_false_statement (OOP selector,
180 tree_node expr);
181
182 /* Special case compilation of an infinite loop, given by the parse
183 node in RECEIVER. Returns true if byte codes were emitted, false
184 if not. If the last argument to the message is not a block
185 expression, this routine cannot do its job, and so returns false to
186 indicate as much. */
187 static mst_Boolean compile_repeat (tree_node receiver);
188
189 /* Compiles all of the statements in STATEMENTLIST. If ISBLOCK is
190 true, adds a final instruction of the block to return the top of
191 stack, if the final statement isn't an explicit return from method
192 (^). Returns whether the last statement was a return (whatever
193 the value of ISBLOCK. */
194 static mst_Boolean compile_statements (tree_node statementList,
195 mst_Boolean isBlock);
196
197 /* Given a tree_node, this routine picks out and concatenates the
198 keywords in SELECTOREXPR (if a TREE_KEYWORD_EXPR) or extracts the
199 selector (if a TREE_UNARY_EXPR or TREE_BINARY_EXPR). Then it turns
200 them into a symbol OOP and returns that symbol. */
201 static OOP compute_selector (tree_node selectorExpr);
202
203 /* Creates a new Array object that contains the literals for the
204 method that's being compiled and returns it. As a side effect, the
205 currently allocated working literal vector is freed. If there were
206 no literals for the current method, _gst_nil_oop is returned. */
207 static OOP get_literals_array (void);
208
209 /* Process the attributes in ATTRIBUTELIST, return the primitive number.
210 Also record a <category: ...> attribute in this_method_category. */
211 static int process_attributes_tree (tree_node attributeList);
212
213 /* Process the attribute in MESSAGEOOP, return the primitive number
214 (so far, this is the only attribute we honor), -1 for a bad
215 primitive number, or 0 for other attributes. */
216 static int process_attribute (OOP messageOOP);
217
218 /* Creates and returns a CompiledMethod. The method is completely
219 filled in, including the descriptor, the method literals, and the
220 byte codes for the method. */
221 static OOP method_new (method_header header,
222 OOP literals,
223 bc_vector bytecodes,
224 OOP class,
225 OOP methodDesc);
226
227 /* Returns an instance of MethodInfo. This instance is used in the
228 reconstruction of the source code for the method, and holds the
229 category that the method belongs to. */
230 static OOP method_info_new (OOP class,
231 OOP selector,
232 method_attributes *attrs,
233 OOP sourceCode,
234 OOP categoryOOP);
235
236 /* This creates a CompiledBlock for the given BYTECODES. The bytecodes
237 are passed through the peephole optimizer and stored, the header is
238 filled according to the given number of arguments ARGS and
239 temporaries TEMPS, and to the cleanness of the block. STACK_DEPTH
240 contains the number of stack slots needed by the block except for
241 arguments and temporaries. */
242 static OOP make_block (int args,
243 int temps,
244 bc_vector bytecodes,
245 int stack_depth);
246
247 /* Create a BlockClosure for the given CompiledBlock, BLOCKOOP. */
248 static OOP make_clean_block_closure (OOP blockOOP);
249
250 /* Compiles a block tree node, EXPR, in a separate context and return
251 the resulting bytecodes. The block's argument declarations are
252 ignored since they are handled by compile_to_by_do (and are absent
253 for other methods like ifTrue:, and:, whileTrue:, etc.); there are
254 no temporaries. It is compiled as a list of statements such that
255 the last statement leaves the value that is produced on the stack,
256 as the value of the "block". */
257 static bc_vector compile_sub_expression (tree_node expr);
258
259 /* Like compile_sub_expression, except that after compiling EXPR this
260 subexpression always ends with an unconditional branch past
261 BRANCHLEN bytecodes. */
262 static bc_vector compile_sub_expression_and_jump (tree_node expr,
263 int branchLen);
264
265 /* Compile a send with the given RECEIVER (used to check for sends to
266 super), SELECTOR and number of arguments NUMARGS. */
267 static void compile_send (tree_node receiver,
268 OOP selector,
269 int numArgs);
270
271 /* Computes and returns the length of a parse tree list, LISTEXPR. */
272 static int list_length (tree_node listExpr);
273
274 /* Adds OOP to the literals associated with the method being compiled
275 and returns the index of the literal slot that was used (0-based).
276 Does not check for duplicates. Automatically puts OOP in the
277 incubator. */
278 static int add_literal (OOP oop);
279
280 /* Compiles STMT, which is a statement expression, including return
281 expressions. */
282 static void compile_statement (tree_node stmt);
283
284 /* Compile EXPR, which is an arbitrary expression, including an
285 assignment expression. */
286 static void compile_expression (tree_node expr);
287
288 /* The basic expression compiler. Often called recursively,
289 dispatches based on the type of EXPR to different routines that
290 specialize in compilations for that expression. */
291 static void compile_simple_expression (tree_node expr);
292
293 /* Compile code to push the value of a variable onto the stack. The
294 special variables, self, true, false, super, and thisContext, are
295 handled specially. For other variables, different code is emitted
296 depending on where the variable lives, such as in a global variable
297 or in a method temporary. */
298 static void compile_variable (tree_node varName);
299
300 /* Compile an expression that pushes a constant expression CONSTEXPR
301 onto the stack. Special cases out the constants that the byte code
302 interpreter knows about, which are the integers in the range -1 to
303 2. Tries to emit the shortest possible byte sequence. */
304 static void compile_constant (tree_node constExpr);
305
306 /* Compile the expressions for a block whose parse tree is BLOCKEXPR.
307 Also, emits code to push the BlockClosure object, and creates the
308 BlockClosure together with its CompiledBlock. */
309 static void compile_block (tree_node blockExpr);
310
311 /* Compiles all of the statements in arrayConstructor, preceded by
312 (Array new: <size of the list>) and with each statement followed
313 with a <pop into instance variable of new stack top> instead of a
314 simple pop. */
315 static void compile_array_constructor (tree_node arrayConstructor);
316
317 /* Compile code to evaluate a unary expression EXPR. Special cases
318 sends to "super". Also, checks to see if it's the first part of a
319 cascaded message send and if so emits code to duplicate the stack
320 top after the evaluation of the receiver for use by the subsequent
321 cascaded expressions. */
322 static void compile_unary_expr (tree_node expr);
323
324 /* Compile code to evaluate a binary expression EXPR. Special cases
325 sends to "super" and open codes whileTrue/whileFalse/repeat when
326 the receiver is a block. Also, checks to see if it's the first
327 part of a cascaded message send and if so emits code to duplicate
328 the stack top after the evaluation of the receiver for use by the
329 subsequent cascaded expressions. */
330 static void compile_binary_expr (tree_node expr);
331
332 /* Compile code to evaluate a keyword expression EXPR. Special cases
333 sends to "super" and open codes while loops, the 4 kinds of if
334 tests, and the conditional #and: and conditional #or: messages,
335 #to:do:, and #to:by:do: with an Integer step. Also, checks to see
336 if it's the first part of a cascaded message send and if so emits
337 code to duplicate the stack top after the evaluation of the
338 receiver for use by the subsequent cascaded expressions. */
339 static void compile_keyword_expr (tree_node expr);
340
341 /* Compiles the code for a cascaded message send. Due to the fact
342 that cascaded sends go to the receiver of the last message before
343 the first cascade "operator" (the ";"), the system to perform
344 cascaded message sends is a bit kludgy. We basically turn on a
345 flag to the compiler that indicates that the value of the receiver
346 of the last message before the cascaded sends is to be duplicated;
347 and then compile code for each cascaded expression, throwing away
348 the result, and duplicating the original receiver so that it can be
349 used by the current message send, and following ones.
350
351 Note that both the initial receiver and all the subsequent cascaded
352 sends can be derived from CASCADEDEXPR. */
353 static void compile_cascaded_message (tree_node cascadedExpr);
354
355 /* Compiles all the assignments in VARLIST, which is a tree_node of
356 type listNode. The generated code assumes that the value on the
357 top of the stack is what's to be used for the assignment. Since
358 this routine has no notion of now the value on top of the stack
359 will be used by the calling environment, it makes sure that when
360 the assignments are through, that the value on top of the stack
361 after the assignment is the same as the value on top of the stack
362 before the assignment. The optimizer should fix this in the
363 unnecessary cases. */
364 static void compile_assignments (tree_node varList);
365
366 /* Compiles a forward jump instruction LEN bytes away (LEN must be >
367 0), using the smallest possible number of bytecodes. JUMPTYPE
368 indicates which among the unconditional, "jump if true" and "jump
369 if false" opcodes is desired. Special cases for the short
370 unconditional jump and the short false jump that the byte code
371 interpreter handles. */
372 static void compile_jump (int len,
373 mst_Boolean jumpType);
374
375 /* Emit code to evaluate each argument to a keyword message send,
376 taking them from the parse tree node LIST. */
377 static void compile_keyword_list (tree_node list);
378
379 /* Called to grow the literal vector that the compiler is using. Modifies
380 the global variables LITERAL_VEC and LITERAL_VEC_MAX to reflect the
381 growth. */
382 static void realloc_literal_vec (void);
383
384 /* Takes a new CompiledMethod METHODOOP and installs it in the method
385 dictionary for the current class. If the current class does not
386 contain a valid method dictionary, one is allocated for it. */
387 static void install_method (OOP methodOOP);
388
389 /* This caches the OOP of the special UndefinedObject>>#__terminate
390 method, which is executed by contexts created with
391 _gst_prepare_execution_environment. */
392 static OOP termination_method;
393
394 /* Used to abort really losing compiles, jumps back to the top level
395 of the compiler */
396 static jmp_buf bad_method;
397
398 /* The linked list of attributes that are specified by the method. */
399 static method_attributes *method_attrs = NULL;
400
401 /* The vector of literals that the compiler uses to accumulate literal
402 constants into */
403 static OOP *literal_vec = NULL;
404
405 /* These indicate the first free slot in the vector of literals in the
406 method being compiled, and the first slot past the literal vector */
407 static OOP *literal_vec_curr, *literal_vec_max;
408
409 /* This indicates whether we are compiling a block */
410 static int inside_block;
411
412 /* HACK ALERT!! HACK ALERT!! This variable is used for cascading.
413 The tree structure is all wrong for the code in cascade processing
414 to find the receiver of the initial message. What this does is
415 when it's true, compile_unary_expr, compile_binary_expr, and
416 compile_keyword_expr record its value, and clear the global (to
417 prevent propagation to compilation of subnodes). After compiling
418 their receiver, if the saved value of the flag is true, they emit a
419 DUP_STACK_TOP, and continue compilation. Since cascaded sends are
420 relatively rare, I figured that this was a better alternative than
421 passing useless parameters around all the time. */
422 static mst_Boolean dup_message_receiver = false;
423
424
425 /* Exit a really losing compilation */
426 #define EXIT_COMPILATION() \
427 longjmp(bad_method, 1)
428
429 /* Answer whether the BLOCKNODE parse node has temporaries or
430 arguments. */
431 #define HAS_PARAMS_OR_TEMPS(blockNode) \
432 (blockNode->v_block.temporaries || blockNode->v_block.arguments)
433
434 /* Answer whether the BLOCKNODE parse node has temporaries and
435 has not exactly one argument. */
436 #define HAS_NOT_ONE_PARAM_OR_TEMPS(blockNode) \
437 (blockNode->v_block.temporaries \
438 || !blockNode->v_block.arguments \
439 || blockNode->v_block.arguments->v_list.next)
440
441
442 void
_gst_install_initial_methods(void)443 _gst_install_initial_methods (void)
444 {
445 const char *methodsForString;
446
447 /* Define the termination method first of all, because
448 compiling #methodsFor: will invoke an evaluation
449 (to get the argument of the <primitive: ...> attribute. */
450 _gst_set_compilation_class (_gst_undefined_object_class);
451 _gst_set_compilation_category (_gst_string_new ("private"));
452 _gst_alloc_bytecodes ();
453 _gst_compile_byte (EXIT_INTERPRETER, 0);
454 _gst_compile_byte (JUMP_BACK, 4);
455
456 /* The zeros are primitive, # of args, # of temps, stack depth */
457 termination_method = _gst_make_new_method (0, 0, 0, 0, _gst_nil_oop,
458 _gst_get_bytecodes (),
459 _gst_this_class,
460 _gst_terminate_symbol,
461 _gst_this_category, -1, -1);
462
463 ((gst_compiled_method) OOP_TO_OBJ (termination_method))->header.headerFlag
464 = MTH_ANNOTATED;
465
466 install_method (termination_method);
467
468 methodsForString = "\n\
469 methodsFor: aCategoryString [\n\
470 \"Calling this method prepares the parser to receive methods \n\
471 to be compiled and installed in the receiver's method dictionary. \n\
472 The methods are put in the category identified by the parameter.\" \n\
473 <primitive: VMpr_Behavior_methodsFor> \n\
474 ]";
475 _gst_set_compilation_class (_gst_behavior_class);
476 _gst_set_compilation_category (_gst_string_new ("compiling methods"));
477 _gst_push_smalltalk_string (_gst_string_new (methodsForString));
478 _gst_parse_stream (true);
479 _gst_pop_stream (true);
480
481 _gst_reset_compilation_category ();
482 }
483
484 OOP
_gst_get_termination_method(void)485 _gst_get_termination_method (void)
486 {
487 if (!termination_method)
488 {
489 termination_method =
490 _gst_find_class_method (_gst_undefined_object_class,
491 _gst_terminate_symbol);
492 }
493
494 return (termination_method);
495 }
496
497 static void
invoke_hook_smalltalk(enum gst_vm_hook hook)498 invoke_hook_smalltalk (enum gst_vm_hook hook)
499 {
500 const char *hook_name;
501 if (!_gst_kernel_initialized)
502 return;
503
504 switch (hook) {
505 case GST_BEFORE_EVAL:
506 hook_name = "beforeEvaluation";
507 break;
508
509 case GST_AFTER_EVAL:
510 hook_name = "afterEvaluation";
511 break;
512
513 case GST_RETURN_FROM_SNAPSHOT:
514 hook_name = "returnFromSnapshot";
515 break;
516
517 case GST_ABOUT_TO_QUIT:
518 hook_name = "aboutToQuit";
519 break;
520
521 case GST_ABOUT_TO_SNAPSHOT:
522 hook_name = "aboutToSnapshot";
523 break;
524
525 case GST_FINISHED_SNAPSHOT:
526 hook_name = "finishedSnapshot";
527 break;
528
529 default:
530 return;
531 }
532
533 _gst_msg_sendf (NULL, "%v %o changed: %S",
534 _gst_object_memory_class, hook_name);
535 }
536
537 void
_gst_invoke_hook(enum gst_vm_hook hook)538 _gst_invoke_hook (enum gst_vm_hook hook)
539 {
540 int save_execution;
541 save_execution = _gst_execution_tracing;
542 if (_gst_execution_tracing == 1)
543 _gst_execution_tracing = 0;
544 invoke_hook_smalltalk (hook);
545 _gst_execution_tracing = save_execution;
546 }
547
548 void
_gst_init_compiler(void)549 _gst_init_compiler (void)
550 {
551 /* Prepare the literal vector for use. The literal vector is where the
552 compiler will store any literals that are used by the method being
553 compiled. */
554 literal_vec = (OOP *) xmalloc (LITERAL_VEC_CHUNK_SIZE * sizeof (OOP));
555
556 literal_vec_curr = literal_vec;
557 literal_vec_max = literal_vec + LITERAL_VEC_CHUNK_SIZE;
558
559 _gst_register_oop_array (&literal_vec, &literal_vec_curr);
560 _gst_reset_compilation_category ();
561 }
562
563 void
_gst_set_compilation_class(OOP class_oop)564 _gst_set_compilation_class (OOP class_oop)
565 {
566 _gst_unregister_oop (_gst_this_class);
567 _gst_this_class = class_oop;
568 _gst_register_oop (_gst_this_class);
569
570 _gst_untrusted_methods = (IS_OOP_UNTRUSTED (_gst_this_context_oop)
571 || IS_OOP_UNTRUSTED (_gst_this_class));
572 }
573
574 void
_gst_set_compilation_category(OOP categoryOOP)575 _gst_set_compilation_category (OOP categoryOOP)
576 {
577 _gst_unregister_oop (_gst_this_category);
578 _gst_this_category = categoryOOP;
579 _gst_register_oop (_gst_this_category);
580
581 _gst_untrusted_methods = (IS_OOP_UNTRUSTED (_gst_this_context_oop)
582 || IS_OOP_UNTRUSTED (_gst_this_class));
583 }
584
585 void
_gst_reset_compilation_category()586 _gst_reset_compilation_category ()
587 {
588 _gst_set_compilation_class (_gst_undefined_object_class);
589 _gst_set_compilation_category (_gst_nil_oop);
590 _gst_untrusted_methods = false;
591 }
592
593
594
595 void
_gst_display_compilation_trace(const char * string,mst_Boolean category)596 _gst_display_compilation_trace (const char *string,
597 mst_Boolean category)
598 {
599 if (!_gst_declare_tracing)
600 return;
601
602 if (category)
603 printf ("%s category %O for %O\n", string,
604 _gst_this_category, _gst_this_class);
605 else
606 printf ("%s for %O\n", string, _gst_this_class);
607 }
608
609
610 OOP
_gst_execute_statements(tree_node temps,tree_node statements,enum undeclared_strategy undeclared,mst_Boolean quiet)611 _gst_execute_statements (tree_node temps,
612 tree_node statements,
613 enum undeclared_strategy undeclared,
614 mst_Boolean quiet)
615 {
616 tree_node messagePattern;
617 int startTime, endTime, deltaTime;
618 unsigned long cacheHits;
619 #ifdef HAVE_GETRUSAGE
620 struct rusage startRusage, endRusage;
621 #endif
622 OOP methodOOP;
623 OOP oldClass, oldCategory;
624 enum undeclared_strategy oldUndeclared;
625 inc_ptr incPtr;
626 YYLTYPE loc;
627
628 if (_gst_regression_testing
629 || _gst_verbosity < 2
630 || !_gst_get_cur_stream_prompt ())
631 quiet = true;
632
633 oldClass = _gst_this_class;
634 oldCategory = _gst_this_category;
635 _gst_register_oop (oldClass);
636 _gst_register_oop (oldCategory);
637
638 _gst_set_compilation_class (_gst_undefined_object_class);
639 _gst_set_compilation_category (_gst_nil_oop);
640 loc = _gst_get_location ();
641
642 messagePattern = _gst_make_unary_expr (&statements->location,
643 NULL, "executeStatements");
644
645 _gst_display_compilation_trace ("Compiling doit code", false);
646
647 /* This is a big hack to let doits access the variables and classes
648 in the current namespace. */
649 oldUndeclared = _gst_set_undeclared (undeclared);
650 SET_CLASS_ENVIRONMENT (_gst_undefined_object_class,
651 _gst_current_namespace);
652
653 if (statements->nodeType != TREE_STATEMENT_LIST)
654 statements = _gst_make_statement_list (&statements->location, statements);
655
656 methodOOP =
657 _gst_compile_method (_gst_make_method (&statements->location, &loc,
658 messagePattern, temps, NULL,
659 statements, false),
660 true, false);
661
662 SET_CLASS_ENVIRONMENT (_gst_undefined_object_class,
663 _gst_smalltalk_dictionary);
664 _gst_set_undeclared (oldUndeclared);
665
666 _gst_set_compilation_class (oldClass);
667 _gst_set_compilation_category (oldCategory);
668 _gst_unregister_oop (oldClass);
669 _gst_unregister_oop (oldCategory);
670
671 if (_gst_had_error) /* don't execute on error */
672 return (NULL);
673
674 incPtr = INC_SAVE_POINTER ();
675 INC_ADD_OOP (methodOOP);
676
677 if (!_gst_raw_profile)
678 _gst_bytecode_counter = _gst_primitives_executed =
679 _gst_self_returns = _gst_inst_var_returns = _gst_literal_returns =
680 _gst_sample_counter = 0;
681
682 startTime = _gst_get_milli_time ();
683 #ifdef HAVE_GETRUSAGE
684 getrusage (RUSAGE_SELF, &startRusage);
685 #endif
686
687 _gst_invoke_hook (GST_BEFORE_EVAL);
688
689 /* send a message to NIL, which will find this synthetic method
690 definition in Object and execute it */
691 _gst_last_returned_value = _gst_nvmsg_send (_gst_nil_oop, methodOOP, NULL, 0);
692 INC_ADD_OOP (_gst_last_returned_value);
693
694 endTime = _gst_get_milli_time ();
695 #ifdef HAVE_GETRUSAGE
696 getrusage (RUSAGE_SELF, &endRusage);
697 #endif
698
699 if (!quiet && _gst_verbosity >= 3)
700 {
701 deltaTime = endTime - startTime;
702 #ifdef ENABLE_JIT_TRANSLATION
703 printf ("Execution took %.3f seconds", deltaTime / 1000.0);
704 #else
705 printf ("%lu byte codes executed\nwhich took %.3f seconds",
706 _gst_bytecode_counter, deltaTime / 1000.0);
707 #endif
708
709 #ifdef HAVE_GETRUSAGE
710 deltaTime = ((endRusage.ru_utime.tv_sec * 1000) +
711 (endRusage.ru_utime.tv_usec / 1000)) -
712 ((startRusage.ru_utime.tv_sec * 1000) +
713 (startRusage.ru_utime.tv_usec / 1000));
714 printf (" (%.3fs user", deltaTime / 1000.0);
715
716 deltaTime = ((endRusage.ru_stime.tv_sec * 1000) +
717 (endRusage.ru_stime.tv_usec / 1000)) -
718 ((startRusage.ru_stime.tv_sec * 1000) +
719 (startRusage.ru_stime.tv_usec / 1000));
720 printf ("+%.3fs sys)", deltaTime / 1000.0);
721 #endif
722 printf ("\n");
723
724 #ifndef ENABLE_JIT_TRANSLATION
725 if (_gst_bytecode_counter)
726 {
727 printf ("%lu primitives, percent %.2f\n", _gst_primitives_executed,
728 100.0 * _gst_primitives_executed / _gst_bytecode_counter);
729 printf ("self returns %lu, inst var returns %lu, literal returns %lu\n",
730 _gst_self_returns, _gst_inst_var_returns, _gst_literal_returns);
731 printf ("%lu method cache lookups since last cleanup, percent %.2f\n",
732 _gst_sample_counter,
733 100.0 * _gst_sample_counter / _gst_bytecode_counter);
734 }
735 #endif
736
737 if (_gst_sample_counter)
738 {
739 #ifdef ENABLE_JIT_TRANSLATION
740 printf
741 ("%lu primitives, %lu inline cache misses since last cache cleanup\n",
742 _gst_primitives_executed, _gst_sample_counter);
743 #endif
744 cacheHits = _gst_sample_counter - _gst_cache_misses;
745 printf ("%lu method cache hits, %lu misses", cacheHits,
746 _gst_cache_misses);
747 if (cacheHits || _gst_cache_misses)
748 printf (", %.2f percent hits\n", (100.0 * cacheHits) / _gst_sample_counter);
749 else
750 printf ("\n");
751 }
752
753 /* Do more frequent flushing to ensure the result are well placed */
754 printf ("returned value is ");
755 fflush(stdout);
756 }
757
758 if (!quiet)
759 {
760 int save_execution;
761
762 save_execution = _gst_execution_tracing;
763 if (_gst_execution_tracing == 1)
764 _gst_execution_tracing = 0;
765 if (_gst_responds_to (_gst_last_returned_value,
766 _gst_intern_string ("printNl"))
767 || _gst_responds_to (_gst_last_returned_value,
768 _gst_does_not_understand_symbol))
769 _gst_str_msg_send (_gst_last_returned_value, "printNl", NULL);
770 else
771 printf ("%O\n", _gst_last_returned_value);
772
773 fflush (stdout);
774 fflush (stderr);
775 _gst_execution_tracing = save_execution;
776 }
777
778 _gst_invoke_hook (GST_AFTER_EVAL);
779 INC_RESTORE_POINTER (incPtr);
780 return (_gst_last_returned_value);
781 }
782
783
784
785 OOP
_gst_compile_method(tree_node method,mst_Boolean returnLast,mst_Boolean install)786 _gst_compile_method (tree_node method,
787 mst_Boolean returnLast,
788 mst_Boolean install)
789 {
790 tree_node statement;
791 OOP selector;
792 OOP methodOOP;
793 bc_vector bytecodes;
794 int primitiveIndex;
795 int stack_depth;
796 inc_ptr incPtr;
797 gst_compiled_method compiledMethod;
798
799 dup_message_receiver = false;
800 literal_vec_curr = literal_vec;
801 this_method_category = _gst_this_category;
802 _gst_unregister_oop (_gst_latest_compiled_method);
803 _gst_latest_compiled_method = _gst_nil_oop;
804
805 incPtr = INC_SAVE_POINTER ();
806
807 _gst_alloc_bytecodes ();
808 _gst_push_new_scope ();
809 inside_block = 0;
810 selector = compute_selector (method->v_method.selectorExpr);
811
812 /* When we are reading from stdin, it's better to write line numbers where
813 1 is the first line *in the current doit*, because for now the prompt
814 does not include the line number. This might change in the future.
815
816 Also, do not emit line numbers if the method has no statements. */
817 if ((method->location.file_offset != -1 && _gst_get_cur_stream_prompt ())
818 || !method->v_method.statements)
819 _gst_line_number (method->location.first_line, LN_RESET);
820 else
821 _gst_line_number (method->location.first_line, LN_RESET | LN_ABSOLUTE);
822
823 INC_ADD_OOP (selector);
824
825 if (_gst_declare_tracing)
826 printf (" class %O, selector %O\n", _gst_this_class, selector);
827
828 if (setjmp (bad_method) == 0)
829 {
830 if (_gst_declare_arguments (method->v_method.selectorExpr) == -1)
831 {
832 _gst_errorf_at (method->location.first_line,
833 "duplicate argument name");
834 EXIT_COMPILATION ();
835 }
836
837 if (_gst_declare_temporaries (method->v_method.temporaries) == -1)
838 {
839 _gst_errorf_at (method->location.first_line,
840 "duplicate temporary variable name");
841 EXIT_COMPILATION ();
842 }
843
844 primitiveIndex = process_attributes_tree (method->v_method.attributes);
845
846 for (statement = method->v_method.statements; statement; )
847 {
848 mst_Boolean wasReturn = statement->v_list.value->nodeType == TREE_RETURN_EXPR;
849 compile_statement (statement->v_list.value);
850
851 statement = statement->v_list.next;
852 if (wasReturn)
853 continue;
854
855 if (!statement && returnLast)
856 /* compile a return of the last evaluated value. Note that in
857 theory the pop above is not necessary in this case
858 (and in fact older versions did not put it),
859 but having it simplifies the optimizer's task
860 because it reduces the number of patterns it has
861 to look for. If necessary, the optimizer itself
862 will remove the pop. */
863 {
864 _gst_compile_byte (RETURN_CONTEXT_STACK_TOP, 0);
865 break;
866 }
867
868 /* ignore the result of the last statement if it's not
869 used */
870 SUB_STACK_DEPTH (1);
871 _gst_compile_byte (POP_STACK_TOP, 0);
872
873 if (!statement)
874 {
875 /* compile a return of self. Note that in
876 theory the pop above is not necessary in this case
877 (and in fact older versions did not put it),
878 but having it simplifies the optimizer's task
879 because it reduces the number of patterns it has
880 to look for. If necessary, the optimizer itself
881 will remove the pop. */
882 _gst_compile_byte (PUSH_SELF, 0);
883 _gst_compile_byte (RETURN_CONTEXT_STACK_TOP, 0);
884 break;
885 }
886 }
887
888 if (method->v_method.statements == NULL)
889 {
890 if (returnLast)
891 {
892 /* special case an empty statement body to return nil */
893 _gst_compile_byte (PUSH_SPECIAL, NIL_INDEX);
894 _gst_compile_byte (RETURN_CONTEXT_STACK_TOP, 0);
895 }
896 else
897 {
898 /* special case an empty statement body to return _gst_self */
899 _gst_compile_byte (PUSH_SELF, 0);
900 _gst_compile_byte (RETURN_CONTEXT_STACK_TOP, 0);
901 }
902 }
903
904 stack_depth = GET_STACK_DEPTH ();
905 bytecodes = _gst_get_bytecodes ();
906
907 methodOOP = _gst_make_new_method (primitiveIndex,
908 _gst_get_arg_count (),
909 _gst_get_temp_count (),
910 stack_depth, _gst_nil_oop, bytecodes,
911 _gst_this_class, selector,
912 _gst_this_category,
913 method->location.file_offset,
914 method->v_method.endPos);
915
916 compiledMethod = (gst_compiled_method) OOP_TO_OBJ (methodOOP);
917 compiledMethod->header.isOldSyntax = method->v_method.isOldSyntax;
918 INC_ADD_OOP (methodOOP);
919
920 if (install)
921 install_method (methodOOP);
922
923 _gst_latest_compiled_method = methodOOP; /* reachable by the
924 root set */
925 _gst_register_oop (_gst_latest_compiled_method);
926 }
927 else
928 {
929 _gst_had_error = true;
930 bytecodes = _gst_get_bytecodes ();
931 literal_vec_curr = literal_vec;
932 _gst_free_bytecodes (bytecodes);
933 }
934
935 _gst_pop_all_scopes ();
936
937 INC_RESTORE_POINTER (incPtr);
938 return (_gst_latest_compiled_method);
939 }
940
941 void
compile_statement(tree_node stmt)942 compile_statement (tree_node stmt)
943 {
944 tree_node receiver;
945
946 if (stmt->nodeType != TREE_RETURN_EXPR)
947 {
948 compile_expression (stmt);
949 return;
950 }
951
952 receiver = stmt->v_expr.receiver;
953 if (inside_block)
954 {
955 compile_expression (receiver);
956 _gst_compile_byte (RETURN_METHOD_STACK_TOP, 0);
957 SUB_STACK_DEPTH (1);
958 return;
959 }
960
961 compile_expression (receiver);
962 _gst_compile_byte (RETURN_CONTEXT_STACK_TOP, 0);
963 SUB_STACK_DEPTH (1);
964 }
965
966 void
compile_expression(tree_node expr)967 compile_expression (tree_node expr)
968 {
969 if (expr->nodeType == TREE_ASSIGN_EXPR)
970 {
971 compile_simple_expression (expr->v_expr.expression);
972 compile_assignments (expr->v_expr.receiver);
973 }
974 else
975 compile_simple_expression (expr);
976 }
977
978 void
compile_simple_expression(tree_node expr)979 compile_simple_expression (tree_node expr)
980 {
981 _gst_line_number (expr->location.first_line, 0);
982 switch (expr->nodeType)
983 {
984 case TREE_VARIABLE_NODE:
985 compile_variable (expr);
986 break;
987 case TREE_CONST_EXPR:
988 compile_constant (expr);
989 break;
990 case TREE_BLOCK_NODE:
991 compile_block (expr);
992 break;
993 case TREE_UNARY_EXPR:
994 compile_unary_expr (expr);
995 break;
996 case TREE_BINARY_EXPR:
997 compile_binary_expr (expr);
998 break;
999 case TREE_KEYWORD_EXPR:
1000 compile_keyword_expr (expr);
1001 break;
1002 case TREE_CASCADE_EXPR:
1003 compile_cascaded_message (expr);
1004 break;
1005 case TREE_ARRAY_CONSTRUCTOR:
1006 compile_array_constructor (expr);
1007 break;
1008 default:
1009 compile_expression (expr);
1010 }
1011 }
1012
1013 void
compile_variable(tree_node varName)1014 compile_variable (tree_node varName)
1015 {
1016 symbol_entry variable;
1017
1018 INCR_STACK_DEPTH ();
1019 if (!_gst_find_variable (&variable, varName))
1020 {
1021 if (varName->v_list.next)
1022 _gst_errorf_at (varName->location.first_line,
1023 "invalid scope resolution");
1024 else
1025 _gst_errorf_at (varName->location.first_line,
1026 "undefined variable %s referenced",
1027 varName->v_list.name);
1028 EXIT_COMPILATION ();
1029 }
1030
1031 if (variable.scope == SCOPE_SPECIAL)
1032 switch (variable.varIndex)
1033 {
1034 case THIS_CONTEXT_INDEX:
1035 {
1036 static OOP contextPartAssociation;
1037 if (!contextPartAssociation)
1038 {
1039 contextPartAssociation =
1040 dictionary_association_at (_gst_smalltalk_dictionary,
1041 _gst_intern_string ("ContextPart"));
1042 }
1043
1044 _gst_compile_byte (PUSH_LIT_VARIABLE,
1045 _gst_add_forced_object (contextPartAssociation));
1046 _gst_compile_byte (SEND_IMMEDIATE, THIS_CONTEXT_SPECIAL);
1047 }
1048 return;
1049
1050 case RECEIVER_INDEX:
1051 _gst_compile_byte (PUSH_SELF, 0);
1052 return;
1053
1054 default:
1055 _gst_compile_byte (PUSH_SPECIAL, variable.varIndex);
1056 return;
1057 }
1058
1059 if (variable.scope != SCOPE_GLOBAL && varName->v_list.next)
1060 {
1061 _gst_errorf_at (varName->location.first_line,
1062 "invalid scope resolution");
1063 EXIT_COMPILATION ();
1064 }
1065
1066 if (variable.scopeDistance != 0)
1067 /* must be a temporary from an outer scope */
1068 _gst_compile_byte (PUSH_OUTER_TEMP,
1069 variable.varIndex * 256 + variable.scopeDistance);
1070
1071 else if (variable.scope == SCOPE_TEMPORARY)
1072 _gst_compile_byte (PUSH_TEMPORARY_VARIABLE, variable.varIndex);
1073
1074 else if (variable.scope == SCOPE_RECEIVER)
1075 _gst_compile_byte (PUSH_RECEIVER_VARIABLE, variable.varIndex);
1076
1077 else
1078 _gst_compile_byte (PUSH_LIT_VARIABLE, variable.varIndex);
1079 }
1080
1081 void
compile_constant(tree_node constExpr)1082 compile_constant (tree_node constExpr)
1083 {
1084 intptr_t intVal;
1085 int index = -1;
1086 OOP constantOOP;
1087 OOP *lit;
1088
1089 /* Scan the current literal frame, looking for a constant equal
1090 to the one that is being compiled. */
1091 for (lit = literal_vec; lit < literal_vec_curr; lit++)
1092 if (equal_constant (*lit, constExpr))
1093 {
1094 index = lit - literal_vec;
1095 break;
1096 }
1097
1098 /* If not found, check if it can be compiled with a PUSH_INTEGER
1099 bytecode, or add it to the literals. */
1100 if (index == -1)
1101 {
1102 constantOOP = _gst_make_constant_oop (constExpr);
1103 if (IS_INT (constantOOP))
1104 {
1105 intVal = TO_INT (constantOOP);
1106 if (intVal >= 0 && intVal <= 0x7FFFFFFFL)
1107 {
1108 INCR_STACK_DEPTH ();
1109 _gst_compile_byte (PUSH_INTEGER, intVal);
1110 return;
1111 }
1112 }
1113
1114 index = add_literal (constantOOP);
1115 }
1116
1117 INCR_STACK_DEPTH ();
1118 _gst_compile_byte (PUSH_LIT_CONSTANT, index);
1119 }
1120
1121 void
compile_block(tree_node blockExpr)1122 compile_block (tree_node blockExpr)
1123 {
1124 bc_vector current_bytecodes, blockByteCodes;
1125 int argCount, tempCount;
1126 int stack_depth;
1127 OOP blockClosureOOP, blockOOP;
1128 gst_compiled_block block;
1129 inc_ptr incPtr;
1130
1131 current_bytecodes = _gst_save_bytecode_array ();
1132
1133 _gst_push_new_scope ();
1134 argCount = _gst_declare_block_arguments (blockExpr->v_block.arguments);
1135 tempCount = _gst_declare_temporaries (blockExpr->v_block.temporaries);
1136
1137 if (argCount == -1)
1138 {
1139 _gst_errorf_at (blockExpr->location.first_line,
1140 "duplicate argument name");
1141 EXIT_COMPILATION ();
1142 }
1143
1144 if (tempCount == -1)
1145 {
1146 _gst_errorf_at (blockExpr->location.first_line,
1147 "duplicate temporary variable name");
1148 EXIT_COMPILATION ();
1149 }
1150
1151 compile_statements (blockExpr->v_block.statements, true);
1152
1153 stack_depth = GET_STACK_DEPTH ();
1154 blockByteCodes = _gst_get_bytecodes ();
1155
1156 _gst_restore_bytecode_array (current_bytecodes);
1157
1158 /* Always allocate objects starting from the deepest one! (that is,
1159 subtle bugs arise if make_block triggers a GC, because
1160 the pointer in the closure might be no longer valid!) */
1161 incPtr = INC_SAVE_POINTER ();
1162 blockOOP = make_block (_gst_get_arg_count (), _gst_get_temp_count (),
1163 blockByteCodes, stack_depth);
1164 INC_ADD_OOP (blockOOP);
1165 _gst_pop_old_scope ();
1166
1167 /* emit standard byte sequence to invoke a block:
1168
1169 push literal (a BlockClosure)
1170 or
1171 push literal (a CompiledBlock)
1172 make dirty block */
1173
1174 INCR_STACK_DEPTH ();
1175 block = (gst_compiled_block) OOP_TO_OBJ (blockOOP);
1176 if (block->header.clean == 0)
1177 {
1178 blockClosureOOP = make_clean_block_closure (blockOOP);
1179 _gst_compile_byte (PUSH_LIT_CONSTANT, add_literal (blockClosureOOP));
1180 }
1181 else
1182 {
1183 _gst_compile_byte (PUSH_LIT_CONSTANT, add_literal (blockOOP));
1184 _gst_compile_byte (MAKE_DIRTY_BLOCK, 0);
1185 }
1186
1187 INC_RESTORE_POINTER (incPtr);
1188 }
1189
1190
1191 mst_Boolean
compile_statements(tree_node statementList,mst_Boolean isBlock)1192 compile_statements (tree_node statementList,
1193 mst_Boolean isBlock)
1194 {
1195 tree_node stmt;
1196
1197 if (statementList == NULL)
1198 {
1199 INCR_STACK_DEPTH ();
1200 _gst_compile_byte (PUSH_SPECIAL, NIL_INDEX);
1201
1202 if (isBlock)
1203 _gst_compile_byte (RETURN_CONTEXT_STACK_TOP, 0);
1204
1205 return (false);
1206 }
1207
1208 if (isBlock)
1209 {
1210 _gst_line_number (statementList->location.first_line, LN_FORCE);
1211 inside_block++;
1212 }
1213
1214 for (stmt = statementList;; stmt = stmt->v_list.next)
1215 {
1216 compile_statement (stmt->v_list.value);
1217 if (!stmt->v_list.next)
1218 break;
1219
1220 /* throw away the value on the top of the stack...we don't need
1221 it for all but the last one. */
1222 SUB_STACK_DEPTH (1);
1223 _gst_compile_byte (POP_STACK_TOP, 0);
1224 }
1225
1226 /* stmt is the last statement here. if it isn't a return, then
1227 return the value on the stack as the result. For inlined blocks,
1228 the returned value is the top of the stack (which is already
1229 there), so we are already done. */
1230 if (stmt->v_list.value->nodeType != TREE_RETURN_EXPR && isBlock)
1231 _gst_compile_byte (RETURN_CONTEXT_STACK_TOP, 0);
1232
1233 if (isBlock)
1234 {
1235 _gst_line_number (-1, 0);
1236 inside_block--;
1237 }
1238
1239 return (stmt->v_list.value->nodeType == TREE_RETURN_EXPR);
1240 }
1241
1242 void
compile_array_constructor(tree_node arrayConstructor)1243 compile_array_constructor (tree_node arrayConstructor)
1244 {
1245 tree_node stmt, statementList;
1246 int i, n;
1247 static OOP arrayAssociation;
1248
1249 statementList = arrayConstructor->v_const.val.aVal;
1250 for (n = 0, stmt = statementList; stmt;
1251 n++, stmt = stmt->v_list.next);
1252
1253 if (!arrayAssociation)
1254 {
1255 arrayAssociation =
1256 dictionary_association_at (_gst_smalltalk_dictionary,
1257 _gst_intern_string ("Array"));
1258 }
1259
1260 ADD_STACK_DEPTH (2);
1261 _gst_compile_byte (PUSH_LIT_VARIABLE,
1262 _gst_add_forced_object (arrayAssociation));
1263 _gst_compile_byte (PUSH_INTEGER, n);
1264 _gst_compile_byte (SEND_IMMEDIATE, NEW_COLON_SPECIAL);
1265 SUB_STACK_DEPTH (1);
1266
1267 /* compile the values now */
1268 for (i = 0, stmt = statementList; i < n;
1269 i++, stmt = stmt->v_list.next)
1270 {
1271 compile_statement (stmt->v_list.value);
1272 _gst_compile_byte (POP_INTO_NEW_STACKTOP, i);
1273
1274 /* throw away the value on the top of the stack... */
1275 SUB_STACK_DEPTH (1);
1276 }
1277 }
1278
1279
1280 void
compile_unary_expr(tree_node expr)1281 compile_unary_expr (tree_node expr)
1282 {
1283 OOP selector;
1284 mst_Boolean savedDupFlag;
1285
1286 savedDupFlag = dup_message_receiver;
1287 dup_message_receiver = false;
1288
1289 selector = expr->v_expr.selector;
1290
1291 /* check for optimized cases of messages to blocks and handle them
1292 specially */
1293 if (selector == _gst_while_true_symbol
1294 || selector == _gst_while_false_symbol)
1295 {
1296 if (compile_while_loop (selector, expr))
1297 return;
1298 }
1299 else if (selector == _gst_repeat_symbol)
1300 {
1301 if (compile_repeat (expr->v_expr.receiver))
1302 return;
1303 }
1304
1305 if (expr->v_expr.receiver != NULL)
1306 {
1307 compile_expression (expr->v_expr.receiver);
1308 if (savedDupFlag)
1309 {
1310 _gst_compile_byte (DUP_STACK_TOP, 0);
1311 INCR_STACK_DEPTH ();
1312 }
1313 }
1314
1315 compile_send (expr, selector, 0);
1316 }
1317
1318 void
compile_binary_expr(tree_node expr)1319 compile_binary_expr (tree_node expr)
1320 {
1321 OOP selector;
1322 mst_Boolean savedDupFlag;
1323
1324 savedDupFlag = dup_message_receiver;
1325 dup_message_receiver = false;
1326
1327 selector = expr->v_expr.selector;
1328
1329 if (expr->v_expr.receiver != NULL)
1330 {
1331 compile_expression (expr->v_expr.receiver);
1332 if (savedDupFlag)
1333 {
1334 _gst_compile_byte (DUP_STACK_TOP, 0);
1335 INCR_STACK_DEPTH ();
1336 }
1337 }
1338
1339 if (expr->v_expr.expression)
1340 compile_expression (expr->v_expr.expression);
1341
1342 compile_send (expr, selector, 1);
1343 }
1344
1345 void
compile_keyword_expr(tree_node expr)1346 compile_keyword_expr (tree_node expr)
1347 {
1348 OOP selector;
1349 int numArgs;
1350 mst_Boolean savedDupFlag;
1351
1352 savedDupFlag = dup_message_receiver;
1353 dup_message_receiver = false;
1354
1355 selector = compute_selector (expr);
1356
1357 /* check for optimized cases of messages to booleans and handle them
1358 specially */
1359 if (selector == _gst_while_true_colon_symbol
1360 || selector == _gst_while_false_colon_symbol)
1361 {
1362 if (compile_while_loop (selector, expr))
1363 return;
1364 }
1365
1366 if (expr->v_expr.receiver)
1367 {
1368 compile_expression (expr->v_expr.receiver);
1369 if (savedDupFlag)
1370 {
1371 _gst_compile_byte (DUP_STACK_TOP, 0);
1372 INCR_STACK_DEPTH ();
1373 }
1374 }
1375
1376 if (selector == _gst_if_true_symbol
1377 || selector == _gst_if_false_symbol)
1378 {
1379 if (compile_if_statement (selector, expr->v_expr.expression))
1380 return;
1381 }
1382 else if (selector == _gst_if_true_if_false_symbol
1383 || selector == _gst_if_false_if_true_symbol)
1384 {
1385 if (compile_if_true_false_statement
1386 (selector, expr->v_expr.expression))
1387 return;
1388 }
1389 else if (selector == _gst_and_symbol
1390 || selector == _gst_or_symbol)
1391 {
1392 if (compile_and_or_statement (selector, expr->v_expr.expression))
1393 return;
1394 }
1395 else if (selector == _gst_times_repeat_symbol)
1396 {
1397 if (compile_times_repeat (expr->v_expr.expression))
1398 return;
1399 }
1400 else if (selector == _gst_to_do_symbol)
1401 {
1402 if (compile_to_by_do (expr->v_expr.expression->v_list.value, NULL,
1403 expr->v_expr.expression->v_list.next->v_list.value))
1404 return;
1405 }
1406 else if (selector == _gst_to_by_do_symbol)
1407 {
1408 if (compile_to_by_do (expr->v_expr.expression->v_list.value,
1409 expr->v_expr.expression->v_list.next->v_list.value,
1410 expr->v_expr.expression->v_list.next->v_list.next->v_list.value))
1411 return;
1412 }
1413
1414 numArgs = list_length (expr->v_expr.expression);
1415
1416 compile_keyword_list (expr->v_expr.expression);
1417 compile_send (expr, selector, numArgs);
1418 }
1419
1420
1421 void
compile_send(tree_node expr,OOP selector,int numArgs)1422 compile_send (tree_node expr,
1423 OOP selector,
1424 int numArgs)
1425 {
1426 const char *str = (const char *) OOP_TO_OBJ (selector)->data;
1427 int len = NUM_INDEXABLE_FIELDS (selector);
1428 struct builtin_selector *bs = _gst_lookup_builtin_selector (str, len);
1429
1430 int super = expr->v_expr.receiver
1431 && is_super (expr->v_expr.receiver);
1432
1433 if (super && IS_NIL (SUPERCLASS (_gst_this_class)))
1434 {
1435 _gst_errorf ("cannot send to super from within a root class\n");
1436 EXIT_COMPILATION ();
1437 }
1438
1439 if (super)
1440 compile_constant (_gst_make_oop_constant (&expr->location,
1441 SUPERCLASS (_gst_this_class)));
1442
1443 if (!bs)
1444 {
1445 int selectorIndex = _gst_add_forced_object (selector);
1446 _gst_compile_byte (SEND | super, (selectorIndex << 8) | numArgs);
1447 }
1448 else if (!super && bs->bytecode < 32)
1449 _gst_compile_byte (bs->bytecode, 0);
1450 else
1451 _gst_compile_byte (SEND_IMMEDIATE | super, bs->bytecode);
1452
1453 SUB_STACK_DEPTH (numArgs);
1454 }
1455
1456 void
compile_keyword_list(tree_node list)1457 compile_keyword_list (tree_node list)
1458 {
1459 for (; list; list = list->v_list.next)
1460 compile_expression (list->v_list.value);
1461 }
1462
1463
1464
1465 mst_Boolean
compile_while_loop(OOP selector,tree_node expr)1466 compile_while_loop (OOP selector,
1467 tree_node expr)
1468 {
1469 int finalJumpLen, finalJumpOfs, jumpAroundLen, jumpAroundOfs,
1470 oldJumpAroundLen;
1471 int whileCondLen;
1472 bc_vector receiverExprCodes, whileExprCodes = NULL;
1473 mst_Boolean colon, whileTrue;
1474
1475 colon = (expr->v_expr.expression != NULL);
1476 whileTrue = (selector == _gst_while_true_colon_symbol)
1477 || (selector == _gst_while_true_symbol);
1478
1479 if (expr->v_expr.receiver->nodeType != TREE_BLOCK_NODE ||
1480 (colon
1481 && expr->v_expr.expression->v_list.value->nodeType !=
1482 TREE_BLOCK_NODE))
1483 return (false);
1484
1485 if (HAS_PARAMS_OR_TEMPS (expr->v_expr.receiver) ||
1486 (colon
1487 && HAS_PARAMS_OR_TEMPS (expr->v_expr.expression->v_list.value)))
1488 return (false);
1489
1490
1491 receiverExprCodes = compile_sub_expression (expr->v_expr.receiver);
1492 whileCondLen = _gst_bytecode_length (receiverExprCodes);
1493 _gst_compile_and_free_bytecodes (receiverExprCodes);
1494
1495 if (colon)
1496 {
1497 whileExprCodes =
1498 compile_sub_expression (expr->v_expr.expression->v_list.value);
1499
1500 jumpAroundOfs = _gst_bytecode_length (whileExprCodes) + 2;
1501 }
1502 else
1503 jumpAroundOfs = 0;
1504
1505 for (oldJumpAroundLen = finalJumpLen = 0; ; oldJumpAroundLen = jumpAroundLen)
1506 {
1507 finalJumpOfs = whileCondLen + 2 + oldJumpAroundLen + jumpAroundOfs;
1508 finalJumpLen = (finalJumpOfs + finalJumpLen >= 65536 ? 6 :
1509 finalJumpOfs + finalJumpLen >= 256 ? 4 : 2);
1510 finalJumpLen = (finalJumpOfs + finalJumpLen >= 65536 ? 6 :
1511 finalJumpOfs + finalJumpLen >= 256 ? 4 : 2);
1512 jumpAroundLen = (jumpAroundOfs + finalJumpLen >= 65536 ? 6 :
1513 jumpAroundOfs + finalJumpLen >= 256 ? 4 : 2);
1514 if (jumpAroundLen == oldJumpAroundLen)
1515 break;
1516 }
1517
1518 /* skip to the while loop if the receiver block yields the proper
1519 value */
1520 compile_jump (jumpAroundLen, whileTrue);
1521
1522 /* otherwise, skip to the end, past the pop stack top and 2 byte
1523 jump and exit the loop */
1524 _gst_compile_byte (JUMP, jumpAroundOfs + finalJumpLen);
1525
1526 if (colon)
1527 {
1528 _gst_compile_and_free_bytecodes (whileExprCodes);
1529 _gst_compile_byte (POP_STACK_TOP, 0); /* we don't care about
1530 while expr's value */
1531 SUB_STACK_DEPTH (1);
1532 }
1533
1534 _gst_compile_byte (JUMP_BACK, finalJumpLen + finalJumpOfs);
1535
1536 /* while loops always return nil (ain't expression languages grand?)
1537 -- inefficient, but anyway the optimizer deletes this. */
1538 INCR_STACK_DEPTH ();
1539 _gst_compile_byte (PUSH_SPECIAL, NIL_INDEX);
1540 return (true);
1541 }
1542
1543
1544 mst_Boolean
compile_repeat(tree_node receiver)1545 compile_repeat (tree_node receiver)
1546 {
1547 int repeatedLoopLen, finalJumpLen;
1548 bc_vector receiverExprCodes;
1549
1550 if (receiver->nodeType != TREE_BLOCK_NODE)
1551 return (false);
1552
1553 if (HAS_PARAMS_OR_TEMPS (receiver))
1554 return (false);
1555
1556 receiverExprCodes = compile_sub_expression (receiver);
1557 repeatedLoopLen = _gst_bytecode_length (receiverExprCodes);
1558
1559 repeatedLoopLen += 2;
1560 finalJumpLen = (repeatedLoopLen >= 65536 ? 6 :
1561 repeatedLoopLen >= 256 ? 4 : 2);
1562 finalJumpLen = (repeatedLoopLen + finalJumpLen >= 65536 ? 6 :
1563 repeatedLoopLen + finalJumpLen >= 256 ? 4 : 2);
1564 finalJumpLen = (repeatedLoopLen + finalJumpLen >= 65536 ? 6 :
1565 repeatedLoopLen + finalJumpLen >= 256 ? 4 : 2);
1566
1567 _gst_compile_and_free_bytecodes (receiverExprCodes);
1568 _gst_compile_byte (POP_STACK_TOP, 0); /* we don't care about expr's
1569 value */
1570 SUB_STACK_DEPTH (1);
1571 _gst_compile_byte (JUMP_BACK, finalJumpLen + repeatedLoopLen);
1572
1573 /* this code is unreachable, it is only here to please the JIT
1574 compiler */
1575 _gst_compile_byte (PUSH_SPECIAL, NIL_INDEX);
1576 INCR_STACK_DEPTH ();
1577 return (true);
1578 }
1579
1580 mst_Boolean
compile_times_repeat(tree_node expr)1581 compile_times_repeat (tree_node expr)
1582 {
1583 int jumpAroundOfs, oldJumpAroundLen, jumpAroundLen;
1584 int finalJumpOfs, finalJumpLen;
1585 bc_vector loopExprCodes;
1586
1587 if (expr->v_list.value->nodeType != TREE_BLOCK_NODE)
1588 return (false);
1589
1590 if (HAS_PARAMS_OR_TEMPS (expr->v_list.value))
1591 return (false);
1592
1593 /* save the receiver for the return value */
1594 _gst_compile_byte (DUP_STACK_TOP, 0);
1595 INCR_STACK_DEPTH ();
1596
1597 loopExprCodes = compile_sub_expression (expr->v_list.value);
1598
1599 _gst_compile_byte (DUP_STACK_TOP, 0);
1600 INCR_STACK_DEPTH ();
1601 _gst_compile_byte (PUSH_INTEGER, 1);
1602 INCR_STACK_DEPTH ();
1603 _gst_compile_byte (GREATER_EQUAL_SPECIAL, 0);
1604 SUB_STACK_DEPTH (1);
1605
1606 /* skip the loop if there are no more occurrences */
1607 jumpAroundOfs = 6 + _gst_bytecode_length (loopExprCodes);
1608 for (oldJumpAroundLen = finalJumpLen = 0; ; oldJumpAroundLen = jumpAroundLen)
1609 {
1610 finalJumpOfs = 6 + oldJumpAroundLen + jumpAroundOfs;
1611 finalJumpLen = (finalJumpOfs + finalJumpLen > 65536 ? 6 :
1612 finalJumpOfs + finalJumpLen > 256 ? 4 : 2);
1613 finalJumpLen = (finalJumpOfs + finalJumpLen > 65536 ? 6 :
1614 finalJumpOfs + finalJumpLen > 256 ? 4 : 2);
1615 jumpAroundLen = (jumpAroundOfs + finalJumpLen > 65536 ? 6 :
1616 jumpAroundOfs + finalJumpLen > 256 ? 4 : 2);
1617 if (jumpAroundLen == oldJumpAroundLen)
1618 break;
1619 }
1620
1621 compile_jump (jumpAroundOfs + finalJumpLen, false);
1622 _gst_compile_byte (PUSH_INTEGER, 1);
1623 INCR_STACK_DEPTH ();
1624 _gst_compile_byte (MINUS_SPECIAL, 0);
1625 SUB_STACK_DEPTH (1);
1626
1627 /* we don't care about block expr's value */
1628 _gst_compile_and_free_bytecodes (loopExprCodes);
1629 _gst_compile_byte (POP_STACK_TOP, 0);
1630 SUB_STACK_DEPTH (1);
1631
1632 _gst_compile_byte (JUMP_BACK, finalJumpLen + finalJumpOfs);
1633
1634 /* delete the 0 that remains on the stack */
1635 _gst_compile_byte (POP_STACK_TOP, 0);
1636 SUB_STACK_DEPTH (1);
1637 return (true);
1638 }
1639
1640 mst_Boolean
compile_to_by_do(tree_node to,tree_node by,tree_node block)1641 compile_to_by_do (tree_node to,
1642 tree_node by,
1643 tree_node block)
1644 {
1645 int jumpAroundOfs, oldJumpAroundLen, jumpAroundLen;
1646 int finalJumpOfs, finalJumpLen;
1647 int index;
1648 bc_vector loopExprCodes, stepCodes = NULL; /* initialize to please
1649 gcc */
1650
1651 if (block->nodeType != TREE_BLOCK_NODE)
1652 return (false);
1653
1654 if (HAS_NOT_ONE_PARAM_OR_TEMPS (block))
1655 return (false);
1656
1657 if (by)
1658 {
1659 if (by->nodeType != TREE_CONST_EXPR
1660 || by->v_const.constType != CONST_INT)
1661 return (false);
1662 }
1663
1664 index =
1665 _gst_declare_name (block->v_block.arguments->v_list.name, false, true);
1666 _gst_compile_byte (STORE_TEMPORARY_VARIABLE, index);
1667
1668 compile_expression (to);
1669 _gst_compile_byte (DUP_STACK_TOP, index);
1670 INCR_STACK_DEPTH ();
1671 _gst_compile_byte (PUSH_TEMPORARY_VARIABLE, index);
1672
1673 if (by)
1674 {
1675 bc_vector current_bytecodes;
1676 current_bytecodes = _gst_save_bytecode_array ();
1677 compile_expression (by);
1678 stepCodes = _gst_get_bytecodes ();
1679 _gst_restore_bytecode_array (current_bytecodes);
1680 jumpAroundOfs = _gst_bytecode_length (stepCodes);
1681 }
1682 else
1683 jumpAroundOfs = 2;
1684
1685 loopExprCodes = compile_sub_expression (block);
1686 jumpAroundOfs += _gst_bytecode_length (loopExprCodes) + 10;
1687
1688 for (oldJumpAroundLen = jumpAroundLen = finalJumpLen = 0; ; oldJumpAroundLen = jumpAroundLen)
1689 {
1690 finalJumpOfs = jumpAroundOfs + jumpAroundLen + 2;
1691 finalJumpLen = (finalJumpOfs + finalJumpLen > 65536 ? 6 :
1692 finalJumpOfs + finalJumpLen > 256 ? 4 : 2);
1693 finalJumpLen = (finalJumpOfs + finalJumpLen > 65536 ? 6 :
1694 finalJumpOfs + finalJumpLen > 256 ? 4 : 2);
1695 jumpAroundLen = (jumpAroundOfs + finalJumpLen > 65536 ? 6 :
1696 jumpAroundOfs + finalJumpLen > 256 ? 4 : 2);
1697 if (jumpAroundLen == oldJumpAroundLen)
1698 break;
1699 }
1700
1701 /* skip the loop if there are no more occurrences */
1702 _gst_compile_byte ((!by || by->v_const.val.iVal > 0)
1703 ? GREATER_EQUAL_SPECIAL : LESS_EQUAL_SPECIAL, 0);
1704 SUB_STACK_DEPTH (1);
1705 compile_jump (jumpAroundOfs + finalJumpLen, false);
1706
1707 /* we don't care about loop expr's value */
1708 _gst_compile_and_free_bytecodes (loopExprCodes);
1709 _gst_compile_byte (POP_STACK_TOP, 0);
1710 SUB_STACK_DEPTH (1);
1711 _gst_compile_byte (DUP_STACK_TOP, 0);
1712 INCR_STACK_DEPTH ();
1713 _gst_compile_byte (PUSH_TEMPORARY_VARIABLE, index);
1714 INCR_STACK_DEPTH ();
1715
1716 if (by)
1717 _gst_compile_and_free_bytecodes (stepCodes);
1718 else
1719 {
1720 _gst_compile_byte (PUSH_INTEGER, 1);
1721 INCR_STACK_DEPTH ();
1722 }
1723
1724 _gst_compile_byte (PLUS_SPECIAL, 0);
1725 SUB_STACK_DEPTH (1);
1726 _gst_compile_byte (STORE_TEMPORARY_VARIABLE, index);
1727
1728 _gst_compile_byte (JUMP_BACK, finalJumpOfs + finalJumpLen);
1729
1730 /* delete the end from the stack */
1731 _gst_compile_byte (POP_STACK_TOP, 0);
1732 SUB_STACK_DEPTH (1);
1733 _gst_undeclare_name ();
1734 return (true);
1735 }
1736
1737
1738 mst_Boolean
compile_if_true_false_statement(OOP selector,tree_node expr)1739 compile_if_true_false_statement (OOP selector,
1740 tree_node expr)
1741 {
1742 bc_vector trueByteCodes, falseByteCodes;
1743
1744 if (expr->v_list.value->nodeType != TREE_BLOCK_NODE
1745 || expr->v_list.next->v_list.value->nodeType != TREE_BLOCK_NODE)
1746 return (false);
1747
1748 if (HAS_PARAMS_OR_TEMPS (expr->v_list.value)
1749 || HAS_PARAMS_OR_TEMPS (expr->v_list.next->v_list.value))
1750 return (false);
1751
1752 if (selector == _gst_if_true_if_false_symbol)
1753 {
1754 falseByteCodes =
1755 compile_sub_expression (expr->v_list.next->v_list.value);
1756 trueByteCodes =
1757 compile_sub_expression_and_jump (expr->v_list.value,
1758 _gst_bytecode_length
1759 (falseByteCodes));
1760 }
1761 else
1762 {
1763 falseByteCodes = compile_sub_expression (expr->v_list.value);
1764 trueByteCodes =
1765 compile_sub_expression_and_jump (expr->v_list.next->v_list.
1766 value,
1767 _gst_bytecode_length
1768 (falseByteCodes));
1769 }
1770
1771 compile_jump (_gst_bytecode_length (trueByteCodes), false);
1772 _gst_compile_and_free_bytecodes (trueByteCodes);
1773 _gst_compile_and_free_bytecodes (falseByteCodes);
1774 return (true);
1775 }
1776
1777 mst_Boolean
compile_if_statement(OOP selector,tree_node expr)1778 compile_if_statement (OOP selector,
1779 tree_node expr)
1780 {
1781 bc_vector thenByteCodes;
1782
1783 if (expr->v_list.value->nodeType != TREE_BLOCK_NODE
1784 || HAS_PARAMS_OR_TEMPS (expr->v_list.value))
1785 return (false);
1786
1787 /* The second parameter (2) is the size of a `push nil' bytecode */
1788 thenByteCodes =
1789 compile_sub_expression_and_jump (expr->v_list.value, 2);
1790 compile_jump (_gst_bytecode_length (thenByteCodes),
1791 selector == _gst_if_false_symbol);
1792 _gst_compile_and_free_bytecodes (thenByteCodes);
1793
1794 /* Compare the code produced here with that produced in #and:/#or:
1795 This produces less efficient bytecodes if the condition is true
1796 (there are two jumps instead of one). Actually, the push will 99%
1797 of the times be followed by a pop stack top, and the optimizer
1798 changes
1799 0: jump to 4
1800 2: push nil
1801 4: pop stack top
1802
1803 to a single pop -- so the code ends up being quite efficent. Note
1804 that instead the result of #and:/#or: will be used (no pop) so we
1805 use the other possible encoding. */
1806 _gst_compile_byte (PUSH_SPECIAL, NIL_INDEX);
1807 return (true);
1808 }
1809
1810
1811 mst_Boolean
compile_and_or_statement(OOP selector,tree_node expr)1812 compile_and_or_statement (OOP selector,
1813 tree_node expr)
1814 {
1815 bc_vector blockByteCodes;
1816 int blockLen;
1817
1818 if (expr->v_list.value->nodeType != TREE_BLOCK_NODE
1819 || HAS_PARAMS_OR_TEMPS (expr->v_list.value))
1820 return (false);
1821
1822 blockByteCodes = compile_sub_expression (expr->v_list.value);
1823 blockLen = _gst_bytecode_length (blockByteCodes);
1824
1825 _gst_compile_byte (DUP_STACK_TOP, 0);
1826 compile_jump (blockLen + 2, selector == _gst_or_symbol);
1827 _gst_compile_byte (POP_STACK_TOP, 0);
1828 _gst_compile_and_free_bytecodes (blockByteCodes);
1829 return (true);
1830 }
1831
1832
1833
1834 bc_vector
compile_sub_expression(tree_node expr)1835 compile_sub_expression (tree_node expr)
1836 {
1837 mst_Boolean returns;
1838 bc_vector current_bytecodes, subExprByteCodes;
1839
1840 current_bytecodes = _gst_save_bytecode_array ();
1841 returns = compile_statements (expr->v_block.statements, false);
1842 if (returns)
1843 INCR_STACK_DEPTH ();
1844
1845 subExprByteCodes = _gst_get_bytecodes ();
1846 _gst_restore_bytecode_array (current_bytecodes);
1847
1848 return (subExprByteCodes);
1849 }
1850
1851
1852 bc_vector
compile_sub_expression_and_jump(tree_node expr,int branchLen)1853 compile_sub_expression_and_jump (tree_node expr,
1854 int branchLen)
1855 {
1856 bc_vector current_bytecodes, subExprByteCodes;
1857 mst_Boolean returns;
1858
1859 current_bytecodes = _gst_save_bytecode_array ();
1860 returns = compile_statements (expr->v_block.statements, false);
1861 if (returns)
1862 INCR_STACK_DEPTH ();
1863
1864 if (!returns)
1865 _gst_compile_byte (JUMP, branchLen);
1866
1867 subExprByteCodes = _gst_get_bytecodes ();
1868 _gst_restore_bytecode_array (current_bytecodes);
1869
1870 return (subExprByteCodes);
1871 }
1872
1873 void
compile_jump(int len,mst_Boolean jumpType)1874 compile_jump (int len,
1875 mst_Boolean jumpType)
1876 {
1877 if (len <= 0)
1878 {
1879 _gst_errorf ("invalid length jump %d -- internal error\n", len);
1880 EXIT_COMPILATION ();
1881 }
1882
1883 SUB_STACK_DEPTH (1);
1884 _gst_compile_byte (jumpType ? POP_JUMP_TRUE : POP_JUMP_FALSE, len);
1885 }
1886
1887
1888 void
compile_cascaded_message(tree_node cascadedExpr)1889 compile_cascaded_message (tree_node cascadedExpr)
1890 {
1891 tree_node message;
1892
1893 dup_message_receiver = true;
1894 compile_expression (cascadedExpr->v_expr.receiver);
1895
1896 for (message = cascadedExpr->v_expr.expression; message;
1897 message = message->v_list.next)
1898 {
1899 _gst_compile_byte (POP_STACK_TOP, 0);
1900 if (message->v_list.next)
1901 _gst_compile_byte (DUP_STACK_TOP, 0);
1902 else
1903 SUB_STACK_DEPTH (1);
1904
1905 compile_expression (message->v_list.value);
1906 /* !!! remember that unary, binary and keywordexpr should ignore
1907 the receiver field if it is nil; that is the case for these
1908 functions and things work out fine if that's the case. */
1909 }
1910 }
1911
1912
1913 void
compile_assignments(tree_node varList)1914 compile_assignments (tree_node varList)
1915 {
1916 symbol_entry variable;
1917
1918 for (; varList; varList = varList->v_list.next)
1919 {
1920 tree_node varName = varList->v_list.value;
1921
1922 _gst_line_number (varList->location.first_line, 0);
1923 if (!_gst_find_variable (&variable, varName))
1924 {
1925 if (varName->v_list.next)
1926 _gst_errorf_at (varName->location.first_line,
1927 "invalid scope resolution");
1928 else
1929 _gst_errorf_at (varName->location.first_line,
1930 "assignment to undeclared variable %s",
1931 varName->v_list.name);
1932 EXIT_COMPILATION ();
1933 }
1934
1935 if (variable.readOnly)
1936 {
1937 _gst_errorf_at (varName->location.first_line,
1938 "invalid assignment to %s %s",
1939 _gst_get_scope_kind (variable.scope),
1940 varName->v_list.name);
1941
1942 EXIT_COMPILATION ();
1943 }
1944
1945 /* Here we have several kinds of things to store: receiver
1946 variable, temporary variable, global variable (reference by
1947 association). */
1948
1949 if (variable.scope != SCOPE_GLOBAL && varName->v_list.next)
1950 {
1951 _gst_errorf_at (varName->location.first_line,
1952 "invalid scope resolution");
1953 EXIT_COMPILATION ();
1954 }
1955
1956 if (variable.scopeDistance > 0)
1957 _gst_compile_byte (STORE_OUTER_TEMP, (variable.varIndex << 8) | variable.scopeDistance);
1958
1959 else if (variable.scope == SCOPE_TEMPORARY)
1960 _gst_compile_byte (STORE_TEMPORARY_VARIABLE, variable.varIndex);
1961
1962 else if (variable.scope == SCOPE_RECEIVER)
1963 _gst_compile_byte (STORE_RECEIVER_VARIABLE, variable.varIndex);
1964
1965 else
1966 {
1967 /* This can become a message send, which might not return the
1968 value. Compile it in a way that can be easily peephole
1969 optimized. */
1970 _gst_compile_byte (STORE_LIT_VARIABLE, variable.varIndex);
1971 _gst_compile_byte (POP_STACK_TOP, 0);
1972 _gst_compile_byte (PUSH_LIT_VARIABLE, variable.varIndex);
1973 }
1974 }
1975 }
1976
1977
1978
1979 mst_Boolean
is_super(tree_node expr)1980 is_super (tree_node expr)
1981 {
1982 return (expr->nodeType == TREE_VARIABLE_NODE
1983 && _gst_intern_string (expr->v_list.name) ==
1984 _gst_super_symbol);
1985 }
1986
1987
1988 mst_Boolean
equal_constant(OOP oop,tree_node constExpr)1989 equal_constant (OOP oop,
1990 tree_node constExpr)
1991 {
1992 tree_node arrayElt;
1993 size_t len, i;
1994
1995 /* ??? this kind of special casing of the elements of arrays bothers
1996 me...it should all be in one neat place. */
1997 if (constExpr->nodeType == TREE_SYMBOL_NODE) /* symbol in array
1998 constant */
1999 return (oop == constExpr->v_expr.selector);
2000
2001 else if (constExpr->nodeType == TREE_ARRAY_ELT_LIST)
2002 {
2003 if (IS_OOP (oop) && OOP_CLASS (oop) == _gst_array_class)
2004 {
2005 for (len = 0, arrayElt = constExpr; arrayElt;
2006 len++, arrayElt = arrayElt->v_list.next);
2007
2008 if (len == NUM_OOPS (OOP_TO_OBJ (oop)))
2009 {
2010 for (i = 1, arrayElt = constExpr; i <= len;
2011 i++, arrayElt = arrayElt->v_list.next)
2012 {
2013 if (!equal_constant
2014 (ARRAY_AT (oop, i), arrayElt->v_list.value))
2015 return (false);
2016 }
2017 return (true);
2018 }
2019 }
2020 return (false);
2021 }
2022
2023
2024 switch (constExpr->v_const.constType)
2025 {
2026 case CONST_INT:
2027 if (oop == FROM_INT (constExpr->v_const.val.iVal))
2028 return (true);
2029 break;
2030
2031 case CONST_CHAR:
2032 if (IS_OOP (oop) && is_a_kind_of (OOP_CLASS (oop), _gst_char_class)
2033 && CHAR_OOP_VALUE (oop) == constExpr->v_const.val.iVal)
2034 return (true);
2035 break;
2036
2037 case CONST_FLOATD:
2038 if (IS_OOP (oop) && OOP_CLASS (oop) == _gst_floatd_class)
2039 {
2040 double d = (double) constExpr->v_const.val.fVal;
2041 if (!memcmp (&d, &OOP_TO_OBJ (oop)->data, sizeof (double)))
2042 return (true);
2043 }
2044 break;
2045
2046 case CONST_FLOATE:
2047 if (IS_OOP (oop) && OOP_CLASS (oop) == _gst_floate_class)
2048 {
2049 float f = (float) constExpr->v_const.val.fVal;
2050 if (!memcmp (&f, &OOP_TO_OBJ (oop)->data, sizeof (float)))
2051 return (true);
2052 }
2053 break;
2054
2055 case CONST_FLOATQ:
2056 if (IS_OOP (oop) && OOP_CLASS (oop) == _gst_floatq_class)
2057 {
2058 long double ld = (long double) constExpr->v_const.val.fVal;
2059 if (!memcmp (&ld, &OOP_TO_OBJ (oop)->data, sizeof (long double)))
2060 return (true);
2061 }
2062 break;
2063
2064 case CONST_STRING:
2065 if (IS_OOP (oop) && OOP_CLASS (oop) == _gst_string_class)
2066 {
2067 len = strlen (constExpr->v_const.val.sVal);
2068 if (len == _gst_string_oop_len (oop))
2069 {
2070 if (strncmp
2071 ((char *) OOP_TO_OBJ (oop)->data,
2072 constExpr->v_const.val.sVal, len) == 0)
2073 return (true);
2074 }
2075 }
2076 break;
2077
2078 case CONST_DEFERRED_BINDING:
2079 if (IS_OOP (oop) && OOP_CLASS (oop) == _gst_deferred_variable_binding_class)
2080 {
2081 gst_deferred_variable_binding binding =
2082 (gst_deferred_variable_binding) OOP_TO_OBJ (oop);
2083 gst_object path = OOP_TO_OBJ (binding->path);
2084 int i, size = NUM_OOPS (path);
2085 OOP *pKey;
2086 tree_node varNode = constExpr->v_const.val.aVal;
2087
2088 /* Use <= because we test the key first. */
2089 for (i = 0, pKey = &binding->key; i <= size; pKey = &path->data[i++])
2090 {
2091 if (!varNode
2092 || *pKey != _gst_intern_string (varNode->v_list.name))
2093 return (false);
2094
2095 varNode = varNode->v_list.next;
2096 }
2097 }
2098 break;
2099
2100 case CONST_BINDING:
2101 constExpr = _gst_find_variable_binding (constExpr->v_const.val.aVal);
2102 if (!constExpr)
2103 return (false);
2104
2105 assert (constExpr->v_const.constType != CONST_BINDING);
2106 return equal_constant (oop, constExpr);
2107
2108 case CONST_OOP:
2109 if (oop == constExpr->v_const.val.oopVal)
2110 return (true);
2111 break;
2112
2113 case CONST_ARRAY:
2114 if (IS_OOP (oop) && OOP_CLASS (oop) == _gst_array_class)
2115 {
2116 /* ??? could keep the length in a counter */
2117 for (len = 0, arrayElt = constExpr->v_const.val.aVal;
2118 arrayElt; len++, arrayElt = arrayElt->v_list.next);
2119 if (len == NUM_OOPS (OOP_TO_OBJ (oop)))
2120 {
2121 for (i = 1, arrayElt = constExpr->v_const.val.aVal;
2122 i <= len; i++, arrayElt = arrayElt->v_list.next)
2123 {
2124 if (!equal_constant
2125 (ARRAY_AT (oop, i), arrayElt->v_list.value))
2126 return (false);
2127 }
2128 return (true);
2129 }
2130 }
2131 break;
2132
2133 default:
2134 break;
2135 }
2136
2137 return (false);
2138 }
2139
2140 OOP
_gst_make_constant_oop(tree_node constExpr)2141 _gst_make_constant_oop (tree_node constExpr)
2142 {
2143 tree_node subexpr;
2144 int len, i;
2145 OOP resultOOP, elementOOP;
2146 inc_ptr incPtr;
2147 byte_object bo;
2148 gst_object result;
2149
2150 if (constExpr == NULL)
2151 return (_gst_nil_oop); /* special case empty array literals */
2152
2153 if (constExpr->nodeType == TREE_SYMBOL_NODE) /* symbol in array
2154 constant */
2155 return (constExpr->v_expr.selector);
2156
2157 else if (constExpr->nodeType == TREE_ARRAY_ELT_LIST)
2158 {
2159 for (len = 0, subexpr = constExpr; subexpr;
2160 len++, subexpr = subexpr->v_list.next);
2161
2162 incPtr = INC_SAVE_POINTER ();
2163
2164 /* this might be an uninitialized form of array creation for
2165 speed; but not now -- with the array temporarily part of the
2166 root set it must be completely initialized (sigh). */
2167 instantiate_with (_gst_array_class, len, &resultOOP);
2168 INC_ADD_OOP (resultOOP);
2169
2170 for (i = 0, subexpr = constExpr; i < len;
2171 i++, subexpr = subexpr->v_list.next)
2172 {
2173 elementOOP = _gst_make_constant_oop (subexpr->v_list.value);
2174 result = OOP_TO_OBJ (resultOOP);
2175 result->data[i] = elementOOP;
2176 }
2177 MAKE_OOP_READONLY (resultOOP, true);
2178 INC_RESTORE_POINTER (incPtr);
2179 return (resultOOP);
2180 }
2181
2182 switch (constExpr->v_const.constType)
2183 {
2184 case CONST_INT:
2185 return (FROM_INT (constExpr->v_const.val.iVal));
2186
2187 case CONST_CHAR:
2188 return (char_new (constExpr->v_const.val.iVal));
2189
2190 case CONST_FLOATD:
2191 return (floatd_new (constExpr->v_const.val.fVal));
2192
2193 case CONST_FLOATE:
2194 return (floate_new (constExpr->v_const.val.fVal));
2195
2196 case CONST_FLOATQ:
2197 return (floatq_new (constExpr->v_const.val.fVal));
2198
2199 case CONST_STRING:
2200 resultOOP = _gst_string_new (constExpr->v_const.val.sVal);
2201 MAKE_OOP_READONLY (resultOOP, true);
2202 return (resultOOP);
2203
2204 case CONST_BYTE_OBJECT:
2205 bo = constExpr->v_const.val.boVal;
2206 result = instantiate_with (bo->class, bo->size, &resultOOP);
2207 memcpy (result->data, bo->body, bo->size);
2208 MAKE_OOP_READONLY (resultOOP, true);
2209 return (resultOOP);
2210
2211 case CONST_DEFERRED_BINDING:
2212 {
2213 gst_deferred_variable_binding dvb;
2214 tree_node varNode = constExpr->v_const.val.aVal;
2215
2216 incPtr = INC_SAVE_POINTER ();
2217 dvb = (gst_deferred_variable_binding)
2218 instantiate (_gst_deferred_variable_binding_class, &resultOOP);
2219 INC_ADD_OOP (resultOOP);
2220
2221 dvb->key = _gst_intern_string (varNode->v_list.name);
2222 dvb->class = _gst_this_class;
2223 dvb->defaultDictionary = _gst_get_undeclared_dictionary ();
2224 dvb->association = _gst_nil_oop;
2225
2226 varNode = varNode->v_list.next;
2227 if (varNode)
2228 {
2229 int i, size = list_length (varNode);
2230 OOP arrayOOP;
2231 gst_object array =
2232 instantiate_with (_gst_array_class, size, &arrayOOP);
2233
2234 dvb->path = arrayOOP;
2235 for (i = 0; i < size; i++, varNode = varNode->v_list.next)
2236 array->data[i] = _gst_intern_string (varNode->v_list.name);
2237 }
2238
2239 INC_RESTORE_POINTER (incPtr);
2240 return (resultOOP);
2241 }
2242
2243 case CONST_BINDING:
2244 subexpr = _gst_find_variable_binding (constExpr->v_const.val.aVal);
2245 if (!subexpr)
2246 {
2247 _gst_errorf_at (constExpr->location.first_line,
2248 "invalid variable binding");
2249 EXIT_COMPILATION ();
2250 }
2251
2252 assert (subexpr->v_const.constType != CONST_BINDING);
2253 return _gst_make_constant_oop (subexpr);
2254
2255 case CONST_OOP:
2256 return (constExpr->v_const.val.oopVal);
2257
2258 case CONST_ARRAY:
2259 for (len = 0, subexpr = constExpr->v_const.val.aVal; subexpr;
2260 len++, subexpr = subexpr->v_list.next);
2261
2262 incPtr = INC_SAVE_POINTER ();
2263 result = instantiate_with (_gst_array_class, len, &resultOOP);
2264 INC_ADD_OOP (resultOOP);
2265
2266 for (i = 0, subexpr = constExpr->v_const.val.aVal; i < len;
2267 i++, subexpr = subexpr->v_list.next)
2268 {
2269 elementOOP = _gst_make_constant_oop (subexpr->v_list.value);
2270 result = OOP_TO_OBJ (resultOOP);
2271 result->data[i] = elementOOP;
2272 }
2273
2274 MAKE_OOP_READONLY (resultOOP, true);
2275 INC_RESTORE_POINTER (incPtr);
2276 return (resultOOP);
2277 }
2278
2279 return (_gst_nil_oop);
2280 }
2281
2282 OOP
make_block(int args,int temps,bc_vector bytecodes,int stack_depth)2283 make_block (int args,
2284 int temps,
2285 bc_vector bytecodes,
2286 int stack_depth)
2287 {
2288 OOP blockOOP;
2289
2290 if (_gst_declare_tracing)
2291 {
2292 printf (" Code for enclosed block:\n");
2293 #ifdef PRINT_BEFORE_OPTIMIZATION
2294 _gst_print_bytecodes (bytecodes, literal_vec);
2295 #endif
2296 }
2297 bytecodes = _gst_optimize_bytecodes (bytecodes);
2298
2299 if (_gst_declare_tracing)
2300 _gst_print_bytecodes (bytecodes, literal_vec);
2301
2302 blockOOP =
2303 _gst_block_new (args, temps, bytecodes, stack_depth, literal_vec);
2304
2305 _gst_free_bytecodes (bytecodes);
2306 return (blockOOP);
2307 }
2308
2309 OOP
make_clean_block_closure(OOP blockOOP)2310 make_clean_block_closure (OOP blockOOP)
2311 {
2312 gst_block_closure closure;
2313 OOP closureOOP;
2314
2315 closure = (gst_block_closure) new_instance (_gst_block_closure_class,
2316 &closureOOP);
2317
2318 /* Use the class as the receiver. This is blatantly wrong, but
2319 at least sets the correct trustfulness on the contexts. If the
2320 receiver was nil, for example, untrusted clean blocks evaluated
2321 from a trusted environment would be treated as trusted (because
2322 nil is trusted). */
2323 closure->receiver = _gst_this_class;
2324 closure->outerContext = _gst_nil_oop;
2325 closure->block = blockOOP;
2326
2327 return (closureOOP);
2328 }
2329
2330 OOP
compute_selector(tree_node selectorExpr)2331 compute_selector (tree_node selectorExpr)
2332 {
2333 if (selectorExpr->nodeType == TREE_UNARY_EXPR
2334 || selectorExpr->nodeType == TREE_BINARY_EXPR)
2335 return (selectorExpr->v_expr.selector);
2336 else
2337 return (_gst_compute_keyword_selector (selectorExpr->v_expr.expression));
2338 }
2339
2340 OOP
_gst_compute_keyword_selector(tree_node keywordList)2341 _gst_compute_keyword_selector (tree_node keywordList)
2342 {
2343 tree_node keyword;
2344 int len;
2345 char *nameBuf, *p;
2346
2347 len = 0;
2348 for (keyword = keywordList; keyword != NULL;
2349 keyword = keyword->v_list.next)
2350 len += strlen (keyword->v_list.name);
2351
2352 p = nameBuf = (char *) alloca (len + 1);
2353 for (keyword = keywordList; keyword != NULL;
2354 keyword = keyword->v_list.next)
2355 {
2356 len = strlen (keyword->v_list.name);
2357 strcpy (p, keyword->v_list.name);
2358 p += len;
2359 }
2360
2361 *p = '\0';
2362
2363 return (_gst_intern_string (nameBuf));
2364 }
2365
2366
2367 OOP
_gst_make_attribute(tree_node attribute_keywords)2368 _gst_make_attribute (tree_node attribute_keywords)
2369 {
2370 tree_node keyword;
2371 OOP selectorOOP, argsArrayOOP, messageOOP;
2372 gst_object argsArray;
2373 int i, numArgs;
2374 inc_ptr incPtr;
2375
2376 incPtr = INC_SAVE_POINTER ();
2377
2378 if (_gst_had_error)
2379 return _gst_nil_oop;
2380
2381 selectorOOP = _gst_compute_keyword_selector (attribute_keywords);
2382 numArgs = list_length (attribute_keywords);
2383 argsArray = instantiate_with (_gst_array_class, numArgs, &argsArrayOOP);
2384 INC_ADD_OOP (argsArrayOOP);
2385
2386 for (i = 0, keyword = attribute_keywords; keyword != NULL;
2387 i++, keyword = keyword->v_list.next)
2388 {
2389 tree_node value = keyword->v_list.value;
2390 OOP result;
2391 if (value->nodeType != TREE_CONST_EXPR)
2392 {
2393 result = _gst_execute_statements (NULL, value, UNDECLARED_NONE, true);
2394 if (!result)
2395 {
2396 _gst_had_error = true;
2397 return _gst_nil_oop;
2398 }
2399 }
2400 else
2401 result = _gst_make_constant_oop (value);
2402
2403 argsArray = OOP_TO_OBJ (argsArrayOOP);
2404 argsArray->data[i] = result;
2405 }
2406
2407 messageOOP = _gst_message_new_args (selectorOOP, argsArrayOOP);
2408 INC_RESTORE_POINTER (incPtr);
2409
2410 MAKE_OOP_READONLY (argsArrayOOP, true);
2411 MAKE_OOP_READONLY (messageOOP, true);
2412 return (messageOOP);
2413 }
2414
2415
2416 int
process_attributes_tree(tree_node attribute_list)2417 process_attributes_tree (tree_node attribute_list)
2418 {
2419 int primitiveIndex = 0;
2420
2421 for (; attribute_list; attribute_list = attribute_list->v_list.next)
2422 {
2423 tree_node value = attribute_list->v_list.value;
2424 OOP messageOOP = value->v_const.val.oopVal;
2425 int result = process_attribute (messageOOP);
2426
2427 if (result < 0)
2428 {
2429 EXIT_COMPILATION ();
2430 }
2431
2432 if (result > 0)
2433 {
2434 if (IS_OOP_UNTRUSTED (_gst_this_class))
2435 {
2436 _gst_errorf ("an untrusted class cannot declare primitives");
2437 EXIT_COMPILATION ();
2438 }
2439
2440 if (primitiveIndex > 0)
2441 {
2442 _gst_errorf ("duplicate primitive declaration");
2443 EXIT_COMPILATION ();
2444 }
2445 primitiveIndex = result;
2446 }
2447 }
2448
2449 return primitiveIndex;
2450 }
2451
2452 int
_gst_process_attributes_array(OOP arrayOOP)2453 _gst_process_attributes_array (OOP arrayOOP)
2454 {
2455 int primitiveIndex = 0;
2456 int n = NUM_WORDS (OOP_TO_OBJ (arrayOOP));
2457 int i;
2458
2459 if (IS_NIL (arrayOOP))
2460 return 0;
2461
2462 for (i = 0; i < n; i++)
2463 {
2464 OOP messageOOP = OOP_TO_OBJ (arrayOOP)->data[i];
2465 int result = process_attribute (messageOOP);
2466
2467 if (result < 0)
2468 return (-1);
2469
2470 if (result > 0)
2471 {
2472 if (primitiveIndex > 0)
2473 return (-1);
2474
2475 primitiveIndex = result;
2476 }
2477 }
2478
2479 return primitiveIndex;
2480 }
2481
2482 int
process_attribute(OOP messageOOP)2483 process_attribute (OOP messageOOP)
2484 {
2485 gst_message message = (gst_message) OOP_TO_OBJ (messageOOP);
2486 OOP selectorOOP = message->selector;
2487 OOP argumentsOOP = message->args;
2488 gst_object arguments = OOP_TO_OBJ (argumentsOOP);
2489
2490 if (selectorOOP == _gst_primitive_symbol)
2491 {
2492 if (IS_INT (arguments->data[0]))
2493 {
2494 int primitiveIndex = TO_INT (arguments->data[0]);
2495 if (primitiveIndex <= 0 || primitiveIndex >= NUM_PRIMITIVES)
2496 {
2497 _gst_errorf ("primitive number out of range");
2498 return (-1);
2499 }
2500
2501 return (primitiveIndex);
2502 }
2503 else
2504 {
2505 _gst_errorf ("bad primitive number, expected SmallInteger");
2506 return (-1);
2507 }
2508 }
2509 else if (selectorOOP == _gst_category_symbol)
2510 {
2511 this_method_category = arguments->data[0];
2512 return (0);
2513 }
2514 else
2515 {
2516 method_attributes *new_attr = (method_attributes *)
2517 xmalloc (sizeof (method_attributes));
2518
2519 new_attr->count = method_attrs ? method_attrs->count + 1 : 0;
2520 new_attr->oop = messageOOP;
2521 new_attr->next = method_attrs;
2522 method_attrs = new_attr;
2523
2524 _gst_register_oop (messageOOP);
2525 return (0);
2526 }
2527 }
2528
2529 void
realloc_literal_vec(void)2530 realloc_literal_vec (void)
2531 {
2532 int size;
2533 ptrdiff_t delta;
2534
2535 size = literal_vec_max - literal_vec + LITERAL_VEC_CHUNK_SIZE;
2536 delta = ((OOP *) xrealloc (literal_vec, size * sizeof (OOP))) - literal_vec;
2537
2538 literal_vec += delta;
2539 literal_vec_curr += delta;
2540 literal_vec_max = literal_vec + size;
2541 }
2542
2543
2544 int
list_length(tree_node listExpr)2545 list_length (tree_node listExpr)
2546 {
2547 tree_node l;
2548 long len;
2549
2550 for (len = 0, l = listExpr; l; l = l->v_list.next, len++);
2551
2552 if (sizeof (int) < sizeof (long) && len > INT_MAX)
2553 {
2554 _gst_errorf ("list too long, %ld", len);
2555 len = INT_MAX;
2556 }
2557
2558 return ((int) len);
2559 }
2560
2561
2562
2563 /***********************************************************************
2564 *
2565 * Literal Vector manipulation routines.
2566 *
2567 ***********************************************************************/
2568
2569
2570 int
add_literal(OOP oop)2571 add_literal (OOP oop)
2572 {
2573 if (literal_vec_curr >= literal_vec_max)
2574 realloc_literal_vec ();
2575
2576 *literal_vec_curr++ = oop;
2577 return (literal_vec_curr - literal_vec - 1);
2578 }
2579
2580 int
_gst_add_forced_object(OOP oop)2581 _gst_add_forced_object (OOP oop)
2582 {
2583 OOP *lit;
2584
2585 for (lit = literal_vec; lit < literal_vec_curr; lit++)
2586 if (*lit == oop)
2587 return (lit - literal_vec);
2588
2589 return (add_literal (oop));
2590 }
2591
2592 OOP
get_literals_array(void)2593 get_literals_array (void)
2594 {
2595 OOP methodLiteralsOOP;
2596 gst_object methodLiterals;
2597
2598 assert (literal_vec_curr > literal_vec);
2599
2600 methodLiterals = new_instance_with (_gst_array_class,
2601 literal_vec_curr - literal_vec,
2602 &methodLiteralsOOP);
2603
2604 memcpy (methodLiterals->data, literal_vec,
2605 (literal_vec_curr - literal_vec) * sizeof(OOP));
2606
2607 literal_vec_curr = literal_vec;
2608
2609 MAKE_OOP_READONLY (methodLiteralsOOP, true);
2610 return (methodLiteralsOOP);
2611 }
2612
2613
2614 void
install_method(OOP methodOOP)2615 install_method (OOP methodOOP)
2616 {
2617 OOP oldMethod, selector, methodDictionaryOOP;
2618 gst_compiled_method method;
2619 gst_method_info descriptor;
2620 int num_attrs, i;
2621
2622 method = (gst_compiled_method) OOP_TO_OBJ (methodOOP);
2623 descriptor = (gst_method_info) OOP_TO_OBJ (method->descriptor);
2624 num_attrs = NUM_INDEXABLE_FIELDS (method->descriptor);
2625
2626 for (i = 0; i < num_attrs; i++)
2627 {
2628 char *result;
2629 OOP attributeOOP = descriptor->attributes[i];
2630 gst_message attribute = (gst_message) OOP_TO_OBJ (attributeOOP);
2631 OOP handlerBlockOOP = _gst_find_pragma_handler (_gst_this_class,
2632 attribute->selector);
2633
2634 if (!IS_NIL (handlerBlockOOP))
2635 {
2636 _gst_msg_sendf (&result, "%s %o value: %o value: %o",
2637 handlerBlockOOP, methodOOP, attributeOOP);
2638 if (result != NULL)
2639 {
2640 _gst_errorf ("%s", result);
2641 EXIT_COMPILATION ();
2642 }
2643 }
2644
2645 method = (gst_compiled_method) OOP_TO_OBJ (methodOOP);
2646 descriptor = (gst_method_info) OOP_TO_OBJ (method->descriptor);
2647 if (num_attrs != NUM_INDEXABLE_FIELDS (method->descriptor))
2648 {
2649 _gst_errorf ("cannot modify method descriptor in pragma handler");
2650 EXIT_COMPILATION ();
2651 }
2652 }
2653
2654 selector = descriptor->selector;
2655
2656 /* methodDictionaryOOP is held onto by the class, which is already
2657 reachable by the root set so we don't need to hold onto it
2658 here. */
2659 methodDictionaryOOP =
2660 _gst_valid_class_method_dictionary (_gst_this_class);
2661
2662 if (_gst_untrusted_methods)
2663 {
2664 oldMethod = _gst_identity_dictionary_at (methodDictionaryOOP,
2665 selector);
2666 if (!IS_NIL (oldMethod) && !IS_OOP_UNTRUSTED (oldMethod))
2667 {
2668 _gst_errorf ("cannot redefine a trusted method as untrusted");
2669 EXIT_COMPILATION ();
2670 }
2671 }
2672
2673 MAKE_OOP_READONLY (methodOOP, true);
2674 oldMethod = _gst_identity_dictionary_at_put (methodDictionaryOOP,
2675 selector, methodOOP);
2676
2677 #ifdef ENABLE_JIT_TRANSLATION
2678 if (oldMethod != _gst_nil_oop)
2679 _gst_discard_native_code (oldMethod);
2680 #endif
2681
2682 #ifdef VERIFY_COMPILED_METHODS
2683 _gst_verify_sent_method (methodOOP);
2684 #endif
2685 _gst_invalidate_method_cache ();
2686 }
2687
2688 OOP
_gst_make_new_method(int primitiveIndex,int numArgs,int numTemps,int maximumStackDepth,OOP literals,bc_vector bytecodes,OOP class,OOP selector,OOP defaultCategoryOOP,int64_t startPos,int64_t endPos)2689 _gst_make_new_method (int primitiveIndex,
2690 int numArgs,
2691 int numTemps,
2692 int maximumStackDepth,
2693 OOP literals,
2694 bc_vector bytecodes,
2695 OOP class,
2696 OOP selector,
2697 OOP defaultCategoryOOP,
2698 int64_t startPos,
2699 int64_t endPos)
2700 {
2701 method_header header;
2702 int newFlags;
2703 OOP method, methodDesc, sourceCode, category;
2704 inc_ptr incPtr;
2705
2706 maximumStackDepth += numArgs + numTemps;
2707 memset (&header, 0, sizeof (method_header));
2708
2709 incPtr = INC_SAVE_POINTER ();
2710 if (primitiveIndex)
2711 {
2712 if (_gst_declare_tracing)
2713 printf (" Primitive Index %d\n", primitiveIndex);
2714
2715 header.headerFlag = MTH_PRIMITIVE;
2716 }
2717
2718 else if (method_attrs)
2719 header.headerFlag = MTH_ANNOTATED;
2720
2721 /* if returning a literal, we must either use comp.c's literal pool
2722 (IS_NIL (LITERALS)), get it from a preexisting literal pool
2723 (LITERAL_VEC_CURR == LITERAL_VEC), or put it into an empty
2724 pool (NUM_WORDS (...) == 0). */
2725 else if (numArgs == 0
2726 && numTemps == 0
2727 && (newFlags = _gst_is_simple_return (bytecodes)) != 0
2728 && (newFlags != MTH_RETURN_LITERAL
2729 || IS_NIL (literals)
2730 || NUM_WORDS (OOP_TO_OBJ (literals)) == 0
2731 || literal_vec_curr == literal_vec))
2732 {
2733 header.headerFlag = newFlags & 0xFF;
2734 /* if returning an instance variable, its index is indicated in
2735 the primitive index */
2736 primitiveIndex = newFlags >> 8;
2737 numTemps = 0;
2738
2739 _gst_free_bytecodes (bytecodes);
2740 bytecodes = NULL;
2741
2742 /* If returning a literal but we have none, it was added with
2743 _gst_add_forced_object. */
2744 }
2745
2746 else
2747 header.headerFlag = MTH_NORMAL;
2748
2749 if (literal_vec_curr > literal_vec)
2750 {
2751 literals = get_literals_array ();
2752 literal_vec_curr = literal_vec;
2753 INC_ADD_OOP (literals);
2754 }
2755
2756 if (bytecodes)
2757 {
2758 #ifdef PRINT_BEFORE_OPTIMIZATION
2759 if (_gst_declare_tracing)
2760 _gst_print_bytecodes (bytecodes, OOP_TO_OBJ (literals)->data);
2761 #endif
2762 bytecodes = _gst_optimize_bytecodes (bytecodes);
2763 }
2764
2765 if (_gst_declare_tracing)
2766 printf (" Allocated stack slots %d\n", maximumStackDepth);
2767
2768 if (_gst_declare_tracing)
2769 _gst_print_bytecodes (bytecodes, OOP_TO_OBJ (literals)->data);
2770
2771 maximumStackDepth += (1 << DEPTH_SCALE) - 1; /* round */
2772 maximumStackDepth >>= DEPTH_SCALE;
2773 maximumStackDepth++; /* just to be sure */
2774
2775 header.stack_depth = maximumStackDepth;
2776 header.primitiveIndex = primitiveIndex;
2777 header.numArgs = numArgs;
2778 header.numTemps = numTemps;
2779 header.intMark = 1;
2780
2781 if (this_method_category)
2782 {
2783 category = this_method_category;
2784 this_method_category = NULL;
2785 }
2786 else
2787 category = defaultCategoryOOP;
2788
2789 if (IS_NIL (class))
2790 sourceCode = _gst_nil_oop;
2791 else
2792 {
2793 sourceCode = _gst_get_source_string (startPos, endPos);
2794 INC_ADD_OOP (sourceCode);
2795 }
2796
2797 methodDesc = method_info_new (class, selector, method_attrs,
2798 sourceCode, category);
2799 INC_ADD_OOP (methodDesc);
2800
2801 method = method_new (header, literals, bytecodes, class, methodDesc);
2802 INC_RESTORE_POINTER (incPtr);
2803 return (method);
2804 }
2805
2806 OOP
method_new(method_header header,OOP literals,bc_vector bytecodes,OOP class,OOP methodDesc)2807 method_new (method_header header,
2808 OOP literals,
2809 bc_vector bytecodes,
2810 OOP class,
2811 OOP methodDesc)
2812 {
2813 int numByteCodes;
2814 gst_compiled_method method;
2815 OOP methodOOP;
2816 gst_object lit;
2817 int i;
2818
2819 if (bytecodes != NULL)
2820 numByteCodes = _gst_bytecode_length (bytecodes);
2821 else
2822 numByteCodes = 0;
2823
2824 method_attrs = NULL;
2825
2826 method = (gst_compiled_method) instantiate_with (_gst_compiled_method_class,
2827 numByteCodes, &methodOOP);
2828
2829 MAKE_OOP_UNTRUSTED (methodOOP,
2830 _gst_untrusted_methods
2831 || IS_OOP_UNTRUSTED (_gst_this_context_oop)
2832 || IS_OOP_UNTRUSTED (class));
2833
2834 method->header = header;
2835 method->descriptor = methodDesc;
2836 method->literals = literals;
2837
2838 for (lit = OOP_TO_OBJ (literals), i = NUM_OOPS (lit); i--;)
2839 {
2840 OOP blockOOP;
2841 gst_compiled_block block;
2842 if (IS_CLASS (lit->data[i], _gst_block_closure_class))
2843 {
2844 gst_block_closure bc;
2845 bc = (gst_block_closure) OOP_TO_OBJ (lit->data[i]);
2846 blockOOP = bc->block;
2847 }
2848 else if (IS_CLASS (lit->data[i], _gst_compiled_block_class))
2849 blockOOP = lit->data[i];
2850 else
2851 continue;
2852
2853 block = (gst_compiled_block) OOP_TO_OBJ (blockOOP);
2854 if (IS_NIL (block->method))
2855 {
2856 MAKE_OOP_UNTRUSTED (blockOOP, IS_OOP_UNTRUSTED (methodOOP));
2857 block->method = methodOOP;
2858 block->literals = literals;
2859 }
2860 }
2861
2862 if (bytecodes != NULL)
2863 {
2864 _gst_copy_bytecodes (method->bytecodes, bytecodes);
2865 _gst_free_bytecodes (bytecodes);
2866 }
2867
2868 return (methodOOP);
2869 }
2870
2871 OOP
_gst_block_new(int numArgs,int numTemps,bc_vector bytecodes,int maximumStackDepth,OOP * literals)2872 _gst_block_new (int numArgs,
2873 int numTemps,
2874 bc_vector bytecodes,
2875 int maximumStackDepth,
2876 OOP * literals)
2877 {
2878 int numByteCodes;
2879 OOP blockOOP;
2880 gst_compiled_block block;
2881 block_header header;
2882
2883 maximumStackDepth += numArgs + numTemps;
2884 maximumStackDepth += (1 << DEPTH_SCALE) - 1; /* round */
2885 maximumStackDepth >>= DEPTH_SCALE;
2886 maximumStackDepth++; /* just to be sure */
2887
2888 numByteCodes = _gst_bytecode_length (bytecodes);
2889
2890 memset (&header, 0, sizeof (header));
2891 header.numArgs = numArgs;
2892 header.numTemps = numTemps;
2893 header.depth = maximumStackDepth;
2894 header.intMark = 1;
2895 header.clean = _gst_check_kind_of_block (bytecodes, literals);
2896
2897 block = (gst_compiled_block) instantiate_with (_gst_compiled_block_class,
2898 numByteCodes, &blockOOP);
2899
2900 block->header = header;
2901 block->method = block->literals = _gst_nil_oop;
2902 _gst_copy_bytecodes (block->bytecodes, bytecodes);
2903
2904 MAKE_OOP_READONLY (blockOOP, true);
2905
2906 return (blockOOP);
2907 }
2908
2909 OOP
method_info_new(OOP class,OOP selector,method_attributes * attrs,OOP sourceCode,OOP categoryOOP)2910 method_info_new (OOP class,
2911 OOP selector,
2912 method_attributes *attrs,
2913 OOP sourceCode,
2914 OOP categoryOOP)
2915 {
2916 method_attributes *next;
2917 gst_method_info methodInfo;
2918 OOP methodInfoOOP;
2919
2920 methodInfo =
2921 (gst_method_info) new_instance_with (_gst_method_info_class,
2922 attrs ? attrs->count + 1 : 0,
2923 &methodInfoOOP);
2924
2925 methodInfo->sourceCode = sourceCode;
2926 methodInfo->category = categoryOOP;
2927 methodInfo->class = class;
2928 methodInfo->selector = selector;
2929
2930 while (attrs)
2931 {
2932 methodInfo->attributes[attrs->count] = attrs->oop;
2933 next = attrs->next;
2934 _gst_unregister_oop (attrs->oop);
2935 free (attrs);
2936 attrs = next;
2937 }
2938
2939 return (methodInfoOOP);
2940 }
2941
2942