1 /* This file implements the bytecode "resolve" pass, which converts
2 the optimization IR to the evaluation bytecode --- where the main
3 difference between the representations is to use stack addresses.
4 This pass is also responsible for closure conversion: lifting
5 functions that are used only in application positions, where all
6 variables captured by the closure can be converted to arguments at
7 every call site.
8
9 The "unresolve" functions convert run-time bytecode back into the
10 optimizer's IR, which is used for cross-module inlining and for
11 `compiled-expression-recompile`.
12
13 See "eval.c" for an overview of compilation passes. */
14
15 #include "schpriv.h"
16 #include "schrunst.h"
17 #include "schmach.h"
18
19 struct Resolve_Info
20 {
21 MZTAG_IF_REQUIRED
22 char in_module, in_proc, enforce_const, no_lift, need_instance_access;
23 int current_depth; /* tracks the stack depth, so variables can be
24 resolved relative to it; this depth is reset
25 on entry to `lambda` forms */
26 int current_lex_depth; /* keeps track of the lexical depth, which isn't
27 reset on entry; this absolute depth is useful
28 for sorting */
29 int max_let_depth; /* filled in by sub-expressions to track the maximum
30 stack depth experienced so far */
31 Scheme_Linklet *linklet;
32 mzshort toplevel_pos; /* tracks where the run-time prefix will be, relative
33 to the current stack depth */
34 void *tl_map; /* fixnum or bit array (as array of `int's) indicating which
35 globals+lifts in prefix are used */
36 struct Resolve_Info *top; /* for merging tl_map from lifted uses */
37
38 Scheme_Hash_Tree *redirects; /* maps variables that will be from the closure
39 to their stack depths for the enclosing `lambda` */
40 Scheme_Object *lifts; /* tracks functions lifted by closure conversion */
41 struct Resolve_Info *next;
42
43 int num_toplevels; /* number of toplevels, initially, in `linklet`,
44 taking into account that some imports may be
45 dropped; lifting adds more */
46 int *toplevel_starts; /* position within toplevels array where an
47 import instance or set of definitions
48 starts; add 1 to an import instance
49 position, and use 0 for definitions (which,
50 both cases, corresponds to adding 1 to
51 `instance_pos` in an
52 `Scheme_IR_Topelevel`). */
53 int *toplevel_deltas; /* shifts for toplevels in the import range to
54 accommodate removals */
55
56 Scheme_Hash_Table *toplevel_defns; /* for pruning unused definitions, if
57 some definitions are unexported
58 resolved position -> definition
59 definition -> #f - not yet used
60 #t - enqueued
61 list - resolved with lifts
62 NULL - used or has side effect */
63
64 Scheme_Hash_Table *static_mode; /* defn pos or ref (cons pos flags) -> static-toplevel */
65 };
66
67 #define cons(a,b) scheme_make_pair(a,b)
68
69 static Scheme_Object *resolve_expr(Scheme_Object *expr, Resolve_Info *info);
70 static Scheme_Object *resolve_lambda(Scheme_Object *_lam, Resolve_Info *info,
71 int can_lift, int convert, int just_compute_lift,
72 Scheme_Object *precomputed_lift);
73 static Resolve_Info *resolve_info_extend(Resolve_Info *info, int size, int lambda);
74 static void resolve_info_add_mapping(Resolve_Info *info, Scheme_IR_Local *var, Scheme_Object *v);
75 static int resolve_info_lookup(Resolve_Info *resolve, Scheme_IR_Local *var, Scheme_Object **lifted,
76 int convert_shift, int flags);
77 static Scheme_Object *resolve_info_lift_added(Resolve_Info *resolve, Scheme_Object *var, int convert_shift);
78 static void resolve_info_set_toplevel_pos(Resolve_Info *info, int pos);
79 static void merge_resolve(Resolve_Info *info, Resolve_Info *new_info);
80 static void merge_resolve_tl_map(Resolve_Info *info, Resolve_Info *new_info);
81 static Scheme_Object *resolve_generate_stub_lift(Resolve_Info *info);
82 static int resolve_toplevel_pos(Resolve_Info *info);
83 static Scheme_Object *resolve_toplevel(Resolve_Info *info, Scheme_Object *expr, int as_reference);
84 static Scheme_Object *resolve_invent_toplevel(Resolve_Info *info);
85 static Scheme_Object *resolve_invented_toplevel_to_defn(Resolve_Info *info, Scheme_Object *tl);
86 static Scheme_Object *shift_lifted_reference(Scheme_Object *tl, Resolve_Info *info, int delta);
87 static Scheme_Object *shift_toplevel(Scheme_Object *expr, int delta);
88 static int is_nonconstant_procedure(Scheme_Object *lam, Resolve_Info *info, Scheme_Hash_Tree *exclude_vars);
89 static int resolve_is_inside_proc(Resolve_Info *info);
90 static int resolve_has_toplevel(Resolve_Info *info);
91 static void set_tl_pos_used(Resolve_Info *info, int pos);
92 static void install_static_prefix(Scheme_Linklet *linket, Resolve_Info *ri);
93 static Scheme_Object *generate_lifted_name(Scheme_Hash_Table *used_names, int search_start);
94 static void enable_expression_resolve_lifts(Resolve_Info *ri);
95 static void extend_linklet_defns(Scheme_Linklet *linklet, int num_lifts);
96 static void prune_unused_imports(Scheme_Linklet *linklet);
97 static void prepare_definition_queue(Scheme_Linklet *linklet, Resolve_Info *rslv);
98 static void remove_definition_names(Scheme_Object *defn, Scheme_Linklet *linklet);
99 static Resolve_Info *resolve_info_create(Scheme_Linklet *rp, int enforce_const, int static_mode);
100
101 #ifdef MZ_PRECISE_GC
102 static void register_traversers(void);
103 #endif
104
105 #define RESOLVE_UNUSED_OK 0x1
106 #define RESOLVE_IGNORE_LIFTS 0x2
107
scheme_init_resolve()108 void scheme_init_resolve()
109 {
110 #ifdef MZ_PRECISE_GC
111 register_traversers();
112 #endif
113 }
114
115 /*========================================================================*/
116 /* applications */
117 /*========================================================================*/
118
check_converted_rator(Scheme_Object * rator,Resolve_Info * info,Scheme_Object ** new_rator,int orig_arg_cnt,int * _rdelta)119 static Scheme_Object *check_converted_rator(Scheme_Object *rator, Resolve_Info *info, Scheme_Object **new_rator,
120 int orig_arg_cnt, int *_rdelta)
121 /* Check whether `rator` refers to a function that has been lifted and
122 changed to accept extra arguments, in which case the application
123 needs to be adjusted with the extra arguments. */
124 {
125 Scheme_Object *lifted;
126
127 if (!SAME_TYPE(SCHEME_TYPE(rator), scheme_ir_local_type))
128 return NULL;
129
130 (void)resolve_info_lookup(info, SCHEME_VAR(rator), &lifted, 0, 0);
131
132 if (lifted && SCHEME_RPAIRP(lifted)) {
133 Scheme_Object *vec, *arity;
134
135 *new_rator = SCHEME_CAR(lifted);
136 vec = SCHEME_CDR(lifted);
137 *_rdelta = 0;
138
139 if (SAME_TYPE(SCHEME_TYPE(*new_rator), scheme_toplevel_type)) {
140 Scheme_Object *tl;
141 tl = shift_lifted_reference(*new_rator, info, orig_arg_cnt + SCHEME_VEC_SIZE(vec) - 1);
142 *new_rator = tl;
143 }
144
145 if (SCHEME_VEC_SIZE(vec) > 1) {
146 /* Check that actual argument count matches expected. If
147 it doesn't, we need to generate explicit code to report
148 the error, so that the conversion's arity change isn't
149 visible. */
150 arity = SCHEME_VEC_ELS(vec)[0];
151 if (SCHEME_INTP(arity)) {
152 if (orig_arg_cnt == SCHEME_INT_VAL(arity))
153 arity = NULL;
154 } else {
155 arity = SCHEME_BOX_VAL(arity);
156 if (orig_arg_cnt >= SCHEME_INT_VAL(arity))
157 arity = NULL;
158 else {
159 Scheme_App2_Rec *app;
160 app = MALLOC_ONE_TAGGED(Scheme_App2_Rec);
161 app->iso.so.type = scheme_application2_type;
162 app->rator = scheme_make_arity_at_least;
163 app->rand = arity;
164 arity = (Scheme_Object *)app;
165 *_rdelta = 1; /* so app gets resolved */
166 }
167 }
168 /* If arity is non-NULL, there's a mismatch. */
169 if (arity) {
170 /* Generate a call to `raise-arity-error' instead of
171 the current *new_rator: */
172 Scheme_Object *old_rator = *new_rator;
173 if (SAME_TYPE(SCHEME_TYPE(old_rator), scheme_toplevel_type)) {
174 /* More coordinate trouble. old_rator was computed for an
175 application with a potentially different number of arguments. */
176 int delta;
177 delta = 3 - SCHEME_VEC_SIZE(vec);
178 if (delta)
179 old_rator = shift_toplevel(old_rator, delta);
180 }
181 vec = scheme_make_vector(3, NULL);
182 SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(0);
183 SCHEME_VEC_ELS(vec)[1] = old_rator;
184 SCHEME_VEC_ELS(vec)[2] = arity;
185 *new_rator = scheme_raise_arity_error_proc;
186 }
187 }
188
189 return vec;
190 } else
191 return NULL;
192 }
193
resolve_application(Scheme_Object * o,Resolve_Info * orig_info,int already_resolved_arg_count)194 static Scheme_Object *resolve_application(Scheme_Object *o, Resolve_Info *orig_info, int already_resolved_arg_count)
195 {
196 Resolve_Info *info;
197 Scheme_App_Rec *app;
198 int i, n, devals;
199
200 app = (Scheme_App_Rec *)o;
201
202 n = app->num_args + 1;
203
204 if (!already_resolved_arg_count) {
205 /* Check whether this is an application of a converted closure: */
206 Scheme_Object *additions = NULL, *rator;
207 int rdelta;
208 additions = check_converted_rator(app->args[0], orig_info, &rator, n - 1, &rdelta);
209 if (additions) {
210 /* Expand application with m arguments */
211 Scheme_App_Rec *app2;
212 Scheme_Object *arg;
213 int m;
214 m = SCHEME_VEC_SIZE(additions) - 1;
215 app2 = scheme_malloc_application(n + m);
216 for (i = 0; i < m; i++) {
217 arg = resolve_info_lift_added(orig_info, SCHEME_VEC_ELS(additions)[i+1], n - 1 + m);
218 app2->args[i + 1] = arg;
219 }
220 for (i = 1; i < n; i++) {
221 app2->args[i + m] = app->args[i];
222 }
223 app2->args[0] = rator;
224 n += m;
225 app = app2;
226 already_resolved_arg_count = m + 1 + rdelta;
227 SCHEME_APPN_FLAGS(app) |= APPN_FLAG_SFS_TAIL;
228 }
229 }
230
231 devals = sizeof(Scheme_App_Rec) + ((n - mzFLEX_DELTA) * sizeof(Scheme_Object *));
232
233 info = resolve_info_extend(orig_info, n - 1, 0);
234
235 for (i = 0; i < n; i++) {
236 Scheme_Object *le;
237 if (already_resolved_arg_count) {
238 already_resolved_arg_count--;
239 } else {
240 le = resolve_expr(app->args[i], info);
241 app->args[i] = le;
242 }
243 }
244
245 merge_resolve(orig_info, info);
246
247 for (i = 0; i < n; i++) {
248 char et;
249 et = scheme_get_eval_type(app->args[i]);
250 ((char *)app XFORM_OK_PLUS devals)[i] = et;
251 }
252
253 return (Scheme_Object *)app;
254 }
255
256 static Scheme_Object *resolve_application3(Scheme_Object *o, Resolve_Info *orig_info, int already_resolved_arg_count);
257
set_app2_eval_type(Scheme_App2_Rec * app)258 static void set_app2_eval_type(Scheme_App2_Rec *app)
259 {
260 short et;
261
262 et = scheme_get_eval_type(app->rand);
263 et = et << 3;
264 et += scheme_get_eval_type(app->rator);
265
266 SCHEME_APPN_FLAGS(app) = et | (SCHEME_APPN_FLAGS(app) & APPN_FLAG_MASK);
267 }
268
scheme_reset_app2_eval_type(Scheme_App2_Rec * app)269 void scheme_reset_app2_eval_type(Scheme_App2_Rec *app)
270 {
271 set_app2_eval_type(app);
272 }
273
resolve_application2(Scheme_Object * o,Resolve_Info * orig_info,int already_resolved_arg_count)274 static Scheme_Object *resolve_application2(Scheme_Object *o, Resolve_Info *orig_info, int already_resolved_arg_count)
275 {
276 Resolve_Info *info;
277 Scheme_App2_Rec *app;
278 Scheme_Object *le, *arg;
279
280 app = (Scheme_App2_Rec *)o;
281
282 if (!already_resolved_arg_count) {
283 /* Check whether this is an application of a converted closure: */
284 Scheme_Object *additions = NULL, *rator;
285 int rdelta;
286 additions = check_converted_rator(app->rator, orig_info, &rator, 1, &rdelta);
287 if (additions) {
288 int m;
289 m = SCHEME_VEC_SIZE(additions) - 1;
290 if (!m) {
291 app->rator = rator;
292 already_resolved_arg_count = 1 + rdelta;
293 } else if (m > 1) {
294 /* Expand application with m arguments */
295 Scheme_App_Rec *app2;
296 int i;
297 app2 = scheme_malloc_application(2 + m);
298 for (i = 0; i < m; i++) {
299 arg = resolve_info_lift_added(orig_info, SCHEME_VEC_ELS(additions)[i+1], 1 + m);
300 app2->args[i + 1] = arg;
301 }
302 app2->args[0] = rator;
303 app2->args[m+1] = app->rand;
304 SCHEME_APPN_FLAGS(app2) |= APPN_FLAG_SFS_TAIL;
305 return resolve_application((Scheme_Object *)app2, orig_info, m + 1 + rdelta);
306 } else {
307 Scheme_App3_Rec *app2;
308 app2 = MALLOC_ONE_TAGGED(Scheme_App3_Rec);
309 app2->iso.so.type = scheme_application3_type;
310 app2->rator = rator;
311 arg = resolve_info_lift_added(orig_info, SCHEME_VEC_ELS(additions)[1], 1 + 1);
312 app2->rand1 = arg;
313 app2->rand2 = app->rand;
314 SCHEME_APPN_FLAGS(app2) |= APPN_FLAG_SFS_TAIL;
315 return resolve_application3((Scheme_Object *)app2, orig_info, m + 1 + rdelta);
316 }
317 }
318 }
319
320 info = resolve_info_extend(orig_info, 1, 0);
321
322 if (!already_resolved_arg_count) {
323 le = resolve_expr(app->rator, info);
324 app->rator = le;
325 } else
326 already_resolved_arg_count--;
327
328 if (!already_resolved_arg_count) {
329 le = resolve_expr(app->rand, info);
330 app->rand = le;
331 } else
332 already_resolved_arg_count--;
333
334 merge_resolve(orig_info, info);
335
336 set_app2_eval_type(app);
337
338 if (SAME_OBJ(app->rator, scheme_varref_const_p_proc)) {
339 if (SAME_TYPE(SCHEME_TYPE(app->rand), scheme_varref_form_type)) {
340 /* drop reference to namespace: */
341 SCHEME_PTR2_VAL(app->rand) = scheme_false;
342 }
343 }
344
345 return (Scheme_Object *)app;
346 }
347
eq_testable_constant(Scheme_Object * v)348 int eq_testable_constant(Scheme_Object *v)
349 {
350 if (SCHEME_SYMBOLP(v)
351 || SCHEME_KEYWORDP(v)
352 || SCHEME_FALSEP(v)
353 || SAME_OBJ(v, scheme_true)
354 || SCHEME_NULLP(v)
355 || SCHEME_VOIDP(v)
356 || SCHEME_EOFP(v))
357 return 1;
358
359 if (SCHEME_CHARP(v) && (SCHEME_CHAR_VAL(v) < 256))
360 return 1;
361
362 if (SCHEME_INTP(v)
363 && IN_FIXNUM_RANGE_ON_ALL_PLATFORMS(SCHEME_INT_VAL(v)))
364 return 1;
365
366 return 0;
367 }
368
set_app3_eval_type(Scheme_App3_Rec * app)369 static void set_app3_eval_type(Scheme_App3_Rec *app)
370 /* set flags used for a shortcut in the interpreter */
371 {
372 short et;
373
374 et = scheme_get_eval_type(app->rand2);
375 et = et << 3;
376 et += scheme_get_eval_type(app->rand1);
377 et = et << 3;
378 et += scheme_get_eval_type(app->rator);
379
380 SCHEME_APPN_FLAGS(app) = et | (SCHEME_APPN_FLAGS(app) & APPN_FLAG_MASK);
381 }
382
scheme_reset_app3_eval_type(Scheme_App3_Rec * app)383 void scheme_reset_app3_eval_type(Scheme_App3_Rec *app)
384 {
385 set_app3_eval_type(app);
386 }
387
resolve_application3(Scheme_Object * o,Resolve_Info * orig_info,int already_resolved_arg_count)388 static Scheme_Object *resolve_application3(Scheme_Object *o, Resolve_Info *orig_info, int already_resolved_arg_count)
389 {
390 Resolve_Info *info;
391 Scheme_App3_Rec *app;
392 Scheme_Object *le;
393
394 app = (Scheme_App3_Rec *)o;
395
396 if (!already_resolved_arg_count) {
397 /* Check whether this is an application of a converted closure: */
398 Scheme_Object *additions = NULL, *rator;
399 int rdelta;
400 additions = check_converted_rator(app->rator, orig_info, &rator, 2, &rdelta);
401 if (additions) {
402 int m, i;
403 m = SCHEME_VEC_SIZE(additions) - 1;
404 if (m) {
405 /* Expand application with m arguments */
406 Scheme_App_Rec *app2;
407 Scheme_Object *arg;
408 app2 = scheme_malloc_application(3 + m);
409 for (i = 0; i < m; i++) {
410 arg = resolve_info_lift_added(orig_info, SCHEME_VEC_ELS(additions)[i+1], 2 + m);
411 app2->args[i + 1] = arg;
412 }
413 app2->args[0] = rator;
414 app2->args[m+1] = app->rand1;
415 app2->args[m+2] = app->rand2;
416 SCHEME_APPN_FLAGS(app2) |= APPN_FLAG_SFS_TAIL;
417 return resolve_application((Scheme_Object *)app2, orig_info, m + 1 + rdelta);
418 } else {
419 app->rator = rator;
420 already_resolved_arg_count = 1 + rdelta;
421 }
422 }
423 }
424
425 info = resolve_info_extend(orig_info, 2, 0);
426
427 if (already_resolved_arg_count) {
428 already_resolved_arg_count--;
429 } else {
430 le = resolve_expr(app->rator, info);
431 app->rator = le;
432 }
433
434 if (already_resolved_arg_count) {
435 already_resolved_arg_count--;
436 } else {
437 le = resolve_expr(app->rand1, info);
438 app->rand1 = le;
439 }
440
441 if (already_resolved_arg_count) {
442 already_resolved_arg_count--;
443 } else {
444 le = resolve_expr(app->rand2, info);
445 app->rand2 = le;
446 }
447
448 /* Optimize `equal?' or `eqv?' test on certain types
449 to `eq?'. This is especially helpful for the JIT.
450 This transformation is also performed at the
451 optimization layer, and we keep it just in case.*/
452 if ((SAME_OBJ(app->rator, scheme_equal_proc)
453 || SAME_OBJ(app->rator, scheme_eqv_proc))
454 && (eq_testable_constant(app->rand1)
455 || eq_testable_constant(app->rand2))) {
456 app->rator = scheme_eq_proc;
457 }
458
459 set_app3_eval_type(app);
460
461 merge_resolve(orig_info, info);
462
463 return (Scheme_Object *)app;
464 }
465
466 /*========================================================================*/
467 /* branch, wcm */
468 /*========================================================================*/
469
resolve_branch(Scheme_Object * o,Resolve_Info * info)470 static Scheme_Object *resolve_branch(Scheme_Object *o, Resolve_Info *info)
471 {
472 Scheme_Branch_Rec *b;
473 Scheme_Object *t, *tb, *fb;
474
475 b = (Scheme_Branch_Rec *)o;
476
477 t = resolve_expr(b->test, info);
478 tb = resolve_expr(b->tbranch, info);
479 fb = resolve_expr(b->fbranch, info);
480
481 b->test = t;
482 b->tbranch = tb;
483 b->fbranch = fb;
484
485 return o;
486 }
487
resolve_wcm(Scheme_Object * o,Resolve_Info * info)488 static Scheme_Object *resolve_wcm(Scheme_Object *o, Resolve_Info *info)
489 {
490 Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o;
491 Scheme_Object *k, *v, *b;
492
493 k = resolve_expr(wcm->key, info);
494 v = resolve_expr(wcm->val, info);
495 b = resolve_expr(wcm->body, info);
496 wcm->key = k;
497 wcm->val = v;
498 wcm->body = b;
499
500 return (Scheme_Object *)wcm;
501 }
502
503 /*========================================================================*/
504 /* sequences */
505 /*========================================================================*/
506
look_for_letv_change(Scheme_Sequence * s)507 static Scheme_Object *look_for_letv_change(Scheme_Sequence *s)
508 {
509 int i, start;
510
511 /* Change (begin e1 ... (set!-for-let [x 10] (void)) e2 ...)
512 to (begin e1 ... (set!-for-let [x 10] e2 ...)), which
513 avoids an unneeded recursive call in the evaluator */
514
515 start = ((SCHEME_TYPE(s) == scheme_begin0_sequence_type) ? 1 : 0);
516
517 for (i = start; i < s->count - 1; i++) {
518 Scheme_Object *v;
519 v = s->array[i];
520 if (SAME_TYPE(SCHEME_TYPE(v), scheme_let_value_type)) {
521 Scheme_Let_Value *lv = (Scheme_Let_Value *)v;
522 if (scheme_omittable_expr(lv->body, 1, -1, OMITTABLE_RESOLVED, NULL, NULL)) {
523 int esize = s->count - (i + 1);
524 int nsize = i + 1;
525 Scheme_Object *nv, *ev;
526
527 if (nsize > 1) {
528 Scheme_Sequence *naya;
529
530 naya = scheme_malloc_sequence(nsize);
531 naya->so.type = s->so.type;
532 naya->count = nsize;
533 nv = (Scheme_Object *)naya;
534
535 for (i = 0; i < nsize; i++) {
536 naya->array[i] = s->array[i];
537 }
538 } else
539 nv = (Scheme_Object *)lv;
540
541 if (esize > 1) {
542 Scheme_Sequence *e;
543 e = scheme_malloc_sequence(esize);
544 e->so.type = s->so.type;
545 e->count = esize;
546
547 for (i = 0; i < esize; i++) {
548 e->array[i] = s->array[i + nsize];
549 }
550
551 ev = (Scheme_Object *)look_for_letv_change(e);
552 } else
553 ev = s->array[nsize];
554
555 lv->body = ev;
556
557 return nv;
558 }
559 }
560 }
561
562 return (Scheme_Object *)s;
563 }
564
resolve_sequence(Scheme_Object * o,Resolve_Info * info)565 static Scheme_Object *resolve_sequence(Scheme_Object *o, Resolve_Info *info)
566 {
567 Scheme_Sequence *s = (Scheme_Sequence *)o;
568 int i;
569
570 for (i = s->count; i--; ) {
571 Scheme_Object *le;
572 le = resolve_expr(s->array[i], info);
573 s->array[i] = le;
574 }
575
576 return look_for_letv_change(s);
577 }
578
579 /*========================================================================*/
580 /* other syntax */
581 /*========================================================================*/
582
583 static Scheme_Object *
define_values_resolve(Scheme_Object * data,Resolve_Info * rslv)584 define_values_resolve(Scheme_Object *data, Resolve_Info *rslv)
585 {
586 intptr_t i, cnt = SCHEME_DEFN_VAR_COUNT(data);
587 Scheme_Object *val, *a;
588 Scheme_IR_Toplevel *var;
589
590 /* If a defined variable doesn't have SCHEME_TOPLEVEL_MUTATED, then
591 resolve to a top-level reference with SCHEME_TOPLEVEL_SEAL, so
592 that we know to set GLOB_IS_IMMUTATED at run time. */
593
594 for (i = 0; i < cnt; i++) {
595 var = SCHEME_DEFN_VAR(data, i);
596 a = resolve_toplevel(rslv, (Scheme_Object *)var, 0);
597 if (rslv->enforce_const
598 && (!(SCHEME_IR_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_MUTATED)))
599 a = scheme_toplevel_to_flagged_toplevel(a, SCHEME_TOPLEVEL_SEAL);
600 SCHEME_DEFN_VAR_(data, i) = a;
601 }
602
603 val = resolve_expr(SCHEME_DEFN_RHS(data), rslv);
604 SCHEME_DEFN_RHS(data) = val;
605
606 return data;
607 }
608
resolve_lift_definition(Resolve_Info * info,Scheme_Object * var,Scheme_Object * rhs)609 static void resolve_lift_definition(Resolve_Info *info, Scheme_Object *var, Scheme_Object *rhs)
610 {
611 Scheme_Object *decl, *vec, *pr;
612
613 decl = scheme_make_vector(2, NULL);
614 decl->type = scheme_define_values_type;
615 SCHEME_DEFN_RHS(decl) = rhs;
616 SCHEME_DEFN_VAR_(decl, 0) = var;
617
618 vec = info->lifts;
619 pr = cons(decl, SCHEME_VEC_ELS(vec)[0]);
620 SCHEME_VEC_ELS(vec)[0] = pr;
621 }
622
623 static Scheme_Object *
inline_variant_resolve(Scheme_Object * data,Resolve_Info * rslv)624 inline_variant_resolve(Scheme_Object *data, Resolve_Info *rslv)
625 {
626 Scheme_Object *a;
627 char no_lift;
628
629 a = SCHEME_VEC_ELS(data)[0];
630 a = resolve_expr(a, rslv);
631 SCHEME_VEC_ELS(data)[0] = a;
632
633 /* Don't lift closures in the inline variant, since that
634 just creates lifted bindings and closure cycles that we
635 don't want to deal with when inlining. */
636 a = SCHEME_VEC_ELS(data)[1];
637 no_lift = rslv->no_lift;
638 rslv->no_lift = 1;
639 a = resolve_expr(a, rslv);
640 rslv->no_lift = no_lift;
641 SCHEME_VEC_ELS(data)[1] = a;
642
643 return data;
644 }
645
646 static Scheme_Object *
set_resolve(Scheme_Object * data,Resolve_Info * rslv)647 set_resolve(Scheme_Object *data, Resolve_Info *rslv)
648 {
649 Scheme_Set_Bang *sb = (Scheme_Set_Bang *)data;
650 Scheme_Object *var, *val;
651
652 var = sb->var;
653 val = sb->val;
654
655 val = resolve_expr(val, rslv);
656
657 if (SAME_TYPE(SCHEME_TYPE(var), scheme_ir_local_type)) {
658 Scheme_Let_Value *lv;
659 Scheme_Object *cv;
660 int li;
661
662 MZ_ASSERT(SCHEME_VAR(var)->mutated);
663
664 cv = scheme_compiled_void();
665
666 lv = MALLOC_ONE_TAGGED(Scheme_Let_Value);
667 lv->iso.so.type = scheme_let_value_type;
668 lv->body = cv;
669 lv->count = 1;
670 li = resolve_info_lookup(rslv, SCHEME_VAR(var), NULL, 0, 0);
671 lv->position = li;
672 SCHEME_LET_VALUE_AUTOBOX(lv) = 1;
673 lv->value = val;
674
675 return (Scheme_Object *)lv;
676 }
677
678 var = resolve_expr(var, rslv);
679
680 sb->var = var;
681 sb->val = val;
682
683 return (Scheme_Object *)sb;
684 }
685
686 static Scheme_Object *
ref_resolve(Scheme_Object * data,Resolve_Info * rslv)687 ref_resolve(Scheme_Object *data, Resolve_Info *rslv)
688 {
689 Scheme_Object *v;
690
691 v = resolve_expr(SCHEME_PTR2_VAL(data), rslv);
692 SCHEME_PTR2_VAL(data) = v;
693
694 v = SCHEME_PTR1_VAL(data);
695 if (SCHEME_SYMBOLP(v) /* => primitive instance */
696 || SAME_OBJ(v, scheme_false) /* => anonymous variable */
697 || SAME_OBJ(v, scheme_true)) { /* simplified local */
698 if (SCHEME_TRUEP(v))
699 SCHEME_VARREF_FLAGS(data) |= 0x1; /* => constant */
700 } else if (SAME_TYPE(SCHEME_TYPE(v), scheme_ir_local_type)) {
701 v = resolve_expr(v, rslv);
702 if (SAME_TYPE(SCHEME_TYPE(v), scheme_local_type))
703 SCHEME_VARREF_FLAGS(data) |= 0x1; /* because mutable would be unbox */
704 v = scheme_true;
705 } else
706 v = resolve_expr(v, rslv);
707 SCHEME_PTR1_VAL(data) = v;
708
709 return data;
710 }
711
712 static Scheme_Object *
apply_values_resolve(Scheme_Object * data,Resolve_Info * rslv)713 apply_values_resolve(Scheme_Object *data, Resolve_Info *rslv)
714 {
715 Scheme_Object *f, *e;
716
717 f = SCHEME_PTR1_VAL(data);
718 e = SCHEME_PTR2_VAL(data);
719
720 f = resolve_expr(f, rslv);
721 e = resolve_expr(e, rslv);
722
723 SCHEME_PTR1_VAL(data) = f;
724 SCHEME_PTR2_VAL(data) = e;
725
726 return data;
727 }
728
set_resolve_mode(Scheme_IR_Local * var)729 static void set_resolve_mode(Scheme_IR_Local *var)
730 {
731 MZ_ASSERT(SAME_TYPE(var->so.type, scheme_ir_local_type));
732 memset(&var->resolve, 0, sizeof(var->resolve));
733 var->mode = SCHEME_VAR_MODE_RESOLVE;
734 }
735
736 static Scheme_Object *
with_immed_mark_resolve(Scheme_Object * data,Resolve_Info * orig_rslv)737 with_immed_mark_resolve(Scheme_Object *data, Resolve_Info *orig_rslv)
738 {
739 Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)data;
740 Scheme_Object *e;
741 Scheme_IR_Local *var;
742 Resolve_Info *rslv = orig_rslv;
743
744 e = resolve_expr(wcm->key, rslv);
745 wcm->key = e;
746
747 e = resolve_expr(wcm->val, rslv);
748 wcm->val = e;
749
750 rslv = resolve_info_extend(rslv, 1, 0);
751
752 var = SCHEME_VAR(SCHEME_CAR(wcm->body));
753 set_resolve_mode(var);
754 var->resolve.co_depth = rslv->current_depth;
755 var->resolve.lex_depth = rslv->current_lex_depth;
756
757 e = resolve_expr(SCHEME_CDR(wcm->body), rslv);
758
759 if (var->mutated) {
760 Scheme_Object *bcode;
761 bcode = scheme_alloc_object();
762 bcode->type = scheme_boxenv_type;
763 SCHEME_PTR1_VAL(bcode) = scheme_make_integer(0);
764 SCHEME_PTR2_VAL(bcode) = e;
765 e = bcode;
766 }
767
768 wcm->body = e;
769
770 merge_resolve(orig_rslv, rslv);
771
772 return data;
773 }
774
775 static Scheme_Object *
case_lambda_resolve(Scheme_Object * expr,Resolve_Info * rslv)776 case_lambda_resolve(Scheme_Object *expr, Resolve_Info *rslv)
777 {
778 int i, all_closed = 1;
779 Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr;
780
781 for (i = 0; i < seq->count; i++) {
782 Scheme_Object *le;
783 le = seq->array[i];
784 le = resolve_lambda(le, rslv, 0, 0, 0, NULL);
785 seq->array[i] = le;
786 if (!SCHEME_PROCP(le))
787 all_closed = 0;
788 }
789
790 if (all_closed) {
791 /* Produce closure directly */
792 return scheme_case_lambda_execute(expr);
793 }
794
795 return expr;
796 }
797
798 /*========================================================================*/
799 /* let, let-values, letrec, etc. */
800 /*========================================================================*/
801
is_lifted_reference(Scheme_Object * v)802 static int is_lifted_reference(Scheme_Object *v)
803 /* check whether `v` is a reference to a lifted function */
804 {
805 if (SCHEME_RPAIRP(v))
806 return 1;
807
808 if (SAME_TYPE(SCHEME_TYPE(v), scheme_toplevel_type)
809 || SAME_TYPE(SCHEME_TYPE(v), scheme_static_toplevel_type))
810 return ((SCHEME_TOPLEVEL_FLAGS(v) & SCHEME_TOPLEVEL_FLAGS_MASK)
811 >= SCHEME_TOPLEVEL_CONST);
812
813 return 0;
814 }
815
is_closed_reference(Scheme_Object * v)816 static int is_closed_reference(Scheme_Object *v)
817 {
818 /* Look for a converted function (possibly with no new arguments)
819 that is accessed directly as a closure, instead of through a
820 top-level reference. */
821 if (SCHEME_RPAIRP(v)) {
822 v = SCHEME_CAR(v);
823 return SCHEME_PROCP(v);
824 }
825
826 return 0;
827 }
828
scheme_resolve_generate_stub_closure()829 static Scheme_Object *scheme_resolve_generate_stub_closure()
830 {
831 Scheme_Closure *cl;
832 Scheme_Object *ca;
833
834 cl = scheme_malloc_empty_closure();
835
836 ca = scheme_make_vector(1, scheme_make_integer(0));
837
838 return scheme_make_raw_pair((Scheme_Object *)cl, ca);
839 }
840
get_convert_arg_count(Scheme_Object * lift)841 static int get_convert_arg_count(Scheme_Object *lift)
842 {
843 if (!lift)
844 return 0;
845 else if (SCHEME_RPAIRP(lift)) {
846 lift = SCHEME_CDR(lift);
847 MZ_ASSERT(SCHEME_VECTORP(lift));
848 return SCHEME_VEC_SIZE(lift) - 1;
849 } else
850 return 0;
851 }
852
get_convert_arg_map(Scheme_Object * lift)853 static Scheme_Object *get_convert_arg_map(Scheme_Object *lift)
854 {
855 if (!lift)
856 return NULL;
857 else if (SCHEME_RPAIRP(lift)) {
858 lift = SCHEME_CDR(lift);
859 MZ_ASSERT(SCHEME_VECTORP(lift));
860 return lift;
861 } else
862 return NULL;
863 }
864
drop_zero_value_return(Scheme_Object * expr)865 static Scheme_Object *drop_zero_value_return(Scheme_Object *expr)
866 {
867 if (SAME_TYPE(SCHEME_TYPE(expr), scheme_sequence_type)) {
868 if (((Scheme_Sequence *)expr)->count == 2) {
869 if (SAME_TYPE(SCHEME_TYPE(((Scheme_Sequence *)expr)->array[1]), scheme_application_type)) {
870 if (((Scheme_App_Rec *)((Scheme_Sequence *)expr)->array[1])->num_args == 0) {
871 if (SAME_OBJ(scheme_values_proc, ((Scheme_App_Rec *)((Scheme_Sequence *)expr)->array[1])->args[0])) {
872 return ((Scheme_Sequence *)expr)->array[0];
873 }
874 }
875 }
876 }
877 }
878
879 return NULL;
880 }
881
882 #define HAS_UNBOXABLE_TYPE(var) ((var)->val_type && (!(var)->escapes_after_k_tick || ALWAYS_PREFER_UNBOX_TYPE((var)->val_type)))
883
check_need_boxed_letrec_rhs(Scheme_IR_Let_Header * head,Scheme_Hash_Tree * binding_vars,Resolve_Info * info,int * _num_rec_procs,int * _rec_proc_nonapply)884 static int check_need_boxed_letrec_rhs(Scheme_IR_Let_Header *head, Scheme_Hash_Tree *binding_vars, Resolve_Info *info,
885 int *_num_rec_procs, int *_rec_proc_nonapply)
886 /* Check whether a `let`+`set!` is needed to implement a set of `letrec` bindings;
887 the result is true if so, otherwise report the number of bindings that are
888 functions for a function-only `letrec`. Set `_rec_proc_nonapply` if any binding
889 is used in a non-application position, since that will disable lifting for
890 closure conversion. */
891 {
892 int recbox = 0;
893 Scheme_IR_Let_Value *irlv;
894 int i;
895
896 irlv = (Scheme_IR_Let_Value *)head->body;
897 for (i = head->num_clauses; i--; irlv = (Scheme_IR_Let_Value *)irlv->body) {
898 int is_proc, is_lift;
899
900 if ((irlv->count == 1)
901 && !irlv->vars[0]->optimize_used
902 && scheme_omittable_expr(irlv->value, irlv->count, -1, 0, NULL, NULL)) {
903 /* record omittable, so we don't have to keep checking: */
904 irlv->vars[0]->resolve_omittable = 1;
905 } else {
906 if (irlv->count == 1)
907 is_proc = scheme_is_ir_lambda(irlv->value, 1, 1);
908 else
909 is_proc = 0;
910
911 if (is_proc)
912 is_lift = 0;
913 else if (SCHEME_IRLV_FLAGS(irlv) & SCHEME_IRLV_NO_GROUP_USES)
914 is_lift = 1;
915 else
916 is_lift = scheme_is_liftable(irlv->value, binding_vars, 5, 1, 0);
917
918 if (!is_proc && !is_lift) {
919 recbox = 1;
920 break;
921 } else {
922 if (!is_lift) {
923 /* is_proc must be true ... */
924 int j;
925
926 for (j = 0; j < irlv->count; j++) {
927 if (irlv->vars[j]->mutated) {
928 recbox = 1;
929 break;
930 }
931 }
932 if (recbox)
933 break;
934
935 if (is_nonconstant_procedure(irlv->value, info, binding_vars)) {
936 (*_num_rec_procs)++;
937 if (irlv->vars[0]->non_app_count)
938 *_rec_proc_nonapply = 1;
939 }
940 }
941 }
942 }
943 }
944
945 if (recbox)
946 *_num_rec_procs = 0;
947
948 return recbox;
949 }
950
build_let_one_chain(Scheme_IR_Let_Header * head,Scheme_Object * body,Resolve_Info * info)951 static Scheme_Object *build_let_one_chain(Scheme_IR_Let_Header *head, Scheme_Object *body, Resolve_Info *info)
952 /* Build a chain of Scheme_Let_One records for a simple binding set */
953 {
954 Scheme_IR_Let_Value *irlv;
955 Scheme_Let_Value *last = NULL;
956 Scheme_Object *first = NULL;
957 int i, j, num_frames;
958 Resolve_Info *linfo;
959
960 j = head->num_clauses;
961
962 irlv = (Scheme_IR_Let_Value *)head->body;
963 for (i = 0; i < j; i++, irlv = (Scheme_IR_Let_Value *)irlv->body) {
964 if (irlv->vars[0]->optimize_used) {
965 int aty, pty, involes_k_cross;
966 aty = irlv->vars[0]->arg_type;
967 pty = scheme_expr_produces_local_type(irlv->value, &involes_k_cross);
968 if (pty && !involes_k_cross && ((pty == aty) || ALWAYS_PREFER_UNBOX_TYPE(pty)))
969 irlv->vars[0]->val_type = pty;
970 else
971 irlv->vars[0]->val_type = 0;
972 }
973 }
974
975 irlv = (Scheme_IR_Let_Value *)head->body;
976 linfo = info;
977 num_frames = 0;
978 for (i = 0; i < head->num_clauses; i++, irlv = (Scheme_IR_Let_Value *)irlv->body) {
979 Scheme_Object *le;
980
981 if (!irlv->vars[0]->optimize_used
982 && scheme_omittable_expr(irlv->value, irlv->count, -1, 0, NULL, NULL)) {
983 /* unused and omittable; skip */
984 } else {
985 linfo = resolve_info_extend(linfo, 1, 0);
986 num_frames++;
987 set_resolve_mode(irlv->vars[0]);
988 irlv->vars[0]->resolve.co_depth = linfo->current_depth;
989 irlv->vars[0]->resolve.lex_depth = linfo->current_lex_depth;
990
991 if (!info->no_lift
992 && !irlv->vars[0]->non_app_count
993 && SAME_TYPE(SCHEME_TYPE(irlv->value), scheme_ir_lambda_type))
994 le = resolve_lambda(irlv->value, linfo, 1, 1, 0, NULL);
995 else
996 le = resolve_expr(irlv->value, linfo);
997
998 if (is_lifted_reference(le)) {
999 MZ_ASSERT(!info->no_lift);
1000 irlv->vars[0]->resolve.lifted = le;
1001 /* Use of binding will be replaced by lift, so drop binding. */
1002 linfo = linfo->next;
1003 --num_frames;
1004 } else {
1005 Scheme_Let_One *lo;
1006 int et;
1007
1008 irlv->vars[0]->resolve.lifted = NULL;
1009
1010 lo = MALLOC_ONE_TAGGED(Scheme_Let_One);
1011 lo->iso.so.type = scheme_let_one_type;
1012 MZ_ASSERT(!SCHEME_RPAIRP(le));
1013 lo->value = le;
1014
1015 et = scheme_get_eval_type(lo->value);
1016 if (HAS_UNBOXABLE_TYPE(irlv->vars[0]))
1017 et |= (irlv->vars[0]->val_type << LET_ONE_TYPE_SHIFT);
1018 SCHEME_LET_EVAL_TYPE(lo) = et;
1019
1020 if (last)
1021 ((Scheme_Let_One *)last)->body = (Scheme_Object *)lo;
1022 else
1023 first = (Scheme_Object *)lo;
1024 last = (Scheme_Let_Value *)lo;
1025 }
1026 }
1027 }
1028
1029 body = resolve_expr(body, linfo);
1030 if (last)
1031 ((Scheme_Let_One *)last)->body = body;
1032 else
1033 first = body;
1034
1035 for (i = 0; i < num_frames; i++) {
1036 merge_resolve(linfo->next, linfo);
1037 linfo = linfo->next;
1038 }
1039
1040 return first;
1041 }
1042
all_unused_and_omittable(Scheme_IR_Let_Header * head)1043 static int all_unused_and_omittable(Scheme_IR_Let_Header *head)
1044 {
1045 Scheme_IR_Let_Value *irlv;
1046 int i, j, any_used = 0;
1047
1048 irlv = (Scheme_IR_Let_Value *)head->body;
1049 for (i = head->num_clauses; i--; irlv = (Scheme_IR_Let_Value *)irlv->body) {
1050 for (j = irlv->count; j--; ) {
1051 if (irlv->vars[j]->optimize_used) {
1052 any_used = 1;
1053 break;
1054 }
1055 }
1056 if (((irlv->count == 1) || !any_used)
1057 && scheme_omittable_expr(irlv->value, irlv->count, -1, 0, NULL, NULL)) {
1058 if ((irlv->count == 1) && !irlv->vars[0]->optimize_used)
1059 irlv->vars[0]->resolve_omittable = 1;
1060 } else
1061 any_used = 1;
1062 }
1063
1064 return !any_used;
1065 }
1066
compute_possible_lifts(Scheme_IR_Let_Header * head,Resolve_Info * info,Scheme_Hash_Tree * binding_vars,int recbox,int num_skips,int num_rec_procs,int rec_proc_nonapply,GC_CAN_IGNORE int * _lifted_recs)1067 static Resolve_Info *compute_possible_lifts(Scheme_IR_Let_Header *head, Resolve_Info *info, Scheme_Hash_Tree *binding_vars,
1068 int recbox, int num_skips, int num_rec_procs, int rec_proc_nonapply,
1069 GC_CAN_IGNORE int *_lifted_recs)
1070 /* First assume that all letrec-bound procedures can be lifted to empty closures.
1071 Then try assuming that all letrec-bound procedures can be at least lifted.
1072 Then fall back to assuming no lifts.
1073 Returns a resolve frame that is set up with lift decisions, and sets
1074 `_lifted_recs` to indicate the number of lifted functions. */
1075 {
1076 int resolve_phase;
1077 Resolve_Info *linfo;
1078 int i, pos, rpos, lifted_recs = 0;
1079 Scheme_IR_Let_Value *irlv;
1080
1081 linfo = NULL;
1082 for (resolve_phase = ((num_rec_procs && !rec_proc_nonapply && !info->no_lift) ? 0 : 2);
1083 resolve_phase < 3;
1084 resolve_phase++) {
1085
1086 /* Don't try plain lifting if we're not inside a proc: */
1087 if ((resolve_phase == 1) && (!resolve_is_inside_proc(info)
1088 || !resolve_has_toplevel(info)))
1089 resolve_phase = 2;
1090
1091 if (resolve_phase < 2) {
1092 linfo = resolve_info_extend(info, head->count - num_rec_procs - num_skips, 0);
1093 lifted_recs = 1;
1094 } else {
1095 linfo = resolve_info_extend(info, head->count - num_skips, 0);
1096 lifted_recs = 0;
1097 }
1098
1099 /* Shuffle procedure letrecs to fall together in the shallowest part. Also determine
1100 and initialize lifts for recursive procedures. Generating lift information
1101 requires an iteration. */
1102 irlv = (Scheme_IR_Let_Value *)head->body;
1103 pos = ((resolve_phase < 2) ? 0 : num_rec_procs);
1104 rpos = 0;
1105 for (i = head->num_clauses; i--; irlv = (Scheme_IR_Let_Value *)irlv->body) {
1106 int j;
1107
1108 if ((irlv->count == 1)
1109 && !irlv->vars[0]->optimize_used
1110 && irlv->vars[0]->resolve_omittable) {
1111 /* skipped */
1112 } else {
1113 for (j = 0; j < irlv->count; j++) {
1114 Scheme_Object *lift;
1115
1116 set_resolve_mode(irlv->vars[j]);
1117 if (recbox)
1118 irlv->vars[j]->mutated = 1;
1119
1120 if (num_rec_procs
1121 && (irlv->count == 1)
1122 && is_nonconstant_procedure(irlv->value, info, binding_vars)) {
1123 MZ_ASSERT(!recbox);
1124 if (resolve_phase == 0)
1125 lift = scheme_resolve_generate_stub_closure();
1126 else if (resolve_phase == 1)
1127 lift = resolve_generate_stub_lift(info);
1128 else
1129 lift = NULL;
1130 MZ_ASSERT(!info->no_lift || !lift);
1131 irlv->vars[0]->resolve.lifted = lift;
1132 irlv->vars[0]->resolve.co_depth = linfo->current_depth - rpos;
1133 irlv->vars[0]->resolve.lex_depth = linfo->current_lex_depth - rpos;
1134 rpos++;
1135 } else {
1136 irlv->vars[j]->resolve.lifted = NULL;
1137 irlv->vars[j]->resolve.co_depth = linfo->current_depth - pos;
1138 irlv->vars[j]->resolve.lex_depth = linfo->current_lex_depth - pos;
1139 /* Since Scheme_Let_Value doesn't record type info, we have
1140 to drop any unboxing type info recorded for the variable: */
1141 irlv->vars[j]->val_type = 0;
1142 pos++;
1143 }
1144 }
1145 }
1146 }
1147
1148 if (resolve_phase < 2) {
1149 /* Given the assumption that all are closed/lifted, compute
1150 actual lift info. We have to iterate if there are
1151 conversions, because a conversion can trigger another
1152 conversion. If the conversion changes for an item, it's
1153 always by adding more conversion arguments. */
1154 int converted;
1155 do {
1156 irlv = (Scheme_IR_Let_Value *)head->body;
1157 converted = 0;
1158 for (i = head->num_clauses; i--; irlv = (Scheme_IR_Let_Value *)irlv->body) {
1159 if ((irlv->count == 1)
1160 && !irlv->vars[0]->optimize_used
1161 && irlv->vars[0]->resolve_omittable) {
1162 /* skipped */
1163 } else if ((irlv->count == 1)
1164 && is_nonconstant_procedure(irlv->value, info, binding_vars)) {
1165 Scheme_Object *lift, *old_lift;
1166 int old_convert_count;
1167 Scheme_Object *old_convert_map, *convert_map;
1168
1169 old_lift = irlv->vars[0]->resolve.lifted;
1170 old_convert_count = get_convert_arg_count(old_lift);
1171 old_convert_map = get_convert_arg_map(old_lift);
1172
1173 lift = resolve_lambda(irlv->value, linfo, 1, 1, 1,
1174 (resolve_phase ? NULL : old_lift));
1175
1176 if (!info->no_lift
1177 && (is_closed_reference(lift)
1178 || (is_lifted_reference(lift) && resolve_phase))) {
1179 if (!SAME_OBJ(old_lift, lift))
1180 irlv->vars[0]->resolve.lifted = lift;
1181 if (get_convert_arg_count(lift) != old_convert_count)
1182 converted = 1;
1183 else if (old_convert_map) {
1184 int z;
1185 convert_map = get_convert_arg_map(lift);
1186 for (z = 0; z < old_convert_count; z++) {
1187 if (SCHEME_VEC_ELS(old_convert_map)[z+1] != SCHEME_VEC_ELS(convert_map)[z+1])
1188 converted = 1;
1189 }
1190 }
1191 } else {
1192 lifted_recs = 0;
1193 converted = 0;
1194 break;
1195 }
1196 }
1197 }
1198 } while (converted);
1199
1200 if (lifted_recs) {
1201 /* All can be closed or lifted --- and some may be converted.
1202 For the converted ones, the argument conversion is right. For
1203 lifted ones, we need to generate the actual offset. For fully
1204 closed ones, we need the actual closure.
1205
1206 If we succeeded with resolve_phase == 0, then all can be
1207 fully closed. We need to resolve again with the stub
1208 closures in place, and the mutate the stub closures with
1209 the actual closure info.
1210
1211 If we succeeded with resolve_phase == 1, then we need
1212 actual lift offsets before resolving procedure bodies.
1213 Also, we need to fix up the stub closures. */
1214 irlv = (Scheme_IR_Let_Value *)head->body;
1215 for (i = head->num_clauses; i--; irlv = (Scheme_IR_Let_Value *)irlv->body) {
1216 if ((irlv->count == 1)
1217 && !irlv->vars[0]->optimize_used
1218 && irlv->vars[0]->resolve_omittable) {
1219 /* skipped */
1220 } else if ((irlv->count == 1) && is_nonconstant_procedure(irlv->value, info, binding_vars)) {
1221 Scheme_Object *lift;
1222 lift = irlv->vars[0]->resolve.lifted;
1223 if (is_closed_reference(lift)) {
1224 (void)resolve_lambda(irlv->value, linfo, 1, 1, 0, lift);
1225 /* lift is the final result; this result might be
1226 referenced in the body of closures already, or in
1227 not-yet-closed functions. If no one uses the result
1228 via linfo, then the code was dead and it will get
1229 GCed. */
1230 irlv->value = NULL; /* indicates that there's nothing more to do with the expr */
1231 } else {
1232 lift = resolve_lambda(irlv->value, linfo, 1, 1, 2, NULL);
1233 /* need to resolve one more time for the body of the lifted function */
1234 irlv->vars[0]->resolve.lifted = lift;
1235 }
1236 }
1237 }
1238
1239 break; /* don't need to iterate */
1240 }
1241 }
1242 }
1243
1244 *_lifted_recs = lifted_recs;
1245
1246 return linfo;
1247 }
1248
scheme_resolve_lets(Scheme_Object * form,Resolve_Info * info)1249 Scheme_Object *scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
1250 /* Convert a Scheme_IR_Let_Header plus Scheme_IR_Let_Value records
1251 into either a sequence of Scheme_Let_One records or Scheme_Let_Void
1252 plus either Scheme_Letrec or Scheme_Let_Value records. Also, check
1253 whether functions that are locally bound can be lifted through
1254 closure conversion. The closure-conversion step may require
1255 iteration to a fixpoint to determine whether a set of
1256 mutually-referential functions can be lifted together, and whether
1257 they must be lifted to the top level or module level (bacsue they
1258 refer to other top-level or module-level bindings) or whether they
1259 can be converted to constant empty closures. */
1260 {
1261 Resolve_Info *linfo;
1262 Scheme_IR_Let_Header *head = (Scheme_IR_Let_Header *)form;
1263 Scheme_IR_Let_Value *irlv, *pre_body;
1264 Scheme_Let_Value *lv, *last = NULL;
1265 Scheme_Object *first = NULL, *body, *last_body = NULL, *last_seq = NULL;
1266 Scheme_Letrec *letrec;
1267 Scheme_Object *boxes;
1268 int i, j, rpos, recbox, num_rec_procs = 0, extra_alloc;
1269 int rec_proc_nonapply = 0;
1270 int num_skips, lifted_recs;
1271 Scheme_Hash_Tree *binding_vars;
1272
1273 /* Find body and make a set of local bindings: */
1274 body = head->body;
1275 pre_body = NULL;
1276 binding_vars = scheme_make_hash_tree(SCHEME_hashtr_eq);
1277 for (i = head->num_clauses; i--; ) {
1278 pre_body = (Scheme_IR_Let_Value *)body;
1279 for (j = 0; j < pre_body->count; j++) {
1280 binding_vars = scheme_hash_tree_set(binding_vars, (Scheme_Object *)pre_body->vars[j], scheme_true);
1281 }
1282 body = pre_body->body;
1283 }
1284
1285 recbox = 0;
1286 if (SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE) {
1287 /* Do we need to box vars in a letrec? */
1288 recbox = check_need_boxed_letrec_rhs(head, binding_vars, info,
1289 &num_rec_procs, &rec_proc_nonapply);
1290 } else {
1291 /* Sequence of single-value, non-assigned lets? */
1292
1293 irlv = (Scheme_IR_Let_Value *)head->body;
1294 for (i = head->num_clauses; i--; irlv = (Scheme_IR_Let_Value *)irlv->body) {
1295 if (irlv->count != 1)
1296 break;
1297 if (irlv->vars[0]->mutated)
1298 break;
1299 }
1300
1301 if (i < 0) {
1302 /* Yes - build chain of Scheme_Let_Ones and we're done: */
1303 return build_let_one_chain(head, body, info);
1304 } else {
1305 /* Maybe some multi-binding lets, but all of them are unused and
1306 the RHSes are omittable? This can happen with auto-generated
1307 code. Checking has the side effect of setting
1308 `resolve_omittable` fields. */
1309 if (all_unused_and_omittable(head)) {
1310 /* All unused and omittable */
1311 return resolve_expr(body, info);
1312 }
1313 }
1314 }
1315
1316 /* Count number of right-hand sides to be skipped entirely */
1317 num_skips = 0;
1318 irlv = (Scheme_IR_Let_Value *)head->body;
1319 for (i = head->num_clauses; i--; irlv = (Scheme_IR_Let_Value *)irlv->body) {
1320 if ((irlv->count == 1) && irlv->vars[0]->resolve_omittable) {
1321 num_skips++;
1322 }
1323 }
1324
1325 /* Compute lifts */
1326 linfo = compute_possible_lifts(head, info, binding_vars,
1327 recbox, num_skips, num_rec_procs, rec_proc_nonapply,
1328 &lifted_recs);
1329
1330 extra_alloc = 0;
1331
1332 if (num_rec_procs) {
1333 if (!lifted_recs) {
1334 /* Since we didn't lift, prepare a frame for function-only
1335 `letrec`; non-function bindings will be put in additional
1336 Scheme_Let_Value steps. */
1337 Scheme_Object **sa;
1338 letrec = MALLOC_ONE_TAGGED(Scheme_Letrec);
1339 letrec->so.type = scheme_letrec_type;
1340 letrec->count = num_rec_procs;
1341 sa = MALLOC_N(Scheme_Object *, num_rec_procs);
1342 letrec->procs = sa;
1343 } else {
1344 extra_alloc = -num_rec_procs;
1345 letrec = NULL;
1346 }
1347 } else
1348 letrec = NULL;
1349
1350 /* Resolve right-hand sides: */
1351 boxes = scheme_null;
1352 irlv = (Scheme_IR_Let_Value *)head->body;
1353 rpos = 0;
1354 for (i = head->num_clauses; i--; irlv = (Scheme_IR_Let_Value *)irlv->body) {
1355 if ((irlv->count == 1)
1356 && !irlv->vars[0]->optimize_used
1357 && irlv->vars[0]->resolve_omittable) {
1358 /* skipped */
1359 } else {
1360 int isproc;
1361 Scheme_Object *expr;
1362 if (!irlv->value)
1363 isproc = 1;
1364 else if (irlv->count == 1)
1365 isproc = is_nonconstant_procedure(irlv->value, info, binding_vars);
1366 else
1367 isproc = 0;
1368 if (num_rec_procs && isproc) {
1369 if (!lifted_recs) {
1370 expr = resolve_lambda(irlv->value, linfo, 0, 0, 0, NULL);
1371 if (!SAME_TYPE(SCHEME_TYPE(expr), scheme_lambda_type)) {
1372 scheme_signal_error("internal error: unexpected empty closure");
1373 }
1374 letrec->procs[rpos++] = expr;
1375 } else {
1376 if (!is_closed_reference(irlv->vars[0]->resolve.lifted)) {
1377 /* Side-effect is to install lifted function: */
1378 (void)resolve_lambda(irlv->value, linfo, 1, 1, 0, irlv->vars[0]->resolve.lifted);
1379 }
1380 rpos++;
1381 }
1382 } else {
1383 int j;
1384
1385 if (!irlv->count)
1386 expr = drop_zero_value_return(irlv->value);
1387 else
1388 expr = NULL;
1389
1390 if (expr) {
1391 /* Change a `[() (begin expr (values))]' clause,
1392 which can be generated by internal-definition expansion,
1393 into a `begin' */
1394 expr = resolve_expr(expr, linfo);
1395 expr = scheme_make_sequence_compilation(scheme_make_pair(expr,
1396 scheme_make_pair(scheme_false,
1397 scheme_null)),
1398 0,
1399 0);
1400
1401 if (last)
1402 last->body = expr;
1403 else if (last_body)
1404 SCHEME_PTR2_VAL(last_body) = expr;
1405 else if (last_seq)
1406 ((Scheme_Sequence *)last_seq)->array[1] = expr;
1407 else
1408 first = expr;
1409 last = NULL;
1410 last_body = NULL;
1411 last_seq = expr;
1412 } else {
1413 expr = resolve_expr(irlv->value, linfo);
1414
1415 lv = MALLOC_ONE_TAGGED(Scheme_Let_Value);
1416 if (last)
1417 last->body = (Scheme_Object *)lv;
1418 else if (last_body)
1419 SCHEME_PTR2_VAL(last_body) = (Scheme_Object *)lv;
1420 else if (last_seq)
1421 ((Scheme_Sequence *)last_seq)->array[1] = (Scheme_Object *)lv;
1422 else
1423 first = (Scheme_Object *)lv;
1424 last = lv;
1425 last_body = NULL;
1426 last_seq = NULL;
1427
1428 lv->iso.so.type = scheme_let_value_type;
1429 lv->value = expr;
1430 if (irlv->count) {
1431 int li;
1432 li = resolve_info_lookup(linfo, irlv->vars[0], NULL, 0, RESOLVE_UNUSED_OK);
1433 lv->position = li;
1434 } else
1435 lv->position = 0;
1436 lv->count = irlv->count;
1437 SCHEME_LET_VALUE_AUTOBOX(lv) = recbox;
1438
1439 for (j = lv->count; j--; ) {
1440 if (!recbox && irlv->vars[j]->mutated) {
1441 GC_CAN_IGNORE Scheme_Object *pos;
1442 pos = scheme_make_integer(lv->position + j);
1443 if ((SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE)
1444 || irlv->vars[j]->must_allocate_immediately) {
1445 /* For let* or a let*-like letrec, we need to insert the boxes after each evaluation. */
1446 Scheme_Object *boxenv;
1447
1448 boxenv = scheme_alloc_object();
1449 boxenv->type = scheme_boxenv_type;
1450 SCHEME_PTR1_VAL(boxenv) = pos;
1451 SCHEME_PTR2_VAL(boxenv) = scheme_false;
1452
1453 if (last)
1454 last->body = boxenv;
1455 else if (last_seq)
1456 ((Scheme_Sequence *)last_seq)->array[1] = boxenv;
1457 else
1458 SCHEME_PTR2_VAL(last_body) = boxenv;
1459 last = NULL;
1460 last_body = boxenv;
1461 last_seq = NULL;
1462 } else {
1463 /* For regular let, delay the boxing until all RHSs are
1464 evaluated. */
1465 boxes = scheme_make_pair(pos, boxes);
1466 }
1467 }
1468 }
1469 }
1470 }
1471 }
1472 }
1473
1474 /* Resolve body: */
1475 body = resolve_expr((Scheme_Object *)irlv, linfo);
1476
1477 while (SCHEME_PAIRP(boxes)) {
1478 /* See bangboxenv... */
1479 Scheme_Object *bcode;
1480 bcode = scheme_alloc_object();
1481 bcode->type = scheme_boxenv_type;
1482 SCHEME_PTR1_VAL(bcode) = SCHEME_CAR(boxes);
1483 SCHEME_PTR2_VAL(bcode) = body;
1484 body = bcode;
1485 boxes = SCHEME_CDR(boxes);
1486 }
1487
1488 /* Link up function-only `letrec` and Scheme_Let_Values chain */
1489 if (letrec) {
1490 letrec->body = body;
1491 if (last)
1492 last->body = (Scheme_Object *)letrec;
1493 else if (last_body)
1494 SCHEME_PTR2_VAL(last_body) = (Scheme_Object *)letrec;
1495 else if (last_seq)
1496 ((Scheme_Sequence *)last_seq)->array[1] = (Scheme_Object *)letrec;
1497 else
1498 first = (Scheme_Object *)letrec;
1499 } else if (last)
1500 last->body = body;
1501 else if (last_body)
1502 SCHEME_PTR2_VAL(last_body) = body;
1503 else if (last_seq)
1504 ((Scheme_Sequence *)last_seq)->array[1] = (Scheme_Object *)body;
1505 else
1506 first = body;
1507
1508 /* Check one last time for a simplification: */
1509 if (head->count + extra_alloc - num_skips) {
1510 int cnt;
1511
1512 cnt = head->count + extra_alloc - num_skips;
1513
1514 if (!recbox && (cnt == 1)
1515 && (SAME_TYPE(SCHEME_TYPE(first), scheme_let_value_type))
1516 && (((Scheme_Let_Value *)first)->count == 1)
1517 && (((Scheme_Let_Value *)first)->position == 0)) {
1518 /* Simplify to let-one after all */
1519 Scheme_Let_One *lo;
1520 int et;
1521
1522 lo = MALLOC_ONE_TAGGED(Scheme_Let_One);
1523 lo->iso.so.type = scheme_let_one_type;
1524 lo->value = ((Scheme_Let_Value *)first)->value;
1525 lo->body = ((Scheme_Let_Value *)first)->body;
1526
1527 et = scheme_get_eval_type(lo->value);
1528 SCHEME_LET_EVAL_TYPE(lo) = et;
1529
1530 first = (Scheme_Object *)lo;
1531 } else {
1532 Scheme_Let_Void *lvd;
1533
1534 lvd = MALLOC_ONE_TAGGED(Scheme_Let_Void);
1535 lvd->iso.so.type = scheme_let_void_type;
1536 lvd->body = first;
1537 lvd->count = cnt;
1538 SCHEME_LET_VOID_AUTOBOX(lvd) = recbox;
1539
1540 first = (Scheme_Object *)lvd;
1541 }
1542 }
1543
1544 merge_resolve(info, linfo);
1545
1546 return first;
1547 }
1548
1549 /*========================================================================*/
1550 /* lambda */
1551 /*========================================================================*/
1552
scheme_boxmap_size(int n)1553 XFORM_NONGCING int scheme_boxmap_size(int n)
1554 {
1555 return ((LAMBDA_TYPE_BITS_PER_ARG * n) + (BITS_PER_MZSHORT - 1)) / BITS_PER_MZSHORT;
1556 }
1557
scheme_boxmap_set(mzshort * boxmap,int j,int bit,int delta)1558 void scheme_boxmap_set(mzshort *boxmap, int j, int bit, int delta)
1559 /* assumes that existing bits are cleared */
1560 {
1561 j *= LAMBDA_TYPE_BITS_PER_ARG;
1562 boxmap[delta + (j / BITS_PER_MZSHORT)] |= ((mzshort)bit << (j & (BITS_PER_MZSHORT - 1)));
1563 }
1564
scheme_boxmap_get(mzshort * boxmap,int j,int delta)1565 int scheme_boxmap_get(mzshort *boxmap, int j, int delta)
1566 {
1567 j *= LAMBDA_TYPE_BITS_PER_ARG;
1568 return (boxmap[delta + (j / BITS_PER_MZSHORT)] >> (j & (BITS_PER_MZSHORT - 1))
1569 & ((1 << LAMBDA_TYPE_BITS_PER_ARG) - 1));
1570 }
1571
is_nonconstant_procedure(Scheme_Object * _lam,Resolve_Info * info,Scheme_Hash_Tree * exclude_vars)1572 static int is_nonconstant_procedure(Scheme_Object *_lam, Resolve_Info *info, Scheme_Hash_Tree *exclude_vars)
1573 {
1574 /* check whether `_lam' --- which is in a `letrec' --- can be converted to
1575 a constant independent of other bindings in the `letrec' */
1576 Scheme_Lambda *lam;
1577 Scheme_IR_Lambda_Info *cl;
1578 Scheme_Object *lifted;
1579 int i;
1580
1581 if (SAME_TYPE(SCHEME_TYPE(_lam), scheme_ir_lambda_type)) {
1582 lam = (Scheme_Lambda *)_lam;
1583
1584 cl = lam->ir_info;
1585 if (cl->has_tl)
1586 return 1;
1587
1588 for (i = 0; i < cl->base_closure->size; i++) {
1589 if (cl->base_closure->vals[i]) {
1590 Scheme_IR_Local *var = (Scheme_IR_Local *)cl->base_closure->keys[i];
1591
1592 if (scheme_hash_tree_get(exclude_vars, (Scheme_Object *)var))
1593 return 1;
1594
1595 if (var->optimize_used) {
1596 MZ_ASSERT(var->mode == SCHEME_VAR_MODE_RESOLVE);
1597 (void)resolve_info_lookup(info, var, &lifted, 0, 0);
1598 if (!lifted)
1599 return 1;
1600 if (SAME_TYPE(SCHEME_TYPE(lifted), scheme_toplevel_type)
1601 || SAME_TYPE(SCHEME_TYPE(lifted), scheme_static_toplevel_type)
1602 || SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(lifted)), scheme_toplevel_type)
1603 || SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(lifted)), scheme_static_toplevel_type))
1604 return 1;
1605 }
1606 }
1607 }
1608
1609 return 0;
1610 }
1611
1612 return 0;
1613 }
1614
1615 static Scheme_Object *
resolve_lambda(Scheme_Object * _lam,Resolve_Info * info,int can_lift,int convert,int just_compute_lift,Scheme_Object * precomputed_lift)1616 resolve_lambda(Scheme_Object *_lam, Resolve_Info *info,
1617 int can_lift, int convert, int just_compute_lift,
1618 Scheme_Object *precomputed_lift)
1619 {
1620 Scheme_Lambda *lam;
1621 int i, closure_size, new_params, num_params;
1622 int need_type_map = 0;
1623 int has_tl, need_lift, using_lifted = 0;
1624 mzshort *closure_map;
1625 Scheme_IR_Lambda_Info *cl;
1626 Resolve_Info *new_info;
1627 Scheme_Object *lifted, *result, *lifteds = NULL;
1628 Scheme_Hash_Table *captured = NULL;
1629
1630 lam = (Scheme_Lambda *)_lam;
1631 cl = lam->ir_info;
1632 if (!just_compute_lift)
1633 lam->iso.so.type = scheme_lambda_type;
1634
1635 if (convert || can_lift) {
1636 if (!convert && !resolve_is_inside_proc(info))
1637 can_lift = 0; /* no point in lifting when outside of a lambda or letrec */
1638 if (!info->lifts)
1639 can_lift = 0;
1640 }
1641
1642 /* Check possibility of unboxing arguments: */
1643 if (cl->arg_types) {
1644 int at_least_one = 0;
1645 for (i = lam->num_params; i--; ) {
1646 if (cl->arg_types[i]) {
1647 int ct;
1648 ct = scheme_predicate_to_local_type(cl->arg_types[i]);
1649 if (ct
1650 && (cl->vars[i]->arg_type == ct)
1651 && (!cl->vars[i]->escapes_after_k_tick
1652 || ALWAYS_PREFER_UNBOX_TYPE(cl->vars[i]->arg_type)))
1653 at_least_one = 1;
1654 else
1655 cl->arg_types[i] = NULL;
1656 }
1657 }
1658 if (at_least_one)
1659 need_type_map = 1;
1660 else
1661 cl->arg_types = NULL;
1662 }
1663
1664 has_tl = (info->static_mode ? 0 : cl->has_tl);
1665
1666 /* Add original closure content to `captured`, pruning variables
1667 that are lifted (so the closure might get smaller). The
1668 `captured' table maps variables to new positions relative to the
1669 current stack. */
1670 closure_size = 0;
1671 captured = scheme_make_hash_table(SCHEME_hash_ptr);
1672 for (i = 0; i < cl->base_closure->size; i++) {
1673 if (cl->base_closure->vals[i]) {
1674 Scheme_IR_Local *var = SCHEME_VAR(cl->base_closure->keys[i]);
1675
1676 if ((var->mode == SCHEME_VAR_MODE_OPTIMIZE)
1677 || !var->optimize_used) {
1678 /* reference must have been optimized away; drop it
1679 from the closure */
1680 } else {
1681 (void)resolve_info_lookup(info, var, &lifted, 0, 0);
1682 if (lifted) {
1683 /* Drop lifted binding from closure. */
1684 if (SAME_TYPE(SCHEME_TYPE(lifted), scheme_toplevel_type)
1685 || (SCHEME_RPAIRP(lifted)
1686 && SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(lifted)), scheme_toplevel_type))) {
1687 /* Former local variable is now a top-level variable. */
1688 has_tl = 1;
1689 }
1690 /* If the lifted binding is for a converted closure,
1691 we may need to add more bindings to this closure. */
1692 if (SCHEME_RPAIRP(lifted)) {
1693 lifteds = scheme_make_raw_pair(lifted, lifteds);
1694 using_lifted = 1;
1695 }
1696 } else {
1697 scheme_hash_set(captured, (Scheme_Object *)var, scheme_make_integer(closure_size));
1698 closure_size++;
1699 /* Currently, we only need type (not boxing) information for closure content: */
1700 if (HAS_UNBOXABLE_TYPE(var))
1701 need_type_map = 1;
1702 }
1703 }
1704 }
1705 }
1706
1707 if (has_tl && !can_lift)
1708 convert = 0;
1709
1710 /* Add variable references introduced by closure conversion. */
1711 while (lifteds) {
1712 int j, cnt;
1713 Scheme_Object *vec;
1714
1715 lifted = SCHEME_CAR(lifteds);
1716 vec = SCHEME_CDR(lifted);
1717 cnt = SCHEME_VEC_SIZE(vec);
1718 --cnt;
1719 for (j = 0; j < cnt; j++) {
1720 Scheme_IR_Local *var = (Scheme_IR_Local *)SCHEME_VEC_ELS(vec)[j+1];
1721 if (!scheme_hash_get(captured, (Scheme_Object *)var)) {
1722 /* Need to capture an extra binding: */
1723 MZ_ASSERT(!var->resolve.lifted);
1724 scheme_hash_set(captured, (Scheme_Object *)var, scheme_make_integer(captured->count));
1725 if (HAS_UNBOXABLE_TYPE(var))
1726 need_type_map = 1;
1727 closure_size++;
1728 }
1729 }
1730
1731 lifteds = SCHEME_CDR(lifteds);
1732 }
1733
1734 /* To make compilation deterministic, sort the captured variables */
1735 if (closure_size) {
1736 Scheme_IR_Local **c;
1737 int j = 0;
1738 c = MALLOC_N(Scheme_IR_Local*, closure_size);
1739 for (i = 0; i < captured->size; i++) {
1740 if (captured->vals[i]) {
1741 c[j++] = SCHEME_VAR(captured->keys[i]);
1742 }
1743 }
1744 scheme_sort_resolve_ir_local_array(c, closure_size);
1745 for (i = 0; i < closure_size; i++) {
1746 scheme_hash_set(captured, (Scheme_Object *)c[i], scheme_make_integer(i));
1747 }
1748 }
1749
1750 if (convert && (closure_size || has_tl || using_lifted)) {
1751 new_params = closure_size;
1752 closure_size = 0;
1753 } else {
1754 new_params = 0;
1755 convert = 0;
1756 }
1757
1758 /* Count the pointer to globals, if any: */
1759 if (has_tl) {
1760 /* GLOBAL ASSUMPTION: jit.c assumes that the array
1761 of globals is the last item in the closure; grep
1762 for "GLOBAL ASSUMPTION" in jit.c and mzmark.c */
1763 closure_size++;
1764 }
1765
1766 /* New arguments due to closure conversion will be added before
1767 the original arguments: */
1768 num_params = lam->num_params + new_params;
1769
1770 if ((num_params == 1)
1771 && !new_params
1772 && (SCHEME_LAMBDA_FLAGS(lam) & LAMBDA_HAS_REST)
1773 && !cl->vars[0]->optimize_used) {
1774 /* We can claim 0 params plus LAMBDA_HAS_REST as an optimization */
1775 num_params = 0;
1776 }
1777
1778 if (!just_compute_lift) {
1779 if (convert && !need_type_map && new_params) {
1780 /* As we turn closure content into arguments, we need mutation
1781 info, so double-check whether a type map is needed after all. */
1782 for (i = 0; i < captured->size; i++) {
1783 if (captured->vals[i]) {
1784 Scheme_IR_Local *var = SCHEME_VAR(captured->keys[i]);
1785 if (var->mutated) {
1786 need_type_map = 1;
1787 break;
1788 }
1789 }
1790 }
1791 }
1792
1793 new_info = resolve_info_extend(info, num_params + closure_size, 1);
1794
1795 lam->closure_size = closure_size;
1796 if (need_type_map)
1797 SCHEME_LAMBDA_FLAGS(lam) |= LAMBDA_HAS_TYPED_ARGS;
1798
1799 MZ_ASSERT(need_type_map || !(SCHEME_LAMBDA_FLAGS(lam) & LAMBDA_HAS_TYPED_ARGS));
1800
1801 /* Create the closure map, if needed */
1802 if (closure_size || need_type_map) {
1803 int bmsz;
1804 if (need_type_map)
1805 bmsz = scheme_boxmap_size(closure_size + num_params);
1806 else
1807 bmsz = 0;
1808 bmsz += closure_size;
1809 closure_map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * bmsz);
1810 memset(closure_map + closure_size, 0, sizeof(mzshort) * (bmsz - closure_size));
1811 } else
1812 closure_map = NULL;
1813
1814 lam->closure_map = closure_map;
1815 lam->num_params = num_params;
1816
1817 /* Register original argument names and types */
1818 for (i = 0; i < num_params - new_params; i++) {
1819 set_resolve_mode(cl->vars[i]);
1820 cl->vars[i]->resolve.co_depth = new_info->current_depth - (i + new_params + closure_size);
1821 cl->vars[i]->resolve.lex_depth = new_info->current_lex_depth - (i + new_params + closure_size);
1822 if (convert) {
1823 /* If we're lifting this function, then arguments can have unboxing
1824 types, because the valdiator will be able to check all the
1825 calls: */
1826 int lt;
1827 if (cl->arg_types) {
1828 lt = scheme_predicate_to_local_type(cl->arg_types[i]);
1829 cl->vars[i]->val_type = lt;
1830 } else
1831 lt = 0;
1832 if (need_type_map) {
1833 if (lt)
1834 scheme_boxmap_set(closure_map, i + new_params,
1835 lt + LAMBDA_TYPE_TYPE_OFFSET,
1836 closure_size);
1837 }
1838 }
1839 }
1840
1841 /* Register closure content (possibly as new params) */
1842 for (i = 0; i < captured->size; i++) {
1843 if (captured->vals[i]) {
1844 int pos = SCHEME_INT_VAL(captured->vals[i]);
1845 Scheme_IR_Local *var = SCHEME_VAR(captured->keys[i]);
1846 resolve_info_add_mapping(new_info, var,
1847 scheme_make_integer(new_info->current_depth
1848 - pos
1849 - (convert
1850 ? closure_size
1851 : 0)));
1852 MZ_ASSERT(need_type_map || (!HAS_UNBOXABLE_TYPE(var) && (!var->mutated || !convert)));
1853 if (need_type_map) {
1854 scheme_boxmap_set(closure_map, (pos + (convert ? 0 : num_params)),
1855 ((HAS_UNBOXABLE_TYPE(var)
1856 ? (var->val_type + LAMBDA_TYPE_TYPE_OFFSET)
1857 : 0)
1858 | (convert
1859 ? (var->mutated ? LAMBDA_TYPE_BOXED : 0)
1860 : 0)),
1861 closure_size);
1862 }
1863 if (!convert) {
1864 int li;
1865 li = resolve_info_lookup(info, var, NULL, 0, 0);
1866 closure_map[pos] = li;
1867 }
1868 }
1869 }
1870
1871 if (has_tl) {
1872 /* array of globals is at the end: */
1873 resolve_info_set_toplevel_pos(new_info, closure_size - 1);
1874 if (closure_map) {
1875 int li;
1876 li = resolve_toplevel_pos(info);
1877 closure_map[closure_size-1] = li;
1878 }
1879 } else
1880 resolve_info_set_toplevel_pos(new_info, -1);
1881
1882 /* Resolve the closure body: */
1883 {
1884 Scheme_Object *code;
1885 code = resolve_expr(lam->body, new_info);
1886 lam->body = code;
1887 }
1888
1889 lam->max_let_depth = (new_info->max_let_depth
1890 + SCHEME_TAIL_COPY_THRESHOLD);
1891
1892 lam->tl_map = new_info->tl_map;
1893 if (!lam->tl_map && has_tl) {
1894 /* Our reason to refer to the top level has apparently gone away;
1895 record that we're not using anything */
1896 lam->tl_map = (void *)0x1;
1897 }
1898
1899 /* Add code to box set!ed argument variables: */
1900 for (i = 0; i < num_params - new_params; i++) {
1901 if (cl->vars[i]->mutated) {
1902 int j = i + closure_size + new_params;
1903 Scheme_Object *bcode;
1904
1905 bcode = scheme_alloc_object();
1906 bcode->type = scheme_boxenv_type;
1907 SCHEME_PTR1_VAL(bcode) = scheme_make_integer(j);
1908 SCHEME_PTR2_VAL(bcode) = lam->body;
1909
1910 lam->body = bcode;
1911 }
1912 }
1913 } else {
1914 new_info = NULL;
1915 closure_map = NULL;
1916 }
1917
1918 if ((closure_size == 1)
1919 && can_lift
1920 && has_tl
1921 && info->lifts) {
1922 need_lift = 1;
1923 } else
1924 need_lift = 0;
1925
1926 /* If the closure is empty, create the closure now */
1927 if (!closure_size) {
1928 if (precomputed_lift) {
1929 result = SCHEME_CAR(precomputed_lift);
1930 if (!just_compute_lift)
1931 ((Scheme_Closure *)result)->code = lam;
1932 } else {
1933 if (just_compute_lift)
1934 result = (Scheme_Object *)scheme_malloc_empty_closure();
1935 else
1936 result = scheme_make_closure(NULL, (Scheme_Object *)lam, 0);
1937 }
1938 } else
1939 result = (Scheme_Object *)lam;
1940
1941 if (need_lift) {
1942 if (just_compute_lift) {
1943 if (just_compute_lift > 1)
1944 result = resolve_invent_toplevel(info);
1945 else
1946 result = resolve_generate_stub_lift(info);
1947 } else {
1948 Scheme_Object *tl, *defn_tl;
1949 if (precomputed_lift) {
1950 tl = precomputed_lift;
1951 if (SCHEME_RPAIRP(tl))
1952 tl = SCHEME_CAR(tl);
1953 } else {
1954 tl = resolve_invent_toplevel(info);
1955 }
1956 defn_tl = resolve_invented_toplevel_to_defn(info, tl);
1957 resolve_lift_definition(info, defn_tl, result);
1958 if (has_tl)
1959 closure_map[0] = 0; /* globals for closure creation will be at 0 after lifting */
1960 result = tl;
1961 merge_resolve_tl_map(new_info->top, new_info);
1962 }
1963 } else if (!just_compute_lift) {
1964 merge_resolve(info, new_info);
1965 }
1966
1967 if (convert) {
1968 /* Generate lift record, which is a vector containing
1969 the original arity and then each variable captured in the closure
1970 (or would be captured if there's no lift conversion). */
1971 Scheme_Object *ca, *arity;
1972
1973 if ((SCHEME_LAMBDA_FLAGS(lam) & LAMBDA_HAS_REST))
1974 arity = scheme_box(scheme_make_integer(num_params - new_params - 1));
1975 else
1976 arity = scheme_make_integer(num_params - new_params);
1977
1978 ca = scheme_make_vector(1 + captured->count, scheme_false);
1979 SCHEME_VEC_ELS(ca)[0] = arity;
1980
1981 for (i = 0; i < captured->size; i++) {
1982 if (captured->vals[i]) {
1983 MZ_ASSERT(SAME_TYPE(scheme_ir_local_type, SCHEME_TYPE(captured->keys[i])));
1984 SCHEME_VEC_ELS(ca)[1 + SCHEME_INT_VAL(captured->vals[i])] = captured->keys[i];
1985 }
1986 }
1987
1988 if (precomputed_lift) {
1989 SCHEME_CAR(precomputed_lift) = result;
1990 SCHEME_CDR(precomputed_lift) = (Scheme_Object *)ca;
1991 result = precomputed_lift;
1992 } else
1993 result = scheme_make_raw_pair(result, (Scheme_Object *)ca);
1994 }
1995
1996 return result;
1997 }
1998
1999 /*========================================================================*/
2000 /* linklet */
2001 /*========================================================================*/
2002
scheme_resolve_linklet(Scheme_Linklet * linklet,int enforce_const,int static_mode)2003 Scheme_Linklet *scheme_resolve_linklet(Scheme_Linklet *linklet, int enforce_const, int static_mode)
2004 {
2005 Scheme_Object *lift_vec, *body = scheme_null, *new_bodies;
2006 Resolve_Info *rslv;
2007 int i, cnt, num_lifts;
2008
2009 rslv = resolve_info_create(linklet, enforce_const, static_mode);
2010 enable_expression_resolve_lifts(rslv);
2011
2012 if (linklet->num_exports < SCHEME_VEC_SIZE(linklet->defns)) {
2013 /* Some definitions are not exported, so resolve in a way
2014 that lets us GC unused definitions */
2015 prepare_definition_queue(linklet, rslv);
2016 }
2017
2018 cnt = SCHEME_VEC_SIZE(linklet->bodies);
2019 for (i = 0; i < cnt; i++) {
2020 Scheme_Object *e;
2021
2022 e = SCHEME_VEC_ELS(linklet->bodies)[i];
2023
2024 if (!rslv->toplevel_defns || !scheme_hash_get(rslv->toplevel_defns, e)) {
2025 e = resolve_expr(e, rslv);
2026
2027 /* add lift just before the expression that introduced it;
2028 this ordering is needed for bytecode validation of
2029 constantness for top-level references */
2030 lift_vec = rslv->lifts;
2031 if (!SCHEME_NULLP(SCHEME_VEC_ELS(lift_vec)[0])) {
2032 body = scheme_append(SCHEME_VEC_ELS(lift_vec)[0], body);
2033 SCHEME_VEC_ELS(lift_vec)[0] = scheme_null;
2034 }
2035 }
2036
2037 body = scheme_make_pair(e, body);
2038 }
2039
2040 /* If we're pruning unused definitions, handle the stack of pending definitions */
2041 if (rslv->toplevel_defns) {
2042 Scheme_Object *l, *e;
2043
2044 /* Loop while the definition stack is non-empty */
2045 while (1) {
2046 l = scheme_hash_get(rslv->toplevel_defns, scheme_null);
2047 if (SCHEME_NULLP(l))
2048 break;
2049 scheme_hash_set(rslv->toplevel_defns, scheme_null, SCHEME_CDR(l));
2050
2051 l = SCHEME_CAR(l);
2052 e = scheme_make_pair(resolve_expr(l, rslv), scheme_null);
2053 lift_vec = rslv->lifts;
2054 if (!SCHEME_NULLP(SCHEME_VEC_ELS(lift_vec)[0])) {
2055 e = scheme_append(SCHEME_VEC_ELS(lift_vec)[0], e);
2056 SCHEME_VEC_ELS(lift_vec)[0] = scheme_null;
2057 }
2058 scheme_hash_set(rslv->toplevel_defns, l, e);
2059 }
2060
2061 /* Update the body list, flattening lifts as we go */
2062 for (l = body, body = scheme_null; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
2063 e = scheme_hash_get(rslv->toplevel_defns, SCHEME_CAR(l));
2064 if (e) {
2065 if (SCHEME_PAIRP(e))
2066 body = scheme_append(e, body);
2067 else {
2068 /* Never reached, so just drop it */
2069 remove_definition_names(SCHEME_CAR(l), linklet);
2070 }
2071 } else
2072 body = scheme_make_pair(SCHEME_CAR(l), body);
2073 }
2074 } else
2075 body = scheme_reverse(body);
2076
2077 linklet->max_let_depth = rslv->max_let_depth;
2078 linklet->need_instance_access = rslv->need_instance_access;
2079
2080 lift_vec = rslv->lifts;
2081 num_lifts = SCHEME_INT_VAL(SCHEME_VEC_ELS(lift_vec)[1]);
2082
2083 /* Recompute body array: */
2084 cnt = scheme_list_length(body);
2085 new_bodies = scheme_make_vector(cnt, scheme_false);
2086 for (i = 0; i < cnt; i++, body = SCHEME_CDR(body)) {
2087 SCHEME_VEC_ELS(new_bodies)[i] = SCHEME_CAR(body);
2088 }
2089
2090 linklet->bodies = new_bodies;
2091
2092 if (num_lifts) {
2093 /* Adjust the `exports` array to take into account lifted
2094 definitions */
2095 extend_linklet_defns(linklet, num_lifts);
2096 }
2097
2098 /* Adjust the imports vector of vectors to drop unused imports at
2099 the level of variables */
2100 prune_unused_imports(linklet);
2101
2102 if (static_mode)
2103 install_static_prefix(linklet, rslv);
2104
2105 return linklet;
2106 }
2107
prepare_definition_queue(Scheme_Linklet * linklet,Resolve_Info * rslv)2108 static void prepare_definition_queue(Scheme_Linklet *linklet, Resolve_Info *rslv)
2109 {
2110 Scheme_Hash_Table *ht;
2111 Scheme_Object *e, *var;
2112 int i, j, cnt, vcnt;
2113
2114 ht = scheme_make_hash_table(SCHEME_hash_ptr);
2115 rslv->toplevel_defns = ht;
2116
2117 /* Queue is initially empty: */
2118 scheme_hash_set(rslv->toplevel_defns, scheme_null, scheme_null);
2119
2120 cnt = SCHEME_VEC_SIZE(linklet->bodies);
2121
2122 for (i = 0; i < cnt; i++) {
2123 e = SCHEME_VEC_ELS(linklet->bodies)[i];
2124
2125 if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) {
2126 vcnt = SCHEME_DEFN_VAR_COUNT(e);
2127 if (SCHEME_DEFN_CAN_OMITP(e)
2128 || scheme_omittable_expr(SCHEME_DEFN_RHS(e), vcnt, 5, 0, NULL, NULL)) {
2129 for (j = 0; j < vcnt; j++) {
2130 var = SCHEME_DEFN_VAR_(e, j);
2131 MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(var), scheme_ir_toplevel_type));
2132 if (SCHEME_IR_TOPLEVEL_POS(var) < (SCHEME_LINKLET_PREFIX_PREFIX
2133 + linklet->num_total_imports
2134 + linklet->num_exports)) {
2135 /* variable is exported */
2136 break;
2137 }
2138 }
2139 if (j >= vcnt) {
2140 scheme_hash_set(rslv->toplevel_defns, e, scheme_true);
2141 for (j = 0; j < vcnt; j++) {
2142 int tl_pos;
2143 var = SCHEME_DEFN_VAR_(e, j);
2144 tl_pos = SCHEME_IR_TOPLEVEL_POS(var) + 1 + linklet->num_total_imports;
2145 scheme_hash_set(rslv->toplevel_defns, scheme_make_integer(tl_pos), e);
2146 }
2147 }
2148 }
2149 }
2150 }
2151 }
2152
remove_definition_names(Scheme_Object * defn,Scheme_Linklet * linklet)2153 static void remove_definition_names(Scheme_Object *defn, Scheme_Linklet *linklet)
2154 {
2155 int i, cnt;
2156 Scheme_Object *var, *name;
2157 Scheme_Hash_Tree *source_names;
2158
2159 MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(defn), scheme_define_values_type));
2160
2161 cnt = SCHEME_DEFN_VAR_COUNT(defn);
2162 for (i = 0; i < cnt; i++) {
2163 var = SCHEME_DEFN_VAR_(defn, i);
2164 MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(var), scheme_ir_toplevel_type));
2165
2166 name = SCHEME_VEC_ELS(linklet->defns)[SCHEME_IR_TOPLEVEL_POS(var)];
2167
2168 if (linklet->source_names) {
2169 source_names = scheme_hash_tree_set(linklet->source_names, name, NULL);
2170 linklet->source_names = source_names;
2171 }
2172
2173 SCHEME_VEC_ELS(linklet->defns)[SCHEME_IR_TOPLEVEL_POS(var)] = scheme_false;
2174 }
2175 }
2176
extend_linklet_defns(Scheme_Linklet * linklet,int num_lifts)2177 static void extend_linklet_defns(Scheme_Linklet *linklet, int num_lifts)
2178 {
2179 int cnt, i;
2180 Scheme_Object *new_defns, *b;
2181 Scheme_Hash_Table *names;
2182
2183 linklet->num_lifts = num_lifts;
2184 cnt = SCHEME_VEC_SIZE(linklet->defns) + num_lifts;
2185 new_defns = scheme_make_vector(cnt, scheme_false);
2186 names = scheme_make_hash_table(SCHEME_hash_ptr);
2187
2188 for (i = 0; i < SCHEME_VEC_SIZE(linklet->defns); i++) {
2189 SCHEME_VEC_ELS(new_defns)[i] = SCHEME_VEC_ELS(linklet->defns)[i];
2190 scheme_hash_set(names, SCHEME_VEC_ELS(new_defns)[i], scheme_true);
2191 }
2192
2193 for (; i < cnt; i++) {
2194 b = generate_lifted_name(names, i - SCHEME_VEC_SIZE(linklet->defns));
2195 SCHEME_VEC_ELS(new_defns)[i] = b;
2196 }
2197
2198 linklet->defns = new_defns;
2199 }
2200
prune_unused_imports(Scheme_Linklet * linklet)2201 static void prune_unused_imports(Scheme_Linklet *linklet)
2202 {
2203 int i, new_i = 0, j;
2204 int num_total_imports;
2205 Scheme_Object *vec, *new_vec, *new_importss;
2206
2207 for (i = SCHEME_VEC_SIZE(linklet->importss); i--; ) {
2208 if (!SCHEME_INTP(SCHEME_VEC_ELS(linklet->importss)[i]))
2209 new_i++;
2210 }
2211 if (new_i != SCHEME_VEC_SIZE(linklet->importss)) {
2212 new_importss = scheme_make_vector(new_i, NULL);
2213 new_i = 0;
2214 } else
2215 new_importss = NULL;
2216
2217 num_total_imports = 0;
2218 for (i = 0; i < SCHEME_VEC_SIZE(linklet->importss); i++) {
2219 int drop = 0, len, drop_all = 0;
2220 vec = SCHEME_VEC_ELS(linklet->importss)[i];
2221 if (SCHEME_INTP(vec)) {
2222 len = SCHEME_INT_VAL(vec);
2223 num_total_imports += len;
2224 drop = len;
2225 drop_all = 1;
2226 } else {
2227 len = SCHEME_VEC_SIZE(vec);
2228 num_total_imports += len;
2229 for (j = 0; j < len; j++) {
2230 if (SCHEME_FALSEP(SCHEME_VEC_ELS(vec)[j]))
2231 drop++;
2232 }
2233 }
2234 if (drop) {
2235 num_total_imports -= drop;
2236 drop = len - drop;
2237 if (!drop_all) {
2238 new_vec = scheme_make_vector(drop, NULL);
2239 for (j = len; j--; ) {
2240 if (!SCHEME_FALSEP(SCHEME_VEC_ELS(vec)[j])) {
2241 SCHEME_VEC_ELS(new_vec)[--drop] = SCHEME_VEC_ELS(vec)[j];
2242 }
2243 }
2244 MZ_ASSERT(!drop);
2245 SCHEME_VEC_ELS(linklet->importss)[i] = new_vec;
2246 }
2247 }
2248 if (!drop_all && new_importss)
2249 SCHEME_VEC_ELS(new_importss)[new_i++] = SCHEME_VEC_ELS(linklet->importss)[i];
2250 }
2251
2252 if (new_importss) {
2253 MZ_ASSERT(new_i == SCHEME_VEC_SIZE(new_importss));
2254 linklet->importss = new_importss;
2255 }
2256
2257 linklet->num_total_imports = num_total_imports;
2258
2259 MZ_ASSERT(!linklet->import_shapes || (linklet->num_total_imports == SCHEME_VEC_SIZE(linklet->import_shapes)));
2260 }
2261
generate_lifted_name(Scheme_Hash_Table * used_names,int search_start)2262 static Scheme_Object *generate_lifted_name(Scheme_Hash_Table *used_names, int search_start)
2263 {
2264 char buf[32];
2265 Scheme_Object *n;
2266
2267 while (1) {
2268 sprintf(buf, "?lifted.%d", search_start);
2269 n = scheme_intern_exact_parallel_symbol(buf, strlen(buf));
2270 if (!scheme_hash_get(used_names, n)) {
2271 scheme_hash_set(used_names, n, scheme_true);
2272 return n;
2273 }
2274 search_start++;
2275 }
2276 }
2277
2278 /*========================================================================*/
2279 /* expressions */
2280 /*========================================================================*/
2281
resolve_k(void)2282 static Scheme_Object *resolve_k(void)
2283 {
2284 Scheme_Thread *p = scheme_current_thread;
2285 Scheme_Object *expr = (Scheme_Object *)p->ku.k.p1;
2286 Resolve_Info *info = (Resolve_Info *)p->ku.k.p2;
2287
2288 p->ku.k.p1 = NULL;
2289 p->ku.k.p2 = NULL;
2290
2291 return resolve_expr(expr, info);
2292 }
2293
resolve_expr(Scheme_Object * expr,Resolve_Info * info)2294 Scheme_Object *resolve_expr(Scheme_Object *expr, Resolve_Info *info)
2295 {
2296 Scheme_Type type = SCHEME_TYPE(expr);
2297
2298 #ifdef DO_STACK_CHECK
2299 # include "mzstkchk.h"
2300 {
2301 Scheme_Thread *p = scheme_current_thread;
2302
2303 p->ku.k.p1 = (void *)expr;
2304 p->ku.k.p2 = (void *)info;
2305
2306 return scheme_handle_stack_overflow(resolve_k);
2307 }
2308 #endif
2309
2310 switch (type) {
2311 case scheme_ir_local_type:
2312 {
2313 int pos;
2314 Scheme_IR_Local *var = SCHEME_VAR(expr);
2315 Scheme_Object *lifted;
2316
2317 pos = resolve_info_lookup(info, var, &lifted, 0, 0);
2318 if (lifted) {
2319 /* Lexical reference replaced with top-level reference for a lifted value: */
2320 return shift_lifted_reference(lifted, info, 0);
2321 } else {
2322 return scheme_make_local(var->mutated
2323 ? scheme_local_unbox_type
2324 : scheme_local_type,
2325 pos,
2326 (HAS_UNBOXABLE_TYPE(var)
2327 ? (SCHEME_LOCAL_TYPE_OFFSET + var->val_type)
2328 : 0));
2329 }
2330 }
2331 case scheme_application_type:
2332 return resolve_application(expr, info, 0);
2333 case scheme_application2_type:
2334 return resolve_application2(expr, info, 0);
2335 case scheme_application3_type:
2336 return resolve_application3(expr, info, 0);
2337 case scheme_sequence_type:
2338 case scheme_begin0_sequence_type:
2339 return resolve_sequence(expr, info);
2340 case scheme_branch_type:
2341 return resolve_branch(expr, info);
2342 case scheme_with_cont_mark_type:
2343 return resolve_wcm(expr, info);
2344 case scheme_ir_lambda_type:
2345 return resolve_lambda(expr, info, !info->no_lift, 0, 0, NULL);
2346 case scheme_ir_let_header_type:
2347 return scheme_resolve_lets(expr, info);
2348 case scheme_ir_toplevel_type:
2349 return resolve_toplevel(info, expr, 1);
2350 case scheme_variable_type:
2351 scheme_signal_error("got top-level in wrong place");
2352 return 0;
2353 case scheme_define_values_type:
2354 return define_values_resolve(expr, info);
2355 case scheme_inline_variant_type:
2356 return inline_variant_resolve(expr, info);
2357 case scheme_set_bang_type:
2358 return set_resolve(expr, info);
2359 case scheme_varref_form_type:
2360 return ref_resolve(expr, info);
2361 case scheme_apply_values_type:
2362 return apply_values_resolve(expr, info);
2363 case scheme_with_immed_mark_type:
2364 return with_immed_mark_resolve(expr, info);
2365 case scheme_case_lambda_sequence_type:
2366 return case_lambda_resolve(expr, info);
2367 case scheme_boxenv_type:
2368 scheme_signal_error("internal error: no boxenv resolve");
2369 default:
2370 return expr;
2371 }
2372 }
2373
resolve_info_lift_added(Resolve_Info * resolve,Scheme_Object * v,int convert_shift)2374 static Scheme_Object *resolve_info_lift_added(Resolve_Info *resolve, Scheme_Object *v, int convert_shift)
2375 {
2376 /* If a variable added as an argument for closure conversion is mutable,
2377 we need to generate a non-unboxing reference to the variable: */
2378 Scheme_IR_Local *var;
2379 int pos;
2380
2381 if (!SAME_TYPE(SCHEME_TYPE(v), scheme_ir_local_type)) {
2382 /* must be an argument to a generated "bad arity" call */
2383 return v;
2384 }
2385
2386 var = SCHEME_VAR(v);
2387
2388 pos = resolve_info_lookup(resolve, var, NULL, convert_shift, RESOLVE_IGNORE_LIFTS);
2389
2390 return scheme_make_local(scheme_local_type,
2391 pos,
2392 ((!var->mutated && HAS_UNBOXABLE_TYPE(var))
2393 ? (SCHEME_LOCAL_TYPE_OFFSET + var->val_type)
2394 : 0));
2395 }
2396
shift_lifted_reference(Scheme_Object * tl,Resolve_Info * info,int delta)2397 static Scheme_Object *shift_lifted_reference(Scheme_Object *tl, Resolve_Info *info, int delta)
2398 {
2399 int pos = SCHEME_TOPLEVEL_POS(tl);
2400 int depth;
2401
2402 MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(tl), scheme_toplevel_type));
2403
2404 depth = resolve_toplevel_pos(info);
2405 tl = scheme_make_toplevel(depth + delta,
2406 pos,
2407 SCHEME_TOPLEVEL_CONST);
2408
2409 /* register if non-stub: */
2410 if (pos >= info->num_toplevels)
2411 set_tl_pos_used(info, pos);
2412
2413 return tl;
2414 }
2415
2416 /*========================================================================*/
2417 /* compile-time env for resolve */
2418 /*========================================================================*/
2419
resolve_info_create(Scheme_Linklet * linklet,int enforce_const,int static_mode)2420 static Resolve_Info *resolve_info_create(Scheme_Linklet *linklet, int enforce_const, int static_mode)
2421 {
2422 Resolve_Info *naya;
2423 int *toplevel_starts, pos, dpos, i, j;
2424 int *toplevel_deltas;
2425
2426 naya = MALLOC_ONE_RT(Resolve_Info);
2427 #ifdef MZTAG_REQUIRED
2428 naya->type = scheme_rt_resolve_info;
2429 #endif
2430 naya->current_depth = 1; /* initial slot for prefix */
2431 naya->max_let_depth = naya->current_depth;
2432 naya->current_lex_depth = 0;
2433 naya->next = NULL;
2434 naya->enforce_const = enforce_const;
2435 naya->linklet = linklet;
2436
2437 if (static_mode) {
2438 Scheme_Hash_Table *ht;
2439 ht = scheme_make_hash_table_equal();
2440 naya->static_mode = ht;
2441 }
2442
2443 toplevel_starts = MALLOC_N_ATOMIC(int, SCHEME_VEC_SIZE(linklet->importss) + 1);
2444 toplevel_deltas = MALLOC_N_ATOMIC(int, (linklet->num_total_imports + SCHEME_LINKLET_PREFIX_PREFIX));
2445 pos = SCHEME_LINKLET_PREFIX_PREFIX;
2446 dpos = pos;
2447 for (i = 0; i < SCHEME_VEC_SIZE(linklet->importss); i++) {
2448 toplevel_starts[i+1] = pos;
2449 if (SCHEME_INTP(SCHEME_VEC_ELS(linklet->importss)[i])) {
2450 /* This import is getting dropped */
2451 pos += SCHEME_INT_VAL(SCHEME_VEC_ELS(linklet->importss)[i]);
2452 } else {
2453 for (j = 0; j < SCHEME_VEC_SIZE(SCHEME_VEC_ELS(linklet->importss)[i]); j++) {
2454 toplevel_deltas[pos] = (dpos - pos);
2455 if (SCHEME_FALSEP(SCHEME_VEC_ELS(SCHEME_VEC_ELS(linklet->importss)[i])[j]))
2456 toplevel_deltas[pos] = 0xFFFFFF; /* shouldn't be used */
2457 else
2458 dpos++;
2459 pos++;
2460 }
2461 }
2462 }
2463 toplevel_starts[0] = dpos;
2464
2465 naya->num_toplevels = (dpos + SCHEME_VEC_SIZE(linklet->defns));
2466
2467 naya->toplevel_starts = toplevel_starts;
2468 naya->toplevel_deltas = toplevel_deltas;
2469
2470 naya->top = naya;
2471
2472 return naya;
2473 }
2474
enable_expression_resolve_lifts(Resolve_Info * ri)2475 static void enable_expression_resolve_lifts(Resolve_Info *ri)
2476 {
2477 Scheme_Object *lift_vec;
2478
2479 lift_vec = scheme_make_vector(2, NULL);
2480 SCHEME_VEC_ELS(lift_vec)[0] = scheme_null;
2481 SCHEME_VEC_ELS(lift_vec)[1] = scheme_make_integer(0);
2482 ri->lifts = lift_vec;
2483 }
2484
resolve_info_extend(Resolve_Info * info,int size,int lambda)2485 static Resolve_Info *resolve_info_extend(Resolve_Info *info, int size, int lambda)
2486 /* size = number of appended items in run-time frame */
2487 {
2488 Resolve_Info *naya;
2489
2490 naya = MALLOC_ONE_RT(Resolve_Info);
2491 #ifdef MZTAG_REQUIRED
2492 naya->type = scheme_rt_resolve_info;
2493 #endif
2494 naya->linklet = info->linklet;
2495 naya->next = (lambda ? NULL : info);
2496 naya->enforce_const = info->enforce_const;
2497 naya->static_mode = info->static_mode;
2498 naya->current_depth = (lambda ? 0 : info->current_depth) + size;
2499 naya->current_lex_depth = info->current_lex_depth + size;
2500 naya->toplevel_pos = (lambda
2501 ? 0
2502 : ((info->toplevel_pos < 0)
2503 ? -1
2504 : (info->toplevel_pos + size)));
2505 naya->no_lift = info->no_lift;
2506 naya->redirects = info->redirects;
2507 naya->max_let_depth = naya->current_depth;
2508 naya->in_proc = lambda || info->in_proc;
2509 naya->lifts = info->lifts;
2510 naya->num_toplevels = info->num_toplevels;
2511 naya->toplevel_starts = info->toplevel_starts;
2512 naya->toplevel_deltas = info->toplevel_deltas;
2513 naya->top = info->top;
2514 naya->toplevel_defns = info->toplevel_defns;
2515
2516 return naya;
2517 }
2518
ensure_tl_map_len(void * old_tl_map,int new_len)2519 static void *ensure_tl_map_len(void *old_tl_map, int new_len)
2520 {
2521 int current_len;
2522 void *tl_map;
2523
2524 if (!old_tl_map)
2525 current_len = 0;
2526 else if ((uintptr_t)old_tl_map & 0x1)
2527 current_len = 31;
2528 else
2529 current_len = (*(int *)old_tl_map) * 32;
2530
2531 if (new_len > current_len) {
2532 /* allocate/grow tl_map */
2533 if (new_len <= 31)
2534 tl_map = (void *)0x1;
2535 else {
2536 int len = ((new_len + 31) / 32);
2537 tl_map = scheme_malloc_atomic((len + 1) * sizeof(int));
2538 memset(tl_map, 0, (len + 1) * sizeof(int));
2539 *(int *)tl_map = len;
2540 }
2541
2542 if (old_tl_map) {
2543 if ((uintptr_t)old_tl_map & 0x1) {
2544 ((int *)tl_map)[1] = ((uintptr_t)old_tl_map >> 1) & 0x7FFFFFFF;
2545 } else {
2546 memcpy((int *)tl_map + 1,
2547 (int *)old_tl_map + 1,
2548 sizeof(int) * (current_len / 32));
2549 }
2550 }
2551
2552 return tl_map;
2553 } else
2554 return old_tl_map;
2555 }
2556
set_tl_pos_used(Resolve_Info * info,int tl_pos)2557 static void set_tl_pos_used(Resolve_Info *info, int tl_pos)
2558 {
2559 void *tl_map;
2560
2561 if (!info->static_mode) {
2562 /* Fixnum-like bit packing avoids allocation in the common case of a
2563 small prefix. We use 31 fixnum-like bits (even on a 64-bit
2564 platform, and even though fixnums are only 30 bits). There's one
2565 bit for each normal top-level, one bit for all syntax objects,
2566 and one bit for each lifted top-level. */
2567
2568 tl_map = ensure_tl_map_len(info->tl_map, tl_pos + 1);
2569 info->tl_map = tl_map;
2570
2571 if ((uintptr_t)info->tl_map & 0x1)
2572 info->tl_map = (void *)((uintptr_t)tl_map | ((uintptr_t)1 << (tl_pos + 1)));
2573 else
2574 ((int *)tl_map)[1 + (tl_pos / 32)] |= ((unsigned)1 << (tl_pos & 31));
2575 }
2576
2577 /* If we're pruning unused definitions, then ensure a newly referenced definition */
2578 if (info->toplevel_defns
2579 && (tl_pos >= (SCHEME_LINKLET_PREFIX_PREFIX
2580 + info->linklet->num_total_imports
2581 + info->linklet->num_exports))) {
2582 Scheme_Object *defn;
2583 defn = scheme_hash_get(info->toplevel_defns, scheme_make_integer(tl_pos));
2584 if (defn) {
2585 if (SAME_OBJ(scheme_true, scheme_hash_get(info->toplevel_defns, defn))) {
2586 /* Enqueue the defn for traversal: */
2587 scheme_hash_set(info->toplevel_defns,
2588 scheme_null,
2589 scheme_make_pair(defn,
2590 scheme_hash_get(info->toplevel_defns, scheme_null)));
2591 /* Add to indicate that it's enqueued */
2592 scheme_hash_set(info->toplevel_defns, defn, scheme_false);
2593 }
2594 scheme_hash_set(info->toplevel_defns, scheme_make_integer(tl_pos), NULL);
2595 }
2596 }
2597 }
2598
merge_tl_map(void * tl_map,void * new_tl_map)2599 static void *merge_tl_map(void *tl_map, void *new_tl_map)
2600 {
2601 if (!tl_map)
2602 return new_tl_map;
2603 else if (!new_tl_map)
2604 return tl_map;
2605 else if (((uintptr_t)new_tl_map) & 0x1) {
2606 if (((uintptr_t)tl_map) & 0x1) {
2607 return (void *)((uintptr_t)tl_map | (uintptr_t)new_tl_map);
2608 } else {
2609 ((int *)tl_map)[1] |= ((uintptr_t)new_tl_map >> 1) & 0x7FFFFFFF;
2610 return tl_map;
2611 }
2612 } else {
2613 int i, len = *(int *)new_tl_map;
2614 tl_map = ensure_tl_map_len(tl_map, len * 32);
2615 for (i = 0; i < len; i++) {
2616 ((int *)tl_map)[1+i] |= ((int *)new_tl_map)[1+i];
2617 }
2618 return tl_map;
2619 }
2620 }
2621
merge_resolve_tl_map(Resolve_Info * info,Resolve_Info * new_info)2622 static void merge_resolve_tl_map(Resolve_Info *info, Resolve_Info *new_info)
2623 {
2624 if (!new_info->tl_map) {
2625 /* nothing to do */
2626 } else {
2627 void *tl_map;
2628 tl_map = merge_tl_map(info->tl_map, new_info->tl_map);
2629 info->tl_map = tl_map;
2630 }
2631
2632 if (new_info->need_instance_access)
2633 info->need_instance_access = 1;
2634 }
2635
merge_resolve(Resolve_Info * info,Resolve_Info * new_info)2636 static void merge_resolve(Resolve_Info *info, Resolve_Info *new_info)
2637 {
2638 if (new_info->next /* NULL => lambda */
2639 && (new_info->max_let_depth > info->max_let_depth))
2640 info->max_let_depth = new_info->max_let_depth;
2641
2642 merge_resolve_tl_map(info, new_info);
2643 }
2644
resolve_info_add_mapping(Resolve_Info * info,Scheme_IR_Local * var,Scheme_Object * v)2645 static void resolve_info_add_mapping(Resolve_Info *info, Scheme_IR_Local *var, Scheme_Object *v)
2646 {
2647 Scheme_Hash_Tree *ht;
2648
2649 if (!info->redirects) {
2650 ht = scheme_make_hash_tree(SCHEME_hashtr_eq);
2651 info->redirects = ht;
2652 }
2653
2654 ht = scheme_hash_tree_set(info->redirects, (Scheme_Object *)var, v);
2655 info->redirects = ht;
2656 }
2657
resolve_info_set_toplevel_pos(Resolve_Info * info,int pos)2658 static void resolve_info_set_toplevel_pos(Resolve_Info *info, int pos)
2659 {
2660 info->toplevel_pos = pos;
2661 }
2662
resolve_info_lookup(Resolve_Info * info,Scheme_IR_Local * var,Scheme_Object ** _lifted,int convert_shift,int flags)2663 static int resolve_info_lookup(Resolve_Info *info, Scheme_IR_Local *var, Scheme_Object **_lifted,
2664 int convert_shift, int flags)
2665 {
2666 Scheme_Object *v;
2667 int depth;
2668
2669 MZ_ASSERT(var->mode == SCHEME_VAR_MODE_RESOLVE);
2670 MZ_ASSERT((flags & RESOLVE_UNUSED_OK) || (var->use_count > 0));
2671 MZ_ASSERT((flags & RESOLVE_UNUSED_OK) || var->optimize_used);
2672
2673 if (var->resolve.lifted && !(flags & RESOLVE_IGNORE_LIFTS)) {
2674 MZ_ASSERT(_lifted);
2675
2676 v = var->resolve.lifted;
2677 *_lifted = v;
2678
2679 return -1;
2680 }
2681
2682 depth = var->resolve.co_depth;
2683 if (info->redirects) {
2684 v = scheme_hash_tree_get(info->redirects, (Scheme_Object *)var);
2685 if (v) {
2686 depth = SCHEME_INT_VAL(v);
2687 MZ_ASSERT(var->val_type <= SCHEME_MAX_LOCAL_TYPE_MASK);
2688 }
2689 }
2690
2691 if (_lifted)
2692 *_lifted = NULL;
2693
2694 return info->current_depth - depth + convert_shift;
2695 }
2696
make_static_toplevel(Scheme_Hash_Table * static_mode,int pos,int flags,int as_ref)2697 static Scheme_Object *make_static_toplevel(Scheme_Hash_Table *static_mode, int pos, int flags, int as_ref)
2698 {
2699 Scheme_Object *key, *tl;
2700
2701 if (as_ref)
2702 key = scheme_make_pair(scheme_make_integer(pos), scheme_make_integer(flags));
2703 else
2704 key = scheme_make_integer(pos);
2705
2706 tl = scheme_hash_get(static_mode, key);
2707 if (!tl) {
2708 tl = (Scheme_Object *)MALLOC_ONE_TAGGED(Scheme_Toplevel);
2709 tl->type = scheme_static_toplevel_type;
2710 SCHEME_TOPLEVEL_POS(tl) = pos;
2711 SCHEME_TOPLEVEL_FLAGS(tl) |= flags;
2712 scheme_hash_set(static_mode, key, tl);
2713 }
2714
2715 return tl;
2716 }
2717
install_static_prefix(Scheme_Linklet * linklet,Resolve_Info * ri)2718 static void install_static_prefix(Scheme_Linklet *linklet, Resolve_Info *ri)
2719 {
2720 Scheme_Prefix *pf;
2721 int i;
2722 Scheme_Hash_Table *ht = ri->static_mode;
2723
2724 /* Allocate prefix with one extra slot, which is used when
2725 reading bytecode to cache Scheme_Toplevel values */
2726 pf = scheme_allocate_linklet_prefix(linklet, 1);
2727 linklet->static_prefix = pf;
2728
2729 for (i = 0; i < ht->size; i++) {
2730 if (ht->vals[i]) {
2731 SCHEME_STATIC_TOPLEVEL_PREFIX(ht->vals[i]) = pf;
2732 }
2733 }
2734 }
2735
resolve_generate_stub_lift(Resolve_Info * info)2736 static Scheme_Object *resolve_generate_stub_lift(Resolve_Info *info)
2737 {
2738 if (info->static_mode)
2739 return make_static_toplevel(info->static_mode, 0, SCHEME_TOPLEVEL_CONST, 0);
2740 else
2741 return scheme_make_toplevel(0, 0, SCHEME_TOPLEVEL_CONST);
2742 }
2743
resolve_toplevel_pos(Resolve_Info * info)2744 static int resolve_toplevel_pos(Resolve_Info *info)
2745 {
2746 MZ_ASSERT(info->toplevel_pos >= 0);
2747 return info->toplevel_pos;
2748 }
2749
resolve_is_inside_proc(Resolve_Info * info)2750 static int resolve_is_inside_proc(Resolve_Info *info)
2751 {
2752 return info->in_proc;
2753 }
2754
resolve_has_toplevel(Resolve_Info * info)2755 static int resolve_has_toplevel(Resolve_Info *info)
2756 {
2757 return (info->toplevel_pos >= 0) || info->static_mode;
2758 }
2759
resolve_toplevel(Resolve_Info * info,Scheme_Object * expr,int as_reference)2760 static Scheme_Object *resolve_toplevel(Resolve_Info *info, Scheme_Object *expr, int as_reference)
2761 {
2762 int skip, pos;
2763
2764 if (info->static_mode)
2765 skip = 0;
2766 else
2767 skip = resolve_toplevel_pos(info);
2768
2769 if (SCHEME_IR_TOPLEVEL_INSTANCE(expr) == -1) {
2770 if (SCHEME_IR_TOPLEVEL_POS(expr) == -1) {
2771 /* (-1, -1) is the instance-access prefix slot */
2772 pos = 0;
2773 info->need_instance_access = 1;
2774 } else
2775 pos = info->toplevel_starts[0] + SCHEME_IR_TOPLEVEL_POS(expr);
2776 } else {
2777 pos = (info->toplevel_starts[SCHEME_IR_TOPLEVEL_INSTANCE(expr) + 1] + SCHEME_IR_TOPLEVEL_POS(expr));
2778 pos += info->toplevel_deltas[pos];
2779 }
2780
2781 if (as_reference)
2782 set_tl_pos_used(info, pos);
2783
2784 if (info->static_mode)
2785 return make_static_toplevel(info->static_mode, pos,
2786 SCHEME_IR_TOPLEVEL_FLAGS((Scheme_IR_Toplevel *)expr) & SCHEME_TOPLEVEL_FLAGS_MASK,
2787 as_reference);
2788 else
2789 return scheme_make_toplevel(skip, pos,
2790 SCHEME_IR_TOPLEVEL_FLAGS((Scheme_IR_Toplevel *)expr) & SCHEME_TOPLEVEL_FLAGS_MASK);
2791 }
2792
shift_toplevel(Scheme_Object * expr,int delta)2793 static Scheme_Object *shift_toplevel(Scheme_Object *expr, int delta)
2794 {
2795 return scheme_make_toplevel(SCHEME_TOPLEVEL_DEPTH(expr) + delta,
2796 SCHEME_TOPLEVEL_POS(expr),
2797 SCHEME_TOPLEVEL_FLAGS(expr) & SCHEME_TOPLEVEL_FLAGS_MASK);
2798 }
2799
resolve_invent_toplevel(Resolve_Info * info)2800 static Scheme_Object *resolve_invent_toplevel(Resolve_Info *info)
2801 {
2802 int skip, pos;
2803 Scheme_Object *count;
2804
2805 skip = resolve_toplevel_pos(info);
2806
2807 count = SCHEME_VEC_ELS(info->lifts)[1];
2808 pos = (int)(SCHEME_INT_VAL(count) + info->num_toplevels);
2809 count = scheme_make_integer(SCHEME_INT_VAL(count) + 1);
2810 SCHEME_VEC_ELS(info->lifts)[1] = count;
2811
2812 set_tl_pos_used(info, pos);
2813
2814 if (info->static_mode)
2815 return make_static_toplevel(info->static_mode, pos, SCHEME_TOPLEVEL_CONST, 0);
2816 else
2817 return scheme_make_toplevel(skip,
2818 pos,
2819 SCHEME_TOPLEVEL_CONST);
2820 }
2821
resolve_invented_toplevel_to_defn(Resolve_Info * info,Scheme_Object * tl)2822 static Scheme_Object *resolve_invented_toplevel_to_defn(Resolve_Info *info, Scheme_Object *tl)
2823 {
2824 if (SAME_TYPE(SCHEME_TYPE(tl), scheme_toplevel_type))
2825 return scheme_make_toplevel(0,
2826 SCHEME_TOPLEVEL_POS(tl),
2827 SCHEME_TOPLEVEL_CONST);
2828 else
2829 return tl;
2830 }
2831
2832 /*========================================================================*/
2833 /* unresolve */
2834 /*========================================================================*/
2835
2836 #if 0
2837 # define return_NULL return (printf("%d\n", __LINE__), NULL)
2838 #else
2839 # define return_NULL return NULL
2840 #endif
2841
2842 #if 0
2843 # define LOG_UNRESOLVE(x) x
2844 #else
2845 # define LOG_UNRESOLVE(x) /* empty */
2846 #endif
2847
2848 typedef struct Unresolve_Info {
2849 MZTAG_IF_REQUIRED
2850 int comp_flags;
2851 int stack_pos; /* stack in resolved coordinates */
2852 int depth; /* stack in unresolved coordinates */
2853 int stack_size;
2854 Scheme_IR_Local **vars;
2855
2856 /* For cross-linklet inlining: */
2857 Scheme_Linklet *linklet;
2858 Scheme_Object *linklet_key;
2859 Optimize_Info *opt_info;
2860
2861 Scheme_Hash_Table *closures; /* handle cycles */
2862 int has_non_leaf, has_tl, body_size;
2863
2864 int inlining;
2865
2866 int num_toplevels; /* compute imports + defns for linklet */
2867 int num_defns; /* initial defns for linklet */
2868 int num_extra_toplevels; /* created toplevels for cyclic lambdas */
2869
2870 Scheme_IR_Toplevel **toplevels;
2871 Scheme_Object *definitions;
2872 int lift_offset;
2873 Scheme_Hash_Table *ref_lifts;
2874 } Unresolve_Info;
2875
2876 static Scheme_Object *unresolve_expr(Scheme_Object *e, Unresolve_Info *ui, int as_rator);
2877 static void locate_cyclic_closures(Scheme_Object *e, Unresolve_Info *ui);
2878 static Scheme_IR_Let_Header *make_let_header(int count);
2879 static Scheme_IR_Let_Value *make_ir_let_value(int count);
2880
new_unresolve_info(Scheme_Linklet * linklet,Scheme_Object * linklet_key,Optimize_Info * opt_info,int comp_flags)2881 static Unresolve_Info *new_unresolve_info(Scheme_Linklet *linklet, Scheme_Object *linklet_key, Optimize_Info *opt_info,
2882 int comp_flags)
2883 {
2884 Unresolve_Info *ui;
2885 Scheme_IR_Local **vars;
2886 Scheme_Hash_Table *ht;
2887
2888 ui = MALLOC_ONE_RT(Unresolve_Info);
2889 SET_REQUIRED_TAG(ui->type = scheme_rt_unresolve_info);
2890
2891 ui->linklet = linklet;
2892 ui->linklet_key = linklet_key;
2893 ui->opt_info = opt_info;
2894
2895 ui->stack_pos = 0;
2896 ui->stack_size = 10;
2897 vars = MALLOC_N(Scheme_IR_Local *, ui->stack_size);
2898 ui->vars = vars;
2899
2900 ui->definitions = scheme_null;
2901 ht = scheme_make_hash_table(SCHEME_hash_ptr);
2902 ui->ref_lifts = ht;
2903 ht = scheme_make_hash_table(SCHEME_hash_ptr);
2904 ui->closures = ht;
2905
2906 ui->comp_flags = comp_flags;
2907
2908 ui->num_defns = SCHEME_VEC_SIZE(linklet->defns);
2909 ui->num_toplevels = (SCHEME_LINKLET_PREFIX_PREFIX
2910 + linklet->num_total_imports
2911 + ui->num_defns);
2912 ui->lift_offset = (ui->num_toplevels
2913 - linklet->num_lifts);
2914
2915 return ui;
2916 }
2917
unresolve_stack_push(Unresolve_Info * ui,int n,int make_vars)2918 static int unresolve_stack_push(Unresolve_Info *ui, int n, int make_vars)
2919 {
2920 int pos, i;
2921 Scheme_IR_Local **vars, *var;
2922
2923 pos = ui->stack_pos;
2924
2925 if (pos + n > ui->stack_size) {
2926 vars = MALLOC_N(Scheme_IR_Local *, ((2 * ui->stack_size) + n));
2927 memcpy(vars, ui->vars, sizeof(Scheme_IR_Local *) * pos);
2928
2929 ui->vars = vars;
2930
2931 ui->stack_size = (2 * ui->stack_size) + n;
2932 }
2933 if (make_vars) {
2934 for (i = 0; i < n; i++) {
2935 var = MALLOC_ONE_TAGGED(Scheme_IR_Local);
2936 var->so.type = scheme_ir_local_type;
2937 ui->vars[pos + i] = var;
2938 }
2939 } else
2940 memset(ui->vars + pos, 0, sizeof(Scheme_IR_Local *) * n);
2941
2942 ui->stack_pos += n;
2943
2944 LOG_UNRESOLVE(printf("push %d(%d), d=%d, sp=%d, [%d, %d, %d, %d, %d]\n", n, r_only, ui->depth, ui->stack_pos,
2945 ui->depths[0], ui->depths[1], ui->depths[2], ui->depths[3], ui->depths[4]));
2946
2947 return pos;
2948 }
2949
unresolve_stack_extract(Unresolve_Info * ui,int pos,int n)2950 static Scheme_IR_Local **unresolve_stack_extract(Unresolve_Info *ui, int pos, int n)
2951 {
2952 Scheme_IR_Local **vars;
2953 int i;
2954
2955 if (!n)
2956 return NULL;
2957
2958 vars = MALLOC_N(Scheme_IR_Local *, n);
2959 for (i = 0; i < n; i++) {
2960 vars[i] = ui->vars[ui->stack_pos - pos - 1 - i];
2961 }
2962
2963 return vars;
2964 }
2965
unresolve_stack_pop(Unresolve_Info * ui,int pos,int n)2966 static Scheme_IR_Local **unresolve_stack_pop(Unresolve_Info *ui, int pos, int n)
2967 {
2968 Scheme_IR_Local **vars;
2969
2970 MZ_ASSERT(!n || (ui->stack_pos == pos + n));
2971
2972 vars = unresolve_stack_extract(ui, 0, n);
2973
2974 ui->stack_pos = pos;
2975
2976 return vars;
2977 }
2978
unresolve_lookup(Unresolve_Info * ui,int pos,int as_rator)2979 static Scheme_IR_Local *unresolve_lookup(Unresolve_Info *ui, int pos, int as_rator)
2980 {
2981 Scheme_IR_Local *var = ui->vars[ui->stack_pos - pos - 1];
2982
2983 if (var->use_count < SCHEME_USE_COUNT_INF)
2984 var->use_count++;
2985 if (!as_rator
2986 && !var->is_ref_arg
2987 && (var->non_app_count < SCHEME_USE_COUNT_INF))
2988 var->non_app_count++;
2989
2990 return var;
2991 }
2992
unresolve_lambda(Scheme_Lambda * rlam,Unresolve_Info * ui)2993 static Scheme_Object *unresolve_lambda(Scheme_Lambda *rlam, Unresolve_Info *ui)
2994 {
2995 Scheme_Lambda *lam;
2996 Scheme_Object *body;
2997 Scheme_IR_Lambda_Info *cl;
2998 int i, pos, lam_pos, init_size, has_non_leaf, has_tl;
2999 Scheme_IR_Local **vars;
3000
3001 scheme_delay_load_closure(rlam);
3002
3003 lam = MALLOC_ONE_TAGGED(Scheme_Lambda);
3004 lam->iso.so.type = scheme_ir_lambda_type;
3005
3006 SCHEME_LAMBDA_FLAGS(lam) = (SCHEME_LAMBDA_FLAGS(rlam)
3007 & (LAMBDA_HAS_REST | LAMBDA_IS_METHOD));
3008
3009
3010 lam->num_params = rlam->num_params;
3011 lam->name = rlam->name;
3012
3013 pos = unresolve_stack_push(ui, lam->num_params, 1);
3014 vars = unresolve_stack_extract(ui, 0, lam->num_params);
3015
3016 if (SCHEME_LAMBDA_FLAGS(rlam) & LAMBDA_HAS_TYPED_ARGS) {
3017 for (i = 0; i < lam->num_params; i++) {
3018 LOG_UNRESOLVE(printf("ref_args[%d] = %d\n", ui->stack_pos - i - 1,
3019 scheme_boxmap_get(rlam->closure_map, i, rlam->closure_size)));
3020 if (scheme_boxmap_get(rlam->closure_map, i, rlam->closure_size) == LAMBDA_TYPE_BOXED) {
3021 vars[i]->is_ref_arg = 1;
3022 }
3023 }
3024 }
3025
3026 if (rlam->closure_size) {
3027 lam_pos = unresolve_stack_push(ui, rlam->closure_size, 0);
3028 for (i = rlam->closure_size; i--; ) {
3029 Scheme_IR_Local *mp;
3030 mp = ui->vars[pos - rlam->closure_map[i] - 1];
3031 ui->vars[ui->stack_pos - i - 1] = mp;
3032 }
3033 } else
3034 lam_pos = 0;
3035
3036 init_size = ui->body_size;
3037 has_non_leaf = ui->has_non_leaf;
3038 ui->has_non_leaf = 0;
3039 has_tl = ui->has_tl;
3040 ui->has_tl = 0;
3041
3042 body = unresolve_expr(rlam->body, ui, 0);
3043 if (!body) return_NULL;
3044
3045 lam->body = body;
3046
3047 cl = MALLOC_ONE_RT(Scheme_IR_Lambda_Info);
3048 SET_REQUIRED_TAG(cl->type = scheme_rt_ir_lambda_info);
3049 lam->ir_info = cl;
3050
3051 cl->body_size = (ui->body_size - init_size);
3052
3053 cl->has_nonleaf = ui->has_non_leaf;
3054 ui->has_non_leaf = has_non_leaf;
3055
3056 cl->has_tl = ui->has_tl;
3057 ui->has_tl = ui->has_tl || has_tl;
3058
3059 if (rlam->closure_size)
3060 (void)unresolve_stack_pop(ui, lam_pos, 0);
3061
3062 (void)unresolve_stack_pop(ui, pos, 0);
3063 cl->vars = vars;
3064
3065 /* We don't need to set any more fields of cl, because
3066 optimize does that. */
3067
3068 return (Scheme_Object *)lam;
3069 }
3070
check_nonleaf_rator(Scheme_Object * rator,Unresolve_Info * ui)3071 static void check_nonleaf_rator(Scheme_Object *rator, Unresolve_Info *ui)
3072 {
3073 if (!scheme_check_leaf_rator(rator))
3074 ui->has_non_leaf = 1;
3075 }
3076
unresolve_toplevel(Scheme_Object * rdata,Unresolve_Info * ui)3077 static Scheme_Object *unresolve_toplevel(Scheme_Object *rdata, Unresolve_Info *ui)
3078 {
3079 Scheme_Object *v;
3080 int pos = SCHEME_TOPLEVEL_POS(rdata);
3081 int flags;
3082
3083 /* Create a reference that works for the optimization context. */
3084
3085 MZ_ASSERT(pos < ui->num_toplevels);
3086
3087 if (ui->inlining && (pos > (SCHEME_LINKLET_PREFIX_PREFIX
3088 + ui->linklet->num_total_imports
3089 + ui->linklet->num_exports))) {
3090 /* Cannot refer to an unexported variable across a module boundary. */
3091 return_NULL;
3092 }
3093
3094 if (ui->inlining) {
3095 /* Can we introduce a new top-level reference while inlining
3096 across a module boundary? */
3097 if (pos >= (ui->linklet->num_total_imports + SCHEME_LINKLET_PREFIX_PREFIX)) {
3098 /* no new instance needed, but maybe a new symbol from that instance */
3099 pos -= (ui->linklet->num_total_imports + SCHEME_LINKLET_PREFIX_PREFIX);
3100 return scheme_optimize_add_import_variable(ui->opt_info, ui->linklet_key,
3101 SCHEME_VEC_ELS(ui->linklet->defns)[pos]);
3102 } else {
3103 /* Find import: */
3104 int instance_pos = 0;
3105 pos -= SCHEME_LINKLET_PREFIX_PREFIX;
3106 while (pos >= SCHEME_VEC_SIZE(SCHEME_VEC_ELS(ui->linklet->importss)[instance_pos])) {
3107 pos -= SCHEME_VEC_SIZE(SCHEME_VEC_ELS(ui->linklet->importss)[instance_pos]);
3108 instance_pos++;
3109 }
3110 MZ_ASSERT(instance_pos < SCHEME_VEC_SIZE(ui->linklet->importss));
3111
3112 /* Getting this imported linklet's import's key may add an import to the
3113 linklet being optimized: */
3114 v = scheme_optimize_get_import_key(ui->opt_info, ui->linklet_key, instance_pos);
3115 if (v) {
3116 /* Can add relevant linklet import (or already have it) */
3117 return scheme_optimize_add_import_variable(ui->opt_info, v,
3118 SCHEME_VEC_ELS(SCHEME_VEC_ELS(ui->linklet->importss)[instance_pos])[pos]);
3119 }
3120 }
3121
3122 return_NULL;
3123 }
3124
3125 flags = SCHEME_TOPLEVEL_FLAGS(rdata) & SCHEME_TOPLEVEL_FLAGS_MASK;
3126 switch (flags) {
3127 case SCHEME_TOPLEVEL_CONST:
3128 break;
3129 case SCHEME_TOPLEVEL_FIXED:
3130 break;
3131 case SCHEME_TOPLEVEL_READY:
3132 default:
3133 if (ui->inlining) {
3134 /* Since we're referencing from an imported context, the
3135 variable is now at least ready: */
3136 flags = SCHEME_TOPLEVEL_READY;
3137 }
3138 }
3139
3140 v = (Scheme_Object *)ui->toplevels[pos];
3141 MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_ir_toplevel_type));
3142
3143 if (flags)
3144 v = scheme_ir_toplevel_to_flagged_toplevel(v, flags);
3145
3146 ui->has_tl = 1;
3147
3148 return v;
3149 }
3150
unresolve_apply_values(Scheme_Object * e,Unresolve_Info * ui)3151 static Scheme_Object *unresolve_apply_values(Scheme_Object *e, Unresolve_Info *ui)
3152 {
3153 Scheme_Object *o, *a, *b;
3154
3155 a = SCHEME_PTR1_VAL(e);
3156 a = unresolve_expr(a, ui, 0);
3157 if (!a) return_NULL;
3158 LOG_UNRESOLVE(printf("unresolve_apply_values: (a) %d %d\n", e->type, a->type));
3159
3160 b = SCHEME_PTR2_VAL(e);
3161 b = unresolve_expr(b, ui, 0);
3162 if (!b) return_NULL;
3163 LOG_UNRESOLVE(printf(" (b) %d\n", b->type));
3164
3165 o = scheme_alloc_object();
3166 o->type = SCHEME_TYPE(e);
3167 SCHEME_PTR1_VAL(o) = a;
3168 SCHEME_PTR2_VAL(o) = b;
3169 return o;
3170 }
3171
unresolve_define_values(Scheme_Object * e,Unresolve_Info * ui)3172 static Scheme_Object *unresolve_define_values(Scheme_Object *e, Unresolve_Info *ui)
3173 {
3174 Scheme_Object *vec, *val, *tl;
3175 int i;
3176
3177 vec = scheme_make_vector(SCHEME_VEC_SIZE(e), NULL);
3178 vec->type = scheme_define_values_type;
3179
3180 LOG_UNRESOLVE(printf("define-values-size!!!: %d\n", (int)SCHEME_VEC_SIZE(e)));
3181 for (i = SCHEME_VEC_SIZE(e); --i;) {
3182 LOG_UNRESOLVE(printf("define-values: %d\n", SCHEME_TYPE(SCHEME_VEC_ELS(e)[i])));
3183 tl = unresolve_toplevel(SCHEME_VEC_ELS(e)[i], ui);
3184 if (!tl) return_NULL;
3185 SCHEME_VEC_ELS(vec)[i] = tl;
3186 }
3187 val = unresolve_expr(SCHEME_VEC_ELS(e)[0], ui, 0);
3188 if (!val) return_NULL;
3189 SCHEME_VEC_ELS(vec)[0] = val;
3190
3191 return vec;
3192 }
3193
make_let_header(int count)3194 static Scheme_IR_Let_Header *make_let_header(int count)
3195 {
3196 Scheme_IR_Let_Header *lh;
3197 lh = MALLOC_ONE_TAGGED(Scheme_IR_Let_Header);
3198 lh->iso.so.type = scheme_ir_let_header_type;
3199 lh->count = count;
3200 lh->num_clauses = 0;
3201 return lh;
3202 }
3203
make_ir_let_value(int count)3204 static Scheme_IR_Let_Value *make_ir_let_value(int count)
3205 {
3206 Scheme_IR_Let_Value *irlv;
3207 irlv = MALLOC_ONE_TAGGED(Scheme_IR_Let_Value);
3208 irlv->iso.so.type = scheme_ir_let_value_type;
3209 irlv->count = count;
3210 return irlv;
3211 }
3212
3213 typedef struct Unresolve_Let_Void_State {
3214 /* All pointers so we can use scheme_malloc */
3215 Scheme_IR_Let_Header *prev_head;
3216 Scheme_IR_Let_Value *prev_let;
3217 Scheme_Sequence *prev_seq;
3218 } Unresolve_Let_Void_State;
3219
3220 /* only one of lh, irlv, seq, or body should be non-NULL */
attach_lv(Scheme_IR_Let_Header * lh,Scheme_IR_Let_Value * irlv,Scheme_Sequence * seq,Scheme_Object * body,Unresolve_Let_Void_State * state)3221 static void attach_lv(Scheme_IR_Let_Header *lh,
3222 Scheme_IR_Let_Value *irlv,
3223 Scheme_Sequence *seq,
3224 Scheme_Object *body,
3225 Unresolve_Let_Void_State *state)
3226 {
3227 Scheme_Object *o;
3228 o = lh ? (Scheme_Object *)lh :
3229 (irlv ? (Scheme_Object *)irlv :
3230 (seq ? (Scheme_Object *)seq : body));
3231
3232 if (state->prev_head) {
3233 state->prev_head->body = o;
3234 } else if (state->prev_let) {
3235 state->prev_let->body = o;
3236 } else if (state->prev_seq) {
3237 state->prev_seq->array[state->prev_seq->count - 1] = o;
3238 }
3239
3240 state->prev_head = lh;
3241 state->prev_let = irlv;
3242 state->prev_seq = seq;
3243 }
3244
push_to_rhs_sequence(Scheme_Object * push_rhs,Scheme_Object * val)3245 static Scheme_Object *push_to_rhs_sequence(Scheme_Object *push_rhs, Scheme_Object *val)
3246 /* move accumulated forms to the next discovered right-hand side for a binding sequence */
3247 {
3248 int len, i;
3249 Scheme_Sequence *seq;
3250
3251 len = scheme_list_length(push_rhs);
3252 seq = scheme_malloc_sequence(len+1);
3253 seq->so.type = scheme_sequence_type;
3254 seq->count = len+1;
3255 seq->array[len] = val;
3256
3257 for (i = len; i--; ) {
3258 seq->array[i] = SCHEME_CAR(push_rhs);
3259 push_rhs = SCHEME_CDR(push_rhs);
3260 }
3261
3262 return (Scheme_Object *)seq;
3263 }
3264
unresolve_let_void(Scheme_Object * e,Unresolve_Info * ui)3265 static Scheme_Object *unresolve_let_void(Scheme_Object *e, Unresolve_Info *ui)
3266 {
3267 Scheme_Let_Void *lv = (Scheme_Let_Void *)e;
3268 int i, pos, count;
3269 Scheme_IR_Local **vars;
3270 Scheme_IR_Let_Header *lh;
3271 Scheme_Object *o, *push_rhs = scheme_null;
3272 Unresolve_Let_Void_State *state;
3273
3274 state = scheme_malloc(sizeof(Unresolve_Let_Void_State));
3275
3276 count = lv->count;
3277 pos = unresolve_stack_push(ui, count, 1);
3278 lh = make_let_header(count);
3279
3280 o = lv->body;
3281 attach_lv(lh, NULL, NULL, NULL, state);
3282 for (i = 0; i < count;) {
3283 switch (SCHEME_TYPE(o)) {
3284 case scheme_let_value_type: {
3285 Scheme_Let_Value *lval = (Scheme_Let_Value *)o;
3286 Scheme_IR_Let_Value *irlv;
3287 Scheme_Object *val;
3288 irlv = make_ir_let_value(lval->count);
3289 lh->num_clauses++;
3290
3291 vars = unresolve_stack_extract(ui, lval->position, lv->count);
3292 irlv->vars = vars;
3293
3294 if (SCHEME_LET_VALUE_AUTOBOX(lval)) {
3295 SCHEME_LET_FLAGS(lh) = SCHEME_LET_RECURSIVE;
3296 }
3297
3298 val = unresolve_expr(lval->value, ui, 0);
3299 if (!val) return_NULL;
3300 if (!SCHEME_NULLP(push_rhs)) {
3301 val = push_to_rhs_sequence(push_rhs, val);
3302 push_rhs = scheme_null;
3303 }
3304 irlv->value = val;
3305
3306 o = lval->body;
3307 attach_lv(NULL, irlv, NULL, NULL, state);
3308 i += lval->count;
3309
3310 break;
3311 }
3312 case scheme_boxenv_type: {
3313 o = SCHEME_PTR2_VAL(o);
3314 break;
3315 }
3316 case scheme_letrec_type: {
3317 Scheme_Letrec *lr = (Scheme_Letrec *)o;
3318 int j;
3319 SCHEME_LET_FLAGS(lh) = SCHEME_LET_RECURSIVE;
3320 for (j = 0; j < lr->count; j++) {
3321 Scheme_IR_Let_Value *irlv;
3322 Scheme_Object *val;
3323 Scheme_IR_Local **vars;
3324 irlv = make_ir_let_value(1);
3325 lh->num_clauses++;
3326 vars = unresolve_stack_extract(ui, j, 1);
3327 val = unresolve_expr(lr->procs[j], ui, 0);
3328 if (!val) return_NULL;
3329 if (!SCHEME_NULLP(push_rhs)) {
3330 val = push_to_rhs_sequence(push_rhs, val);
3331 push_rhs = scheme_null;
3332 }
3333 irlv->value = val;
3334 irlv->vars = vars;
3335 attach_lv(NULL, irlv, NULL, NULL, state);
3336 i++;
3337 }
3338 o = lr->body;
3339 break;
3340 }
3341 case scheme_sequence_type: {
3342 Scheme_Sequence *seq = (Scheme_Sequence *)o;
3343 int i;
3344 for (i = 0; i < seq->count - 1; i++) {
3345 if (!SAME_TYPE(SCHEME_TYPE(seq->array[i]), scheme_local_type)) {
3346 push_rhs = scheme_make_pair(unresolve_expr(seq->array[i], ui, 0), push_rhs);
3347 }
3348 }
3349 o = seq->array[seq->count - 1];
3350 break;
3351 }
3352 default: {
3353 scheme_signal_error("internal error: unexpected form in let-void: %d", SCHEME_TYPE(o));
3354 }
3355 }
3356 }
3357
3358 o = unresolve_expr(o, ui, 0);
3359 if (!o) return_NULL;
3360 attach_lv(NULL, NULL, NULL, o, state);
3361
3362 (void)unresolve_stack_pop(ui, pos, 0);
3363
3364 return (Scheme_Object *)lh;
3365 }
3366
unresolve_closure(Scheme_Object * e,Unresolve_Info * ui)3367 static Scheme_Object *unresolve_closure(Scheme_Object *e, Unresolve_Info *ui)
3368 {
3369 Scheme_Object *r, *c;
3370
3371 if (ui->closures)
3372 c = scheme_hash_get(ui->closures, e);
3373 else
3374 c = NULL;
3375
3376 if (ui->inlining) {
3377 /* can't handle cyclic closures */
3378 if (c) return_NULL;
3379 if (!ui->closures) {
3380 Scheme_Hash_Table *ht;
3381 ht = scheme_make_hash_table(SCHEME_hash_ptr);
3382 ui->closures = ht;
3383 }
3384 scheme_hash_set(ui->closures, e, scheme_true);
3385 } else {
3386 if (c && SAME_TYPE(SCHEME_TYPE(c), scheme_ir_toplevel_type))
3387 return c;
3388 }
3389
3390 r = unresolve_lambda(SCHEME_CLOSURE_CODE(e), ui);
3391
3392 if (ui->inlining)
3393 scheme_hash_set(ui->closures, e, NULL);
3394
3395 return r;
3396 }
3397
unresolve_let_value(Scheme_Let_Value * lv,Unresolve_Info * ui,Scheme_Object * val,Scheme_Object * body)3398 static Scheme_Object *unresolve_let_value(Scheme_Let_Value *lv, Unresolve_Info *ui,
3399 Scheme_Object* val, Scheme_Object *body) {
3400 Scheme_Set_Bang *sb;
3401 Scheme_IR_Local *var;
3402 Scheme_Sequence *seq;
3403
3404 LOG_UNRESOLVE(printf("set! position: %d (stack pos %d)\n", lv->position, ui->stack_pos));
3405
3406 if (!lv->count) {
3407 /* Not a set! case; just make sure the expression produces 0 arguments */
3408 Scheme_IR_Let_Header *head;
3409 Scheme_IR_Let_Value *irlv;
3410
3411 head = make_let_header(0);
3412 head->num_clauses = 1;
3413 irlv = make_ir_let_value(0);
3414 head->body = (Scheme_Object *)irlv;
3415 irlv->value = val;
3416 irlv->body = body;
3417
3418 return (Scheme_Object *)head;
3419 }
3420
3421 var = unresolve_lookup(ui, lv->position, 0);
3422
3423 if (var->is_ref_arg) {
3424 Scheme_App2_Rec *app2;
3425 app2 = MALLOC_ONE_TAGGED(Scheme_App2_Rec);
3426 app2->iso.so.type = scheme_application2_type;
3427 app2->rator = (Scheme_Object *)var;
3428 app2->rand = val;
3429 seq = scheme_malloc_sequence(2);
3430 seq->so.type = scheme_sequence_type;
3431 seq->count = 2;
3432 seq->array[0] = (Scheme_Object *)app2;
3433 seq->array[1] = body;
3434 return (Scheme_Object *)seq;
3435 }
3436
3437 var->mutated = 1;
3438
3439 sb = MALLOC_ONE_TAGGED(Scheme_Set_Bang);
3440 sb->so.type = scheme_set_bang_type;
3441 sb->var = (Scheme_Object *)var;
3442 sb->val = val;
3443
3444 seq = scheme_malloc_sequence(2);
3445 seq->so.type = scheme_sequence_type;
3446 seq->count = 2;
3447 seq->array[0] = (Scheme_Object *)sb;
3448 seq->array[1] = body;
3449
3450 return (Scheme_Object *)seq;
3451 }
3452
maybe_unresolve_app_refs(Scheme_Object * rator,Scheme_App_Rec * app,Scheme_App2_Rec * app2,Scheme_App3_Rec * app3,Unresolve_Info * ui)3453 static Scheme_Object *maybe_unresolve_app_refs(Scheme_Object *rator,
3454 Scheme_App_Rec *app,
3455 Scheme_App2_Rec *app2,
3456 Scheme_App3_Rec *app3,
3457 Unresolve_Info *ui)
3458 {
3459 Scheme_Lambda *lam = NULL;
3460
3461 if (SAME_TYPE(SCHEME_TYPE(rator), scheme_closure_type)
3462 && (SCHEME_LAMBDA_FLAGS((SCHEME_CLOSURE_CODE(rator))) & LAMBDA_HAS_TYPED_ARGS)) {
3463 lam = SCHEME_CLOSURE_CODE(rator);
3464 } else if (SAME_TYPE(SCHEME_TYPE(rator), scheme_toplevel_type)
3465 || SAME_TYPE(SCHEME_TYPE(rator), scheme_static_toplevel_type)) {
3466 lam = (Scheme_Lambda *)scheme_hash_get(ui->ref_lifts, scheme_make_integer(SCHEME_TOPLEVEL_POS(rator)));
3467 }
3468
3469 if (lam) {
3470 Scheme_App_Rec *new_app = NULL;
3471 Scheme_App2_Rec *new_app2 = NULL;
3472 Scheme_App3_Rec *new_app3 = NULL;
3473 Scheme_Object *arg;
3474 Scheme_Object *new_rator;
3475 int i;
3476
3477 if (app) {
3478 if (lam->num_params != app->num_args)
3479 return NULL;
3480 new_app = scheme_malloc_application(app->num_args + 1);
3481 } else if (app2) {
3482 if (lam->num_params != 1)
3483 return NULL;
3484 new_app2 = MALLOC_ONE_TAGGED(Scheme_App2_Rec);
3485 new_app2->iso.so.type = scheme_application2_type;
3486 } else {
3487 if (lam->num_params != 2)
3488 return NULL;
3489 new_app3 = MALLOC_ONE_TAGGED(Scheme_App3_Rec);
3490 new_app3->iso.so.type = scheme_application3_type;
3491 }
3492
3493 LOG_UNRESOLVE(printf("REF app\n"));
3494 for(i = 0; i < lam->num_params; i++) {
3495 if (app)
3496 arg = app->args[i + 1];
3497 else if (app2)
3498 arg = app2->rand;
3499 else if (i)
3500 arg = app3->rand2;
3501 else
3502 arg = app3->rand1;
3503 LOG_UNRESOLVE(printf("%d: %d\n", i, scheme_boxmap_get(lam->closure_map, i, lam->closure_size)));
3504 LOG_UNRESOLVE(printf("ui->stack_pos = %d, argpos = %d, i = %d\n", ui->stack_pos, SCHEME_LOCAL_POS(arg), i));
3505 if ((scheme_boxmap_get(lam->closure_map, i, lam->closure_size) == LAMBDA_TYPE_BOXED)
3506 && SAME_TYPE(SCHEME_TYPE(arg), scheme_local_type)
3507 && !ui->vars[ui->stack_pos - SCHEME_LOCAL_POS(arg) - 1]->is_ref_arg) {
3508 Scheme_Case_Lambda *cl;
3509 Scheme_Lambda *d0, *d1;
3510 Scheme_Set_Bang *sb;
3511 Scheme_Object *s;
3512 Scheme_IR_Local *arg_var;
3513 int pos;
3514 Scheme_IR_Local **vars;
3515 Scheme_IR_Lambda_Info *ci;
3516 LOG_UNRESOLVE(printf("This will be a case-lambda: %d\n", i));
3517
3518 cl = (Scheme_Case_Lambda *)scheme_malloc_tagged(sizeof(Scheme_Case_Lambda)
3519 + ((2 - mzFLEX_DELTA) * sizeof(Scheme_Object *)));
3520
3521 cl->so.type = scheme_case_lambda_sequence_type;
3522 cl->count = 2;
3523 s = scheme_make_symbol("cl");
3524 s = scheme_gensym(s);
3525 cl->name = s;
3526
3527 arg_var = unresolve_lookup(ui, SCHEME_LOCAL_POS(arg), 0);
3528 arg_var->mutated = 1;
3529
3530 d0 = MALLOC_ONE_TAGGED(Scheme_Lambda);
3531 d0->iso.so.type = scheme_ir_lambda_type;
3532 d0->num_params = 0;
3533 d0->body = (Scheme_Object *)arg_var;
3534 ci = MALLOC_ONE_RT(Scheme_IR_Lambda_Info);
3535 SET_REQUIRED_TAG(ci->type = scheme_rt_ir_lambda_info);
3536 d0->ir_info = ci;
3537 s = scheme_make_symbol("d0");
3538 s = scheme_gensym(s);
3539 d0->name = s;
3540 cl->array[0] = (Scheme_Object *)d0;
3541
3542 pos = unresolve_stack_push(ui, 1, 1);
3543 vars = unresolve_stack_pop(ui, pos, 1);
3544
3545 d1 = MALLOC_ONE_TAGGED(Scheme_Lambda);
3546 d1->iso.so.type = scheme_ir_lambda_type;
3547 d1->num_params = 1;
3548
3549 sb = MALLOC_ONE_TAGGED(Scheme_Set_Bang);
3550 sb->so.type = scheme_set_bang_type;
3551 sb->var = (Scheme_Object *)arg_var;
3552 sb->val = (Scheme_Object *)vars[0];
3553 d1->body = (Scheme_Object *)sb;
3554 ci = MALLOC_ONE_RT(Scheme_IR_Lambda_Info);
3555 SET_REQUIRED_TAG(ci->type = scheme_rt_ir_lambda_info);
3556 ci->vars = vars;
3557 vars[0]->use_count = 1;
3558 vars[0]->non_app_count = 1;
3559 d1->ir_info = ci;
3560
3561
3562 s = scheme_make_symbol("d1");
3563 s = scheme_gensym(s);
3564 d1->name = s;
3565 cl->array[1] = (Scheme_Object *)d1;
3566
3567 arg = (Scheme_Object *)cl;
3568 } else {
3569 arg = unresolve_expr(arg, ui, 0);
3570 }
3571
3572 if (new_app)
3573 new_app->args[i + 1] = arg;
3574 else if (new_app2)
3575 new_app2->rand = arg;
3576 else if (i)
3577 new_app3->rand2 = arg;
3578 else
3579 new_app3->rand1 = arg;
3580 }
3581 new_rator = unresolve_expr(rator, ui, 0);
3582
3583 if (new_app) {
3584 new_app->args[0] = new_rator;
3585 return (Scheme_Object *)new_app;
3586 } else if (new_app2) {
3587 new_app2->rator = new_rator;
3588 return (Scheme_Object *)new_app2;
3589 } else {
3590 new_app3->rator = new_rator;
3591 return (Scheme_Object *)new_app3;
3592 }
3593 }
3594
3595 return NULL;
3596 }
3597
unresolve_expr_k(void)3598 static Scheme_Object *unresolve_expr_k(void)
3599 {
3600 Scheme_Thread *p = scheme_current_thread;
3601 Scheme_Object *e = (Scheme_Object *)p->ku.k.p1;
3602 Unresolve_Info *ui = (Unresolve_Info *)p->ku.k.p2;
3603
3604 p->ku.k.p1 = NULL;
3605 p->ku.k.p2 = NULL;
3606
3607 return unresolve_expr(e, ui, p->ku.k.i1);
3608 }
3609
unresolve_expr(Scheme_Object * e,Unresolve_Info * ui,int as_rator)3610 static Scheme_Object *unresolve_expr(Scheme_Object *e, Unresolve_Info *ui, int as_rator)
3611 {
3612 #ifdef DO_STACK_CHECK
3613 {
3614 # include "mzstkchk.h"
3615 {
3616 Scheme_Thread *p = scheme_current_thread;
3617
3618 p->ku.k.p1 = (void *)e;
3619 p->ku.k.p2 = (void *)ui;
3620 p->ku.k.i1 = as_rator;
3621
3622 return scheme_handle_stack_overflow(unresolve_expr_k);
3623 }
3624 }
3625 #endif
3626
3627 ui->body_size++;
3628
3629 switch (SCHEME_TYPE(e)) {
3630 case scheme_local_type:
3631 return (Scheme_Object *)unresolve_lookup(ui, SCHEME_LOCAL_POS(e), as_rator);
3632 case scheme_local_unbox_type:
3633 {
3634 Scheme_IR_Local *var;
3635 var = unresolve_lookup(ui, SCHEME_LOCAL_POS(e), as_rator);
3636 if (var->is_ref_arg) {
3637 Scheme_App_Rec *app;
3638 LOG_UNRESOLVE(printf("local unbox: %d (stack pos %d)\n", SCHEME_LOCAL_POS(e), ui->stack_pos));
3639 app = scheme_malloc_application(1);
3640 app->args[0] = (Scheme_Object *)var;
3641 return (Scheme_Object *)app;
3642 }
3643 return (Scheme_Object *)var;
3644 }
3645 case scheme_sequence_type:
3646 case scheme_begin0_sequence_type:
3647 {
3648 Scheme_Sequence *seq = (Scheme_Sequence *)e, *seq2;
3649 int i;
3650
3651 seq2 = scheme_malloc_sequence(seq->count);
3652 seq2->so.type = seq->so.type;
3653 seq2->count = seq->count;
3654 for (i = seq->count; i--; ) {
3655 e = unresolve_expr(seq->array[i], ui, 0);
3656 if (!e) return_NULL;
3657 seq2->array[i] = e;
3658 }
3659
3660 return (Scheme_Object *)seq2;
3661 }
3662 break;
3663 case scheme_application_type:
3664 {
3665 Scheme_App_Rec *app = (Scheme_App_Rec *)e, *app2;
3666 Scheme_Object *a;
3667 int pos, i;
3668
3669 ui->body_size += app->num_args;
3670 check_nonleaf_rator(app->args[0], ui);
3671
3672 pos = unresolve_stack_push(ui, app->num_args, 0);
3673
3674 e = maybe_unresolve_app_refs(app->args[0], app, NULL, NULL, ui);
3675 if (e) {
3676 (void)unresolve_stack_pop(ui, pos, 0);
3677 return e;
3678 }
3679
3680 app2 = scheme_malloc_application(app->num_args+1);
3681
3682 for (i = app->num_args + 1; i--; ) {
3683 a = unresolve_expr(app->args[i], ui, !i);
3684 if (!a) return_NULL;
3685 app2->args[i] = a;
3686 }
3687
3688 (void)unresolve_stack_pop(ui, pos, 0);
3689
3690 return (Scheme_Object *)app2;
3691 }
3692 case scheme_application2_type:
3693 {
3694 Scheme_App2_Rec *app = (Scheme_App2_Rec *)e, *app2;
3695 Scheme_Object *rator, *rand;
3696 int pos;
3697
3698 ui->body_size += 1;
3699 check_nonleaf_rator(app->rator, ui);
3700
3701 pos = unresolve_stack_push(ui, 1, 0);
3702
3703 e = maybe_unresolve_app_refs(app->rator, NULL, app, NULL, ui);
3704 if (e) {
3705 (void)unresolve_stack_pop(ui, pos, 0);
3706 return e;
3707 }
3708
3709 rator = unresolve_expr(app->rator, ui, 1);
3710 if (!rator) return_NULL;
3711 rand = unresolve_expr(app->rand, ui, 0);
3712 if (!rand) return_NULL;
3713
3714 (void)unresolve_stack_pop(ui, pos, 0);
3715
3716 app2 = MALLOC_ONE_TAGGED(Scheme_App2_Rec);
3717 app2->iso.so.type = scheme_application2_type;
3718 app2->rator = rator;
3719 app2->rand = rand;
3720
3721 return (Scheme_Object *)app2;
3722 }
3723 case scheme_application3_type:
3724 {
3725 Scheme_App3_Rec *app = (Scheme_App3_Rec *)e, *app2;
3726 Scheme_Object *rator, *rand1, *rand2;
3727 int pos;
3728
3729 ui->body_size += 2;
3730 check_nonleaf_rator(app->rator, ui);
3731
3732 pos = unresolve_stack_push(ui, 2, 0);
3733
3734 e = maybe_unresolve_app_refs(app->rator, NULL, NULL, app, ui);
3735 if (e) {
3736 (void)unresolve_stack_pop(ui, pos, 0);
3737 return e;
3738 }
3739
3740 rator = unresolve_expr(app->rator, ui, 1);
3741 if (!rator) return_NULL;
3742 rand1 = unresolve_expr(app->rand1, ui, 0);
3743 if (!rand1) return_NULL;
3744 rand2 = unresolve_expr(app->rand2, ui, 0);
3745 if (!rand2) return_NULL;
3746
3747 (void)unresolve_stack_pop(ui, pos, 0);
3748
3749 app2 = MALLOC_ONE_TAGGED(Scheme_App3_Rec);
3750 app2->iso.so.type = scheme_application3_type;
3751 app2->rator = rator;
3752 app2->rand1 = rand1;
3753 app2->rand2 = rand2;
3754
3755 return (Scheme_Object *)app2;
3756 }
3757 case scheme_branch_type:
3758 {
3759 Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)e, *b2;
3760 Scheme_Object *tst, *thn, *els;
3761
3762 tst = unresolve_expr(b->test, ui, 0);
3763 if (!tst) return_NULL;
3764 thn = unresolve_expr(b->tbranch, ui, 0);
3765 if (!thn) return_NULL;
3766 els = unresolve_expr(b->fbranch, ui, 0);
3767 if (!els) return_NULL;
3768
3769 b2 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec);
3770 b2->so.type = scheme_branch_type;
3771 b2->test = tst;
3772 b2->tbranch = thn;
3773 b2->fbranch = els;
3774
3775 return (Scheme_Object *)b2;
3776 }
3777 case scheme_with_cont_mark_type:
3778 {
3779 Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)e, *wcm2;
3780 Scheme_Object *k, *v, *b;
3781
3782 k = unresolve_expr(wcm->key, ui, 0);
3783 if (!k) return_NULL;
3784 v = unresolve_expr(wcm->val, ui, 0);
3785 if (!v) return_NULL;
3786 b = unresolve_expr(wcm->body, ui, 0);
3787 if (!b) return_NULL;
3788
3789 wcm2 = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark);
3790 wcm2->so.type = scheme_with_cont_mark_type;
3791 wcm2->key = k;
3792 wcm2->val = v;
3793 wcm2->body = b;
3794
3795 return (Scheme_Object *)wcm2;
3796 }
3797 case scheme_with_immed_mark_type:
3798 {
3799 Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)e, *wcm2;
3800 Scheme_Object *k, *v, *b;
3801 Scheme_IR_Local **vars;
3802 int pos;
3803
3804 k = unresolve_expr(wcm->key, ui, 0);
3805 if (!k) return_NULL;
3806 v = unresolve_expr(wcm->val, ui, 0);
3807 if (!v) return_NULL;
3808
3809 pos = unresolve_stack_push(ui, 1, 1);
3810 vars = unresolve_stack_extract(ui, 0, 1);
3811 b = unresolve_expr(wcm->body, ui, 0);
3812 if (!b) return_NULL;
3813 (void)unresolve_stack_pop(ui, pos, 0);
3814
3815 wcm2 = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark);
3816 wcm2->so.type = scheme_with_immed_mark_type;
3817 wcm2->key = k;
3818 wcm2->val = v;
3819 b = scheme_make_raw_pair((Scheme_Object *)vars[0], b);
3820 wcm2->body = b;
3821
3822 return (Scheme_Object *)wcm2;
3823 }
3824 case scheme_let_void_type:
3825 {
3826 return unresolve_let_void(e, ui);
3827 }
3828 case scheme_let_one_type:
3829 {
3830 Scheme_Let_One *lo = (Scheme_Let_One *)e;
3831 Scheme_Object *rhs, *body;
3832 Scheme_IR_Let_Header *lh;
3833 Scheme_IR_Let_Value *irlv;
3834 Scheme_IR_Local **vars;
3835 int pos;
3836
3837 pos = unresolve_stack_push(ui, 1, 1);
3838 rhs = unresolve_expr(lo->value, ui, 0);
3839 if (!rhs) return_NULL;
3840
3841 body = unresolve_expr(lo->body, ui, 0);
3842 if (!body) return_NULL;
3843
3844 vars = unresolve_stack_pop(ui, pos, 1);
3845
3846 lh = MALLOC_ONE_TAGGED(Scheme_IR_Let_Header);
3847 lh->iso.so.type = scheme_ir_let_header_type;
3848 lh->count = 1;
3849 lh->num_clauses = 1;
3850
3851 irlv = MALLOC_ONE_TAGGED(Scheme_IR_Let_Value);
3852 irlv->iso.so.type = scheme_ir_let_value_type;
3853 irlv->count = 1;
3854 irlv->value = rhs;
3855 irlv->vars = vars;
3856 irlv->body = body;
3857
3858 lh->body = (Scheme_Object *)irlv;
3859
3860 return (Scheme_Object *)lh;
3861 }
3862 case scheme_closure_type:
3863 {
3864 return unresolve_closure(e, ui);
3865 }
3866 case scheme_lambda_type:
3867 {
3868 return unresolve_lambda((Scheme_Lambda *)e, ui);
3869 }
3870 case scheme_inline_variant_type:
3871 {
3872 Scheme_Object *a;
3873 a = SCHEME_VEC_ELS(e)[0];
3874 a = unresolve_expr(a, ui, 0);
3875 if (!a) return_NULL;
3876 return a;
3877 }
3878 case scheme_define_values_type:
3879 {
3880 return unresolve_define_values(e, ui);
3881 }
3882 case scheme_set_bang_type:
3883 {
3884 Scheme_Set_Bang *sb = (Scheme_Set_Bang *)e, *sb2;
3885 Scheme_Object *var, *val;
3886 var = unresolve_expr(sb->var, ui, 0);
3887 if (!var) return_NULL;
3888 if (SAME_TYPE(SCHEME_TYPE(var), scheme_ir_toplevel_type)) {
3889 if (((Scheme_IR_Toplevel *)var)->instance_pos != -1) {
3890 /* Cannot inline a `set!` of another linklet's variable */
3891 return_NULL;
3892 }
3893 SCHEME_IR_TOPLEVEL_FLAGS(((Scheme_IR_Toplevel *)var)) |= SCHEME_TOPLEVEL_MUTATED;
3894 }
3895 val = unresolve_expr(sb->val, ui, 0);
3896 if (!val) return_NULL;
3897
3898 LOG_UNRESOLVE(printf("SET BANG: %d, %d\n", SCHEME_TYPE(val), SCHEME_TYPE(var)));
3899
3900 sb2 = MALLOC_ONE_TAGGED(Scheme_Set_Bang);
3901 sb2->so.type = scheme_set_bang_type;
3902 sb2->var = var;
3903 sb2->val = val;
3904 sb2->set_undef = (ui->comp_flags & COMP_ALLOW_SET_UNDEFINED);
3905 return (Scheme_Object *)sb2;
3906 }
3907 case scheme_varref_form_type:
3908 {
3909 Scheme_Object *a, *b, *o;
3910 a = SCHEME_PTR1_VAL(e);
3911 a = unresolve_expr(a, ui, 0);
3912 if (!a) return_NULL;
3913 LOG_UNRESOLVE(printf("unresolve_varref: (a) %d %d\n", e->type, a->type));
3914
3915 if (SAME_TYPE(SCHEME_TYPE(a), scheme_ir_toplevel_type)) {
3916 SCHEME_IR_TOPLEVEL_FLAGS((Scheme_IR_Toplevel *)a) |= SCHEME_TOPLEVEL_MUTATED;
3917 }
3918
3919 b = SCHEME_PTR2_VAL(e);
3920 MZ_ASSERT(SCHEME_FALSEP(b)
3921 || (SAME_TYPE(SCHEME_TYPE(b), scheme_toplevel_type)
3922 && !SCHEME_TOPLEVEL_POS(b))
3923 || (SAME_TYPE(SCHEME_TYPE(b), scheme_static_toplevel_type)
3924 && !SCHEME_TOPLEVEL_POS(b)));
3925 b = unresolve_expr(b, ui, 0);
3926 if (!b) return_NULL;
3927 MZ_ASSERT(SCHEME_FALSEP(b) || (SAME_TYPE(SCHEME_TYPE(b), scheme_ir_toplevel_type)
3928 && (((Scheme_IR_Toplevel *)b)->instance_pos == -1)
3929 && (((Scheme_IR_Toplevel *)b)->variable_pos == -1)));
3930 LOG_UNRESOLVE(printf(" (b) %d\n", b->type));
3931
3932 o = scheme_alloc_object();
3933 o->type = scheme_varref_form_type;
3934 SCHEME_PTR1_VAL(o) = a;
3935 SCHEME_PTR2_VAL(o) = b;
3936 return o;
3937 }
3938 case scheme_apply_values_type:
3939 {
3940 return unresolve_apply_values(e, ui);
3941 }
3942 case scheme_boxenv_type:
3943 {
3944 return unresolve_expr(SCHEME_PTR2_VAL(e), ui, 0);
3945 }
3946 case scheme_toplevel_type:
3947 case scheme_static_toplevel_type:
3948 {
3949 return unresolve_toplevel(e, ui);
3950 }
3951 case scheme_case_lambda_sequence_type:
3952 {
3953 int i, cnt;
3954 Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)e, *cl2;
3955
3956 cl2 = (Scheme_Case_Lambda *)scheme_malloc_tagged(sizeof(Scheme_Case_Lambda)
3957 + ((cl->count - mzFLEX_DELTA) * sizeof(Scheme_Object*)));
3958 cl2->so.type = scheme_case_lambda_sequence_type;
3959 cl2->count = cl->count;
3960 cl2->name = cl->name; /* this may need more handling, see schpriv.c:1456 */
3961
3962 cnt = cl->count;
3963
3964 for (i = 0; i < cnt; i++) {
3965 Scheme_Object *le;
3966 Scheme_Lambda *lam;
3967 if (SAME_TYPE(SCHEME_TYPE(cl->array[i]), scheme_closure_type)) {
3968 lam = ((Scheme_Closure *)cl->array[i])->code;
3969 } else {
3970 lam = (Scheme_Lambda *)cl->array[i];
3971 }
3972
3973 le = unresolve_lambda(lam, ui);
3974 if (!le) return_NULL;
3975
3976 cl2->array[i] = le;
3977 }
3978
3979 return (Scheme_Object *)cl2;
3980 }
3981 case scheme_let_value_type:
3982 {
3983 Scheme_Let_Value *lv = (Scheme_Let_Value *)e;
3984 Scheme_Object *val, *body;
3985 val = unresolve_expr(lv->value, ui, 0);
3986 if (!val) return_NULL;
3987
3988 body = unresolve_expr(lv->body, ui, 0);
3989 if (!body) return_NULL;
3990
3991 return unresolve_let_value(lv, ui, val, body);
3992 }
3993 default:
3994 if (SCHEME_TYPE(e) > _scheme_values_types_) {
3995 if (scheme_ir_duplicate_ok(e, 1) || !ui->inlining)
3996 return e;
3997 else if (ui->inlining)
3998 return_NULL;
3999 }
4000
4001 scheme_signal_error("internal error: no unresolve for: %d", SCHEME_TYPE(e));
4002 return_NULL;
4003 }
4004 }
4005
locate_cyclic_closures(Scheme_Object * e,Unresolve_Info * ui)4006 void locate_cyclic_closures(Scheme_Object *e, Unresolve_Info *ui)
4007 {
4008 switch(SCHEME_TYPE(e)) {
4009 case scheme_sequence_type:
4010 case scheme_begin0_sequence_type:
4011 {
4012 Scheme_Sequence *seq = (Scheme_Sequence *)e;
4013 int i;
4014 for (i = 0; i < seq->count; i++) {
4015 locate_cyclic_closures(seq->array[i], ui);
4016 }
4017 }
4018 break;
4019 case scheme_application_type:
4020 {
4021 Scheme_App_Rec *app = (Scheme_App_Rec *)e;
4022 int i;
4023 for (i = 0; i < app->num_args + 1; i++) {
4024 locate_cyclic_closures(app->args[i], ui);
4025 }
4026 }
4027 break;
4028 case scheme_application2_type:
4029 {
4030 Scheme_App2_Rec *app = (Scheme_App2_Rec *)e;
4031 locate_cyclic_closures(app->rator, ui);
4032 locate_cyclic_closures(app->rand, ui);
4033 }
4034 break;
4035 case scheme_application3_type:
4036 {
4037 Scheme_App3_Rec *app = (Scheme_App3_Rec *)e;
4038 locate_cyclic_closures(app->rator, ui);
4039 locate_cyclic_closures(app->rand1, ui);
4040 locate_cyclic_closures(app->rand2, ui);
4041 }
4042 break;
4043 case scheme_branch_type:
4044 {
4045 Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)e;
4046 locate_cyclic_closures(b->test, ui);
4047 locate_cyclic_closures(b->tbranch, ui);
4048 locate_cyclic_closures(b->fbranch, ui);
4049 }
4050 break;
4051 case scheme_with_cont_mark_type:
4052 case scheme_with_immed_mark_type:
4053 {
4054 Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)e;
4055 locate_cyclic_closures(wcm->key, ui);
4056 locate_cyclic_closures(wcm->val, ui);
4057 locate_cyclic_closures(wcm->body, ui);
4058 }
4059 break;
4060 case scheme_let_void_type:
4061 {
4062 Scheme_Let_Void *lv = (Scheme_Let_Void *)e;
4063 locate_cyclic_closures(lv->body, ui);
4064 }
4065 break;
4066 case scheme_letrec_type:
4067 {
4068 Scheme_Letrec *lr = (Scheme_Letrec *)e;
4069 int i;
4070 for (i = 0; i < lr->count; i++) {
4071 locate_cyclic_closures(lr->procs[i], ui);
4072 }
4073 locate_cyclic_closures(lr->body, ui);
4074 }
4075 break;
4076 case scheme_let_one_type:
4077 {
4078 Scheme_Let_One *lo = (Scheme_Let_One *)e;
4079 locate_cyclic_closures(lo->value, ui);
4080 locate_cyclic_closures(lo->body, ui);
4081 }
4082 break;
4083 case scheme_closure_type:
4084 {
4085 Scheme_Object *c;
4086 c = scheme_hash_get(ui->closures, e);
4087
4088 if (SAME_OBJ(c, scheme_true)) {
4089 Scheme_IR_Toplevel *tl;
4090
4091 tl = scheme_make_ir_toplevel(-1, ui->num_defns + ui->num_extra_toplevels, 0);
4092 ui->num_extra_toplevels++;
4093
4094 scheme_hash_set(ui->closures, e, (Scheme_Object *)tl);
4095 } else if (c) {
4096 /* do nothing */
4097 } else {
4098 Scheme_Closure *cl = (Scheme_Closure *)e;
4099 scheme_hash_set(ui->closures, e, scheme_true);
4100 locate_cyclic_closures((Scheme_Object *)cl->code, ui);
4101 }
4102 }
4103 break;
4104 case scheme_lambda_type:
4105 {
4106 Scheme_Lambda *cd = (Scheme_Lambda *)e;
4107 locate_cyclic_closures(cd->body, ui);
4108 }
4109 break;
4110 case scheme_inline_variant_type:
4111 {
4112 Scheme_Object *a;
4113 a = SCHEME_VEC_ELS(e)[0];
4114 locate_cyclic_closures(a, ui);
4115 }
4116 break;
4117 case scheme_define_values_type:
4118 {
4119 if (SCHEME_VEC_SIZE(e) == 2) {
4120 int pos = SCHEME_TOPLEVEL_POS(SCHEME_VEC_ELS(e)[1]);
4121 if (pos >= ui->lift_offset) {
4122 Scheme_Lambda *lam = (Scheme_Lambda *)SCHEME_VEC_ELS(e)[0];
4123 if (SCHEME_LAMBDA_FLAGS(lam) & LAMBDA_HAS_TYPED_ARGS) {
4124 scheme_hash_set(ui->ref_lifts, scheme_make_integer(pos), (Scheme_Object *)lam);
4125 }
4126 }
4127 }
4128
4129 locate_cyclic_closures(SCHEME_VEC_ELS(e)[0], ui);
4130 }
4131 break;
4132 case scheme_set_bang_type:
4133 {
4134 Scheme_Set_Bang *sb = (Scheme_Set_Bang *)e;
4135 locate_cyclic_closures(sb->var, ui);
4136 locate_cyclic_closures(sb->val, ui);
4137 }
4138 break;
4139 case scheme_varref_form_type:
4140 case scheme_apply_values_type:
4141 {
4142 Scheme_Object *a, *b;
4143 a = SCHEME_PTR1_VAL(e);
4144 locate_cyclic_closures(a, ui);
4145 b = SCHEME_PTR2_VAL(e);
4146 locate_cyclic_closures(b, ui);
4147 }
4148 break;
4149 case scheme_boxenv_type:
4150 {
4151 locate_cyclic_closures(SCHEME_PTR2_VAL(e), ui);
4152 }
4153 break;
4154 case scheme_case_lambda_sequence_type:
4155 {
4156 Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)e;
4157 int i;
4158 for (i = 0; i < cl->count; i++) {
4159 locate_cyclic_closures(cl->array[i], ui);
4160 }
4161 }
4162 break;
4163 case scheme_let_value_type:
4164 {
4165 Scheme_Let_Value *lv = (Scheme_Let_Value *)e;
4166 locate_cyclic_closures(lv->value, ui);
4167 locate_cyclic_closures(lv->body, ui);
4168 }
4169 break;
4170 default:
4171 break;
4172 }
4173 }
4174
convert_closures_to_definitions(Unresolve_Info * ui)4175 static void convert_closures_to_definitions(Unresolve_Info *ui)
4176 {
4177 Scheme_Object *d, *var, *val;
4178 Scheme_Lambda *lam;
4179 int i;
4180
4181 for (i = 0; i < ui->closures->size; i++) {
4182 if (ui->closures->vals[i] && !SAME_OBJ(ui->closures->vals[i], scheme_true)) {
4183 MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(ui->closures->vals[i]), scheme_ir_toplevel_type));
4184 d = scheme_make_vector(2, NULL);
4185 d->type = scheme_define_values_type;
4186 var = ui->closures->vals[i];
4187 lam = SCHEME_CLOSURE_CODE(ui->closures->keys[i]);
4188 val = unresolve_lambda(lam, ui);
4189 SCHEME_VEC_ELS(d)[0] = val;
4190 SCHEME_VEC_ELS(d)[1] = var;
4191 d = cons(d, ui->definitions);
4192 ui->definitions = d;
4193 }
4194 }
4195 }
4196
scheme_unresolve_linklet(Scheme_Linklet * linklet,int comp_flags)4197 Scheme_Linklet *scheme_unresolve_linklet(Scheme_Linklet *linklet, int comp_flags)
4198 /* Convert from "resolved" form back to the intermediate representation used
4199 by the optimizer. Unresolving generates an intermediate-representation prefix
4200 (for top levels and syntax literals) in addition to the code. */
4201 {
4202 Scheme_Linklet *new_linklet;
4203 Scheme_Object *bs, *bs2, *ds, *imports;
4204 Unresolve_Info *ui;
4205 Scheme_IR_Toplevel **toplevels, *tl;
4206 int i, j, cnt, len;
4207
4208 new_linklet = MALLOC_ONE_TAGGED(Scheme_Linklet);
4209 memcpy(new_linklet, linklet, sizeof(Scheme_Linklet));
4210
4211 ui = new_unresolve_info(new_linklet, NULL, NULL, comp_flags);
4212
4213 cnt = ui->num_toplevels;
4214 toplevels = MALLOC_N(Scheme_IR_Toplevel *, cnt);
4215 tl = scheme_make_ir_toplevel(-1, -1, 0);
4216 i = 0;
4217 toplevels[i++] = tl;
4218 for (j = 0; j < SCHEME_VEC_SIZE(linklet->importss); j++) {
4219 int k;
4220 imports = SCHEME_VEC_ELS(linklet->importss)[j];
4221 for (k = 0; k < SCHEME_VEC_SIZE(imports); k++) {
4222 tl = scheme_make_ir_toplevel(j, k, 0);
4223 toplevels[i++] = tl;
4224 }
4225 }
4226 for (j = 0; i < cnt; j++) {
4227 tl = scheme_make_ir_toplevel(-1, j, 0);
4228 toplevels[i++] = tl;
4229 }
4230 ui->toplevels = toplevels;
4231
4232 cnt = SCHEME_VEC_SIZE(linklet->bodies);
4233 bs = scheme_make_vector(cnt, NULL);
4234
4235 for (i = 0; i < cnt; i++) {
4236 locate_cyclic_closures(SCHEME_VEC_ELS(linklet->bodies)[i], ui);
4237 }
4238
4239 convert_closures_to_definitions(ui);
4240
4241 for (i = 0; i < cnt; i++) {
4242 Scheme_Object *b;
4243 b = unresolve_expr(SCHEME_VEC_ELS(linklet->bodies)[i], ui, 0);
4244 if (!b) return_NULL;
4245 SCHEME_VEC_ELS(bs)[i] = b;
4246 }
4247 len = scheme_list_length(ui->definitions);
4248 ds = ui->definitions;
4249 bs2 = scheme_make_vector(cnt + len, NULL);
4250 for (i = 0; SCHEME_PAIRP(ds); ds = SCHEME_CDR(ds), i++) {
4251 SCHEME_VEC_ELS(bs2)[i] = SCHEME_CAR(ds);
4252 }
4253 for (i = 0; i < cnt; i++) {
4254 SCHEME_VEC_ELS(bs2)[i + len] = SCHEME_VEC_ELS(bs)[i];
4255 }
4256
4257 new_linklet->bodies = bs2;
4258
4259 if (ui->num_extra_toplevels) {
4260 /* Extend defn-name array to extra toplevels: */
4261 extend_linklet_defns(new_linklet, ui->num_extra_toplevels);
4262 }
4263
4264 return new_linklet;
4265 }
4266
scheme_unresolve(Scheme_Object * iv,int argc,int * _has_cases,Scheme_Linklet * linklet,Scheme_Object * linklet_key,Optimize_Info * opt_info)4267 Scheme_Object *scheme_unresolve(Scheme_Object *iv, int argc, int *_has_cases,
4268 Scheme_Linklet *linklet, Scheme_Object *linklet_key, Optimize_Info *opt_info)
4269 /* Convert a single function from "resolved" form back to the
4270 intermediate representation used by the optimizer. Unresolving can
4271 add new items to the intermediate-representation prefix for top levels. */
4272 {
4273 Scheme_Object *o;
4274 Scheme_Lambda *lam = NULL;
4275 Unresolve_Info *ui;
4276
4277 MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(iv), scheme_inline_variant_type));
4278
4279 o = SCHEME_VEC_ELS(iv)[1];
4280
4281 if (SAME_TYPE(SCHEME_TYPE(o), scheme_closure_type))
4282 lam = ((Scheme_Closure *)o)->code;
4283 else if (SAME_TYPE(SCHEME_TYPE(o), scheme_lambda_type))
4284 lam = (Scheme_Lambda *)o;
4285 else if (SAME_TYPE(SCHEME_TYPE(o), scheme_case_lambda_sequence_type)
4286 || SAME_TYPE(SCHEME_TYPE(o), scheme_case_closure_type)) {
4287 Scheme_Case_Lambda *seqin = (Scheme_Case_Lambda *)o;
4288 int i, cnt;
4289 cnt = seqin->count;
4290 if (cnt > 1) *_has_cases = 1;
4291 for (i = 0; i < cnt; i++) {
4292 if (SAME_TYPE(SCHEME_TYPE(seqin->array[i]), scheme_closure_type)) {
4293 /* An empty closure, created at compile time */
4294 lam = ((Scheme_Closure *)seqin->array[i])->code;
4295 } else {
4296 lam = (Scheme_Lambda *)seqin->array[i];
4297 }
4298 if ((!(SCHEME_LAMBDA_FLAGS(lam) & LAMBDA_HAS_REST)
4299 && (lam->num_params == argc))
4300 || ((SCHEME_LAMBDA_FLAGS(lam) & LAMBDA_HAS_REST)
4301 && (lam->num_params - 1 <= argc)))
4302 break;
4303 else
4304 lam = NULL;
4305 }
4306 } else
4307 lam = NULL;
4308
4309 if (!lam)
4310 return_NULL;
4311
4312 ui = new_unresolve_info(linklet, linklet_key, opt_info, 0);
4313 ui->inlining = 1;
4314
4315 /* convert an optimized & resolved closure back to compiled form: */
4316 o = unresolve_lambda(lam, ui);
4317
4318 return o;
4319 }
4320
4321 /*========================================================================*/
4322 /* precise GC traversers */
4323 /*========================================================================*/
4324
4325 #ifdef MZ_PRECISE_GC
4326
4327 START_XFORM_SKIP;
4328
4329 #include "mzmark_resolve.inc"
4330
register_traversers(void)4331 static void register_traversers(void)
4332 {
4333 GC_REG_TRAV(scheme_rt_resolve_info, mark_resolve_info);
4334 GC_REG_TRAV(scheme_rt_unresolve_info, mark_unresolve_info);
4335 }
4336
4337 END_XFORM_SKIP;
4338
4339 #endif
4340