?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
codegen: introduce gen_mov and use it instead of explicit coding
[ajla.git] / pcode.c
blobb1aa3fcc956e395d84cb87c4454c10ae49481ec5
1 /*
2 * Copyright (C) 2024 Mikulas Patocka
3 *
4 * This file is part of Ajla.
5 *
6 * Ajla is free software: you can redistribute it and/or modify it under the
7 * terms of the GNU General Public License as published by the Free Software
8 * Foundation, either version 3 of the License, or (at your option) any later
9 * version.
10 *
11 * Ajla is distributed in the hope that it will be useful, but WITHOUT ANY
12 * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
13 * A PARTICULAR PURPOSE. See the GNU General Public License for more details.
14 *
15 * You should have received a copy of the GNU General Public License along with
16 * Ajla. If not, see <https://www.gnu.org/licenses/>.
17 */
18
19 #include "ajla.h"
20
21 #ifndef FILE_OMIT
22
23 #include "mem_al.h"
24 #include "tree.h"
25 #include "tick.h"
26 #include "type.h"
27 #include "data.h"
28 #include "layout.h"
29 #include "funct.h"
30 #include "builtin.h"
31 #include "module.h"
32 #include "rwlock.h"
33 #include "arrayu.h"
34 #include "code-op.h"
35 #include "ipret.h"
36 #include "ipfn.h"
37 #include "save.h"
38 #include "codegen.h"
39
40 #include "pcode.h"
41
42 #define NO_OPCODE ((code_t)-1)
43
44 #define fx(n) (OPCODE_FIXED_OP + (OPCODE_FIXED_OP_##n) * OPCODE_FIXED_OP_MULT)
45 #define in(n) (OPCODE_INT_OP + (OPCODE_INT_OP_##n) * OPCODE_INT_OP_MULT)
46 #define re(n) (OPCODE_REAL_OP + (OPCODE_REAL_OP_##n) * OPCODE_REAL_OP_MULT)
47 #define bo(n) (OPCODE_BOOL_OP + (OPCODE_BOOL_OP_##n) * OPCODE_BOOL_OP_MULT)
48
49 #define Op_Mov (Op_N + 0)
50 #define Op_Copy (Op_N + 1)
51 #define Op_Ldc (Op_N + 2)
52 #define Op_NN (Op_N + 3)
53
54 shared_var const code_t pcode2code[Op_NN][5]
55 #ifndef FILE_COMPRESSION
56 = {
57 { fx(add), fx(add), in(add), re(add), NO_OPCODE, },
58 { fx(subtract), fx(subtract), in(subtract), re(subtract), NO_OPCODE, },
59 { fx(multiply), fx(multiply), in(multiply), re(multiply), NO_OPCODE, },
60 { fx(divide), fx(udivide), in(divide), NO_OPCODE, NO_OPCODE, },
61 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(divide), NO_OPCODE, },
62 { fx(modulo), fx(umodulo), in(modulo), re(modulo), NO_OPCODE, },
63 { fx(power), fx(power), in(power), re(power), NO_OPCODE, },
64 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(atan2), NO_OPCODE, },
65 { fx(and), fx(and), in(and), NO_OPCODE, bo(and), },
66 { fx(or), fx(or), in(or), NO_OPCODE, bo(or), },
67 { fx(xor), fx(xor), in(xor), NO_OPCODE, bo(not_equal), },
68 { fx(shl), fx(shl), in(shl), re(ldexp), NO_OPCODE, },
69 { fx(shr), fx(ushr), in(shr), NO_OPCODE, NO_OPCODE, },
70 { fx(rol), fx(rol), NO_OPCODE, NO_OPCODE, NO_OPCODE, },
71 { fx(ror), fx(ror), NO_OPCODE, NO_OPCODE, NO_OPCODE, },
72 { fx(bts), fx(bts), in(bts), NO_OPCODE, NO_OPCODE, },
73 { fx(btr), fx(btr), in(btr), NO_OPCODE, NO_OPCODE, },
74 { fx(btc), fx(btc), in(btc), NO_OPCODE, NO_OPCODE, },
75 { fx(equal), fx(equal), in(equal), re(equal), bo(equal), },
76 { fx(not_equal), fx(not_equal), in(not_equal), re(not_equal), bo(not_equal), },
77 { fx(less), fx(uless), in(less), re(less), bo(less), },
78 { fx(less_equal), fx(uless_equal), in(less_equal), re(less_equal), bo(less_equal), },
79 { fx(bt), fx(bt), in(bt), NO_OPCODE, NO_OPCODE, },
80 { fx(not), fx(not), in(not), NO_OPCODE, bo(not), },
81 { fx(neg), fx(neg), in(neg), re(neg), NO_OPCODE, },
82 { fx(inc), fx(inc), in(inc), NO_OPCODE, NO_OPCODE, },
83 { fx(dec), fx(dec), in(dec), NO_OPCODE, NO_OPCODE, },
84 { fx(bswap), fx(bswap), NO_OPCODE, NO_OPCODE, NO_OPCODE, },
85 { fx(brev), fx(brev), NO_OPCODE, NO_OPCODE, NO_OPCODE, },
86 { fx(bsf), fx(bsf), in(bsf), NO_OPCODE, NO_OPCODE, },
87 { fx(bsr), fx(bsr), in(bsr), NO_OPCODE, NO_OPCODE, },
88 { fx(popcnt), fx(popcnt), in(popcnt), NO_OPCODE, NO_OPCODE, },
89 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(sqrt), NO_OPCODE, },
90 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(cbrt), NO_OPCODE, },
91 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(sin), NO_OPCODE, },
92 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(cos), NO_OPCODE, },
93 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(tan), NO_OPCODE, },
94 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(asin), NO_OPCODE, },
95 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(acos), NO_OPCODE, },
96 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(atan), NO_OPCODE, },
97 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(sinh), NO_OPCODE, },
98 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(cosh), NO_OPCODE, },
99 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(tanh), NO_OPCODE, },
100 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(asinh), NO_OPCODE, },
101 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(acosh), NO_OPCODE, },
102 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(atanh), NO_OPCODE, },
103 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(exp2), NO_OPCODE, },
104 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(exp), NO_OPCODE, },
105 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(exp10), NO_OPCODE, },
106 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(log2), NO_OPCODE, },
107 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(log), NO_OPCODE, },
108 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(log10), NO_OPCODE, },
109 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(round), NO_OPCODE, },
110 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(floor), NO_OPCODE, },
111 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(ceil), NO_OPCODE, },
112 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(trunc), NO_OPCODE, },
113 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(fract), NO_OPCODE, },
114 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(mantissa), NO_OPCODE, },
115 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(exponent), NO_OPCODE, },
116 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(next_number), NO_OPCODE, },
117 { NO_OPCODE, NO_OPCODE, NO_OPCODE, re(prev_number), NO_OPCODE, },
118 { fx(to_int), fx(uto_int), in(to_int), re(to_int), NO_OPCODE, },
119 { fx(from_int), fx(ufrom_int), in(from_int), re(from_int), NO_OPCODE, },
120 { OPCODE_IS_EXCEPTION, NO_OPCODE, NO_OPCODE, re(is_exception), NO_OPCODE, },
121 { OPCODE_EXCEPTION_CLASS,NO_OPCODE, NO_OPCODE, NO_OPCODE, NO_OPCODE, },
122 { OPCODE_EXCEPTION_TYPE,NO_OPCODE, NO_OPCODE, NO_OPCODE, NO_OPCODE, },
123 { OPCODE_EXCEPTION_AUX, NO_OPCODE, NO_OPCODE, NO_OPCODE, NO_OPCODE, },
124 { OPCODE_SYSTEM_PROPERTY,NO_OPCODE, NO_OPCODE, NO_OPCODE, NO_OPCODE, },
125 { fx(move), fx(move), in(move), re(move), bo(move), },
126 { fx(copy), fx(copy), in(copy), re(copy), bo(copy), },
127 { fx(ldc), fx(ldc), in(ldc), re(ldc), NO_OPCODE, },
128 }
129 #endif
130 ;
131
132 #undef fx
133 #undef in
134 #undef re
135 #undef bo
136
137 static void instruction_class(const struct type *t, unsigned *cls, code_t *typeq, pcode_t op)
138 {
139 if ((op == Un_IsException && !TYPE_TAG_IS_REAL(t->tag)) || op == Un_ExceptionClass || op == Un_ExceptionType || op == Un_ExceptionAux || op == Un_SystemProperty) {
140 *typeq = 0;
141 *cls = 0;
142 } else if (TYPE_TAG_IS_FIXED(t->tag)) {
143 *typeq = (TYPE_TAG_IDX_FIXED(t->tag) >> 1) * OPCODE_FIXED_TYPE_MULT;
144 *cls = TYPE_TAG_FIXED_IS_UNSIGNED(t->tag);
145 } else if (TYPE_TAG_IS_INT(t->tag)) {
146 *typeq = TYPE_TAG_IDX_INT(t->tag) * OPCODE_INT_TYPE_MULT;
147 *cls = 2;
148 } else if (TYPE_TAG_IS_REAL(t->tag)) {
149 *typeq = TYPE_TAG_IDX_REAL(t->tag) * OPCODE_REAL_TYPE_MULT;
150 *cls = 3;
151 } else if (t->tag == TYPE_TAG_flat_option) {
152 *typeq = 0;
153 *cls = 4;
154 } else {
155 internal(file_line, "instruction_class: invalid type %u", t->tag);
156 }
157 }
158
159 static code_t get_code(pcode_t op, const struct type *t)
160 {
161 code_t code, typeq;
162 unsigned cls;
163 ajla_assert(op >= 0 && op < Op_NN, (file_line, "get_code: invalid operation %"PRIdMAX"", (intmax_t)op));
164 instruction_class(t, &cls, &typeq, op);
165 code = pcode2code[op][cls];
166 ajla_assert(code != NO_OPCODE, (file_line, "get_code: invalid instruction and type: %"PRIdMAX", %u", (intmax_t)op, t->tag));
167 code += typeq;
168 return code_alt(code);
169 }
170
171 #define INIT_ARG_MODE 0
172 #define INIT_ARG_MODE_1 1
173 typedef unsigned char arg_mode_t;
174
175 static bool adjust_arg_mode(arg_mode_t *am, uintmax_t offs, ajla_error_t *mayfail)
176 {
177 arg_mode_t my_am;
178 if (offs + uzero <= 0xff) my_am = 0;
179 else if (offs + uzero <= 0xffffU) my_am = 1;
180 else if (offs + uzero <= 0xffffffffUL + uzero) my_am = 2;
181 else my_am = 3;
182 if (unlikely(my_am >= ARG_MODE_N)) {
183 if (mayfail) {
184 *mayfail = error_ajla(EC_ASYNC, AJLA_ERROR_SIZE_OVERFLOW);
185 return false;
186 }
187 internal(file_line, "adjust_arg_mode: too big arg mode: offset %"PRIuMAX", max mode %d", (uintmax_t)offs, ARG_MODE_N);
188 }
189 if (unlikely(my_am > *am))
190 *am = my_am;
191 return true;
192 }
193
194 #define get_arg_mode(am, val) \
195 do { \
196 if (unlikely(!adjust_arg_mode(&(am), (val), ctx->err))) \
197 goto exception; \
198 } while (0)
199
200 struct local_type {
201 const struct type *type;
202 pcode_t type_index;
203 };
204
205 struct pcode_type {
206 const struct type *type;
207 struct local_arg *argument;
208 frame_t slot;
209 pcode_t color;
210 int8_t extra_type;
211 bool is_dereferenced_in_call_argument;
212 uint8_t varflags;
213 };
214
215 struct color {
216 flat_size_t size;
217 flat_size_t align;
218 bool is_argument;
219 };
220
221 struct label_ref {
222 size_t code_pos;
223 pcode_t label;
224 };
225
226 struct ld_ref {
227 struct tree_entry entry;
228 size_t idx;
229 pointer_t *ptr;
230 };
231
232 struct build_function_context {
233 const pcode_t *pcode;
234 const pcode_t *pcode_limit;
235 const pcode_t *pcode_instr_end;
236
237 ajla_error_t *err;
238 pointer_t ret_val;
239
240 pcode_t function_type;
241 pcode_t n_local_types;
242 pcode_t n_labels;
243 frame_t n_local_variables;
244 arg_t n_arguments;
245 arg_t n_return_values;
246 arg_t n_real_arguments;
247 arg_t n_real_return_values;
248 frame_t n_slots;
249
250 uint8_t *function_name;
251
252 struct local_type *local_types;
253 struct pcode_type *pcode_types; /* indexed by pcode idx */
254 struct layout *layout;
255 struct local_variable *local_variables; /* indexed by slot */
256 struct local_variable_flags *local_variables_flags; /* indexed by slot */
257
258 struct color *colors;
259 size_t n_colors;
260
261 size_t *labels;
262 struct label_ref *label_ref;
263 size_t label_ref_len;
264
265 pointer_t **ld;
266 size_t ld_len;
267 struct tree ld_tree;
268
269 struct local_arg *args;
270
271 const struct type **types;
272 size_t types_len;
273 struct data *ft_free;
274
275 code_t *code;
276 size_t code_len;
277
278 frame_t *record_entries;
279 size_t record_entries_len;
280
281 struct record_definition *record_definition;
282
283 struct line_position *lp;
284 size_t lp_size;
285
286 struct escape_data *escape_data;
287
288 unsigned checkpoint_num;
289
290 bool is_eval;
291 bool leaf;
292
293 pcode_t builtin_type_indices[TYPE_TAG_N];
294 };
295
296 static const pcode_t no_type_index = -1;
297 static const pcode_t error_type_index = -2;
298 static const size_t no_label = (size_t)-1;
299
300 static void init_ctx(struct build_function_context *ctx)
301 {
302 size_t i;
303 ctx->n_real_arguments = 0;
304 ctx->function_name = NULL;
305 ctx->local_types = NULL;
306 ctx->pcode_types = NULL;
307 ctx->layout = NULL;
308 ctx->local_variables = NULL;
309 ctx->local_variables_flags = NULL;
310 ctx->colors = NULL;
311 ctx->labels = NULL;
312 ctx->label_ref = NULL;
313 ctx->ld = NULL;
314 tree_init(&ctx->ld_tree);
315 ctx->args = NULL;
316 ctx->types = NULL;
317 ctx->ft_free = NULL;
318 ctx->types_len = 0;
319 ctx->code = NULL;
320 ctx->record_entries = NULL;
321 ctx->record_definition = NULL;
322 ctx->lp = NULL;
323 ctx->lp_size = 0;
324 ctx->escape_data = NULL;
325 ctx->checkpoint_num = 0;
326 ctx->leaf = true;
327 for (i = 0; i < n_array_elements(ctx->builtin_type_indices); i++)
328 ctx->builtin_type_indices[i] = no_type_index;
329 }
330
331 static void free_ld_tree(struct build_function_context *ctx)
332 {
333 while (!tree_is_empty(&ctx->ld_tree)) {
334 struct ld_ref *ld_ref = get_struct(tree_any(&ctx->ld_tree), struct ld_ref, entry);
335 tree_delete(&ld_ref->entry);
336 mem_free(ld_ref);
337 }
338 }
339
340 static void done_ctx(struct build_function_context *ctx)
341 {
342 if (ctx->function_name)
343 mem_free(ctx->function_name);
344 if (ctx->local_types)
345 mem_free(ctx->local_types);
346 if (ctx->pcode_types)
347 mem_free(ctx->pcode_types);
348 if (ctx->layout)
349 layout_free(ctx->layout);
350 if (ctx->local_variables)
351 mem_free(ctx->local_variables);
352 if (ctx->local_variables_flags)
353 mem_free(ctx->local_variables_flags);
354 if (ctx->colors)
355 mem_free(ctx->colors);
356 if (ctx->labels)
357 mem_free(ctx->labels);
358 if (ctx->label_ref)
359 mem_free(ctx->label_ref);
360 if (ctx->ld)
361 mem_free(ctx->ld);
362 free_ld_tree(ctx);
363 if (ctx->args)
364 mem_free(ctx->args);
365 if (ctx->types)
366 mem_free(ctx->types);
367 if (ctx->ft_free)
368 mem_free(ctx->ft_free);
369 if (ctx->code)
370 mem_free(ctx->code);
371 if (ctx->record_entries)
372 mem_free(ctx->record_entries);
373 if (ctx->record_definition) {
374 mem_free(ctx->record_definition->idx_to_frame);
375 mem_free(ctx->record_definition);
376 }
377 if (ctx->lp)
378 mem_free(ctx->lp);
379 if (ctx->escape_data)
380 mem_free(ctx->escape_data);
381 }
382
383 static char *function_name(const struct build_function_context *ctx)
384 {
385 if (ctx->function_name)
386 return cast_ptr(char *, ctx->function_name);
387 return "";
388 }
389
390 static pcode_t pcode_get_fn(struct build_function_context *ctx argument_position)
391 {
392 ajla_assert(ctx->pcode < ctx->pcode_limit, (caller_file_line, "pcode_get_fn(%s): no pcode left", function_name(ctx)));
393 return *ctx->pcode++;
394 }
395 #define pcode_get() pcode_get_fn(ctx pass_file_line)
396
397 static pcode_t u_pcode_get_fn(struct build_function_context *ctx argument_position)
398 {
399 pcode_t p = pcode_get_fn(ctx pass_position);
400 ajla_assert(p >= 0, (caller_file_line, "u_pcode_get_fn(%s): negative pcode %"PRIdMAX"", function_name(ctx), (intmax_t)p));
401 return p;
402 }
403 #define u_pcode_get() u_pcode_get_fn(ctx pass_file_line)
404
405 typedef const pcode_t *pcode_position_save_t;
406
407 static inline void pcode_position_save(struct build_function_context *ctx, pcode_position_save_t *save)
408 {
409 *save = ctx->pcode;
410 }
411
412 static inline void pcode_position_restore(struct build_function_context *ctx, const pcode_position_save_t *save)
413 {
414 ctx->pcode = *save;
415 }
416
417 typedef size_t code_position_save_t;
418
419 static inline void code_position_save(struct build_function_context *ctx, code_position_save_t *save)
420 {
421 *save = ctx->code_len;
422 }
423
424 static inline void code_position_restore(struct build_function_context *ctx, const code_position_save_t *save)
425 {
426 ajla_assert_lo(ctx->code_len >= *save, (file_line, "code_position_restore(%s): attempting to restore forward: %"PRIuMAX" < %"PRIuMAX"", function_name(ctx), (uintmax_t)ctx->code_len, (uintmax_t)*save));
427 ctx->code_len = *save;
428 }
429
430 const struct type *pcode_get_type(pcode_t q)
431 {
432 const struct type *t;
433 switch (q) {
434 case T_SInt8:
435 t = type_get_fixed(0, false);
436 break;
437 case T_UInt8:
438 t = type_get_fixed(0, true);
439 break;
440 case T_SInt16:
441 t = type_get_fixed(1, false);
442 break;
443 case T_UInt16:
444 t = type_get_fixed(1, true);
445 break;
446 case T_SInt32:
447 t = type_get_fixed(2, false);
448 break;
449 case T_UInt32:
450 t = type_get_fixed(2, true);
451 break;
452 case T_SInt64:
453 t = type_get_fixed(3, false);
454 break;
455 case T_UInt64:
456 t = type_get_fixed(3, true);
457 break;
458 case T_SInt128:
459 t = type_get_fixed(4, false);
460 break;
461 case T_UInt128:
462 t = type_get_fixed(4, true);
463 break;
464
465 case T_Integer:
466 t = type_get_int(INT_DEFAULT_N);
467 break;
468 case T_Integer8:
469 t = type_get_int(0);
470 break;
471 case T_Integer16:
472 t = type_get_int(1);
473 break;
474 case T_Integer32:
475 t = type_get_int(2);
476 break;
477 case T_Integer64:
478 t = type_get_int(3);
479 break;
480 case T_Integer128:
481 t = type_get_int(4);
482 break;
483
484 case T_Real16:
485 t = type_get_real(0);
486 break;
487 case T_Real32:
488 t = type_get_real(1);
489 break;
490 case T_Real64:
491 t = type_get_real(2);
492 break;
493 case T_Real80:
494 t = type_get_real(3);
495 break;
496 case T_Real128:
497 t = type_get_real(4);
498 break;
499
500 case T_FlatOption:
501 t = type_get_flat_option();
502 break;
503
504 case T_Undetermined:
505 t = type_get_unknown();
506 break;
507
508 default:
509 t = NULL;
510 break;
511 }
512 return t;
513 }
514
515 static const struct type *pcode_to_type(const struct build_function_context *ctx, pcode_t q, ajla_error_t *mayfail)
516 {
517 const struct type *t;
518 if (q >= 0) {
519 ajla_assert_lo(q < ctx->n_local_types, (file_line, "pcode_to_type(%s): invalid local type: %"PRIdMAX" >= %"PRIdMAX"", function_name(ctx), (intmax_t)q, (intmax_t)ctx->n_local_types));
520 return ctx->local_types[q].type;
521 }
522 t = pcode_get_type(q);
523 if (unlikely(!t)) {
524 if (q == T_SInt64 || q == T_UInt64 || q == T_SInt128 || q == T_UInt128)
525 return pcode_get_type(T_Integer128);
526 if (q == T_Real16 || q == T_Real32 || q == T_Real64 || q == T_Real80 || q == T_Real128)
527 return pcode_get_type(T_Integer128);
528 if (unlikely(!mayfail))
529 internal(file_line, "pcode_to_type(%s): invalid type %"PRIdMAX"", function_name(ctx), (intmax_t)q);
530 *mayfail = error_ajla(EC_ASYNC, AJLA_ERROR_NOT_SUPPORTED);
531 }
532 return t;
533 }
534
535 static pcode_t type_to_pcode(const struct type *type)
536 {
537 if (TYPE_TAG_IS_FIXED(type->tag))
538 return (pcode_t)(T_SInt8 - TYPE_TAG_IDX_FIXED(type->tag));
539 else if (TYPE_TAG_IS_INT(type->tag))
540 return (pcode_t)(T_Integer8 - TYPE_TAG_IDX_INT(type->tag));
541 else if (TYPE_TAG_IS_REAL(type->tag))
542 return (pcode_t)(T_Real16 - TYPE_TAG_IDX_REAL(type->tag));
543 else if (type->tag == TYPE_TAG_flat_option)
544 return T_FlatOption;
545 else
546 internal(file_line, "type_to_pcode: invalid type %u", type->tag);
547 return 0;
548 }
549
550 static pcode_t pcode_to_type_index(struct build_function_context *ctx, pcode_t q, bool non_flat)
551 {
552 pcode_t *result;
553 const struct type *type = pcode_to_type(ctx, q, NULL);
554 if (!TYPE_IS_FLAT(type) && non_flat)
555 return no_type_index;
556
557 if (q >= 0) {
558 result = &ctx->local_types[q].type_index;
559 } else {
560 unsigned tag = type->tag;
561 ajla_assert_lo(tag < n_array_elements(ctx->builtin_type_indices), (file_line, "pcode_to_type_index(%s): invalid type tag %u", function_name(ctx), tag));
562 result = &ctx->builtin_type_indices[tag];
563 }
564 if (*result != no_type_index)
565 return *result;
566 if (unlikely((pcode_t)ctx->types_len < 0)) {
567 fatal_mayfail(error_ajla(EC_ASYNC, AJLA_ERROR_SIZE_OVERFLOW), ctx->err, "type array overflow");
568 return error_type_index;
569 }
570 if (unlikely(!array_add_mayfail(const struct type *, &ctx->types, &ctx->types_len, type, NULL, ctx->err)))
571 return error_type_index;
572 return *result = (pcode_t)(ctx->types_len - 1);
573 }
574
575 #define pcode_get_var_deref(var, deref) \
576 do { \
577 pcode_t r_ = u_pcode_get(); \
578 ajla_assert_lo(!(r_ & ~(pcode_t)Flag_Free_Argument), (file_line, "pcode_get_ref(%s): invalid reference flag %"PRIdMAX"", function_name(ctx), (intmax_t)r_));\
579 *(deref) = !!(r_ & Flag_Free_Argument); \
580 *(var) = pcode_get(); \
581 } while (0)
582
583 #define var_elided(idx) (((idx) < zero) || ctx->pcode_types[idx].type == NULL)
584
585 static struct pcode_type *get_var_type(struct build_function_context *ctx, pcode_t v)
586 {
587 ajla_assert_lo(!var_elided(v), (file_line, "get_var_type(%s): variable %"PRIdMAX" is elided", function_name(ctx), (intmax_t)v));
588 ajla_assert_lo((frame_t)v < ctx->n_local_variables, (file_line, "get_var_type(%s): invalid local variable %"PRIdMAX", limit %"PRIuMAX"", function_name(ctx), (intmax_t)v, (uintmax_t)ctx->n_local_variables));
589 return &ctx->pcode_types[v];
590 }
591
592 static bool pcode_load_blob(struct build_function_context *ctx, uint8_t **blob, size_t *l)
593 {
594 pcode_t n, i, q;
595
596 if (blob) {
597 if (unlikely(!array_init_mayfail(uint8_t, blob, l, ctx->err)))
598 return false;
599 }
600
601 q = 0; /* avoid warning */
602 n = u_pcode_get();
603 for (i = 0; i < n; i++) {
604 uint8_t val;
605 if (!(i & 3)) {
606 q = pcode_get();
607 }
608 val = q;
609 q >>= 8;
610 if (blob) {
611 if (unlikely(!array_add_mayfail(uint8_t, blob, l, (uint8_t)val, NULL, ctx->err)))
612 return false;
613 }
614 }
615
616 return true;
617 }
618
619 static bool pcode_generate_blob(uint8_t *str, size_t str_len, pcode_t **res_blob, size_t *res_len, ajla_error_t *err)
620 {
621 size_t i;
622 if (unlikely(str_len > signed_maximum(pcode_t))) {
623 fatal_mayfail(error_ajla(EC_ASYNC, AJLA_ERROR_SIZE_OVERFLOW), err, "pcode overflow");
624 return false;
625 }
626 if (unlikely(!array_init_mayfail(pcode_t, res_blob, res_len, err)))
627 return false;
628 if (unlikely(!array_add_mayfail(pcode_t, res_blob, res_len, 0, NULL, err)))
629 return false;
630 for (i = 0; i < str_len; i++) {
631 uint8_t b = str[i];
632 if (!(**res_blob % sizeof(pcode_t))) {
633 if (unlikely(!array_add_mayfail(pcode_t, res_blob, res_len, b, NULL, err)))
634 return false;
635 } else {
636 (*res_blob)[*res_len - 1] |= (upcode_t)((b) & 0xff) << (**res_blob % sizeof(pcode_t) * 8);
637 }
638 (**res_blob)++;
639 }
640 return true;
641 }
642
643 static pointer_t *pcode_module_load_function(struct build_function_context *ctx)
644 {
645 unsigned path_idx;
646 bool program;
647 pointer_t *ptr;
648 uint8_t *blob = NULL;
649 size_t l;
650 struct module_designator *md = NULL;
651 struct function_designator *fd = NULL;
652 pcode_t q;
653
654 q = u_pcode_get();
655 path_idx = (unsigned)q;
656 if (unlikely(q != (pcode_t)path_idx))
657 goto exception_overflow;
658 program = path_idx & 1;
659 path_idx >>= 1;
660 if (unlikely(!pcode_load_blob(ctx, &blob, &l)))
661 goto exception;
662
663 md = module_designator_alloc(path_idx, blob, l, program, ctx->err);
664 if (unlikely(!md))
665 goto exception;
666
667 mem_free(blob), blob = NULL;
668
669 fd = function_designator_alloc(ctx->pcode, ctx->err);
670 if (unlikely(!fd))
671 goto exception;
672 ctx->pcode += fd->n_entries + 1;
673
674 ptr = module_load_function(md, fd, false, ctx->err);
675 if (unlikely(!ptr))
676 goto exception;
677
678 module_designator_free(md), md = NULL;
679 function_designator_free(fd), fd = NULL;
680
681 return ptr;
682
683 exception_overflow:
684 fatal_mayfail(error_ajla(EC_ASYNC, AJLA_ERROR_SIZE_OVERFLOW), ctx->err, "pcode overflow");
685 exception:
686 if (blob)
687 mem_free(blob);
688 if (md)
689 module_designator_free(md);
690 if (fd)
691 function_designator_free(fd);
692 return NULL;
693 }
694
695 #define no_function_idx ((size_t)-1)
696
697 static int ld_tree_compare(const struct tree_entry *e, uintptr_t ptr)
698 {
699 struct ld_ref *ld_ref = get_struct(e, struct ld_ref, entry);
700 uintptr_t ld_ptr = ptr_to_num(ld_ref->ptr);
701 if (ld_ptr < ptr)
702 return -1;
703 if (ld_ptr > ptr)
704 return 1;
705 return 0;
706 }
707
708 static size_t pcode_module_load_function_idx(struct build_function_context *ctx, pointer_t *ptr, bool must_exist)
709 {
710 struct tree_entry *e;
711 struct ld_ref *ld_ref;
712 struct tree_insert_position ins;
713
714 e = tree_find_for_insert(&ctx->ld_tree, ld_tree_compare, ptr_to_num(ptr), &ins);
715 if (e) {
716 ld_ref = get_struct(e, struct ld_ref, entry);
717 return ld_ref->idx;
718 }
719
720 if (unlikely(must_exist))
721 internal(file_line, "pcode_module_load_function_idx: local directory preload didn't work");
722
723 ld_ref = mem_alloc_mayfail(struct ld_ref *, sizeof(struct ld_ref), ctx->err);
724 if (unlikely(!ld_ref))
725 return no_function_idx;
726 ld_ref->ptr = ptr;
727 ld_ref->idx = ctx->ld_len;
728
729 tree_insert_after_find(&ld_ref->entry, &ins);
730
731 if (unlikely(!array_add_mayfail(pointer_t *, &ctx->ld, &ctx->ld_len, ptr, NULL, ctx->err)))
732 return no_function_idx;
733 return ctx->ld_len - 1;
734 }
735
736 #define gen_code(n) \
737 do { \
738 if (unlikely(!array_add_mayfail(code_t, &ctx->code, &ctx->code_len, n, NULL, ctx->err)))\
739 goto exception; \
740 } while (0)
741
742 #if !CODE_ENDIAN
743 #define gen_uint32(n) \
744 do { \
745 gen_code((code_t)((n) & 0xffff)); \
746 gen_code((code_t)((n) >> 15 >> 1)); \
747 } while (0)
748 #else
749 #define gen_uint32(n) \
750 do { \
751 gen_code((code_t)((n) >> 15 >> 1)); \
752 gen_code((code_t)((n) & 0xffff)); \
753 } while (0)
754 #endif
755
756 #define gen_am(am, m) \
757 do { \
758 if (am <= 1) { \
759 gen_code((code_t)(m)); \
760 } else if (am == 2) { \
761 gen_uint32((m)); \
762 } else { \
763 internal(file_line, "gen_am(%s): arg mode %d", function_name(ctx), am);\
764 } \
765 } while (0)
766
767 #define gen_am_two(am, m, n) \
768 do { \
769 if (!am) { \
770 gen_code((code_t)((m) + ((n) << 8))); \
771 } else if (am == 1) { \
772 gen_code((code_t)(m)); \
773 gen_code((code_t)(n)); \
774 } else if (am == 2) { \
775 gen_uint32((m)); \
776 gen_uint32((n)); \
777 } else { \
778 internal(file_line, "gen_am_two(%s): arg mode %d", function_name(ctx), am);\
779 } \
780 } while (0)
781
782 #define gen_relative_jump(lbl, diff) \
783 do { \
784 uint32_t target; \
785 ajla_assert_lo((lbl) < ctx->n_labels, (file_line, "gen_relative_jump(%s): invalid label %"PRIdMAX"", function_name(ctx), (intmax_t)(lbl)));\
786 if (ctx->labels[lbl] == no_label) { \
787 struct label_ref lr; \
788 lr.code_pos = ctx->code_len; \
789 lr.label = (lbl); \
790 if (unlikely(!array_add_mayfail(struct label_ref, &ctx->label_ref, &ctx->label_ref_len, lr, NULL, ctx->err)))\
791 goto exception; \
792 target = -(((uint32_t)(diff) + 1) / (uint32_t)sizeof(code_t) * (uint32_t)sizeof(code_t));\
793 } else { \
794 target = ((uint32_t)ctx->labels[lbl] - (uint32_t)(ctx->code_len + SIZEOF_IP_T / (uint32_t)sizeof(code_t))) * (uint32_t)sizeof(code_t);\
795 } \
796 if (SIZEOF_IP_T == 2) \
797 gen_code((code_t)target); \
798 else if (SIZEOF_IP_T == 4) \
799 gen_uint32(target); \
800 else not_reached(); \
801 } while (0)
802
803 static bool gen_checkpoint(struct build_function_context *ctx, const pcode_t *params, pcode_t n_params)
804 {
805 arg_mode_t am;
806 code_t code;
807 pcode_t i;
808 pcode_t n_used_params;
809
810 if (unlikely(ctx->is_eval))
811 return true;
812
813 am = INIT_ARG_MODE_1;
814 get_arg_mode(am, n_params);
815
816 n_used_params = 0;
817 for (i = 0; i < n_params; i++) {
818 const struct pcode_type *tv;
819 pcode_t var = params[i];
820 if (var_elided(var))
821 continue;
822 tv = get_var_type(ctx, var);
823 get_arg_mode(am, tv->slot);
824 n_used_params++;
825 }
826
827 code = OPCODE_CHECKPOINT;
828 code += am * OPCODE_MODE_MULT;
829 gen_code(code);
830 gen_am(ARG_MODE_N - 1, ctx->checkpoint_num);
831
832 gen_am(am, n_used_params);
833
834 for (i = 0; i < n_params; i++) {
835 const struct pcode_type *tv;
836 pcode_t var = params[i];
837 if (var_elided(var))
838 continue;
839 tv = get_var_type(ctx, var);
840 gen_am(am, tv->slot);
841 }
842
843 ctx->checkpoint_num++;
844 if (unlikely(!ctx->checkpoint_num)) {
845 fatal_mayfail(error_ajla(EC_ASYNC, AJLA_ERROR_SIZE_OVERFLOW), ctx->err, "checkpoint number overflow");
846 goto exception;
847 }
848 return true;
849
850 exception:
851 return false;
852 }
853
854 static bool pcode_free(struct build_function_context *ctx, pcode_t res)
855 {
856 arg_mode_t am;
857 const struct pcode_type *tr;
858 code_t code;
859 const struct color *c;
860
861 if (unlikely(var_elided(res)))
862 return true;
863 tr = get_var_type(ctx, res);
864 am = INIT_ARG_MODE;
865 get_arg_mode(am, tr->slot);
866 c = &ctx->colors[tr->color];
867 if (!TYPE_IS_FLAT(tr->type) && c->is_argument)
868 code = OPCODE_DEREFERENCE_CLEAR;
869 else
870 code = OPCODE_DEREFERENCE;
871 code += am * OPCODE_MODE_MULT;
872 gen_code(code);
873 gen_am(am, tr->slot);
874
875 return true;
876
877 exception:
878 return false;
879 }
880
881 static bool pcode_copy(struct build_function_context *ctx, bool type_cast, pcode_t res, pcode_t a1, bool a1_deref)
882 {
883 const struct pcode_type *tr, *t1;
884 arg_mode_t am;
885 code_t code;
886
887 tr = get_var_type(ctx, res);
888 t1 = get_var_type(ctx, a1);
889
890 if (t1->slot == tr->slot) {
891 ajla_assert(a1_deref, (file_line, "pcode_copy(%s): dereference not set", function_name(ctx)));
892 /*
893 * If we copy a value to itself, we must clear may_be_borrowed,
894 * otherwise we get failure in start03.ajla and start04.ajla.
895 *
896 * (note that pcode_copy is called from pcode_structured_write)
897 *
898 * The reason for the crash is that may_be_borrowed is per-variable,
899 * not per-slot flag - if we copy to a different variable occupying
900 * the same slot, we won't see may_be_borrowed anymore.
901 */
902
903 if (t1->type->size == 0) {
904 am = INIT_ARG_MODE;
905 get_arg_mode(am, t1->slot);
906 code = OPCODE_TAKE_BORROWED;
907 code += am * OPCODE_MODE_MULT;
908 gen_code(code);
909 gen_am(am, t1->slot);
910 }
911
912 return true;
913 }
914
915 if ((t1->type->size == 0 && tr->type->size == 0) || type_cast) {
916 const struct color *c = &ctx->colors[t1->color];
917 am = INIT_ARG_MODE;
918 get_arg_mode(am, t1->slot);
919 get_arg_mode(am, tr->slot);
920 if (type_cast) {
921 code = a1_deref ? OPCODE_BOX_MOVE_CLEAR : OPCODE_BOX_COPY;
922 } else {
923 code = a1_deref ? (c->is_argument ? OPCODE_REF_MOVE_CLEAR : OPCODE_REF_MOVE) : OPCODE_REF_COPY;
924 }
925 code += am * OPCODE_MODE_MULT;
926 gen_code(code);
927 gen_am_two(am, t1->slot, tr->slot);
928 } else if (t1->type->tag == TYPE_TAG_flat_record || t1->type->tag == TYPE_TAG_flat_array) {
929 ajla_assert_lo(tr->type == t1->type, (file_line, "pcode_copy(%s): invalid types for flat copy instruction: %u, %u", function_name(ctx), t1->type->tag, tr->type->tag));
930 am = INIT_ARG_MODE;
931 get_arg_mode(am, t1->slot);
932 get_arg_mode(am, tr->slot);
933 code = a1_deref ? OPCODE_FLAT_MOVE : OPCODE_FLAT_COPY;
934 code += am * OPCODE_MODE_MULT;
935 gen_code(code);
936 gen_am_two(am, t1->slot, tr->slot);
937 } else {
938 ajla_assert_lo(tr->type == t1->type, (file_line, "pcode_copy(%s): invalid types for copy instruction: %u, %u", function_name(ctx), t1->type->tag, tr->type->tag));
939 am = INIT_ARG_MODE;
940 get_arg_mode(am, t1->slot);
941 get_arg_mode(am, tr->slot);
942 code = get_code(a1_deref ? Op_Mov : Op_Copy, t1->type);
943 code += am * OPCODE_MODE_MULT;
944 gen_code(code);
945 gen_am_two(am, t1->slot, tr->slot);
946 }
947 return true;
948
949 exception:
950 return false;
951 }
952
953 static bool pcode_process_arguments(struct build_function_context *ctx, pcode_t n_arguments, pcode_t *n_real_arguments, arg_mode_t *am)
954 {
955 pcode_t ai;
956 if (n_real_arguments)
957 *n_real_arguments = 0;
958 for (ai = 0; ai < n_arguments; ai++) {
959 pcode_t a1;
960 struct pcode_type *t1;
961 bool deref;
962 pcode_get_var_deref(&a1, &deref);
963 if (unlikely(var_elided(a1)))
964 continue;
965 t1 = get_var_type(ctx, a1);
966 if (n_real_arguments) {
967 get_arg_mode(*am, t1->slot);
968 (*n_real_arguments)++;
969 t1->is_dereferenced_in_call_argument = deref;
970 } else {
971 code_t flags = 0;
972 if (deref) {
973 flags |= OPCODE_FLAG_FREE_ARGUMENT;
974 if (!TYPE_IS_FLAT(t1->type))
975 flags |= OPCODE_CALL_MAY_GIVE;
976 } else {
977 if (!t1->is_dereferenced_in_call_argument && !TYPE_IS_FLAT(t1->type))
978 flags |= OPCODE_CALL_MAY_LEND;
979 }
980 gen_am_two(*am, t1->slot, flags);
981 }
982 }
983 if (n_real_arguments)
984 get_arg_mode(*am, *n_real_arguments);
985 return true;
986
987 exception:
988 return false;
989 }
990
991 static bool pcode_dereference_arguments(struct build_function_context *ctx, pcode_t n_arguments)
992 {
993 pcode_t ai;
994 for (ai = 0; ai < n_arguments; ai++) {
995 pcode_t a1;
996 bool deref;
997 pcode_get_var_deref(&a1, &deref);
998 if (deref) {
999 if (unlikely(!pcode_free(ctx, a1)))
1000 goto exception;
1001 }
1002 }
1003 return true;
1004
1005 exception:
1006 return false;
1007 }
1008
1009 static bool pcode_finish_call(struct build_function_context *ctx, const struct pcode_type **rets, size_t rets_l, bool test_flat)
1010 {
1011 size_t i;
1012 frame_t slot;
1013 frame_t *vars = NULL;
1014 size_t n_vars = 0;
1015
1016 ctx->leaf = false;
1017
1018 for (i = 0; i < rets_l; i++) {
1019 const struct pcode_type *tv = rets[i];
1020 if (ARG_MODE_N >= 3) {
1021 gen_uint32(tv->slot);
1022 } else {
1023 gen_code((code_t)tv->slot);
1024 }
1025 gen_code(TYPE_IS_FLAT(tv->type) ? OPCODE_MAY_RETURN_FLAT : 0);
1026 }
1027
1028 if (unlikely(test_flat)) {
1029 arg_mode_t am;
1030
1031 if (unlikely(!gen_checkpoint(ctx, NULL, 0)))
1032 goto exception;
1033
1034 vars = mem_alloc_array_mayfail(mem_alloc_mayfail, frame_t *, 0, 0, ctx->n_slots, sizeof(frame_t), ctx->err);
1035 if (unlikely(!vars))
1036 goto exception;
1037 am = INIT_ARG_MODE_1;
1038 for (slot = MIN_USEABLE_SLOT; slot < ctx->n_slots; slot++) {
1039 if (ctx->local_variables_flags[slot].must_be_flat) {
1040 vars[n_vars++] = slot;
1041 get_arg_mode(am, slot);
1042 }
1043 }
1044 if (n_vars) {
1045 code_t code;
1046 get_arg_mode(am, n_vars);
1047 code = OPCODE_ESCAPE_NONFLAT;
1048 code += am * OPCODE_MODE_MULT;
1049 gen_code(code);
1050 gen_am(am, n_vars);
1051 for (i = 0; i < n_vars; i++)
1052 gen_am(am, vars[i]);
1053 }
1054 mem_free(vars);
1055 vars = NULL;
1056 }
1057
1058 return true;
1059
1060 exception:
1061 if (vars)
1062 mem_free(vars);
1063 return false;
1064 }
1065
1066 static bool pcode_call(struct build_function_context *ctx, pcode_t instr)
1067 {
1068 bool elide = false;
1069 arg_mode_t am = INIT_ARG_MODE;
1070 pcode_t q;
1071 pcode_t res;
1072 const struct pcode_type *tr = NULL; /* avoid warning */
1073 const struct pcode_type *ts = NULL; /* avoid warning */
1074 pcode_t call_mode = 0; /* avoid warning */
1075 pcode_t src_fn = 0; /* avoid warning */
1076 bool src_deref = false; /* avoid warning */
1077 code_t code;
1078 arg_t ai;
1079 pcode_t n_arguments, n_real_arguments;
1080 arg_t n_return_values, n_real_return_values;
1081 size_t fn_idx = 0; /* avoid warning */
1082 pcode_position_save_t saved;
1083 const struct pcode_type **rets = NULL;
1084 size_t rets_l;
1085
1086 if (instr == P_Load_Fn || instr == P_Curry) {
1087 res = u_pcode_get();
1088 if (unlikely(var_elided(res))) {
1089 elide = true;
1090 } else {
1091 tr = get_var_type(ctx, res);
1092 get_arg_mode(am, tr->slot);
1093 }
1094 n_return_values = 0; /* avoid warning */
1095 } else if (instr == P_Call || instr == P_Call_Indirect) {
1096 call_mode = u_pcode_get();
1097 q = u_pcode_get();
1098 n_return_values = (arg_t)q;
1099 if (unlikely(q != (pcode_t)n_return_values))
1100 goto exception_overflow;
1101 } else {
1102 internal(file_line, "pcode_call(%s): invalid instruction %"PRIdMAX"", function_name(ctx), (intmax_t)instr);
1103 }
1104
1105 q = u_pcode_get();
1106 n_arguments = (arg_t)q;
1107 if (unlikely(q != (pcode_t)n_arguments))
1108 goto exception_overflow;
1109 if (instr == P_Load_Fn || instr == P_Call) {
1110 pointer_t *ptr;
1111 if (instr == P_Load_Fn)
1112 u_pcode_get(); /* call mode */
1113 ptr = pcode_module_load_function(ctx);
1114 if (unlikely(!ptr))
1115 goto exception;
1116 fn_idx = pcode_module_load_function_idx(ctx, ptr, true);
1117 if (unlikely(fn_idx == no_function_idx))
1118 goto exception;
1119 get_arg_mode(am, fn_idx);
1120 src_deref = false; /* avoid warning */
1121 src_fn = ~sign_bit(pcode_t); /* avoid warning */
1122 }
1123 if (instr == P_Curry || instr == P_Call_Indirect) {
1124 pcode_get_var_deref(&src_fn, &src_deref);
1125 }
1126
1127 pcode_position_save(ctx, &saved);
1128
1129 if (unlikely(!pcode_process_arguments(ctx, n_arguments, &n_real_arguments, &am)))
1130 goto exception;
1131
1132 n_real_return_values = 0;
1133 if (instr == P_Call || instr == P_Call_Indirect) {
1134 for (ai = 0; ai < n_return_values; ai++) {
1135 q = u_pcode_get();
1136 if (unlikely(var_elided(q)))
1137 continue;
1138 n_real_return_values++;
1139 }
1140 if (!n_real_return_values)
1141 elide = true;
1142 get_arg_mode(am, n_return_values);
1143 }
1144 pcode_position_restore(ctx, &saved);
1145
1146 if (unlikely(elide)) {
1147 /* TODO: remove the function from local directory if we just added it */
1148 if (src_deref) {
1149 if (unlikely(!pcode_free(ctx, src_fn)))
1150 goto exception;
1151 }
1152 pcode_dereference_arguments(ctx, n_arguments);
1153
1154 goto skip_instr;
1155 }
1156
1157 if (instr == P_Curry || instr == P_Call_Indirect) {
1158 ts = get_var_type(ctx, src_fn);
1159 ajla_assert_lo(ts->type->tag == TYPE_TAG_unknown, (file_line, "pcode_call(%s): expected function type, got %u", function_name(ctx), ts->type->tag));
1160 get_arg_mode(am, ts->slot);
1161 fn_idx = no_function_idx; /* avoid warning */
1162 }
1163
1164 code = 0; /* avoid warning */
1165 switch (instr) {
1166 case P_Load_Fn:
1167 code = OPCODE_LOAD_FN;
1168 break;
1169 case P_Curry:
1170 code = OPCODE_CURRY;
1171 break;
1172 case P_Call:
1173 switch (call_mode) {
1174 case Call_Mode_Unspecified:
1175 case Call_Mode_Normal:
1176 code = OPCODE_CALL;
1177 break;
1178 case Call_Mode_Strict:
1179 case Call_Mode_Inline:
1180 code = OPCODE_CALL_STRICT;
1181 break;
1182 case Call_Mode_Spark:
1183 code = OPCODE_CALL_SPARK;
1184 break;
1185 case Call_Mode_Lazy:
1186 code = OPCODE_CALL_LAZY;
1187 break;
1188 case Call_Mode_Cache:
1189 code = OPCODE_CALL_CACHE;
1190 break;
1191 case Call_Mode_Save:
1192 code = OPCODE_CALL_SAVE;
1193 break;
1194 default:
1195 internal(file_line, "pcode_call(%s): invalid call mode %ld", function_name(ctx), (long)call_mode);
1196 }
1197 break;
1198 case P_Call_Indirect:
1199 switch (call_mode) {
1200 case Call_Mode_Unspecified:
1201 case Call_Mode_Normal:
1202 code = OPCODE_CALL_INDIRECT;
1203 break;
1204 case Call_Mode_Strict:
1205 case Call_Mode_Inline:
1206 code = OPCODE_CALL_INDIRECT_STRICT;
1207 break;
1208 case Call_Mode_Spark:
1209 code = OPCODE_CALL_INDIRECT_SPARK;
1210 break;
1211 case Call_Mode_Lazy:
1212 code = OPCODE_CALL_INDIRECT_LAZY;
1213 break;
1214 case Call_Mode_Cache:
1215 code = OPCODE_CALL_INDIRECT_CACHE;
1216 break;
1217 case Call_Mode_Save:
1218 code = OPCODE_CALL_INDIRECT_SAVE;
1219 break;
1220 default:
1221 internal(file_line, "pcode_call(%s): invalid call mode %ld", function_name(ctx), (long)call_mode);
1222 }
1223 break;
1224 default:
1225 internal(file_line, "pcode_call(%s): invalid instruction %"PRIdMAX"", function_name(ctx), (intmax_t)instr);
1226 }
1227
1228 code += am * OPCODE_MODE_MULT;
1229 gen_code(code);
1230 if (instr == P_Load_Fn || instr == P_Curry)
1231 gen_am_two(am, n_real_arguments, tr->slot);
1232 else
1233 gen_am_two(am, n_real_arguments, n_real_return_values);
1234 if (instr == P_Load_Fn || instr == P_Call)
1235 gen_am(am, fn_idx);
1236 else
1237 gen_am_two(am, ts->slot, src_deref ? OPCODE_FLAG_FREE_ARGUMENT : 0);
1238
1239 if (unlikely(!pcode_process_arguments(ctx, n_arguments, NULL, &am)))
1240 goto exception;
1241
1242 if (instr == P_Call || instr == P_Call_Indirect) {
1243 if (unlikely(!array_init_mayfail(const struct pcode_type *, &rets, &rets_l, ctx->err)))
1244 goto exception;
1245 for (ai = 0; ai < n_return_values; ai++) {
1246 const struct pcode_type *tv;
1247 q = u_pcode_get();
1248 if (unlikely(var_elided(q)))
1249 continue;
1250 tv = get_var_type(ctx, q);
1251 if (unlikely(!array_add_mayfail(const struct pcode_type *, &rets, &rets_l, tv, NULL, ctx->err)))
1252 goto exception;
1253 }
1254 if (unlikely(!pcode_finish_call(ctx, rets, rets_l, false)))
1255 goto exception;
1256 mem_free(rets);
1257 rets = NULL;
1258 }
1259
1260 return true;
1261
1262 exception_overflow:
1263 *ctx->err = error_ajla(EC_ASYNC, AJLA_ERROR_SIZE_OVERFLOW);
1264 exception:
1265 if (rets)
1266 mem_free(rets);
1267 return false;
1268
1269 skip_instr:
1270 ctx->pcode = ctx->pcode_instr_end;
1271 return true;
1272 }
1273
1274 static bool pcode_op_to_call(struct build_function_context *ctx, pcode_t op, const struct pcode_type *tr, const struct pcode_type *t1, pcode_t flags1, const struct pcode_type *t2, pcode_t flags2, bool preload)
1275 {
1276 const char *module;
1277 struct module_designator *md = NULL;
1278 struct function_designator *fd = NULL;
1279 unsigned fn;
1280 pointer_t *ptr;
1281 size_t fn_idx;
1282 arg_mode_t am;
1283 code_t code;
1284
1285 switch (t1->extra_type ? t1->extra_type : tr->extra_type) {
1286 case T_SInt128: module = "private/long"; fn = 0 * Op_N; break;
1287 case T_UInt128: module = "private/long"; fn = 1 * Op_N; break;
1288 case T_Real16: module = "private/longreal"; fn = 0 * Op_N; break;
1289 case T_Real32: module = "private/longreal"; fn = 1 * Op_N; break;
1290 case T_Real64: module = "private/longreal"; fn = 2 * Op_N; break;
1291 case T_Real80: module = "private/longreal"; fn = 3 * Op_N; break;
1292 case T_Real128: module = "private/longreal"; fn = 4 * Op_N; break;
1293 default:
1294 internal(file_line, "pcode_op_to_call: type %d, %d", t1->extra_type, tr->extra_type);
1295 }
1296 fn += op;
1297
1298 md = module_designator_alloc(0, cast_ptr(const uint8_t *, module), strlen(module), false, ctx->err);
1299 if (unlikely(!md))
1300 goto exception;
1301 fd = function_designator_alloc_single(fn, ctx->err);
1302 if (unlikely(!fd))
1303 goto exception;
1304 ptr = module_load_function(md, fd, false, ctx->err);
1305 if (unlikely(!ptr))
1306 goto exception;
1307 module_designator_free(md), md = NULL;
1308 function_designator_free(fd), fd = NULL;
1309 fn_idx = pcode_module_load_function_idx(ctx, ptr, !preload);
1310 if (unlikely(fn_idx == no_function_idx))
1311 goto exception;
1312
1313 if (preload)
1314 return true;
1315
1316 am = INIT_ARG_MODE;
1317 get_arg_mode(am, fn_idx);
1318 get_arg_mode(am, t1->slot);
1319 if (t2)
1320 get_arg_mode(am, t2->slot);
1321
1322 code = OPCODE_CALL + am * OPCODE_MODE_MULT;
1323 gen_code(code);
1324 gen_am_two(am, t2 ? 2 : 1, 1);
1325 gen_am(am, fn_idx);
1326 gen_am_two(am, t1->slot, flags1 & Flag_Free_Argument ? OPCODE_FLAG_FREE_ARGUMENT : 0);
1327 if (t2)
1328 gen_am_two(am, t2->slot, flags2 & Flag_Free_Argument ? OPCODE_FLAG_FREE_ARGUMENT : 0);
1329
1330 if (unlikely(!pcode_finish_call(ctx, &tr, 1, true)))
1331 goto exception;
1332
1333 return true;
1334
1335 exception:
1336 if (md)
1337 module_designator_free(md);
1338 if (fd)
1339 function_designator_free(fd);
1340 return false;
1341 }
1342
1343 #define sb0(pos) \
1344 do { \
1345 while ((size_t)(pos) >= 8 * *blob_len) \
1346 if (unlikely(!array_add_mayfail(uint8_t, blob, blob_len, 0, NULL, err)))\
1347 return false; \
1348 } while (0)
1349
1350 #define sb(pos) \
1351 do { \
1352 sb0(pos); \
1353 (*blob)[(pos) >> 3] |= 1U << ((pos) & 7); \
1354 } while (0)
1355
1356 #define re(n, rtype, ntype, pack, unpack) \
1357 static bool cat(pcode_generate_,rtype)(ntype val, uint8_t **blob, size_t *blob_len, ajla_error_t *err)\
1358 { \
1359 int ex_bits, sig_bits; \
1360 int min_exp, max_exp, e; \
1361 int pos; \
1362 ntype norm; \
1363 switch (n) { \
1364 case 0: ex_bits = 5; sig_bits = 11; break; \
1365 case 1: ex_bits = 8; sig_bits = 24; break; \
1366 case 2: ex_bits = 11; sig_bits = 53; break; \
1367 case 3: ex_bits = 15; sig_bits = 64; break; \
1368 case 4: ex_bits = 15; sig_bits = 113; break; \
1369 default: internal(file_line, "invalid real type %d", n);\
1370 } \
1371 min_exp = -(1 << (ex_bits - 1)) - sig_bits + 3; \
1372 max_exp = (1 << (ex_bits - 1)) - sig_bits + 2; \
1373 if (unlikely(cat(isnan_,ntype)(val))) { \
1374 fatal_mayfail(error_ajla(EC_SYNC, AJLA_ERROR_NAN), err, "NaN");\
1375 return false; \
1376 } \
1377 if (unlikely(val == 0)) { \
1378 if (unlikely(1. / val < 0)) \
1379 sb(sig_bits); \
1380 e = min_exp; \
1381 goto set_e; \
1382 } \
1383 if (unlikely(val < 0)) { \
1384 sb(sig_bits); \
1385 val = -val; \
1386 } \
1387 if (unlikely(!cat(isfinite_,ntype)(val))) { \
1388 sb(sig_bits - 1); \
1389 e = max_exp; \
1390 goto set_e; \
1391 } \
1392 norm = cat(mathfunc_,ntype)(frexp)(val, &e); \
1393 e -= sig_bits; \
1394 pos = sig_bits - 1; \
1395 if (e < min_exp) { \
1396 pos -= min_exp - e; \
1397 e = min_exp; \
1398 } \
1399 while (pos >= 0) { \
1400 int bit; \
1401 norm *= 2; \
1402 bit = norm; \
1403 norm -= bit; \
1404 if (bit) \
1405 sb(pos); \
1406 pos--; \
1407 } \
1408 set_e: \
1409 pos = sig_bits + 1; \
1410 while (e && e != -1) { \
1411 if (e & 1) \
1412 sb(pos); \
1413 pos++; \
1414 if (e >= 0) \
1415 e >>= 1; \
1416 else \
1417 e = ~(~e >> 1); \
1418 } \
1419 do { \
1420 if (e & 1) \
1421 sb(pos); \
1422 else \
1423 sb0(pos); \
1424 pos++; \
1425 } while (pos & 7); \
1426 return true; \
1427 }
1428 for_all_real(re, for_all_empty)
1429 #undef re
1430 #undef sb0
1431 #undef sb
1432
1433 bool pcode_generate_blob_from_value(pointer_t ptr, pcode_t pcode_type, pcode_t **res_blob, size_t *res_len, ajla_error_t *err)
1434 {
1435 uint8_t *blob;
1436 size_t blob_len;
1437
1438 struct data *d;
1439 const struct type *type;
1440
1441 type = pcode_to_type(NULL, pcode_type, err);
1442 if (unlikely(!type))
1443 return false;
1444
1445 if (unlikely(!array_init_mayfail(uint8_t, &blob, &blob_len, err)))
1446 return false;
1447 #define emit_byte(b) \
1448 do { \
1449 if (unlikely(!array_add_mayfail(uint8_t, &blob, &blob_len, b, NULL, err)))\
1450 return false; \
1451 } while (0)
1452
1453 d = pointer_get_data(ptr);
1454 if (likely(da_tag(d) == DATA_TAG_flat)) {
1455 bool negative;
1456 uintbig_t value;
1457 size_t size, i;
1458 switch (type->tag) {
1459 #define fx(n, type, utype, sz, bits) \
1460 case TYPE_TAG_integer + n: \
1461 case TYPE_TAG_fixed + 2 * n + TYPE_TAG_fixed_signed:\
1462 case TYPE_TAG_fixed + 2 * n + TYPE_TAG_fixed_unsigned:\
1463 negative = *cast_ptr(type *, da_flat(d)) < 0;\
1464 value = *cast_ptr(type *, da_flat(d)); \
1465 size = sz; \
1466 goto process_int;
1467 #define re(n, rtype, ntype, pack, unpack) \
1468 case TYPE_TAG_real + n: { \
1469 if (unlikely(!cat(pcode_generate_,rtype)(unpack(*cast_ptr(rtype *, da_flat(d))), &blob, &blob_len, err)))\
1470 return false; \
1471 goto process_real; \
1472 }
1473 for_all_fixed(fx);
1474 for_all_real(re, for_all_empty);
1475 default:
1476 internal(file_line, "pcode_generate_blob_from_value: invalid type tag %u", type->tag);
1477 }
1478 #undef fx
1479 #undef re
1480 if (0) {
1481 bool sign;
1482 process_int:
1483 for (i = 0; i < size; i++) {
1484 emit_byte(value);
1485 value >>= 8;
1486 }
1487 sign = blob_len && blob[blob_len - 1] & 0x80;
1488 if (unlikely(sign != negative))
1489 emit_byte(negative ? 0xff : 0x00);
1490
1491 while (blob_len >= 2 && blob[blob_len - 1] == (negative ? 0xff : 0x00) && (blob[blob_len - 2] & 0x80) == (negative ? 0x80 : 0x00))
1492 blob_len--;
1493
1494 if (blob_len == 1 && !blob[0])
1495 blob_len = 0;
1496 }
1497 } else if (unlikely(da_tag(d) == DATA_TAG_longint)) {
1498 mem_free(blob);
1499 if (unlikely(!mpint_export_to_blob(&da(d,longint)->mp, &blob, &blob_len, err)))
1500 return false;
1501 } else if (likely(da_tag(d) == DATA_TAG_option)) {
1502 ajla_option_t opt;
1503 ajla_assert_lo(pointer_is_empty(da(d,option)->pointer), (file_line, "pcode_generate_blob_from_value: non-empty option"));
1504 opt = da(d,option)->option;
1505 do
1506 emit_byte(opt & 0xff);
1507 while ((opt >>= 8));
1508 } else {
1509 internal(file_line, "pcode_generate_blob_from_value: invalid data tag %u", da_tag(d));
1510 }
1511
1512 #if REAL_MASK
1513 process_real:
1514 #endif
1515 if (unlikely(!pcode_generate_blob(blob, blob_len, res_blob, res_len, err))) {
1516 mem_free(blob);
1517 return false;
1518 }
1519
1520 mem_free(blob);
1521
1522 #undef emit_byte
1523 return true;
1524 }
1525
1526
1527 #define test(bit) ((size_t)(bit) < 8 * dl ? (d[(bit) >> 3] >> ((bit) & 7)) & 1 : dl ? d[dl - 1] >> 7 : 0)
1528
1529 #define re(n, rtype, ntype, pack, unpack) \
1530 static inline rtype cat(strto_,rtype)(const unsigned char *d, size_t dl)\
1531 { \
1532 int ex_bits, sig_bits; \
1533 int ex; \
1534 int i; \
1535 bool b; \
1536 ntype val; \
1537 switch (n) { \
1538 case 0: ex_bits = 5; sig_bits = 11; break; \
1539 case 1: ex_bits = 8; sig_bits = 24; break; \
1540 case 2: ex_bits = 11; sig_bits = 53; break; \
1541 case 3: ex_bits = 15; sig_bits = 64; break; \
1542 case 4: ex_bits = 15; sig_bits = 113; break; \
1543 default: internal(file_line, "invalid real type %d", n);\
1544 } \
1545 ex = 0; \
1546 b = false; \
1547 for (i = 0; i < ex_bits + 1; i++) { \
1548 b = test(sig_bits + 1 + i); \
1549 ex |= (int)b << i; \
1550 } \
1551 if (b) \
1552 ex |= -1U << i; \
1553 val = 0; \
1554 for (i = 0; i < sig_bits; i++) { \
1555 if (test(i)) { \
1556 val += cat(mathfunc_,ntype)(ldexp)(1, ex + i); \
1557 } \
1558 } \
1559 if (test(sig_bits)) \
1560 val = -val; \
1561 return pack(val); \
1562 }
1563 for_all_real(re, for_all_empty)
1564 #undef re
1565
1566 static bool pcode_decode_real(struct build_function_context *ctx, const struct type *type, const char attr_unused *blob, size_t attr_unused blob_l, code_t attr_unused **result, size_t attr_unused *result_len)
1567 {
1568 switch (type->tag) {
1569 #define re(n, rtype, ntype, pack, unpack) \
1570 case TYPE_TAG_real + n: { \
1571 rtype val = cat(strto_,rtype)((const unsigned char *)blob, blob_l);\
1572 *result_len = round_up(sizeof(rtype), sizeof(code_t)) / sizeof(code_t);\
1573 if (unlikely(!(*result = mem_alloc_array_mayfail(mem_calloc_mayfail, code_t *, 0, 0, *result_len, sizeof(code_t), ctx->err))))\
1574 goto err; \
1575 memcpy(*result, &val, sizeof(rtype)); \
1576 break; \
1577 }
1578 for_all_real(re, for_all_empty);
1579 default:
1580 internal(file_line, "pcode_decode_real(%s): invalid type tag %u", function_name(ctx), type->tag);
1581 #undef re
1582 }
1583 return true;
1584
1585 goto err;
1586 err:
1587 return false;
1588 }
1589
1590 static bool pcode_generate_constant_from_blob(struct build_function_context *ctx, pcode_t res, uint8_t *blob, size_t l)
1591 {
1592 const struct pcode_type *pt;
1593 bool is_emulated_fixed_8, is_emulated_fixed_16;
1594 const struct type *type;
1595 size_t orig_l;
1596 code_t *raw_result = NULL;
1597
1598 size_t requested_size;
1599 bool const_swap;
1600 code_t code;
1601 arg_mode_t am;
1602
1603 size_t is;
1604
1605 pt = get_var_type(ctx, res);
1606 type = pt->type;
1607 is_emulated_fixed_8 = pt->extra_type == T_SInt64 || pt->extra_type == T_UInt64;
1608 is_emulated_fixed_16 = pt->extra_type == T_SInt128 || pt->extra_type == T_UInt128;
1609
1610 orig_l = l;
1611
1612 if (TYPE_TAG_IS_FIXED(type->tag)) {
1613 if (TYPE_TAG_FIXED_IS_UNSIGNED(type->tag) && l == (size_t)type->size + 1 && blob[l - 1] == 0x00)
1614 l--;
1615 ajla_assert_lo(l <= type->size, (file_line, "pcode_generate_constant_from_blob(%s): too long constant for type %u", function_name(ctx), type->tag));
1616 if (l <= sizeof(code_t))
1617 requested_size = sizeof(code_t);
1618 else
1619 requested_size = round_up(type->size, sizeof(code_t));
1620 } else if (TYPE_TAG_IS_INT(type->tag)) {
1621 if (is_emulated_fixed_8 && l && blob[l - 1] & 0x80)
1622 requested_size = 8;
1623 else if (is_emulated_fixed_16 && l && blob[l - 1] & 0x80)
1624 requested_size = 16;
1625 else if (l <= sizeof(code_t))
1626 requested_size = sizeof(code_t);
1627 else if (l <= type->size)
1628 requested_size = round_up(type->size, sizeof(code_t));
1629 else
1630 requested_size = round_up(l, sizeof(code_t));
1631 } else if (TYPE_TAG_IS_REAL(type->tag)) {
1632 if (!unlikely(pcode_decode_real(ctx, type, cast_ptr(const char *, blob), l, &raw_result, &requested_size)))
1633 return false;
1634 } else {
1635 internal(file_line, "pcode_generate_constant_from_blob(%s): unknown type %u", function_name(ctx), type->tag);
1636 }
1637
1638 if (likely(!raw_result)) {
1639 while (l < requested_size) {
1640 uint8_t c = !l ? 0 : !(blob[l - 1] & 0x80) ? 0 : 0xff;
1641 if (unlikely(!array_add_mayfail(uint8_t, &blob, &l, c, NULL, ctx->err)))
1642 goto exception;
1643 }
1644 }
1645
1646 code = get_code(Op_Ldc, type);
1647 const_swap = !!CODE_ENDIAN;
1648
1649 if (TYPE_TAG_IS_FIXED(type->tag)) {
1650 if (requested_size < type->size)
1651 code += (OPCODE_FIXED_OP_ldc16 - OPCODE_FIXED_OP_ldc) * OPCODE_FIXED_OP_MULT;
1652 } else if (TYPE_TAG_IS_INT(type->tag)) {
1653 if ((is_emulated_fixed_8 || is_emulated_fixed_16) && l && blob[l - 1] & 0x80) {
1654 if (unlikely(!array_add_mayfail(uint8_t, &blob, &l, 0, NULL, ctx->err)))
1655 goto exception;
1656 code = OPCODE_INT_LDC_LONG;
1657 } else if (requested_size < type->size) {
1658 code += (OPCODE_INT_OP_ldc16 - OPCODE_INT_OP_ldc) * OPCODE_INT_OP_MULT;
1659 } else if (requested_size > type->size && orig_l > type->size) {
1660 code = OPCODE_INT_LDC_LONG;
1661 }
1662 }
1663
1664 am = INIT_ARG_MODE;
1665 get_arg_mode(am, pt->slot);
1666
1667 gen_code(code + am * OPCODE_MODE_MULT);
1668 gen_am(am, pt->slot);
1669 if (unlikely(code == OPCODE_INT_LDC_LONG)) {
1670 gen_uint32(l / sizeof(code_t));
1671 /*debug("load long constant: %zu (%d)", l, type->tag);*/
1672 }
1673 if (unlikely(raw_result != NULL)) {
1674 size_t idx;
1675 for (idx = 0; idx < requested_size; idx++)
1676 gen_code(raw_result[idx]);
1677 } else for (is = 0; is < l; is += sizeof(code_t)) {
1678 size_t idx = !const_swap ? is : l - sizeof(code_t) - is;
1679 gen_code(blob[idx] + (blob[idx + 1] << 8));
1680 }
1681
1682 mem_free(blob), blob = NULL;
1683 if (unlikely(raw_result != NULL))
1684 mem_free(raw_result);
1685
1686 return true;
1687
1688 exception:
1689 if (blob)
1690 mem_free(blob);
1691 if (raw_result)
1692 mem_free(raw_result);
1693 return false;
1694 }
1695
1696 static bool pcode_generate_constant(struct build_function_context *ctx, pcode_t res, int_default_t val)
1697 {
1698 uint8_t *blob;
1699 size_t l;
1700 uint_default_t uval = (uint_default_t)val;
1701
1702 if (unlikely(!array_init_mayfail(uint8_t, &blob, &l, ctx->err)))
1703 return false;
1704
1705 while (uval) {
1706 if (unlikely(!array_add_mayfail(uint8_t, &blob, &l, (uint8_t)uval, NULL, ctx->err)))
1707 return false;
1708 uval >>= 8;
1709 }
1710
1711 return pcode_generate_constant_from_blob(ctx, res, blob, l);
1712 }
1713
1714 static bool pcode_generate_option_from_blob(struct build_function_context *ctx, const struct pcode_type *tr, uint8_t *blob, size_t l)
1715 {
1716 arg_mode_t am;
1717 size_t i;
1718 ajla_option_t opt;
1719 code_t code;
1720
1721 opt = 0;
1722 for (i = 0; i < l; i++) {
1723 ajla_option_t o = (ajla_option_t)blob[i];
1724 opt |= o << (i * 8);
1725 if (unlikely(opt >> (i * 8) != o))
1726 goto exception_overflow;
1727 }
1728
1729 am = INIT_ARG_MODE;
1730 get_arg_mode(am, tr->slot);
1731 if (likely(opt == (ajla_option_t)(ajla_flat_option_t)opt) && tr->type->tag == TYPE_TAG_flat_option) {
1732 code = OPCODE_OPTION_CREATE_EMPTY_FLAT;
1733 } else {
1734 code = OPCODE_OPTION_CREATE_EMPTY;
1735 }
1736 code += am * OPCODE_MODE_MULT;
1737 gen_code(code);
1738 gen_am_two(am, tr->slot, opt);
1739
1740 mem_free(blob);
1741 return true;
1742
1743 exception_overflow:
1744 *ctx->err = error_ajla(EC_ASYNC, AJLA_ERROR_SIZE_OVERFLOW);
1745 exception:
1746 mem_free(blob);
1747 return false;
1748 }
1749
1750 static bool pcode_load_constant(struct build_function_context *ctx)
1751 {
1752 pcode_t res;
1753 uint8_t *blob;
1754 size_t l;
1755 const struct pcode_type *tr;
1756
1757 res = u_pcode_get();
1758 if (unlikely(!pcode_load_blob(ctx, &blob, &l)))
1759 return false;
1760
1761 if (var_elided(res)) {
1762 mem_free(blob);
1763 return true;
1764 }
1765
1766 tr = get_var_type(ctx, res);
1767
1768 if (tr->type->tag == TYPE_TAG_flat_option || tr->type->tag == TYPE_TAG_unknown) {
1769 return pcode_generate_option_from_blob(ctx, tr, blob, l);
1770 } else {
1771 return pcode_generate_constant_from_blob(ctx, res, blob, l);
1772 }
1773 }
1774
1775 static bool pcode_structured_loop(struct build_function_context *ctx, pcode_t n_steps, code_t extra_flags, arg_mode_t *am, bool gen)
1776 {
1777 pcode_t i = 0;
1778 do {
1779 pcode_t type;
1780 if (i == n_steps - 1)
1781 extra_flags |= OPCODE_STRUCTURED_FLAG_END;
1782
1783 type = pcode_get();
1784 switch (type) {
1785 case Structured_Record: {
1786 arg_t idx;
1787 pcode_t rec_local, q, type_idx;
1788 const struct record_definition *def;
1789 frame_t slot;
1790
1791 rec_local = u_pcode_get();
1792 q = u_pcode_get();
1793
1794 idx = (arg_t)q;
1795 if (unlikely(q != (pcode_t)idx))
1796 goto exception_overflow;
1797
1798 def = type_def(pcode_to_type(ctx, rec_local, NULL),record);
1799
1800 if (record_definition_is_elided(def, idx)) {
1801 ajla_assert_lo(!gen, (file_line, "pcode_structured_loop(%s): elided record entry in the second pass", function_name(ctx)));
1802 continue;
1803 }
1804
1805 type_idx = pcode_to_type_index(ctx, rec_local, false);
1806 if (unlikely(type_idx == error_type_index))
1807 goto exception;
1808
1809 slot = record_definition_slot(def, idx);
1810 if (!gen) {
1811 get_arg_mode(*am, slot);
1812 get_arg_mode(*am, type_idx);
1813 } else {
1814 gen_am_two(*am, OPCODE_STRUCTURED_RECORD | extra_flags, slot);
1815 gen_am(*am, type_idx);
1816 }
1817 break;
1818 }
1819 case Structured_Option: {
1820 ajla_option_t opt;
1821 pcode_t q;
1822
1823 q = u_pcode_get();
1824 opt = (ajla_option_t)q;
1825 if (unlikely(q != (pcode_t)opt))
1826 goto exception_overflow;
1827
1828 if (!gen) {
1829 get_arg_mode(*am, opt);
1830 } else {
1831 gen_am_two(*am, OPCODE_STRUCTURED_OPTION | extra_flags, opt);
1832 gen_am(*am, 0);
1833 }
1834 break;
1835 }
1836 case Structured_Array: {
1837 pcode_t var, local_type, local_idx;
1838 const struct pcode_type *var_type;
1839
1840 var = u_pcode_get();
1841
1842 local_type = pcode_get();
1843
1844 if (var_elided(var)) {
1845 ajla_assert_lo(!gen, (file_line, "pcode_structured_loop(%s): elided array index in the second pass", function_name(ctx)));
1846 continue;
1847 }
1848
1849 var_type = get_var_type(ctx, var);
1850 ajla_assert_lo(type_is_equal(var_type->type, type_get_int(INT_DEFAULT_N)), (file_line, "pcode_structured_loop(%s): invalid index type %u", function_name(ctx), var_type->type->tag));
1851
1852 local_idx = pcode_to_type_index(ctx, local_type, false);
1853 if (unlikely(local_idx == error_type_index))
1854 goto exception;
1855
1856 if (!gen) {
1857 get_arg_mode(*am, var_type->slot);
1858 get_arg_mode(*am, local_idx);
1859 } else {
1860 gen_am_two(*am, OPCODE_STRUCTURED_ARRAY | extra_flags, var_type->slot);
1861 gen_am(*am, local_idx);
1862 }
1863 break;
1864 }
1865 default:
1866 internal(file_line, "pcode_structured_loop(%s): invalid type %"PRIdMAX"", function_name(ctx), (uintmax_t)type);
1867 }
1868 } while (++i < n_steps);
1869
1870 return true;
1871
1872 exception_overflow:
1873 *ctx->err = error_ajla(EC_ASYNC, AJLA_ERROR_SIZE_OVERFLOW);
1874 exception:
1875 return false;
1876 }
1877
1878 static bool pcode_structured_write(struct build_function_context *ctx)
1879 {
1880 pcode_t structured, scalar, n_steps;
1881 bool scalar_deref;
1882 pcode_t structured_source = 0; /* avoid warning */
1883 bool structured_source_deref = false; /* avoid warning */
1884 const struct pcode_type *structured_type, *scalar_type;
1885 code_t extra_flags = 0;
1886 arg_mode_t am = INIT_ARG_MODE;
1887
1888 pcode_position_save_t saved;
1889
1890 n_steps = u_pcode_get();
1891 ajla_assert_lo(n_steps != 0, (file_line, "pcode_structured_write(%s): zero n_steps", function_name(ctx)));
1892 structured = u_pcode_get();
1893 pcode_get_var_deref(&structured_source, &structured_source_deref);
1894 pcode_get_var_deref(&scalar, &scalar_deref);
1895 if (scalar_deref)
1896 extra_flags |= OPCODE_STRUCTURED_FREE_VARIABLE;
1897
1898 pcode_position_save(ctx, &saved);
1899
1900 if (!pcode_structured_loop(ctx, n_steps, extra_flags, &am, false))
1901 goto exception;
1902
1903 if (unlikely(var_elided(structured)) || unlikely(var_elided(scalar)))
1904 return true;
1905
1906 pcode_position_restore(ctx, &saved);
1907
1908 if (!pcode_copy(ctx, false, structured, structured_source, structured_source_deref))
1909 goto exception;
1910
1911 structured_type = get_var_type(ctx, structured);
1912 scalar_type = get_var_type(ctx, scalar);
1913 get_arg_mode(am, structured_type->slot);
1914 get_arg_mode(am, scalar_type->slot);
1915
1916 gen_code(OPCODE_STRUCTURED + am * OPCODE_MODE_MULT);
1917 gen_am_two(am, structured_type->slot, scalar_type->slot);
1918
1919 if (!pcode_structured_loop(ctx, n_steps, extra_flags, &am, true))
1920 goto exception;
1921
1922 return true;
1923
1924 exception:
1925 return false;
1926 }
1927
1928 static bool pcode_record_create(struct build_function_context *ctx)
1929 {
1930 pcode_t result, q;
1931 pcode_position_save_t saved;
1932 pcode_t n_arguments, n_real_arguments;
1933 const struct pcode_type *tr;
1934 arg_mode_t am = INIT_ARG_MODE;
1935
1936 result = u_pcode_get();
1937 q = u_pcode_get();
1938 n_arguments = (arg_t)q;
1939 if (unlikely(q != (pcode_t)n_arguments))
1940 goto exception_overflow;
1941
1942 pcode_position_save(ctx, &saved);
1943
1944 if (unlikely(!pcode_process_arguments(ctx, n_arguments, &n_real_arguments, &am)))
1945 goto exception;
1946
1947 pcode_position_restore(ctx, &saved);
1948
1949 if (unlikely(var_elided(result))) {
1950 pcode_dereference_arguments(ctx, n_arguments);
1951 return true;
1952 }
1953
1954 tr = get_var_type(ctx, result);
1955 get_arg_mode(am, tr->slot);
1956
1957 gen_code(OPCODE_RECORD_CREATE + am * OPCODE_MODE_MULT);
1958 gen_am_two(am, tr->slot, n_real_arguments);
1959
1960 if (unlikely(!pcode_process_arguments(ctx, n_arguments, NULL, &am)))
1961 goto exception;
1962
1963 return true;
1964
1965 exception_overflow:
1966 *ctx->err = error_ajla(EC_ASYNC, AJLA_ERROR_SIZE_OVERFLOW);
1967 exception:
1968 return false;
1969 }
1970
1971 static bool pcode_array_create(struct build_function_context *ctx)
1972 {
1973 pcode_t result, local_type, length, n_real_arguments;
1974 pcode_position_save_t saved;
1975 const struct pcode_type *tr;
1976 arg_mode_t am = INIT_ARG_MODE;
1977
1978 result = u_pcode_get();
1979 local_type = pcode_get();
1980 length = u_pcode_get();
1981 pcode_get();
1982
1983 pcode_position_save(ctx, &saved);
1984
1985 if (unlikely(!pcode_process_arguments(ctx, length, &n_real_arguments, &am)))
1986 goto exception;
1987
1988 pcode_position_restore(ctx, &saved);
1989
1990 if (unlikely(var_elided(result))) {
1991 pcode_dereference_arguments(ctx, length);
1992 return true;
1993 }
1994
1995 ajla_assert_lo(length == n_real_arguments, (file_line, "pcode_array_create(%s): some elements are elided: %"PRIdMAX" != %"PRIdMAX"", function_name(ctx), (intmax_t)length, (intmax_t)n_real_arguments));
1996
1997 tr = get_var_type(ctx, result);
1998 get_arg_mode(am, tr->slot);
1999
2000 if (!length) {
2001 pcode_t type_idx = pcode_to_type_index(ctx, local_type, true);
2002 if (unlikely(type_idx == error_type_index))
2003 goto exception;
2004 if (type_idx == no_type_index) {
2005 gen_code(OPCODE_ARRAY_CREATE_EMPTY + am * OPCODE_MODE_MULT);
2006 gen_am(am, tr->slot);
2007 } else {
2008 get_arg_mode(am, type_idx);
2009 gen_code(OPCODE_ARRAY_CREATE_EMPTY_FLAT + am * OPCODE_MODE_MULT);
2010 gen_am_two(am, tr->slot, type_idx);
2011 }
2012 } else {
2013 get_arg_mode(am, length);
2014 gen_code(OPCODE_ARRAY_CREATE + am * OPCODE_MODE_MULT);
2015 gen_am_two(am, tr->slot, length);
2016 if (unlikely(!pcode_process_arguments(ctx, length, NULL, &am)))
2017 goto exception;
2018 }
2019
2020 return true;
2021
2022 exception:
2023 return false;
2024 }
2025
2026 static bool pcode_array_string(struct build_function_context *ctx)
2027 {
2028 pcode_t result;
2029 uint8_t *blob;
2030 size_t blob_len, i;
2031 const struct pcode_type *tr;
2032 arg_mode_t am = INIT_ARG_MODE;
2033
2034 result = u_pcode_get();
2035
2036 if (!pcode_load_blob(ctx, &blob, &blob_len))
2037 goto exception;
2038 if (likely(var_elided(result))) {
2039 mem_free(blob);
2040 return true;
2041 }
2042
2043 tr = get_var_type(ctx, result);
2044 get_arg_mode(am, tr->slot);
2045 get_arg_mode(am, blob_len);
2046 gen_code(OPCODE_ARRAY_STRING + am * OPCODE_MODE_MULT);
2047 gen_am_two(am, tr->slot, blob_len);
2048 for (i = 0; i < blob_len; i += 2) {
2049 union {
2050 code_t c;
2051 uint8_t b[2];
2052 } u;
2053 u.b[0] = blob[i];
2054 u.b[1] = i + 1 < blob_len ? blob[i + 1] : 0;
2055 gen_code(u.c);
2056 }
2057 mem_free(blob);
2058 return true;
2059
2060 exception:
2061 if (blob)
2062 mem_free(blob);
2063 return false;
2064 }
2065
2066 static bool pcode_array_unicode(struct build_function_context *ctx)
2067 {
2068 pcode_t result;
2069 pcode_t len, i;
2070 const struct pcode_type *tr;
2071 arg_mode_t am = INIT_ARG_MODE;
2072
2073 result = u_pcode_get();
2074
2075 len = ctx->pcode_instr_end - ctx->pcode;
2076
2077 tr = get_var_type(ctx, result);
2078 get_arg_mode(am, tr->slot);
2079 get_arg_mode(am, len);
2080 gen_code(OPCODE_ARRAY_UNICODE + am * OPCODE_MODE_MULT);
2081 gen_am_two(am, tr->slot, len);
2082 for (i = 0; i < len; i++) {
2083 union {
2084 pcode_t p;
2085 code_t c[2];
2086 } u;
2087 u.p = pcode_get();
2088 gen_code(u.c[0]);
2089 gen_code(u.c[1]);
2090 }
2091 return true;
2092
2093 exception:
2094 return false;
2095 }
2096
2097
2098 static bool pcode_io(struct build_function_context *ctx)
2099 {
2100 pcode_t io_type, n_outputs, n_inputs, n_params;
2101 unsigned pass;
2102 bool elided = false;
2103 code_position_save_t saved;
2104
2105 code_position_save(ctx, &saved);
2106
2107 io_type = u_pcode_get();
2108 n_outputs = u_pcode_get();
2109 n_inputs = u_pcode_get();
2110 n_params = u_pcode_get();
2111
2112 ajla_assert_lo(!((io_type | n_outputs | n_inputs | n_params) & ~0xff), (file_line, "pcode_io(%s): data out of range %"PRIdMAX" %"PRIdMAX" %"PRIdMAX" %"PRIdMAX"", function_name(ctx), (intmax_t)io_type, (intmax_t)n_outputs, (intmax_t)n_inputs, (intmax_t)n_params));
2113
2114 gen_code(OPCODE_IO);
2115 gen_code(io_type | (n_outputs << 8));
2116 gen_code(n_inputs | (n_params << 8));
2117
2118 for (pass = 0; pass < 3; pass++) {
2119 unsigned val;
2120 if (!pass) val = n_outputs;
2121 else if (pass == 1) val = n_inputs;
2122 else val = n_params;
2123
2124 while (val--) {
2125 pcode_t var = pcode_get();
2126 if (!pass && var_elided(var))
2127 elided = true;
2128 if (!elided) {
2129 if (pass < 2) {
2130 const struct pcode_type *t1;
2131 t1 = get_var_type(ctx, var);
2132 gen_uint32(t1->slot);
2133 } else {
2134 gen_uint32(var);
2135 }
2136 }
2137 }
2138 }
2139
2140 if (elided)
2141 code_position_restore(ctx, &saved);
2142
2143 return true;
2144
2145 exception:
2146 return false;
2147 }
2148
2149
2150 static bool pcode_args(struct build_function_context *ctx)
2151 {
2152 const struct pcode_type *tr;
2153 arg_t i, vv;
2154
2155 ajla_assert_lo(!ctx->args, (file_line, "pcode_args(%s): args already specified", function_name(ctx)));
2156
2157 ctx->args = mem_alloc_array_mayfail(mem_alloc_mayfail, struct local_arg *, 0, 0, ctx->n_arguments, sizeof(struct local_arg), ctx->err);
2158 if (unlikely(!ctx->args))
2159 return false;
2160
2161 for (i = 0, vv = 0; i < ctx->n_arguments; i++) {
2162 pcode_t res = pcode_get();
2163 if (unlikely(var_elided(res)))
2164 continue;
2165 tr = get_var_type(ctx, res);
2166 ctx->args[vv].slot = tr->slot;
2167 ctx->args[vv].may_be_borrowed = !TYPE_IS_FLAT(tr->type);
2168 ctx->args[vv].may_be_flat = TYPE_IS_FLAT(tr->type);
2169 ctx->pcode_types[res].argument = &ctx->args[vv];
2170 ctx->colors[tr->color].is_argument = true;
2171 if (!TYPE_IS_FLAT(tr->type))
2172 ctx->local_variables_flags[tr->slot].may_be_borrowed = true;
2173 vv++;
2174 }
2175 ctx->n_real_arguments = vv;
2176
2177 return true;
2178 }
2179
2180
2181 struct pcode_return_struct {
2182 pcode_t flags;
2183 pcode_t res;
2184 };
2185
2186 static bool pcode_return(struct build_function_context *ctx)
2187 {
2188 arg_mode_t am = INIT_ARG_MODE;
2189 arg_t i, vv;
2190 struct pcode_return_struct *prs;
2191
2192 prs = mem_alloc_array_mayfail(mem_alloc_mayfail, struct pcode_return_struct *, 0, 0, ctx->n_return_values, sizeof(struct pcode_return_struct), ctx->err);
2193 if (unlikely(!prs))
2194 goto exception;
2195
2196 for (i = 0, vv = 0; i < ctx->n_return_values; i++) {
2197 const struct pcode_type *tr;
2198 pcode_t flags = u_pcode_get();
2199 pcode_t res = pcode_get();
2200 prs[i].flags = flags;
2201 prs[i].res = res;
2202 if (unlikely((flags & Flag_Return_Elided) != 0))
2203 continue;
2204 tr = get_var_type(ctx, res);
2205 get_arg_mode(am, tr->slot);
2206 vv++;
2207 }
2208
2209 ajla_assert_lo(ctx->n_real_return_values == vv, (file_line, "pcode_return(%s): return arguments mismatch: %u != %u", function_name(ctx), (unsigned)ctx->n_real_return_values, (unsigned)vv));
2210
2211 for (i = 0; i < ctx->n_return_values; i++) {
2212 if (unlikely((prs[i].flags & (Flag_Free_Argument | Flag_Return_Elided)) == (Flag_Free_Argument | Flag_Return_Elided))) {
2213 arg_t j;
2214 arg_t q = (arg_t)-1;
2215 for (j = 0; j < i; j++)
2216 if (prs[j].res == prs[i].res && !(prs[j].flags & Flag_Return_Elided))
2217 q = j;
2218 if (q != (arg_t)-1) {
2219 prs[q].flags |= Flag_Free_Argument;
2220 } else {
2221 if (!pcode_free(ctx, prs[i].res))
2222 goto exception;
2223 }
2224 prs[i].flags &= ~Flag_Free_Argument;
2225 }
2226 }
2227
2228 gen_code(OPCODE_RETURN + am * OPCODE_MODE_MULT);
2229
2230 for (i = 0; i < ctx->n_return_values; i++) {
2231 unsigned code_flags;
2232 const struct pcode_type *tr;
2233 pcode_t flags = prs[i].flags;
2234 pcode_t res = prs[i].res;
2235 if (unlikely((flags & Flag_Return_Elided) != 0))
2236 continue;
2237 tr = get_var_type(ctx, res);
2238 code_flags = 0;
2239 if (flags & Flag_Free_Argument)
2240 code_flags |= OPCODE_FLAG_FREE_ARGUMENT;
2241 gen_am_two(am, tr->slot, code_flags);
2242 }
2243
2244 mem_free(prs);
2245 return true;
2246
2247 exception:
2248 if (prs)
2249 mem_free(prs);
2250 return false;
2251 }
2252
2253 static void pcode_get_instr(struct build_function_context *ctx, pcode_t *instr, pcode_t *instr_params)
2254 {
2255 *instr = u_pcode_get();
2256 *instr_params = u_pcode_get();
2257 ajla_assert(ctx->pcode_limit - ctx->pcode >= *instr_params, (file_line, "pcode_get_instr(%s): instruction %"PRIdMAX" crosses pcode boundary: %"PRIdMAX" > %"PRIdMAX"", function_name(ctx), (intmax_t)*instr, (intmax_t)*instr_params, (intmax_t)(ctx->pcode_limit - ctx->pcode)));
2258 ctx->pcode_instr_end = ctx->pcode + *instr_params;
2259
2260 }
2261
2262 static bool pcode_preload_ld(struct build_function_context *ctx)
2263 {
2264 pcode_position_save_t saved;
2265
2266 pcode_position_save(ctx, &saved);
2267 while (ctx->pcode != ctx->pcode_limit) {
2268 pcode_t instr, instr_params;
2269 pcode_get_instr(ctx, &instr, &instr_params);
2270 switch (instr) {
2271 case P_Args:
2272 if (unlikely(!pcode_args(ctx)))
2273 goto exception;
2274 break;
2275 #if NEED_OP_EMULATION
2276 case P_BinaryOp:
2277 case P_UnaryOp: {
2278 const struct pcode_type *tr, *t1;
2279 pcode_t op = u_pcode_get();
2280 pcode_t res = u_pcode_get();
2281 pcode_t flags1 = u_pcode_get();
2282 pcode_t a1 = pcode_get();
2283 if (unlikely(var_elided(res)))
2284 break;
2285 tr = get_var_type(ctx, res);
2286 t1 = get_var_type(ctx, a1);
2287 if (unlikely(t1->extra_type) || unlikely(tr->extra_type)) {
2288 if (unlikely(!pcode_op_to_call(ctx, op, tr, t1, flags1, NULL, 0, true)))
2289 goto exception;
2290 }
2291 break;
2292 }
2293 #endif
2294 case P_Load_Fn:
2295 case P_Call: {
2296 pointer_t *ptr;
2297 size_t fn_idx;
2298 ctx->pcode += 3;
2299 ptr = pcode_module_load_function(ctx);
2300 if (unlikely(!ptr))
2301 goto exception;
2302 fn_idx = pcode_module_load_function_idx(ctx, ptr, false);
2303 if (unlikely(fn_idx == no_function_idx))
2304 goto exception;
2305 break;
2306 }
2307 }
2308 ctx->pcode = ctx->pcode_instr_end;
2309 }
2310 pcode_position_restore(ctx, &saved);
2311
2312 return true;
2313
2314 exception:
2315 return false;
2316 }
2317
2318 static bool pcode_check_args(struct build_function_context *ctx)
2319 {
2320 size_t i;
2321 arg_mode_t am;
2322 frame_t *vars = NULL;
2323 size_t n_vars = 0;
2324
2325 vars = mem_alloc_array_mayfail(mem_alloc_mayfail, frame_t *, 0, 0, ctx->n_real_arguments, sizeof(frame_t), ctx->err);
2326 if (unlikely(!vars))
2327 goto exception;
2328
2329 am = INIT_ARG_MODE_1;
2330 for (i = 0; i < ctx->n_real_arguments; i++) {
2331 frame_t slot = ctx->args[i].slot;
2332 if (ctx->local_variables_flags[slot].must_be_flat) {
2333 vars[n_vars++] = slot;
2334 get_arg_mode(am, slot);
2335 }
2336 }
2337 if (n_vars) {
2338 code_t code;
2339 get_arg_mode(am, n_vars);
2340 code = OPCODE_ESCAPE_NONFLAT;
2341 code += am * OPCODE_MODE_MULT;
2342 gen_code(code);
2343 gen_am(am, n_vars);
2344 for (i = 0; i < n_vars; i++)
2345 gen_am(am, vars[i]);
2346 }
2347 mem_free(vars);
2348 vars = NULL;
2349
2350 return true;
2351
2352 exception:
2353 if (vars)
2354 mem_free(vars);
2355 return false;
2356 }
2357
2358 static bool pcode_generate_instructions(struct build_function_context *ctx)
2359 {
2360 if (unlikely(!gen_checkpoint(ctx, NULL, 0)))
2361 goto exception;
2362
2363 if (unlikely(!pcode_check_args(ctx)))
2364 goto exception;
2365
2366 while (ctx->pcode != ctx->pcode_limit) {
2367 pcode_t instr, instr_params;
2368 pcode_get_instr(ctx, &instr, &instr_params);
2369 switch (instr) {
2370 pcode_t p, op, res, a1, a2, aa, flags, flags1, flags2;
2371 const struct pcode_type *tr, *t1, *t2, *ta;
2372 bool a1_deref, a2_deref;
2373 arg_mode_t am;
2374 code_t code;
2375 struct line_position lp;
2376 struct record_definition *def;
2377
2378 case P_BinaryOp:
2379 op = u_pcode_get();
2380 ajla_assert_lo(op >= Op_N || Op_IsBinary(op), (file_line, "P_BinaryOp(%s): invalid binary op %"PRIdMAX"", function_name(ctx), (intmax_t)op));
2381 res = u_pcode_get();
2382 flags1 = u_pcode_get();
2383 a1 = pcode_get();
2384 flags2 = u_pcode_get();
2385 a2 = pcode_get();
2386 if (unlikely(var_elided(res))) {
2387 if (flags1 & Flag_Free_Argument)
2388 pcode_free(ctx, a1);
2389 if (flags2 & Flag_Free_Argument)
2390 pcode_free(ctx, a2);
2391 break;
2392 }
2393 tr = get_var_type(ctx, res);
2394 t1 = get_var_type(ctx, a1);
2395 t2 = get_var_type(ctx, a2);
2396 ajla_assert_lo(op >= Op_N ||
2397 (type_is_equal(t1->type, t2->type) &&
2398 type_is_equal(tr->type, (Op_IsBool(op) ? type_get_flat_option()
2399 : Op_IsInt(op) ? type_get_int(INT_DEFAULT_N)
2400 : t1->type))), (file_line, "P_BinaryOp(%s): invalid types for binary operation %"PRIdMAX": %u, %u, %u", function_name(ctx), (intmax_t)op, t1->type->tag, t2->type->tag, tr->type->tag));
2401 if (NEED_OP_EMULATION && unlikely(t1->extra_type)) {
2402 if (unlikely(!pcode_op_to_call(ctx, op, tr, t1, flags1, t2, flags2, false)))
2403 goto exception;
2404 break;
2405 }
2406 am = INIT_ARG_MODE;
2407 get_arg_mode(am, t1->slot);
2408 get_arg_mode(am, t2->slot);
2409 get_arg_mode(am, tr->slot);
2410 code = (code_t)((likely(op < Op_N) ? get_code(op, t1->type) : (code_t)(op - Op_N)) + am * OPCODE_MODE_MULT);
2411 gen_code(code);
2412 gen_am_two(am, t1->slot, t2->slot);
2413 gen_am_two(am, tr->slot, flags1 & Flag_Op_Strict ? OPCODE_OP_FLAG_STRICT : 0);
2414 if (flags1 & Flag_Free_Argument) {
2415 if (t1->slot != tr->slot)
2416 pcode_free(ctx, a1);
2417 }
2418 if (flags2 & Flag_Free_Argument) {
2419 if (t2->slot != tr->slot)
2420 pcode_free(ctx, a2);
2421 }
2422 break;
2423 case P_UnaryOp:
2424 op = u_pcode_get();
2425 ajla_assert_lo(op >= Op_N || Op_IsUnary(op), (file_line, "P_UnaryOp(%s): invalid unary op %"PRIdMAX"", function_name(ctx), (intmax_t)op));
2426 res = u_pcode_get();
2427 flags1 = u_pcode_get();
2428 a1 = pcode_get();
2429 if (unlikely(var_elided(res))) {
2430 if (flags1 & Flag_Free_Argument)
2431 pcode_free(ctx, a1);
2432 break;
2433 }
2434 tr = get_var_type(ctx, res);
2435 t1 = get_var_type(ctx, a1);
2436 ajla_assert_lo(op >= Op_N || op == Un_ConvertFromInt ||
2437 type_is_equal(tr->type, (Op_IsBool(op) ? type_get_flat_option()
2438 : Op_IsInt(op) ? type_get_int(INT_DEFAULT_N)
2439 : t1->type)), (file_line, "P_UnaryOp(%s): invalid types for unary operation %"PRIdMAX": %u, %u", function_name(ctx), (intmax_t)op, t1->type->tag, tr->type->tag));
2440 if (NEED_OP_EMULATION && (unlikely(t1->extra_type) || unlikely(tr->extra_type))) {
2441 if (unlikely(!pcode_op_to_call(ctx, op, tr, t1, flags1, NULL, 0, false)))
2442 goto exception;
2443 break;
2444 }
2445 am = INIT_ARG_MODE;
2446 get_arg_mode(am, t1->slot);
2447 get_arg_mode(am, tr->slot);
2448 code = (code_t)((likely(op < Op_N) ? get_code(op, op != Un_ConvertFromInt ? t1->type : tr->type) : (code_t)(op - Op_N)) + am * OPCODE_MODE_MULT);
2449 gen_code(code);
2450 gen_am_two(am, t1->slot, tr->slot);
2451 gen_am(am, flags1 & Flag_Op_Strict ? OPCODE_OP_FLAG_STRICT : 0);
2452 if (flags1 & Flag_Free_Argument) {
2453 if (t1->slot != tr->slot)
2454 pcode_free(ctx, a1);
2455 }
2456 break;
2457 case P_Copy:
2458 case P_Copy_Type_Cast:
2459 res = u_pcode_get();
2460 pcode_get_var_deref(&a1, &a1_deref);
2461 if (unlikely(var_elided(res))) {
2462 if (a1_deref) {
2463 if (unlikely(!pcode_free(ctx, a1)))
2464 goto exception;
2465 }
2466 break;
2467 }
2468 if (unlikely(!pcode_copy(ctx, instr != P_Copy, res, a1, a1_deref)))
2469 goto exception;
2470 break;
2471 case P_Free:
2472 res = u_pcode_get();
2473 if (unlikely(!pcode_free(ctx, res)))
2474 goto exception;
2475 break;
2476 case P_Eval:
2477 a1 = pcode_get();
2478 if (unlikely(var_elided(a1)))
2479 break;
2480 t1 = get_var_type(ctx, a1);
2481 am = INIT_ARG_MODE;
2482 get_arg_mode(am, t1->slot);
2483 code = OPCODE_EVAL;
2484 code += am * OPCODE_MODE_MULT;
2485 gen_code(code);
2486 gen_am(am, t1->slot);
2487 break;
2488 case P_Keep:
2489 a1 = pcode_get();
2490 break;
2491 case P_Fn:
2492 res = u_pcode_get();
2493 ajla_assert_lo(var_elided(res), (file_line, "P_Fn(%s): Fn result is not elided", function_name(ctx)));
2494 a1 = u_pcode_get();
2495 a2 = u_pcode_get();
2496 for (p = 0; p < a1; p++)
2497 pcode_get();
2498 for (p = 0; p < a2; p++)
2499 pcode_get();
2500 break;
2501 case P_Load_Local_Type:
2502 res = u_pcode_get();
2503 ajla_assert_lo(var_elided(res), (file_line, "P_Load_Local_Type(%s): Load_Local_Type result is not elided", function_name(ctx)));
2504 pcode_get();
2505 u_pcode_get();
2506 break;
2507 case P_Load_Fn:
2508 case P_Curry:
2509 case P_Call_Indirect:
2510 case P_Call:
2511 if (unlikely(!pcode_call(ctx, instr)))
2512 goto exception;
2513 break;
2514 case P_Load_Const:
2515 if (unlikely(!pcode_load_constant(ctx)))
2516 goto exception;
2517 break;
2518 case P_Structured_Write:
2519 if (unlikely(!pcode_structured_write(ctx)))
2520 goto exception;
2521 break;
2522 case P_Record_Type:
2523 case P_Option_Type:
2524 for (p = 0; p < instr_params; p++)
2525 pcode_get();
2526 break;
2527 case P_Record_Create:
2528 if (unlikely(!pcode_record_create(ctx)))
2529 goto exception;
2530 break;
2531 case P_Record_Load_Slot:
2532 res = u_pcode_get();
2533 a1 = u_pcode_get();
2534 op = u_pcode_get();
2535 tr = get_var_type(ctx, res);
2536 t1 = get_var_type(ctx, a1);
2537 am = INIT_ARG_MODE;
2538 get_arg_mode(am, tr->slot);
2539 get_arg_mode(am, t1->slot);
2540 get_arg_mode(am, op);
2541 code = OPCODE_RECORD_LOAD;
2542 code += am * OPCODE_MODE_MULT;
2543 gen_code(code);
2544 gen_am_two(am, t1->slot, op);
2545 gen_am_two(am, tr->slot, OPCODE_OP_FLAG_STRICT);
2546 break;
2547 case P_Record_Load:
2548 res = u_pcode_get();
2549 flags = u_pcode_get();
2550 a1 = u_pcode_get();
2551 op = u_pcode_get();
2552 if (unlikely(var_elided(res)))
2553 break;
2554 tr = get_var_type(ctx, res);
2555 t1 = get_var_type(ctx, a1);
2556 if (TYPE_IS_FLAT(tr->type))
2557 flags &= ~Flag_Borrow;
2558 if (t1->type->tag == TYPE_TAG_flat_record) {
2559 def = type_def(type_def(t1->type,flat_record)->base,record);
2560 } else {
2561 def = type_def(t1->type,record);
2562 }
2563 ajla_assert_lo(!record_definition_is_elided(def, op), (file_line, "P_RecordLoad(%s): record entry %"PRIuMAX" is elided", function_name(ctx), (uintmax_t)op));
2564 op = record_definition_slot(def, op);
2565 am = INIT_ARG_MODE;
2566 get_arg_mode(am, tr->slot);
2567 get_arg_mode(am, t1->slot);
2568 get_arg_mode(am, op);
2569 code = OPCODE_RECORD_LOAD;
2570 code += am * OPCODE_MODE_MULT;
2571 gen_code(code);
2572 gen_am_two(am, t1->slot, op);
2573 gen_am_two(am, tr->slot,
2574 (flags & Flag_Evaluate ? OPCODE_OP_FLAG_STRICT : 0) |
2575 (flags & Flag_Borrow ? OPCODE_STRUCT_MAY_BORROW : 0));
2576 if (flags & Flag_Borrow)
2577 ctx->local_variables_flags[tr->slot].may_be_borrowed = true;
2578 break;
2579 case P_Option_Load:
2580 res = u_pcode_get();
2581 flags = u_pcode_get();
2582 a1 = u_pcode_get();
2583 op = u_pcode_get();
2584 if (unlikely(var_elided(res)))
2585 break;
2586 tr = get_var_type(ctx, res);
2587 t1 = get_var_type(ctx, a1);
2588 if (TYPE_IS_FLAT(tr->type))
2589 flags &= ~Flag_Borrow;
2590 am = INIT_ARG_MODE;
2591 get_arg_mode(am, tr->slot);
2592 get_arg_mode(am, t1->slot);
2593 get_arg_mode(am, op);
2594 code = OPCODE_OPTION_LOAD;
2595 code += am * OPCODE_MODE_MULT;
2596 gen_code(code);
2597 gen_am_two(am, t1->slot, op);
2598 gen_am_two(am, tr->slot,
2599 (flags & Flag_Evaluate ? OPCODE_OP_FLAG_STRICT : 0) |
2600 (flags & Flag_Borrow ? OPCODE_STRUCT_MAY_BORROW : 0));
2601 if (flags & Flag_Borrow)
2602 ctx->local_variables_flags[tr->slot].may_be_borrowed = true;
2603 break;
2604 case P_Option_Create:
2605 res = u_pcode_get();
2606 op = u_pcode_get();
2607 pcode_get_var_deref(&a1, &a1_deref);
2608 if (unlikely(var_elided(res))) {
2609 if (a1_deref) {
2610 if (unlikely(!pcode_free(ctx, a1)))
2611 goto exception;
2612 }
2613 break;
2614 }
2615 tr = get_var_type(ctx, res);
2616 t1 = get_var_type(ctx, a1);
2617 ajla_assert_lo(tr->type->tag == TYPE_TAG_flat_option || tr->type->tag == TYPE_TAG_unknown, (file_line, "P_Option_Create(%s): invalid type %u", function_name(ctx), tr->type->tag));
2618 am = INIT_ARG_MODE;
2619 get_arg_mode(am, tr->slot);
2620 get_arg_mode(am, t1->slot);
2621 get_arg_mode(am, op);
2622 if (unlikely(op != (pcode_t)(ajla_option_t)op))
2623 goto exception_overflow;
2624 code = OPCODE_OPTION_CREATE;
2625 code += am * OPCODE_MODE_MULT;
2626 gen_code(code);
2627 gen_am_two(am, tr->slot, op);
2628 gen_am_two(am, t1->slot, a1_deref ? OPCODE_FLAG_FREE_ARGUMENT : 0);
2629 break;
2630 case P_Option_Test:
2631 res = u_pcode_get();
2632 a1 = u_pcode_get();
2633 op = u_pcode_get();
2634 if (unlikely(var_elided(res)))
2635 break;
2636 tr = get_var_type(ctx, res);
2637 t1 = get_var_type(ctx, a1);
2638 ajla_assert_lo((t1->type->tag == TYPE_TAG_flat_option || t1->type->tag == TYPE_TAG_unknown) && tr->type->tag == TYPE_TAG_flat_option, (file_line, "P_Option_Test(%s): invalid types for option test %u, %u", function_name(ctx), t1->type->tag, tr->type->tag));
2639 am = INIT_ARG_MODE;
2640 get_arg_mode(am, tr->slot);
2641 get_arg_mode(am, t1->slot);
2642 get_arg_mode(am, op);
2643 if (unlikely(op != (pcode_t)(ajla_option_t)op))
2644 goto exception_overflow;
2645 if (t1->type->tag == TYPE_TAG_flat_option)
2646 code = OPCODE_OPTION_TEST_FLAT;
2647 else
2648 code = OPCODE_OPTION_TEST;
2649 code += am * OPCODE_MODE_MULT;
2650 gen_code(code);
2651 gen_am_two(am, t1->slot, op);
2652 gen_am(am, tr->slot);
2653 break;
2654 case P_Option_Ord:
2655 res = u_pcode_get();
2656 a1 = u_pcode_get();
2657 if (unlikely(var_elided(res)))
2658 break;
2659 tr = get_var_type(ctx, res);
2660 t1 = get_var_type(ctx, a1);
2661 ajla_assert_lo((t1->type->tag == TYPE_TAG_flat_option || t1->type->tag == TYPE_TAG_unknown) && type_is_equal(tr->type, type_get_int(INT_DEFAULT_N)), (file_line, "P_Option_Ord(%s): invalid types for option test %u, %u", function_name(ctx), t1->type->tag, tr->type->tag));
2662 am = INIT_ARG_MODE;
2663 get_arg_mode(am, tr->slot);
2664 get_arg_mode(am, t1->slot);
2665 if (t1->type->tag == TYPE_TAG_flat_option)
2666 code = OPCODE_OPTION_ORD_FLAT;
2667 else
2668 code = OPCODE_OPTION_ORD;
2669 code += am * OPCODE_MODE_MULT;
2670 gen_code(code);
2671 gen_am_two(am, t1->slot, tr->slot);
2672 break;
2673 case P_Array_Flexible:
2674 case P_Array_Fixed:
2675 res = u_pcode_get();
2676 ajla_assert_lo(var_elided(res), (file_line, "P_Array_Flexible(%s): P_Array_Flexible result is not elided", function_name(ctx)));
2677 a1 = pcode_get();
2678 ajla_assert_lo(var_elided(a1), (file_line, "P_Array_Flexible(%s): P_Array_Flexible argument is not elided", function_name(ctx)));
2679 if (instr == P_Array_Fixed)
2680 pcode_get();
2681 break;
2682 case P_Array_Create:
2683 if (unlikely(!pcode_array_create(ctx)))
2684 goto exception;
2685 break;
2686 case P_Array_Fill:
2687 res = u_pcode_get();
2688 pcode_get(); /* local type */
2689 op = u_pcode_get();
2690 ajla_assert_lo(!(op & ~(pcode_t)(Flag_Free_Argument | Flag_Array_Fill_Sparse)), (file_line, "P_Array_Fill(%s): invalid flags %"PRIdMAX"", function_name(ctx), (intmax_t)op));
2691 a1 = pcode_get();
2692 a2 = pcode_get();
2693 if (unlikely(var_elided(res)))
2694 break;
2695 tr = get_var_type(ctx, res);
2696 t1 = get_var_type(ctx, a1);
2697 t2 = get_var_type(ctx, a2);
2698 ajla_assert_lo(type_is_equal(t2->type, type_get_int(INT_DEFAULT_N)), (file_line, "P_Array_Fill(%s): invalid length type: %u", function_name(ctx), t2->type->tag));
2699 am = INIT_ARG_MODE;
2700 get_arg_mode(am, t1->slot);
2701 get_arg_mode(am, t2->slot);
2702 get_arg_mode(am, tr->slot);
2703 gen_code(OPCODE_ARRAY_FILL + am * OPCODE_MODE_MULT);
2704 gen_am_two(am, t1->slot,
2705 ((op & Flag_Free_Argument) ? OPCODE_FLAG_FREE_ARGUMENT : 0) |
2706 ((op & Flag_Array_Fill_Sparse) ? OPCODE_ARRAY_FILL_FLAG_SPARSE : 0)
2707 );
2708 gen_am_two(am, t2->slot, tr->slot);
2709 break;
2710 case P_Array_String:
2711 if (unlikely(!pcode_array_string(ctx)))
2712 goto exception;
2713 break;
2714 case P_Array_Unicode:
2715 if (unlikely(!pcode_array_unicode(ctx)))
2716 goto exception;
2717 break;
2718 case P_Array_Load:
2719 res = u_pcode_get();
2720 flags = u_pcode_get();
2721 a1 = u_pcode_get();
2722 a2 = u_pcode_get();
2723 if (unlikely(var_elided(res)))
2724 break;
2725 tr = get_var_type(ctx, res);
2726 t1 = get_var_type(ctx, a1);
2727 t2 = get_var_type(ctx, a2);
2728 if (TYPE_IS_FLAT(tr->type))
2729 flags &= ~Flag_Borrow;
2730 am = INIT_ARG_MODE;
2731 get_arg_mode(am, tr->slot);
2732 get_arg_mode(am, t1->slot);
2733 get_arg_mode(am, t2->slot);
2734 code = OPCODE_ARRAY_LOAD;
2735 code += am * OPCODE_MODE_MULT;
2736 gen_code(code);
2737 gen_am_two(am, t1->slot, t2->slot);
2738 gen_am_two(am, tr->slot,
2739 (flags & Flag_Evaluate ? OPCODE_OP_FLAG_STRICT : 0) |
2740 (flags & Flag_Borrow ? OPCODE_STRUCT_MAY_BORROW : 0) |
2741 (flags & Flag_Index_In_Range ? OPCODE_ARRAY_INDEX_IN_RANGE : 0));
2742 if (flags & Flag_Borrow)
2743 ctx->local_variables_flags[tr->slot].may_be_borrowed = true;
2744 break;
2745 case P_Array_Len:
2746 res = u_pcode_get();
2747 a1 = u_pcode_get();
2748 flags = u_pcode_get();
2749 ajla_assert_lo(!(flags & ~Flag_Evaluate), (file_line, "P_Array_Len(%s): invalid flags %"PRIuMAX"", function_name(ctx), (uintmax_t)flags));
2750 if (unlikely(var_elided(res)))
2751 break;
2752 tr = get_var_type(ctx, res);
2753 t1 = get_var_type(ctx, a1);
2754 ajla_assert_lo(type_is_equal(tr->type, type_get_int(INT_DEFAULT_N)), (file_line, "P_Array_Len(%s): invalid result type: %u", function_name(ctx), tr->type->tag));
2755 if (TYPE_IS_FLAT(t1->type)) {
2756 ajla_assert_lo(t1->type->tag == TYPE_TAG_flat_array, (file_line, "P_Array_Len(%s): invalid flat array type: %u", function_name(ctx), t1->type->tag));
2757 if (unlikely(!pcode_generate_constant(ctx, res, (int_default_t)type_def(t1->type,flat_array)->n_elements)))
2758 goto exception;
2759 } else {
2760 ajla_assert_lo(t1->type->tag == TYPE_TAG_unknown, (file_line, "P_Array_Len(%s): invalid array type: %u", function_name(ctx), t1->type->tag));
2761 am = INIT_ARG_MODE;
2762 get_arg_mode(am, t1->slot);
2763 get_arg_mode(am, tr->slot);
2764 gen_code(OPCODE_ARRAY_LEN + am * OPCODE_MODE_MULT);
2765 gen_am_two(am, t1->slot, tr->slot);
2766 gen_am(am, flags & Flag_Evaluate ? OPCODE_OP_FLAG_STRICT : 0);
2767 }
2768 break;
2769 case P_Array_Len_Greater_Than:
2770 res = u_pcode_get();
2771 a1 = u_pcode_get();
2772 a2 = u_pcode_get();
2773 flags = u_pcode_get();
2774 ajla_assert_lo(!(flags & ~Flag_Evaluate), (file_line, "P_Array_Len_Greater_Than(%s): invalid flags %"PRIuMAX"", function_name(ctx), (uintmax_t)flags));
2775 if (unlikely(var_elided(res)))
2776 break;
2777 tr = get_var_type(ctx, res);
2778 t1 = get_var_type(ctx, a1);
2779 t2 = get_var_type(ctx, a2);
2780 ajla_assert_lo(type_is_equal(tr->type, type_get_flat_option()), (file_line, "P_Array_Len_Greater_Than(%s): invalid result type: %u", function_name(ctx), tr->type->tag));
2781 ajla_assert_lo(type_is_equal(t2->type, type_get_int(INT_DEFAULT_N)), (file_line, "P_Array_Len_Greater_Than(%s): invalid length type: %u", function_name(ctx), t2->type->tag));
2782
2783 am = INIT_ARG_MODE;
2784 get_arg_mode(am, t1->slot);
2785 get_arg_mode(am, t2->slot);
2786 get_arg_mode(am, tr->slot);
2787 gen_code(OPCODE_ARRAY_LEN_GREATER_THAN + am * OPCODE_MODE_MULT);
2788 gen_am_two(am, t1->slot, t2->slot);
2789 gen_am_two(am, tr->slot, flags & Flag_Evaluate ? OPCODE_OP_FLAG_STRICT : 0);
2790 break;
2791 case P_Array_Sub:
2792 res = u_pcode_get();
2793 flags = u_pcode_get();
2794 aa = u_pcode_get();
2795 a1 = u_pcode_get();
2796 a2 = u_pcode_get();
2797 ajla_assert_lo(!(flags & ~(Flag_Free_Argument | Flag_Evaluate)), (file_line, "P_Array_Sub(%s): invalid flags %"PRIuMAX"", function_name(ctx), (uintmax_t)flags));
2798 if (unlikely(var_elided(res)))
2799 break;
2800 tr = get_var_type(ctx, res);
2801 ta = get_var_type(ctx, aa);
2802 t1 = get_var_type(ctx, a1);
2803 t2 = get_var_type(ctx, a2);
2804 ajla_assert_lo(type_is_equal(t1->type, type_get_int(INT_DEFAULT_N)), (file_line, "P_Array_Sub(%s): invalid length type: %u", function_name(ctx), t1->type->tag));
2805 ajla_assert_lo(type_is_equal(t2->type, type_get_int(INT_DEFAULT_N)), (file_line, "P_Array_Sub(%s): invalid length type: %u", function_name(ctx), t2->type->tag));
2806
2807 am = INIT_ARG_MODE;
2808 get_arg_mode(am, ta->slot);
2809 get_arg_mode(am, t1->slot);
2810 get_arg_mode(am, t2->slot);
2811 get_arg_mode(am, tr->slot);
2812 gen_code(OPCODE_ARRAY_SUB + am * OPCODE_MODE_MULT);
2813 gen_am_two(am, ta->slot, t1->slot);
2814 gen_am_two(am, t2->slot, tr->slot);
2815 gen_am(am,
2816 (flags & Flag_Free_Argument ? OPCODE_FLAG_FREE_ARGUMENT : 0) |
2817 (flags & Flag_Evaluate ? OPCODE_OP_FLAG_STRICT : 0)
2818 );
2819 break;
2820 case P_Array_Skip:
2821 res = u_pcode_get();
2822 flags = u_pcode_get();
2823 aa = u_pcode_get();
2824 a1 = u_pcode_get();
2825 ajla_assert_lo(!(flags & ~(Flag_Free_Argument | Flag_Evaluate)), (file_line, "P_Array_Skip(%s): invalid flags %"PRIuMAX"", function_name(ctx), (uintmax_t)flags));
2826 if (unlikely(var_elided(res)))
2827 break;
2828 tr = get_var_type(ctx, res);
2829 ta = get_var_type(ctx, aa);
2830 t1 = get_var_type(ctx, a1);
2831 ajla_assert_lo(type_is_equal(t1->type, type_get_int(INT_DEFAULT_N)), (file_line, "P_Array_Skip(%s): invalid length type: %u", function_name(ctx), t1->type->tag));
2832
2833 am = INIT_ARG_MODE;
2834 get_arg_mode(am, ta->slot);
2835 get_arg_mode(am, t1->slot);
2836 get_arg_mode(am, tr->slot);
2837 gen_code(OPCODE_ARRAY_SKIP + am * OPCODE_MODE_MULT);
2838 gen_am_two(am, ta->slot, t1->slot);
2839 gen_am_two(am, tr->slot,
2840 (flags & Flag_Free_Argument ? OPCODE_FLAG_FREE_ARGUMENT : 0) |
2841 (flags & Flag_Evaluate ? OPCODE_OP_FLAG_STRICT : 0)
2842 );
2843 break;
2844 case P_Array_Append:
2845 case P_Array_Append_One:
2846 res = u_pcode_get();
2847 pcode_get_var_deref(&a1, &a1_deref);
2848 pcode_get_var_deref(&a2, &a2_deref);
2849 if (unlikely(var_elided(res)))
2850 break;
2851 tr = get_var_type(ctx, res);
2852 t1 = get_var_type(ctx, a1);
2853 t2 = get_var_type(ctx, a2);
2854 am = INIT_ARG_MODE;
2855 get_arg_mode(am, tr->slot);
2856 get_arg_mode(am, t1->slot);
2857 get_arg_mode(am, t2->slot);
2858 if (instr == P_Array_Append) {
2859 gen_code(OPCODE_ARRAY_APPEND + am * OPCODE_MODE_MULT);
2860 } else {
2861 if (TYPE_IS_FLAT(t2->type)) {
2862 gen_code(OPCODE_ARRAY_APPEND_ONE_FLAT + am * OPCODE_MODE_MULT);
2863 } else {
2864 gen_code(OPCODE_ARRAY_APPEND_ONE + am * OPCODE_MODE_MULT);
2865 }
2866 }
2867 gen_am_two(am, tr->slot, (a1_deref ? OPCODE_FLAG_FREE_ARGUMENT : 0) | (a2_deref ? OPCODE_FLAG_FREE_ARGUMENT_2 : 0));
2868 gen_am_two(am, t1->slot, t2->slot);
2869 break;
2870 case P_Array_Flatten:
2871 res = u_pcode_get();
2872 pcode_get_var_deref(&a1, &a1_deref);
2873 if (unlikely(var_elided(res)))
2874 break;
2875 tr = get_var_type(ctx, res);
2876 t1 = get_var_type(ctx, a1);
2877 am = INIT_ARG_MODE;
2878 get_arg_mode(am, tr->slot);
2879 get_arg_mode(am, t1->slot);
2880 gen_code(OPCODE_ARRAY_FLATTEN + am * OPCODE_MODE_MULT);
2881 gen_am_two(am, tr->slot, (a1_deref ? OPCODE_FLAG_FREE_ARGUMENT : 0));
2882 gen_am(am, t1->slot);
2883 break;
2884 case P_Jmp:
2885 res = u_pcode_get();
2886 ajla_assert_lo(res < ctx->n_labels, (file_line, "P_Jmp(%s): invalid label %"PRIdMAX"", function_name(ctx), (intmax_t)res));
2887 #if SIZEOF_IP_T > 2
2888 if (ctx->labels[res] != no_label) {
2889 uint32_t target;
2890 target = (uint32_t)((ctx->code_len - ctx->labels[res]) * sizeof(code_t));
2891 if (likely(target < 0x10000)) {
2892 gen_code(OPCODE_JMP_BACK_16);
2893 gen_code((code_t)target);
2894 break;
2895 }
2896 }
2897 #endif
2898 gen_code(OPCODE_JMP);
2899 gen_relative_jump(res, SIZEOF_IP_T);
2900 break;
2901 case P_Jmp_False:
2902 res = pcode_get();
2903 tr = get_var_type(ctx, res);
2904 ajla_assert_lo(type_is_equal(tr->type, type_get_flat_option()), (file_line, "P_Jmp_False(%s): invalid type for conditional jump: %u", function_name(ctx), tr->type->tag));
2905
2906 a1 = u_pcode_get();
2907 a2 = u_pcode_get();
2908
2909 am = INIT_ARG_MODE;
2910 get_arg_mode(am, tr->slot);
2911 code = OPCODE_JMP_FALSE + am * OPCODE_MODE_MULT;
2912 gen_code(code);
2913 gen_am(am, tr->slot);
2914 gen_relative_jump(a1, SIZEOF_IP_T * 2);
2915 gen_relative_jump(a2, SIZEOF_IP_T);
2916 break;
2917 case P_Label:
2918 gen_code(OPCODE_LABEL);
2919 res = u_pcode_get();
2920 ajla_assert_lo(res < ctx->n_labels, (file_line, "P_Label(%s): invalid label %"PRIdMAX"", function_name(ctx), (intmax_t)res));
2921 ajla_assert_lo(ctx->labels[res] == no_label, (file_line, "P_Label(%s): label %"PRIdMAX" already defined", function_name(ctx), (intmax_t)res));
2922 ctx->labels[res] = ctx->code_len;
2923 break;
2924 case P_IO:
2925 if (unlikely(!pcode_io(ctx)))
2926 goto exception;
2927 break;
2928 case P_Args:
2929 ctx->pcode = ctx->pcode_instr_end;
2930 break;
2931 case P_Return_Vars:
2932 for (p = 0; p < instr_params; p++)
2933 pcode_get();
2934 break;
2935 case P_Return:
2936 if (unlikely(!pcode_return(ctx)))
2937 goto exception;
2938 break;
2939 case P_Checkpoint:
2940 if (unlikely(!gen_checkpoint(ctx, ctx->pcode, instr_params)))
2941 goto exception;
2942 for (p = 0; p < instr_params; p++)
2943 u_pcode_get();
2944 break;
2945 case P_Line_Info:
2946 lp.line = u_pcode_get();
2947 lp.ip = ctx->code_len;
2948 if (unlikely(!array_add_mayfail(struct line_position, &ctx->lp, &ctx->lp_size, lp, NULL, ctx->err)))
2949 goto exception;
2950 break;
2951 default:
2952 internal(file_line, "pcode_generate_instructions(%s): invalid pcode %"PRIdMAX"", function_name(ctx), (intmax_t)instr);
2953 }
2954
2955 if (unlikely(ctx->pcode != ctx->pcode_instr_end)) {
2956 const pcode_t *pp;
2957 char *s;
2958 size_t l;
2959 str_init(&s, &l);
2960 for (pp = ctx->pcode_instr_end - instr_params - 2; pp < ctx->pcode; pp++) {
2961 str_add_char(&s, &l, ' ');
2962 str_add_signed(&s, &l, *pp, 10);
2963 }
2964 str_finish(&s, &l);
2965 internal(file_line, "pcode_generate_instructions(%s): mismatched instruction %"PRIdMAX" length: %"PRIdMAX" != %"PRIdMAX":%s", function_name(ctx), (intmax_t)instr, (intmax_t)(ctx->pcode - (ctx->pcode_instr_end - instr_params)), (intmax_t)instr_params, s);
2966 }
2967 }
2968 if (unlikely(ctx->code_len > sign_bit(ip_t) / sizeof(code_t) + uzero))
2969 goto exception_overflow;
2970 return true;
2971
2972 exception_overflow:
2973 *ctx->err = error_ajla(EC_ASYNC, AJLA_ERROR_SIZE_OVERFLOW);
2974 exception:
2975 return false;
2976 }
2977
2978 static bool pcode_generate_record(struct build_function_context *ctx)
2979 {
2980 arg_t ai;
2981 frame_t layout_idx;
2982 struct record_definition *def;
2983 if (unlikely(!array_init_mayfail(frame_t, &ctx->record_entries, &ctx->record_entries_len, ctx->err)))
2984 goto exception;
2985
2986 ctx->layout = layout_start(slot_bits, frame_flags_per_slot_bits, slot_size, data_record_offset, ctx->err);
2987 if (unlikely(!ctx->layout))
2988 goto exception;
2989
2990 for (; ctx->pcode != ctx->pcode_limit; ctx->pcode = ctx->pcode_instr_end) {
2991 pcode_t instr, instr_params;
2992 pcode_get_instr(ctx, &instr, &instr_params);
2993
2994 if (instr == P_Load_Local_Type) {
2995 pcode_t var, fn_var;
2996 pcode_t attr_unused idx;
2997 const struct pcode_type *p;
2998 const struct type *t;
2999
3000 ajla_assert_lo(instr_params == 3, (file_line, "pcode_generate_record(%s): invalid number of parameters %"PRIdMAX"", function_name(ctx), (intmax_t)instr_params));
3001
3002 var = u_pcode_get();
3003 fn_var = pcode_get();
3004 idx = u_pcode_get();
3005 if (unlikely(fn_var != -1))
3006 continue;
3007 if (unlikely(var != (pcode_t)(frame_t)var))
3008 goto exception_overflow;
3009 ajla_assert_lo((size_t)idx == ctx->record_entries_len, (file_line, "pcode_generate_record(%s): invalid index: %"PRIdMAX" != %"PRIuMAX"", function_name(ctx), (intmax_t)idx, (uintmax_t)ctx->record_entries_len));
3010
3011 if (unlikely(!array_add_mayfail(frame_t, &ctx->record_entries, &ctx->record_entries_len, var, NULL, ctx->err)))
3012 goto exception;
3013
3014 if (var_elided(var))
3015 continue;
3016
3017 p = get_var_type(ctx, var);
3018 t = p->type;
3019
3020 if (unlikely(!layout_add(ctx->layout, maximum(t->size, 1), t->align, ctx->err)))
3021 goto exception;
3022 }
3023 }
3024
3025 array_finish(frame_t, &ctx->record_entries, &ctx->record_entries_len);
3026
3027 if (unlikely(ctx->record_entries_len != (size_t)(arg_t)ctx->record_entries_len))
3028 goto exception_overflow;
3029
3030 if (unlikely(!layout_compute(ctx->layout, false, ctx->err)))
3031 goto exception;
3032
3033
3034 def = type_alloc_record_definition(layout_size(ctx->layout), ctx->err);
3035 if (unlikely(!def))
3036 goto exception;
3037 def->n_slots = layout_size(ctx->layout);
3038 def->alignment = maximum(layout_alignment(ctx->layout), frame_align);
3039 def->n_entries = (arg_t)ctx->record_entries_len;
3040
3041 layout_idx = 0;
3042 for (ai = 0; ai < ctx->record_entries_len; ai++) {
3043 frame_t var, slot;
3044 const struct pcode_type *te;
3045 var = ctx->record_entries[ai];
3046 if (var_elided((pcode_t)var)) {
3047 ctx->record_entries[ai] = NO_FRAME_T;
3048 continue;
3049 }
3050 slot = layout_get(ctx->layout, layout_idx++);
3051 ctx->record_entries[ai] = slot;
3052 te = get_var_type(ctx, (pcode_t)var);
3053 def->types[slot] = te->type;
3054 }
3055
3056 def->idx_to_frame = ctx->record_entries, ctx->record_entries = NULL;
3057 ctx->record_definition = def;
3058
3059 layout_free(ctx->layout), ctx->layout = NULL;
3060
3061 return true;
3062
3063 exception_overflow:
3064 *ctx->err = error_ajla(EC_ASYNC, AJLA_ERROR_SIZE_OVERFLOW);
3065 exception:
3066 return false;
3067 }
3068
3069 /*
3070 * pointer_empty -> ret_ex
3071 * poitner_mark -> err
3072 * other -> thunk(error) or data(function)
3073 */
3074 static pointer_t pcode_build_function_core(frame_s *fp, const code_t *ip, const pcode_t *pcode, size_t size, const struct module_designator *md, const struct function_designator *fd, void **ret_ex, ajla_error_t *err)
3075 {
3076 frame_t v;
3077 pcode_t p, q, subfns;
3078
3079 size_t is;
3080
3081 struct data *ft, *fn;
3082 struct function_descriptor *sfd;
3083 bool is_saved;
3084
3085 #if defined(HAVE_CODEGEN)
3086 union internal_arg ia[1];
3087 #endif
3088
3089 struct build_function_context ctx_;
3090 struct build_function_context *ctx = &ctx_;
3091
3092 init_ctx(ctx);
3093 ctx->err = err;
3094 ctx->pcode = pcode;
3095 ctx->pcode_limit = pcode + size;
3096 ctx->is_eval = !fp;
3097
3098 q = u_pcode_get() & Fn_Mask;
3099 ajla_assert_lo(q == Fn_Function || q == Fn_Record || q == Fn_Option, (file_line, "pcode_build_function_core: invalid function type %"PRIdMAX"", (intmax_t)q));
3100 ctx->function_type = q;
3101
3102 u_pcode_get(); /* call mode - used by the optimizer */
3103
3104 subfns = u_pcode_get();
3105
3106 ctx->n_local_types = u_pcode_get();
3107
3108 q = u_pcode_get();
3109 ctx->n_local_variables = (frame_t)q;
3110 if (unlikely(q != (pcode_t)ctx->n_local_variables))
3111 goto exception_overflow;
3112
3113 q = u_pcode_get();
3114 ctx->n_arguments = (arg_t)q;
3115 ajla_assert_lo(q == (pcode_t)ctx->n_arguments, (file_line, "pcode_build_function_core: overflow in n_arguments"));
3116
3117 q = u_pcode_get();
3118 ctx->n_return_values = (arg_t)q;
3119 ajla_assert_lo(q == (pcode_t)ctx->n_return_values, (file_line, "pcode_build_function_core: overflow in n_return_values"));
3120
3121 ajla_assert_lo((arg_t)ctx->n_arguments <= ctx->n_local_variables, (file_line, "pcode_build_function_core: invalid ctx->n_arguments or ctx->n_local_variables"));
3122
3123 q = u_pcode_get();
3124 ctx->n_real_return_values = (arg_t)q;
3125 ajla_assert_lo(ctx->n_real_return_values <= ctx->n_return_values, (file_line, "pcode_build_function_core: invalid n_real_return_values"));
3126
3127 ctx->n_labels = u_pcode_get();
3128
3129 if (unlikely(!pcode_load_blob(ctx, &ctx->function_name, &is)))
3130 goto exception;
3131 if (unlikely(!array_add_mayfail(uint8_t, &ctx->function_name, &is, 0, NULL, ctx->err)))
3132 goto exception;
3133 array_finish(uint8_t, &ctx->function_name, &is);
3134
3135 while (subfns--) {
3136 q = u_pcode_get();
3137 while (q--)
3138 pcode_get();
3139 }
3140
3141 ctx->local_types = mem_alloc_array_mayfail(mem_alloc_mayfail, struct local_type *, 0, 0, ctx->n_local_types, sizeof(struct local_type), ctx->err);
3142 if (unlikely(!ctx->local_types))
3143 goto exception;
3144
3145 for (p = 0; p < ctx->n_local_types; p++) {
3146 pointer_t *ptr;
3147 struct data *rec_fn;
3148 const struct record_definition *def;
3149 pcode_t base_idx, n_elements;
3150 struct type_entry *flat_rec;
3151 arg_t ai;
3152 const struct type *tt, *tp;
3153
3154 q = pcode_get();
3155 switch (q) {
3156 case Local_Type_Record:
3157 ptr = pcode_module_load_function(ctx);
3158 if (unlikely(!ptr))
3159 goto exception;
3160 pointer_follow(ptr, false, rec_fn, PF_WAIT, fp, ip,
3161 *ret_ex = ex_;
3162 ctx->ret_val = pointer_empty();
3163 goto ret,
3164 thunk_reference(thunk_);
3165 ctx->ret_val = pointer_thunk(thunk_);
3166 goto ret;
3167 );
3168 ajla_assert_lo(da(rec_fn,function)->record_definition != NULL, (file_line, "pcode_build_function_core(%s): record has no definition", function_name(ctx)));
3169 def = type_def(da(rec_fn,function)->record_definition,record);
3170 tt = &def->type;
3171 break;
3172 case Local_Type_Flat_Record:
3173 base_idx = u_pcode_get();
3174 ajla_assert_lo(base_idx < p, (file_line, "pcode_build_function_core(%s): invalid base record index: %"PRIdMAX" >= %"PRIdMAX"", function_name(ctx), (intmax_t)base_idx, (intmax_t)p));
3175 n_elements = u_pcode_get();
3176 def = type_def(ctx->local_types[base_idx].type,record);
3177 ajla_assert_lo(n_elements == (pcode_t)def->n_entries, (file_line, "pcode_build_function_core(%s): the number of entries doesn't match: %"PRIdMAX" != %"PRIuMAX"", function_name(ctx), (intmax_t)n_elements, (uintmax_t)def->n_entries));
3178 flat_rec = type_prepare_flat_record(&def->type, ctx->err);
3179 if (unlikely(!flat_rec))
3180 goto record_not_flattened;
3181 for (ai = 0; ai < def->n_entries; ai++) {
3182 pcode_t typ = pcode_get();
3183 tp = pcode_to_type(ctx, typ, NULL);
3184 if (unlikely(!TYPE_IS_FLAT(tp))) {
3185 type_free_flat_record(flat_rec);
3186 goto record_not_flattened;
3187 }
3188 type_set_flat_record_entry(flat_rec, ai, tp);
3189 }
3190 tt = type_get_flat_record(flat_rec, ctx->err);
3191 if (unlikely(!tt))
3192 goto record_not_flattened;
3193 break;
3194 record_not_flattened:
3195 tt = &def->type;
3196 break;
3197 case Local_Type_Flat_Array:
3198 base_idx = pcode_get();
3199 n_elements = pcode_get();
3200 tp = pcode_to_type(ctx, base_idx, NULL);
3201 if (unlikely(!TYPE_IS_FLAT(tp)))
3202 goto array_not_flattened;
3203 if (unlikely(n_elements > signed_maximum(int_default_t) + zero))
3204 goto array_not_flattened;
3205 tt = type_get_flat_array(tp, n_elements, ctx->err);
3206 if (unlikely(!tt))
3207 goto array_not_flattened;
3208 break;
3209 array_not_flattened:
3210 tt = type_get_unknown();
3211 break;
3212 default:
3213 internal(file_line, "pcode_build_function_core(%s): invalid local type %"PRIdMAX"", function_name(ctx), (intmax_t)q);
3214 }
3215 ctx->local_types[p].type = tt;
3216 ctx->local_types[p].type_index = no_type_index;
3217 }
3218
3219 ctx->layout = layout_start(slot_bits, frame_flags_per_slot_bits, frame_align, frame_offset, ctx->err);
3220 if (unlikely(!ctx->layout))
3221 goto exception;
3222
3223 ctx->pcode_types = mem_alloc_array_mayfail(mem_alloc_mayfail, struct pcode_type *, 0, 0, ctx->n_local_variables, sizeof(struct pcode_type), ctx->err);
3224 if (unlikely(!ctx->pcode_types))
3225 goto exception;
3226
3227 if (unlikely(!array_init_mayfail(struct color, &ctx->colors, &ctx->n_colors, ctx->err)))
3228 goto exception;
3229 is = 0;
3230 for (v = 0; v < ctx->n_local_variables; v++) {
3231 struct pcode_type *pt;
3232 pcode_t typ, color, varflags;
3233
3234 pcode_get();
3235 typ = pcode_get();
3236 color = pcode_get();
3237 varflags = u_pcode_get();
3238 pcode_load_blob(ctx, NULL, NULL);
3239 pt = &ctx->pcode_types[v];
3240 pt->argument = NULL;
3241 pt->extra_type = 0;
3242 pt->varflags = varflags;
3243
3244 if (color == -1) {
3245 pt->type = NULL;
3246 } else {
3247 const struct type *t = pcode_to_type(ctx, typ, NULL);
3248 struct color empty_color = { 0, 0, false };
3249 is++;
3250
3251 pt->type = t;
3252 pt->color = color;
3253 if (typ < 0 && !pcode_get_type(typ))
3254 pt->extra_type = typ;
3255 while ((size_t)color >= ctx->n_colors)
3256 if (unlikely(!array_add_mayfail(struct color, &ctx->colors, &ctx->n_colors, empty_color, NULL, ctx->err)))
3257 goto exception;
3258
3259
3260 if (!ctx->colors[color].align) {
3261 ctx->colors[color].size = t->size;
3262 ctx->colors[color].align = t->align;
3263 } else {
3264 ajla_assert_lo(ctx->colors[color].size == t->size &&
3265 ctx->colors[color].align == t->align,
3266 (file_line, "pcode_build_function_core(%s): mismatching variables are put into the same slot: %u != %u || %u != %u", function_name(ctx), ctx->colors[color].size, t->size, ctx->colors[color].align, t->align));
3267 }
3268
3269 }
3270 }
3271 /*debug("n_local_variables: %s: %u * %zu = %zu (valid %zu, colors %zu, pcode %zu / %zu)", function_name(ctx), ctx->n_local_variables, sizeof(struct pcode_type), ctx->n_local_variables * sizeof(struct pcode_type), is, ctx->n_colors, ctx->pcode - pcode, ctx->pcode_limit - ctx->pcode);*/
3272
3273 for (is = 0; is < ctx->n_colors; is++) {
3274 const struct color *c = &ctx->colors[is];
3275 if (c->align) {
3276 if (unlikely(!layout_add(ctx->layout, maximum(c->size, 1), c->align, ctx->err)))
3277 goto exception;
3278 } else {
3279 if (unlikely(!layout_add(ctx->layout, 0, 1, ctx->err)))
3280 goto exception;
3281 }
3282 }
3283
3284 if (unlikely(!layout_compute(ctx->layout, false, ctx->err)))
3285 goto exception;
3286
3287 ctx->n_slots = layout_size(ctx->layout);
3288
3289 ctx->local_variables = mem_alloc_array_mayfail(mem_calloc_mayfail, struct local_variable *, 0, 0, ctx->n_slots, sizeof(struct local_variable), ctx->err);
3290 if (unlikely(!ctx->local_variables))
3291 goto exception;
3292
3293 ctx->local_variables_flags = mem_alloc_array_mayfail(mem_calloc_mayfail, struct local_variable_flags *, 0, 0, ctx->n_slots, sizeof(struct local_variable_flags), ctx->err);
3294 if (unlikely(!ctx->local_variables_flags))
3295 goto exception;
3296
3297 for (v = 0; v < ctx->n_local_variables; v++) {
3298 struct pcode_type *pt = &ctx->pcode_types[v];
3299 if (!pt->type) {
3300 pt->slot = NO_FRAME_T;
3301 } else {
3302 pt->slot = layout_get(ctx->layout, pt->color);
3303 ctx->local_variables[pt->slot].type = pt->type;
3304 /*ctx->local_variables_flags[pt->slot].may_be_borrowed = false;*/
3305 ctx->local_variables_flags[pt->slot].must_be_flat = !!(pt->varflags & VarFlag_Must_Be_Flat) /*|| TYPE_TAG_IS_BUILTIN(pt->type->tag)*/;
3306 }
3307 }
3308
3309 layout_free(ctx->layout), ctx->layout = NULL;
3310
3311 #if 0
3312 {
3313 unsigned n_elided = 0;
3314 for (v = 0; v < ctx->n_local_variables; v++) {
3315 struct pcode_type *pt = &ctx->pcode_types[v];
3316 if (!pt->type)
3317 n_elided++;
3318 }
3319 debug("function, elided %d/%d", n_elided, ctx->n_local_variables);
3320 }
3321 #endif
3322
3323 if (unlikely(!array_init_mayfail(pointer_t *, &ctx->ld, &ctx->ld_len, ctx->err)))
3324 goto exception;
3325
3326 if (unlikely(!pcode_preload_ld(ctx)))
3327 goto exception;
3328
3329 if (md) {
3330 sfd = save_find_function_descriptor(md, fd);
3331 } else {
3332 sfd = NULL;
3333 }
3334
3335 is_saved = false;
3336 if (sfd) {
3337 ctx->code = sfd->code;
3338 ctx->code_len = sfd->code_size;
3339 ft = sfd->types;
3340 is_saved = true;
3341 goto skip_codegen;
3342 }
3343
3344 ctx->labels = mem_alloc_array_mayfail(mem_alloc_mayfail, size_t *, 0, 0, ctx->n_labels, sizeof(size_t), ctx->err);
3345 if (unlikely(!ctx->labels))
3346 goto exception;
3347 for (p = 0; p < ctx->n_labels; p++)
3348 ctx->labels[p] = no_label;
3349
3350 if (unlikely(!array_init_mayfail(struct label_ref, &ctx->label_ref, &ctx->label_ref_len, ctx->err)))
3351 goto exception;
3352
3353 if (unlikely(!array_init_mayfail(const struct type *, &ctx->types, &ctx->types_len, ctx->err)))
3354 goto exception;
3355
3356 if (unlikely(!array_init_mayfail(code_t, &ctx->code, &ctx->code_len, ctx->err)))
3357 goto exception;
3358
3359 if (unlikely(!array_init_mayfail(struct line_position, &ctx->lp, &ctx->lp_size, ctx->err)))
3360 goto exception;
3361
3362 if (unlikely(ctx->function_type == Fn_Record) || unlikely(ctx->function_type == Fn_Option)) {
3363 if (ctx->function_type == Fn_Record) {
3364 if (unlikely(!pcode_generate_record(ctx)))
3365 goto exception;
3366 }
3367 gen_code(OPCODE_UNREACHABLE);
3368 } else {
3369 if (unlikely(!pcode_generate_instructions(ctx)))
3370 goto exception;
3371 }
3372
3373 array_finish(code_t, &ctx->code, &ctx->code_len);
3374 array_finish(struct line_position, &ctx->lp, &ctx->lp_size);
3375
3376 for (is = 0; is < ctx->label_ref_len; is++) {
3377 uint32_t diff;
3378 struct label_ref *lr = &ctx->label_ref[is];
3379 ajla_assert_lo(lr->label < ctx->n_labels, (file_line, "pcode_build_function_core(%s): invalid label %"PRIdMAX"", function_name(ctx), (intmax_t)lr->label));
3380 ajla_assert_lo(ctx->labels[lr->label] != no_label, (file_line, "pcode_build_function_core(%s): label %"PRIdMAX" was not defined", function_name(ctx), (intmax_t)lr->label));
3381 diff = ((uint32_t)ctx->labels[lr->label] - (uint32_t)lr->code_pos) * sizeof(code_t);
3382 if (SIZEOF_IP_T == 2) {
3383 ctx->code[lr->code_pos] += (code_t)diff;
3384 } else if (SIZEOF_IP_T == 4 && !CODE_ENDIAN) {
3385 uint32_t val = ctx->code[lr->code_pos] | ((uint32_t)ctx->code[lr->code_pos + 1] << 16);
3386 val += diff;
3387 ctx->code[lr->code_pos] = val & 0xffff;
3388 ctx->code[lr->code_pos + 1] = val >> 16;
3389 } else if (SIZEOF_IP_T == 4 && CODE_ENDIAN) {
3390 uint32_t val = ((uint32_t)ctx->code[lr->code_pos] << 16) | ctx->code[lr->code_pos + 1];
3391 val += diff;
3392 ctx->code[lr->code_pos] = val >> 16;
3393 ctx->code[lr->code_pos + 1] = val & 0xffff;
3394 } else {
3395 not_reached();
3396 }
3397 }
3398
3399 mem_free(ctx->labels), ctx->labels = NULL;
3400 mem_free(ctx->label_ref), ctx->label_ref = NULL;
3401
3402 ft = data_alloc_flexible(function_types, types, ctx->types_len, ctx->err);
3403 if (unlikely(!ft))
3404 goto exception;
3405 da(ft,function_types)->n_types = ctx->types_len;
3406 memcpy(da(ft,function_types)->types, ctx->types, ctx->types_len * sizeof(const struct type *));
3407 mem_free(ctx->types);
3408 ctx->types = NULL;
3409 ctx->ft_free = ft;
3410
3411 skip_codegen:
3412
3413 mem_free(ctx->colors), ctx->colors = NULL;
3414 mem_free(ctx->pcode_types), ctx->pcode_types = NULL;
3415 mem_free(ctx->local_types), ctx->local_types = NULL;
3416 free_ld_tree(ctx);
3417 array_finish(pointer_t *, &ctx->ld, &ctx->ld_len);
3418
3419 if (profiling_escapes) {
3420 ctx->escape_data = mem_alloc_array_mayfail(mem_calloc_mayfail, struct escape_data *, 0, 0, ctx->code_len, sizeof(struct escape_data), ctx->err);
3421 if (unlikely(!ctx->escape_data))
3422 goto exception;
3423 }
3424
3425 fn = data_alloc_flexible(function, local_directory, ctx->ld_len, ctx->err);
3426 if (unlikely(!fn))
3427 goto exception;
3428
3429 da(fn,function)->frame_slots = frame_offset / slot_size + ctx->n_slots;
3430 da(fn,function)->n_bitmap_slots = bitmap_slots(ctx->n_slots);
3431 da(fn,function)->n_arguments = ctx->n_real_arguments;
3432 da(fn,function)->n_return_values = ctx->n_real_return_values;
3433 da(fn,function)->code = ctx->code;
3434 da(fn,function)->code_size = ctx->code_len;
3435 da(fn,function)->local_variables = ctx->local_variables;
3436 if (!is_saved) {
3437 da(fn,function)->local_variables_flags = ctx->local_variables_flags;
3438 } else {
3439 mem_free(ctx->local_variables_flags);
3440 da(fn,function)->local_variables_flags = sfd->local_variables_flags;
3441 }
3442 da(fn,function)->args = ctx->args;
3443 da(fn,function)->types_ptr = pointer_data(ft);
3444 da(fn,function)->record_definition = ctx->record_definition ? &ctx->record_definition->type : NULL;
3445 da(fn,function)->function_name = cast_ptr(char *, ctx->function_name);
3446 da(fn,function)->module_designator = md;
3447 da(fn,function)->function_designator = fd;
3448 if (!is_saved) {
3449 da(fn,function)->lp = ctx->lp;
3450 da(fn,function)->lp_size = ctx->lp_size;
3451 } else {
3452 da(fn,function)->lp = sfd->lp;
3453 da(fn,function)->lp_size = sfd->lp_size;
3454 }
3455 memcpy(da(fn,function)->local_directory, ctx->ld, ctx->ld_len * sizeof(pointer_t *));
3456 da(fn,function)->local_directory_size = ctx->ld_len;
3457 mem_free(ctx->ld);
3458 #ifdef HAVE_CODEGEN
3459 ia[0].ptr = fn;
3460 da(fn,function)->codegen = function_build_internal_thunk(codegen_fn, 1, ia);
3461 store_relaxed(&da(fn,function)->codegen_failed, 0);
3462 #endif
3463 function_init_common(fn);
3464
3465 if (sfd) {
3466 /*if (memcmp(ctx->code, sfd->code, ctx->code_len * sizeof(code_t))) internal(file_line, "code mismatch");*/
3467 da(fn,function)->loaded_cache = sfd->data_saved_cache;
3468 /*if (da(fn,function)->loaded_cache) debug("loaded cache: %s", function_name(ctx));*/
3469 }
3470
3471 da(fn,function)->escape_data = ctx->escape_data;
3472 da(fn,function)->leaf = ctx->leaf;
3473 da(fn,function)->is_saved = is_saved;
3474
3475 ipret_prefetch_functions(fn);
3476
3477 return pointer_data(fn);
3478
3479 exception_overflow:
3480 *ctx->err = error_ajla(EC_ASYNC, AJLA_ERROR_SIZE_OVERFLOW);
3481 exception:
3482 ctx->ret_val = pointer_mark();
3483 ret:
3484 done_ctx(ctx);
3485 return ctx->ret_val;
3486 }
3487
3488 static void *pcode_build_function(frame_s *fp, const code_t *ip, const pcode_t *pcode, size_t size, const struct module_designator *md, const struct function_designator *fd)
3489 {
3490 pointer_t ptr;
3491 void *ex;
3492 ajla_error_t err;
3493 ptr = pcode_build_function_core(fp, ip, pcode, size, md, fd, &ex, &err);
3494 if (unlikely(pointer_is_empty(ptr)))
3495 return ex;
3496 if (unlikely(pointer_is_mark(ptr)))
3497 return function_return(fp, pointer_error(err, NULL, NULL pass_file_line));
3498 return function_return(fp, ptr);
3499 }
3500
3501 void *pcode_build_function_from_builtin(frame_s *fp, const code_t *ip, union internal_arg arguments[])
3502 {
3503 const pcode_t *start;
3504 size_t size;
3505 struct module_designator *md = arguments[0].ptr;
3506 struct function_designator *fd = arguments[1].ptr;
3507 builtin_find_function(md->path, md->path_len, fd->n_entries, fd->entries, &start, &size);
3508 return pcode_build_function(fp, ip, start, size, md, arguments[1].ptr);
3509 }
3510
3511 void *pcode_build_function_from_array(frame_s *fp, const code_t *ip, union internal_arg arguments[])
3512 {
3513 pointer_t *ptr;
3514 void *ex;
3515 struct thunk *thunk;
3516 char *bytes;
3517 size_t bytes_l;
3518 const struct function_designator *fd;
3519 const pcode_t *start;
3520 size_t size;
3521
3522 ptr = arguments[0].ptr;
3523 ex = pointer_deep_eval(ptr, fp, ip, &thunk);
3524 if (unlikely(ex != POINTER_FOLLOW_THUNK_GO)) {
3525 if (ex == POINTER_FOLLOW_THUNK_EXCEPTION) {
3526 return function_return(fp, pointer_thunk(thunk));
3527 }
3528 return ex;
3529 }
3530
3531 array_to_bytes(ptr, &bytes, &bytes_l);
3532 bytes_l--;
3533
3534 if (unlikely(bytes_l % sizeof(pcode_t) != 0))
3535 internal(file_line, "pcode_build_function_from_array: invalid length: %lu", (unsigned long)bytes_l);
3536
3537 start = cast_ptr(const pcode_t *, bytes);
3538 size = bytes_l / sizeof(pcode_t);
3539 fd = arguments[2].ptr;
3540
3541 /*builtin_walk_nested(&start, &size, fd->n_entries, fd->entries);*/
3542
3543 ex = pcode_build_function(fp, ip, start, size, arguments[1].ptr, fd);
3544
3545 mem_free(bytes);
3546
3547 return ex;
3548 }
3549
3550 void *pcode_array_from_builtin(frame_s *fp, const code_t attr_unused *ip, union internal_arg arguments[])
3551 {
3552 const struct type *t;
3553 struct data *d;
3554 ajla_error_t err;
3555 const pcode_t *start;
3556 size_t size;
3557 struct module_designator *md = arguments[0].ptr;
3558 struct function_designator *fd = arguments[1].ptr;
3559
3560 builtin_find_function(md->path, md->path_len, fd->n_entries, fd->entries, &start, &size);
3561
3562 t = type_get_fixed(log_2(sizeof(pcode_t)), false);
3563 d = data_alloc_array_flat_mayfail(t, size, size, false, &err pass_file_line);
3564 if (unlikely(!d)) {
3565 return function_return(fp, pointer_thunk(thunk_alloc_exception_error(err, NULL, NULL, NULL pass_file_line)));
3566 }
3567
3568 memcpy(da_array_flat(d), start, size * sizeof(pcode_t));
3569
3570 return function_return(fp, pointer_data(d));
3571 }
3572
3573
3574 pointer_t pcode_build_eval_function(pcode_t src_type, pcode_t dest_type, pcode_t op, pcode_t *blob_1, size_t blob_1_len, pcode_t *blob_2, size_t blob_2_len, ajla_error_t *err)
3575 {
3576 pcode_t *pc = NULL;
3577 size_t pc_l;
3578 unsigned n_local_variables;
3579 unsigned n_arguments;
3580 unsigned i;
3581 pointer_t ptr;
3582
3583 if (unlikely(!array_init_mayfail(pcode_t, &pc, &pc_l, err)))
3584 goto ret_err;
3585 #define add(x) \
3586 do { \
3587 if (unlikely(!array_add_mayfail(pcode_t, &pc, &pc_l, x, NULL, err)))\
3588 goto ret_err; \
3589 } while (0)
3590 #define addstr(x, l) \
3591 do { \
3592 if (unlikely(!array_add_multiple_mayfail(pcode_t, &pc, &pc_l, x, l, NULL, err)))\
3593 goto ret_err; \
3594 } while (0)
3595
3596 n_local_variables = Op_IsUnary(op) ? 2 : 3;
3597 n_arguments = n_local_variables - 1;
3598
3599 add(Fn_Function);
3600 add(Call_Mode_Strict);
3601 add(0);
3602 add(0);
3603 add(n_local_variables);
3604 add(0);
3605 add(1);
3606 add(1);
3607 add(0);
3608 add(0);
3609
3610 for (i = 0; i < n_local_variables; i++) {
3611 pcode_t t = i < n_arguments ? src_type : dest_type;
3612 add(t);
3613 add(t);
3614 add(i);
3615 add(0);
3616 add(0);
3617 }
3618
3619 add(P_Args);
3620 add(0);
3621
3622 add(P_Load_Const);
3623 add(1 + blob_1_len);
3624 add(0);
3625 addstr(blob_1, blob_1_len);
3626 if (n_arguments == 2) {
3627 add(P_Load_Const);
3628 add(1 + blob_2_len);
3629 add(1);
3630 addstr(blob_2, blob_2_len);
3631 }
3632
3633 add(Op_IsUnary(op) ? P_UnaryOp : P_BinaryOp);
3634 add(Op_IsUnary(op) ? 4 : 6);
3635 add(op);
3636 add(n_arguments);
3637 add(Flag_Free_Argument | Flag_Op_Strict);
3638 add(0);
3639 if (n_arguments == 2) {
3640 add(Flag_Free_Argument);
3641 add(1);
3642 }
3643
3644 add(P_Return);
3645 add(2);
3646 add(Flag_Free_Argument);
3647 add(n_arguments);
3648
3649 #undef add
3650 #undef addstr
3651
3652 ptr = pcode_build_function_core(NULL, NULL, pc, pc_l, NULL, NULL, NULL, err);
3653
3654 mem_free(pc);
3655
3656 return ptr;
3657
3658 ret_err:
3659 if (pc)
3660 mem_free(pc);
3661 return pointer_empty();
3662 }
3663
3664
3665 static void *pcode_alloc_op_function(pointer_t *ptr, frame_s *fp, const code_t *ip, void *(*build_fn)(frame_s *fp, const code_t *ip, union internal_arg ia[]), unsigned n_arguments, union internal_arg ia[], pointer_t **result)
3666 {
3667 struct data *function;
3668 pointer_t fn_thunk;
3669
3670 #ifdef POINTER_FOLLOW_IS_LOCKLESS
3671 const addrlock_depth lock_depth = DEPTH_THUNK;
3672 #else
3673 const addrlock_depth lock_depth = DEPTH_POINTER;
3674 #endif
3675
3676 again:
3677 pointer_follow(ptr, false, function, PF_WAIT, fp, ip,
3678 return ex_,
3679 *result = ptr;
3680 return POINTER_FOLLOW_THUNK_RETRY);
3681
3682 if (likely(function != NULL)) {
3683 *result = ptr;
3684 return POINTER_FOLLOW_THUNK_RETRY;
3685 }
3686
3687 fn_thunk = function_build_internal_thunk(build_fn, n_arguments, ia);
3688
3689 barrier_write_before_lock();
3690 address_lock(ptr, lock_depth);
3691 if (likely(pointer_is_empty(*pointer_volatile(ptr)))) {
3692 *pointer_volatile(ptr) = fn_thunk;
3693 address_unlock(ptr, lock_depth);
3694 } else {
3695 address_unlock(ptr, lock_depth);
3696 pointer_dereference(fn_thunk);
3697 }
3698
3699 goto again;
3700 }
3701
3702 static void *pcode_build_op_function(frame_s *fp, const code_t *ip, union internal_arg a[])
3703 {
3704 pcode_t src_type = (pcode_t)a[0].i;
3705 pcode_t dest_type = (pcode_t)a[1].i;
3706 pcode_t op = (pcode_t)a[2].i;
3707 unsigned flags = (unsigned)a[3].i;
3708 unsigned i;
3709 unsigned n_local_variables;
3710 unsigned n_arguments;
3711 pcode_t pcode[41];
3712 pcode_t *pc = pcode;
3713
3714 n_local_variables = flags & PCODE_FIND_OP_UNARY ? 2 : 3;
3715 n_arguments = n_local_variables - 1;
3716
3717 *pc++ = Fn_Function;
3718 *pc++ = Call_Mode_Strict;
3719 *pc++ = 0;
3720 *pc++ = 0;
3721 *pc++ = (pcode_t)n_local_variables;
3722 *pc++ = (pcode_t)n_arguments;
3723 *pc++ = 1;
3724 *pc++ = 1;
3725 *pc++ = 0;
3726 *pc++ = 0;
3727
3728 for (i = 0; i < n_local_variables; i++) {
3729 pcode_t t = i < n_arguments ? src_type : dest_type;
3730 *pc++ = t;
3731 *pc++ = t;
3732 *pc++ = i;
3733 *pc++ = 0;
3734 *pc++ = 0;
3735 }
3736
3737 *pc++ = P_Args;
3738 *pc++ = n_arguments;
3739 for (i = 0; i < n_arguments; i++)
3740 *pc++ = i;
3741
3742 *pc++ = (pcode_t)(flags & PCODE_FIND_OP_UNARY ? P_UnaryOp : P_BinaryOp);
3743 *pc++ = (pcode_t)(flags & PCODE_FIND_OP_UNARY ? 4 : 6);
3744 *pc++ = op;
3745 *pc++ = (pcode_t)n_arguments;
3746 *pc++ = Flag_Free_Argument | Flag_Op_Strict;
3747 *pc++ = 0;
3748 if (!(flags & PCODE_FIND_OP_UNARY)) {
3749 *pc++ = Flag_Free_Argument;
3750 *pc++ = 1;
3751 }
3752
3753 *pc++ = P_Return;
3754 *pc++ = 2;
3755 *pc++ = Flag_Free_Argument;
3756 *pc++ = n_arguments;
3757
3758 ajla_assert_lo((size_t)(pc - pcode) <= n_array_elements(pcode), (file_line, "pcode_build_op_function: array overflow: %"PRIdMAX" > %"PRIdMAX", src_type %"PRIdMAX", dest_type %"PRIdMAX", op %"PRIdMAX"", (intmax_t)(pc - pcode), (intmax_t)n_array_elements(pcode), (intmax_t)src_type, (intmax_t)dest_type, (intmax_t)op));
3759
3760 return pcode_build_function(fp, ip, pcode, pc - pcode, NULL, NULL);
3761 }
3762
3763 static pointer_t fixed_op_thunk[TYPE_FIXED_N][OPCODE_FIXED_OP_N];
3764 static pointer_t int_op_thunk[TYPE_INT_N][OPCODE_INT_OP_N];
3765 static pointer_t real_op_thunk[TYPE_REAL_N][OPCODE_REAL_OP_N];
3766 static pointer_t bool_op_thunk[OPCODE_BOOL_TYPE_MULT];
3767
3768 void * attr_fastcall pcode_find_op_function(const struct type *type, const struct type *rtype, code_t code, unsigned flags, frame_s *fp, const code_t *ip, pointer_t **result)
3769 {
3770 union internal_arg ia[4];
3771 pointer_t *ptr;
3772
3773 type_tag_t tag = likely(!(flags & PCODE_CONVERT_FROM_INT)) ? type->tag : rtype->tag;
3774
3775 if (TYPE_TAG_IS_FIXED(tag)) {
3776 unsigned idx = (code - OPCODE_FIXED_OP - (TYPE_TAG_IDX_FIXED(tag) >> 1) * OPCODE_FIXED_TYPE_MULT) / OPCODE_FIXED_OP_MULT;
3777 ajla_assert(idx < OPCODE_FIXED_OP_N, (file_line, "pcode_find_op_function: invalid parameters, type %u, code %04x", tag, code));
3778 ptr = &fixed_op_thunk[TYPE_TAG_IDX_FIXED(tag) >> 1][idx];
3779 } else if (TYPE_TAG_IS_INT(tag)) {
3780 unsigned idx = (code - OPCODE_INT_OP - TYPE_TAG_IDX_INT(tag) * OPCODE_INT_TYPE_MULT) / OPCODE_INT_OP_MULT;
3781 ajla_assert(idx < OPCODE_INT_OP_N, (file_line, "pcode_find_op_function: invalid parameters, type %u, code %04x", tag, code));
3782 ptr = &int_op_thunk[TYPE_TAG_IDX_INT(tag)][idx];
3783 ajla_assert(is_power_of_2(type->size), (file_line, "pcode_find_op_function: invalid integer type size %"PRIuMAX"", (uintmax_t)type->size));
3784 } else if (TYPE_TAG_IS_REAL(tag)) {
3785 unsigned idx = (code - OPCODE_REAL_OP - TYPE_TAG_IDX_REAL(tag) * OPCODE_REAL_TYPE_MULT) / OPCODE_REAL_OP_MULT;
3786 ajla_assert(idx < OPCODE_REAL_OP_N, (file_line, "pcode_find_op_function: invalid parameters, type %u, code %04x", tag, code));
3787 ptr = &real_op_thunk[TYPE_TAG_IDX_REAL(tag)][idx];
3788 } else if (tag) {
3789 unsigned idx = (code - OPCODE_BOOL_OP) / OPCODE_BOOL_OP_MULT;
3790 ajla_assert(idx < OPCODE_BOOL_OP_N, (file_line, "pcode_find_op_function: invalid parameters, type %u, code %04x", tag, code));
3791 ptr = &bool_op_thunk[idx];
3792 } else {
3793 internal(file_line, "pcode_find_op_function: invalid type %u", tag);
3794 }
3795
3796 ia[0].i = type_to_pcode(type);
3797 ia[1].i = type_to_pcode(rtype);
3798 ia[2].i = code + Op_N;
3799 ia[3].i = flags;
3800
3801 return pcode_alloc_op_function(ptr, fp, ip, pcode_build_op_function, 4, ia, result);
3802 }
3803
3804 static void *pcode_build_is_exception_function(frame_s *fp, const code_t *ip, union internal_arg attr_unused a[])
3805 {
3806 pcode_t pcode[36];
3807 pcode_t *pc = pcode;
3808
3809 *pc++ = Fn_Function;
3810 *pc++ = Call_Mode_Strict;
3811 *pc++ = 0;
3812 *pc++ = 0;
3813 *pc++ = 2;
3814 *pc++ = 1;
3815 *pc++ = 1;
3816 *pc++ = 1;
3817 *pc++ = 0;
3818 *pc++ = 0;
3819
3820 *pc++ = T_Undetermined;
3821 *pc++ = T_Undetermined;
3822 *pc++ = 0;
3823 *pc++ = 0;
3824 *pc++ = 0;
3825
3826 *pc++ = T_FlatOption;
3827 *pc++ = T_FlatOption;
3828 *pc++ = 1;
3829 *pc++ = 0;
3830 *pc++ = 0;
3831
3832 *pc++ = P_Args;
3833 *pc++ = 1;
3834 *pc++ = 0;
3835
3836 *pc++ = P_UnaryOp;
3837 *pc++ = 4;
3838 *pc++ = Un_IsException;
3839 *pc++ = 1;
3840 *pc++ = Flag_Free_Argument | Flag_Op_Strict;
3841 *pc++ = 0;
3842
3843 *pc++ = P_Free;
3844 *pc++ = 1;
3845 *pc++ = 0;
3846
3847 *pc++ = P_Return;
3848 *pc++ = 2;
3849 *pc++ = Flag_Free_Argument;
3850 *pc++ = 1;
3851
3852 ajla_assert_lo((size_t)(pc - pcode) == n_array_elements(pcode), (file_line, "pcode_build_is_exception_function: array overflow: %"PRIdMAX" != %"PRIdMAX"", (intmax_t)(pc - pcode), (intmax_t)n_array_elements(pcode)));
3853
3854 return pcode_build_function(fp, ip, pcode, pc - pcode, NULL, NULL);
3855 }
3856
3857 static pointer_t is_exception_thunk;
3858
3859 void * attr_fastcall pcode_find_is_exception(frame_s *fp, const code_t *ip, pointer_t **result)
3860 {
3861 return pcode_alloc_op_function(&is_exception_thunk, fp, ip, pcode_build_is_exception_function, 0, NULL, result);
3862 }
3863
3864 static void *pcode_build_get_exception_function(frame_s *fp, const code_t *ip, union internal_arg a[])
3865 {
3866 pcode_t pcode[36];
3867 pcode_t *pc = pcode;
3868
3869 *pc++ = Fn_Function;
3870 *pc++ = Call_Mode_Strict;
3871 *pc++ = 0;
3872 *pc++ = 0;
3873 *pc++ = 2;
3874 *pc++ = 1;
3875 *pc++ = 1;
3876 *pc++ = 1;
3877 *pc++ = 0;
3878 *pc++ = 0;
3879
3880 *pc++ = T_Undetermined;
3881 *pc++ = T_Undetermined;
3882 *pc++ = 0;
3883 *pc++ = 0;
3884 *pc++ = 0;
3885
3886 *pc++ = T_Integer;
3887 *pc++ = T_Integer;
3888 *pc++ = 1;
3889 *pc++ = 0;
3890 *pc++ = 0;
3891
3892 *pc++ = P_Args;
3893 *pc++ = 1;
3894 *pc++ = 0;
3895
3896 *pc++ = P_UnaryOp;
3897 *pc++ = 4;
3898 *pc++ = Un_ExceptionClass + a[0].i;
3899 *pc++ = 1;
3900 *pc++ = Flag_Free_Argument | Flag_Op_Strict;
3901 *pc++ = 0;
3902
3903 *pc++ = P_Free;
3904 *pc++ = 1;
3905 *pc++ = 0;
3906
3907 *pc++ = P_Return;
3908 *pc++ = 2;
3909 *pc++ = Flag_Free_Argument;
3910 *pc++ = 1;
3911
3912 ajla_assert_lo((size_t)(pc - pcode) == n_array_elements(pcode), (file_line, "pcode_build_get_exception_function: array overflow: %"PRIdMAX" != %"PRIdMAX"", (intmax_t)(pc - pcode), (intmax_t)n_array_elements(pcode)));
3913
3914 return pcode_build_function(fp, ip, pcode, pc - pcode, NULL, NULL);
3915 }
3916
3917 static pointer_t get_exception_thunk[3];
3918
3919 void * attr_fastcall pcode_find_get_exception(unsigned mode, frame_s *fp, const code_t *ip, pointer_t **result)
3920 {
3921 union internal_arg ia[1];
3922 ia[0].i = mode;
3923 return pcode_alloc_op_function(&get_exception_thunk[mode], fp, ip, pcode_build_get_exception_function, 1, ia, result);
3924 }
3925
3926 static void *pcode_build_array_load_function(frame_s *fp, const code_t *ip, union internal_arg attr_unused a[])
3927 {
3928 pcode_t pcode[45];
3929 pcode_t *pc = pcode;
3930
3931 *pc++ = Fn_Function;
3932 *pc++ = Call_Mode_Strict;
3933 *pc++ = 0;
3934 *pc++ = 0;
3935 *pc++ = 3;
3936 *pc++ = 2;
3937 *pc++ = 1;
3938 *pc++ = 1;
3939 *pc++ = 0;
3940 *pc++ = 0;
3941
3942 *pc++ = T_Undetermined;
3943 *pc++ = T_Undetermined;
3944 *pc++ = 0;
3945 *pc++ = 0;
3946 *pc++ = 0;
3947
3948 *pc++ = T_Integer;
3949 *pc++ = T_Integer;
3950 *pc++ = 1;
3951 *pc++ = 0;
3952 *pc++ = 0;
3953
3954 *pc++ = T_Undetermined;
3955 *pc++ = T_Undetermined;
3956 *pc++ = 2;
3957 *pc++ = 0;
3958 *pc++ = 0;
3959
3960 *pc++ = P_Args;
3961 *pc++ = 2;
3962 *pc++ = 0;
3963 *pc++ = 1;
3964
3965 *pc++ = P_Array_Load;
3966 *pc++ = 4;
3967 *pc++ = 2;
3968 *pc++ = Flag_Evaluate;
3969 *pc++ = 0;
3970 *pc++ = 1;
3971
3972 *pc++ = P_Free;
3973 *pc++ = 1;
3974 *pc++ = 0;
3975
3976 *pc++ = P_Free;
3977 *pc++ = 1;
3978 *pc++ = 1;
3979
3980 *pc++ = P_Return;
3981 *pc++ = 2;
3982 *pc++ = Flag_Free_Argument;
3983 *pc++ = 2;
3984
3985 ajla_assert_lo((size_t)(pc - pcode) == n_array_elements(pcode), (file_line, "pcode_build_array_load_function: array mismatch: %"PRIdMAX" != %"PRIdMAX"", (intmax_t)(pc - pcode), (intmax_t)n_array_elements(pcode)));
3986
3987 return pcode_build_function(fp, ip, pcode, pc - pcode, NULL, NULL);
3988 }
3989
3990 static pointer_t array_load_thunk;
3991
3992 void * attr_fastcall pcode_find_array_load_function(frame_s *fp, const code_t *ip, pointer_t **result)
3993 {
3994 return pcode_alloc_op_function(&array_load_thunk, fp, ip, pcode_build_array_load_function, 0, NULL, result);
3995 }
3996
3997 static void *pcode_build_array_len_function(frame_s *fp, const code_t *ip, union internal_arg attr_unused a[])
3998 {
3999 pcode_t pcode[35];
4000 pcode_t *pc = pcode;
4001
4002 *pc++ = Fn_Function;
4003 *pc++ = Call_Mode_Strict;
4004 *pc++ = 0;
4005 *pc++ = 0;
4006 *pc++ = 2;
4007 *pc++ = 1;
4008 *pc++ = 1;
4009 *pc++ = 1;
4010 *pc++ = 0;
4011 *pc++ = 0;
4012
4013 *pc++ = T_Undetermined;
4014 *pc++ = T_Undetermined;
4015 *pc++ = 0;
4016 *pc++ = 0;
4017 *pc++ = 0;
4018
4019 *pc++ = T_Integer;
4020 *pc++ = T_Integer;
4021 *pc++ = 1;
4022 *pc++ = 0;
4023 *pc++ = 0;
4024
4025 *pc++ = P_Args;
4026 *pc++ = 1;
4027 *pc++ = 0;
4028
4029 *pc++ = P_Array_Len;
4030 *pc++ = 3;
4031 *pc++ = 1;
4032 *pc++ = 0;
4033 *pc++ = Flag_Evaluate;
4034
4035 *pc++ = P_Free;
4036 *pc++ = 1;
4037 *pc++ = 0;
4038
4039 *pc++ = P_Return;
4040 *pc++ = 2;
4041 *pc++ = Flag_Free_Argument;
4042 *pc++ = 1;
4043
4044 ajla_assert_lo((size_t)(pc - pcode) == n_array_elements(pcode), (file_line, "pcode_build_array_len_function: array mismatch: %"PRIdMAX" != %"PRIdMAX"", (intmax_t)(pc - pcode), (intmax_t)n_array_elements(pcode)));
4045
4046 return pcode_build_function(fp, ip, pcode, pc - pcode, NULL, NULL);
4047 }
4048
4049 static pointer_t array_len_thunk;
4050
4051 void * attr_fastcall pcode_find_array_len_function(frame_s *fp, const code_t *ip, pointer_t **result)
4052 {
4053 return pcode_alloc_op_function(&array_len_thunk, fp, ip, pcode_build_array_len_function, 0, NULL, result);
4054 }
4055
4056 static void *pcode_build_array_len_greater_than_function(frame_s *fp, const code_t *ip, union internal_arg attr_unused a[])
4057 {
4058 pcode_t pcode[45];
4059 pcode_t *pc = pcode;
4060
4061 *pc++ = Fn_Function;
4062 *pc++ = Call_Mode_Strict;
4063 *pc++ = 0;
4064 *pc++ = 0;
4065 *pc++ = 3;
4066 *pc++ = 2;
4067 *pc++ = 1;
4068 *pc++ = 1;
4069 *pc++ = 0;
4070 *pc++ = 0;
4071
4072 *pc++ = T_Undetermined;
4073 *pc++ = T_Undetermined;
4074 *pc++ = 0;
4075 *pc++ = 0;
4076 *pc++ = 0;
4077
4078 *pc++ = T_Integer;
4079 *pc++ = T_Integer;
4080 *pc++ = 1;
4081 *pc++ = 0;
4082 *pc++ = 0;
4083
4084 *pc++ = T_FlatOption;
4085 *pc++ = T_FlatOption;
4086 *pc++ = 2;
4087 *pc++ = 0;
4088 *pc++ = 0;
4089
4090 *pc++ = P_Args;
4091 *pc++ = 2;
4092 *pc++ = 0;
4093 *pc++ = 1;
4094
4095 *pc++ = P_Array_Len_Greater_Than;
4096 *pc++ = 4;
4097 *pc++ = 2;
4098 *pc++ = 0;
4099 *pc++ = 1;
4100 *pc++ = Flag_Evaluate;
4101
4102 *pc++ = P_Free;
4103 *pc++ = 1;
4104 *pc++ = 0;
4105
4106 *pc++ = P_Free;
4107 *pc++ = 1;
4108 *pc++ = 1;
4109
4110 *pc++ = P_Return;
4111 *pc++ = 2;
4112 *pc++ = Flag_Free_Argument;
4113 *pc++ = 2;
4114
4115 ajla_assert_lo((size_t)(pc - pcode) == n_array_elements(pcode), (file_line, "pcode_build_array_len_function: array mismatch: %"PRIdMAX" != %"PRIdMAX"", (intmax_t)(pc - pcode), (intmax_t)n_array_elements(pcode)));
4116
4117 return pcode_build_function(fp, ip, pcode, pc - pcode, NULL, NULL);
4118 }
4119
4120 static pointer_t array_len_greater_than_thunk;
4121
4122 void * attr_fastcall pcode_find_array_len_greater_than_function(frame_s *fp, const code_t *ip, pointer_t **result)
4123 {
4124 return pcode_alloc_op_function(&array_len_greater_than_thunk, fp, ip, pcode_build_array_len_greater_than_function, 0, NULL, result);
4125 }
4126
4127 static void *pcode_build_array_sub_function(frame_s *fp, const code_t *ip, union internal_arg attr_unused a[])
4128 {
4129 pcode_t pcode[55];
4130 pcode_t *pc = pcode;
4131
4132 *pc++ = Fn_Function;
4133 *pc++ = Call_Mode_Strict;
4134 *pc++ = 0;
4135 *pc++ = 0;
4136 *pc++ = 4;
4137 *pc++ = 3;
4138 *pc++ = 1;
4139 *pc++ = 1;
4140 *pc++ = 0;
4141 *pc++ = 0;
4142
4143 *pc++ = T_Undetermined;
4144 *pc++ = T_Undetermined;
4145 *pc++ = 0;
4146 *pc++ = 0;
4147 *pc++ = 0;
4148
4149 *pc++ = T_Integer;
4150 *pc++ = T_Integer;
4151 *pc++ = 1;
4152 *pc++ = 0;
4153 *pc++ = 0;
4154
4155 *pc++ = T_Integer;
4156 *pc++ = T_Integer;
4157 *pc++ = 2;
4158 *pc++ = 0;
4159 *pc++ = 0;
4160
4161 *pc++ = T_Undetermined;
4162 *pc++ = T_Undetermined;
4163 *pc++ = 3;
4164 *pc++ = 0;
4165 *pc++ = 0;
4166
4167 *pc++ = P_Args;
4168 *pc++ = 3;
4169 *pc++ = 0;
4170 *pc++ = 1;
4171 *pc++ = 2;
4172
4173 *pc++ = P_Array_Sub;
4174 *pc++ = 5;
4175 *pc++ = 3;
4176 *pc++ = Flag_Evaluate;
4177 *pc++ = 0;
4178 *pc++ = 1;
4179 *pc++ = 2;
4180
4181 *pc++ = P_Free;
4182 *pc++ = 1;
4183 *pc++ = 0;
4184
4185 *pc++ = P_Free;
4186 *pc++ = 1;
4187 *pc++ = 1;
4188
4189 *pc++ = P_Free;
4190 *pc++ = 1;
4191 *pc++ = 2;
4192
4193 *pc++ = P_Return;
4194 *pc++ = 2;
4195 *pc++ = Flag_Free_Argument;
4196 *pc++ = 3;
4197
4198 ajla_assert_lo((size_t)(pc - pcode) == n_array_elements(pcode), (file_line, "pcode_build_array_len_function: array mismatch: %"PRIdMAX" != %"PRIdMAX"", (intmax_t)(pc - pcode), (intmax_t)n_array_elements(pcode)));
4199
4200 return pcode_build_function(fp, ip, pcode, pc - pcode, NULL, NULL);
4201 }
4202
4203 static pointer_t array_sub_thunk;
4204
4205 void * attr_fastcall pcode_find_array_sub_function(frame_s *fp, const code_t *ip, pointer_t **result)
4206 {
4207 return pcode_alloc_op_function(&array_sub_thunk, fp, ip, pcode_build_array_sub_function, 0, NULL, result);
4208 }
4209
4210 static void *pcode_build_array_skip_function(frame_s *fp, const code_t *ip, union internal_arg attr_unused a[])
4211 {
4212 pcode_t pcode[45];
4213 pcode_t *pc = pcode;
4214
4215 *pc++ = Fn_Function;
4216 *pc++ = Call_Mode_Strict;
4217 *pc++ = 0;
4218 *pc++ = 0;
4219 *pc++ = 3;
4220 *pc++ = 2;
4221 *pc++ = 1;
4222 *pc++ = 1;
4223 *pc++ = 0;
4224 *pc++ = 0;
4225
4226 *pc++ = T_Undetermined;
4227 *pc++ = T_Undetermined;
4228 *pc++ = 0;
4229 *pc++ = 0;
4230 *pc++ = 0;
4231
4232 *pc++ = T_Integer;
4233 *pc++ = T_Integer;
4234 *pc++ = 1;
4235 *pc++ = 0;
4236 *pc++ = 0;
4237
4238 *pc++ = T_Undetermined;
4239 *pc++ = T_Undetermined;
4240 *pc++ = 2;
4241 *pc++ = 0;
4242 *pc++ = 0;
4243
4244 *pc++ = P_Args;
4245 *pc++ = 2;
4246 *pc++ = 0;
4247 *pc++ = 1;
4248
4249 *pc++ = P_Array_Skip;
4250 *pc++ = 4;
4251 *pc++ = 2;
4252 *pc++ = Flag_Evaluate;
4253 *pc++ = 0;
4254 *pc++ = 1;
4255
4256 *pc++ = P_Free;
4257 *pc++ = 1;
4258 *pc++ = 0;
4259
4260 *pc++ = P_Free;
4261 *pc++ = 1;
4262 *pc++ = 1;
4263
4264 *pc++ = P_Return;
4265 *pc++ = 2;
4266 *pc++ = Flag_Free_Argument;
4267 *pc++ = 2;
4268
4269 ajla_assert_lo((size_t)(pc - pcode) == n_array_elements(pcode), (file_line, "pcode_build_array_len_function: array mismatch: %"PRIdMAX" != %"PRIdMAX"", (intmax_t)(pc - pcode), (intmax_t)n_array_elements(pcode)));
4270
4271 return pcode_build_function(fp, ip, pcode, pc - pcode, NULL, NULL);
4272 }
4273
4274 static pointer_t array_skip_thunk;
4275
4276 void * attr_fastcall pcode_find_array_skip_function(frame_s *fp, const code_t *ip, pointer_t **result)
4277 {
4278 return pcode_alloc_op_function(&array_skip_thunk, fp, ip, pcode_build_array_skip_function, 0, NULL, result);
4279 }
4280
4281 static void *pcode_build_array_append_function(frame_s *fp, const code_t *ip, union internal_arg attr_unused a[])
4282 {
4283 pcode_t pcode[43];
4284 pcode_t *pc = pcode;
4285
4286 *pc++ = Fn_Function;
4287 *pc++ = Call_Mode_Strict;
4288 *pc++ = 0;
4289 *pc++ = 0;
4290 *pc++ = 3;
4291 *pc++ = 2;
4292 *pc++ = 1;
4293 *pc++ = 1;
4294 *pc++ = 0;
4295 *pc++ = 0;
4296
4297 *pc++ = T_Undetermined;
4298 *pc++ = T_Undetermined;
4299 *pc++ = 0;
4300 *pc++ = 0;
4301 *pc++ = 0;
4302
4303 *pc++ = T_Undetermined;
4304 *pc++ = T_Undetermined;
4305 *pc++ = 1;
4306 *pc++ = 0;
4307 *pc++ = 0;
4308
4309 *pc++ = T_Undetermined;
4310 *pc++ = T_Undetermined;
4311 *pc++ = 2;
4312 *pc++ = 0;
4313 *pc++ = 0;
4314
4315 *pc++ = P_Args;
4316 *pc++ = 2;
4317 *pc++ = 0;
4318 *pc++ = 1;
4319
4320 *pc++ = P_Eval;
4321 *pc++ = 1;
4322 *pc++ = 0;
4323
4324 #if 0
4325 *pc++ = P_Eval;
4326 *pc++ = 1;
4327 *pc++ = 1;
4328 #endif
4329
4330 *pc++ = P_Array_Append;
4331 *pc++ = 5;
4332 *pc++ = 2;
4333 *pc++ = Flag_Free_Argument;
4334 *pc++ = 0;
4335 *pc++ = Flag_Free_Argument;
4336 *pc++ = 1;
4337
4338 *pc++ = P_Return;
4339 *pc++ = 2;
4340 *pc++ = Flag_Free_Argument;
4341 *pc++ = 2;
4342 ajla_assert_lo((size_t)(pc - pcode) == n_array_elements(pcode), (file_line, "pcode_build_array_append_function: array mismatch: %"PRIdMAX" != %"PRIdMAX"", (intmax_t)(pc - pcode), (intmax_t)n_array_elements(pcode)));
4343
4344 return pcode_build_function(fp, ip, pcode, pc - pcode, NULL, NULL);
4345 }
4346
4347 static pointer_t array_append_thunk;
4348
4349 void * attr_fastcall pcode_find_array_append_function(frame_s *fp, const code_t *ip, pointer_t **result)
4350 {
4351 return pcode_alloc_op_function(&array_append_thunk, fp, ip, pcode_build_array_append_function, 0, NULL, result);
4352 }
4353
4354
4355 static void *pcode_build_option_ord_function(frame_s *fp, const code_t *ip, union internal_arg attr_unused a[])
4356 {
4357 pcode_t pcode[37];
4358 pcode_t *pc = pcode;
4359
4360 *pc++ = Fn_Function;
4361 *pc++ = Call_Mode_Strict;
4362 *pc++ = 0;
4363 *pc++ = 0;
4364 *pc++ = 2;
4365 *pc++ = 1;
4366 *pc++ = 1;
4367 *pc++ = 1;
4368 *pc++ = 0;
4369 *pc++ = 0;
4370
4371 *pc++ = T_Undetermined;
4372 *pc++ = T_Undetermined;
4373 *pc++ = 0;
4374 *pc++ = 0;
4375 *pc++ = 0;
4376
4377 *pc++ = T_Integer;
4378 *pc++ = T_Integer;
4379 *pc++ = 1;
4380 *pc++ = 0;
4381 *pc++ = 0;
4382
4383 *pc++ = P_Args;
4384 *pc++ = 1;
4385 *pc++ = 0;
4386
4387 *pc++ = P_Eval;
4388 *pc++ = 1;
4389 *pc++ = 0;
4390
4391 *pc++ = P_Option_Ord;
4392 *pc++ = 2;
4393 *pc++ = 1;
4394 *pc++ = 0;
4395
4396 *pc++ = P_Free;
4397 *pc++ = 1;
4398 *pc++ = 0;
4399
4400 *pc++ = P_Return;
4401 *pc++ = 2;
4402 *pc++ = Flag_Free_Argument;
4403 *pc++ = 1;
4404
4405 ajla_assert_lo((size_t)(pc - pcode) == n_array_elements(pcode), (file_line, "pcode_build_option_ord_function: array mismatch: %"PRIdMAX" != %"PRIdMAX"", (intmax_t)(pc - pcode), (intmax_t)n_array_elements(pcode)));
4406
4407 return pcode_build_function(fp, ip, pcode, pc - pcode, NULL, NULL);
4408 }
4409
4410 static pointer_t option_ord_thunk;
4411
4412 void * attr_fastcall pcode_find_option_ord_function(frame_s *fp, const code_t *ip, pointer_t **result)
4413 {
4414 return pcode_alloc_op_function(&option_ord_thunk, fp, ip, pcode_build_option_ord_function, 0, NULL, result);
4415 }
4416
4417
4418 struct function_key {
4419 unsigned char tag;
4420 frame_t id;
4421 };
4422
4423 static void *pcode_build_record_option_load_function(frame_s *fp, const code_t *ip, union internal_arg a[])
4424 {
4425 pcode_t pcode[38];
4426 pcode_t *pc = pcode;
4427 pcode_t result_type = a[0].i == PCODE_FUNCTION_OPTION_TEST ? T_FlatOption : T_Undetermined;
4428
4429 *pc++ = Fn_Function;
4430 *pc++ = Call_Mode_Strict;
4431 *pc++ = 0;
4432 *pc++ = 0;
4433 *pc++ = 2;
4434 *pc++ = 1;
4435 *pc++ = 1;
4436 *pc++ = 1;
4437 *pc++ = 0;
4438 *pc++ = 0;
4439
4440 *pc++ = T_Undetermined;
4441 *pc++ = T_Undetermined;
4442 *pc++ = 0;
4443 *pc++ = 0;
4444 *pc++ = 0;
4445
4446 *pc++ = result_type;
4447 *pc++ = result_type;
4448 *pc++ = 1;
4449 *pc++ = 0;
4450 *pc++ = 0;
4451
4452 *pc++ = P_Args;
4453 *pc++ = 1;
4454 *pc++ = 0;
4455
4456 switch (a[0].i) {
4457 case PCODE_FUNCTION_RECORD_LOAD:
4458 /* P_Record_Load_Slot already sets Flag_Evaluate */
4459 *pc++ = P_Record_Load_Slot;
4460 *pc++ = 3;
4461 *pc++ = 1;
4462 *pc++ = 0;
4463 *pc++ = (pcode_t)a[1].i;
4464 break;
4465 case PCODE_FUNCTION_OPTION_LOAD:
4466 *pc++ = P_Option_Load;
4467 *pc++ = 4;
4468 *pc++ = 1;
4469 *pc++ = Flag_Evaluate;
4470 *pc++ = 0;
4471 *pc++ = (pcode_t)a[1].i;
4472 break;
4473 case PCODE_FUNCTION_OPTION_TEST:
4474 *pc++ = P_Eval;
4475 *pc++ = 1;
4476 *pc++ = 0;
4477 *pc++ = P_Option_Test;
4478 *pc++ = 3;
4479 *pc++ = 1;
4480 *pc++ = 0;
4481 *pc++ = (pcode_t)a[1].i;
4482 break;
4483 default:
4484 internal(file_line, "pcode_build_record_option_load_function: invalid operation %"PRIuMAX"", (uintmax_t)a[0].i);
4485 }
4486
4487 *pc++ = P_Free;
4488 *pc++ = 1;
4489 *pc++ = 0;
4490
4491 *pc++ = P_Return;
4492 *pc++ = 2;
4493 *pc++ = Flag_Free_Argument;
4494 *pc++ = 1;
4495
4496 ajla_assert_lo((size_t)(pc - pcode) <= n_array_elements(pcode), (file_line, "pcode_build_record_option_load_function: array overflow: %"PRIdMAX" > %"PRIdMAX"", (intmax_t)(pc - pcode), (intmax_t)n_array_elements(pcode)));
4497
4498 return pcode_build_function(fp, ip, pcode, pc - pcode, NULL, NULL);
4499 }
4500
4501 struct pcode_function {
4502 struct tree_entry entry;
4503 struct function_key key;
4504 pointer_t ptr;
4505 };
4506
4507 shared_var struct tree pcode_functions;
4508 rwlock_decl(pcode_functions_mutex);
4509
4510 static int record_option_load_compare(const struct tree_entry *e1, uintptr_t e2)
4511 {
4512 struct pcode_function *rl = get_struct(e1, struct pcode_function, entry);
4513 struct function_key *key = cast_cpp(struct function_key *, num_to_ptr(e2));
4514 if (rl->key.tag != key->tag)
4515 return (int)rl->key.tag - key->tag;
4516 if (rl->key.id < key->id)
4517 return -1;
4518 if (rl->key.id > key->id)
4519 return -1;
4520 return 0;
4521 }
4522
4523 static pointer_t *pcode_find_function_for_key(struct function_key *key)
4524 {
4525 struct tree_entry *e;
4526
4527 rwlock_lock_read(&pcode_functions_mutex);
4528 e = tree_find(&pcode_functions, record_option_load_compare, ptr_to_num(key));
4529 rwlock_unlock_read(&pcode_functions_mutex);
4530 if (unlikely(!e)) {
4531 struct tree_insert_position ins;
4532 rwlock_lock_write(&pcode_functions_mutex);
4533 e = tree_find_for_insert(&pcode_functions, record_option_load_compare, ptr_to_num(key), &ins);
4534 if (likely(!e)) {
4535 ajla_error_t sink;
4536 struct pcode_function *rl;
4537 rl = mem_alloc_mayfail(struct pcode_function *, sizeof(struct pcode_function), &sink);
4538 if (unlikely(!rl)) {
4539 rwlock_unlock_write(&pcode_functions_mutex);
4540 return NULL;
4541 }
4542 rl->key = *key;
4543 rl->ptr = pointer_empty();
4544 e = &rl->entry;
4545 tree_insert_after_find(e, &ins);
4546 }
4547 rwlock_unlock_write(&pcode_functions_mutex);
4548 }
4549 return &get_struct(e, struct pcode_function, entry)->ptr;
4550 }
4551
4552 void * attr_fastcall pcode_find_record_option_load_function(unsigned char tag, frame_t slot, frame_s *fp, const code_t *ip, pointer_t **result)
4553 {
4554 struct function_key key;
4555 pointer_t *ptr;
4556 union internal_arg ia[2];
4557
4558 if (unlikely((uintmax_t)slot > (uintmax_t)signed_maximum(pcode_t) + zero)) {
4559 *result = out_of_memory_ptr;
4560 return POINTER_FOLLOW_THUNK_RETRY;
4561 }
4562
4563 key.tag = tag;
4564 key.id = slot;
4565
4566 ptr = pcode_find_function_for_key(&key);
4567 if (unlikely(!ptr)) {
4568 *result = out_of_memory_ptr;
4569 return POINTER_FOLLOW_THUNK_RETRY;
4570 }
4571
4572 ia[0].i = tag;
4573 ia[1].i = slot;
4574 return pcode_alloc_op_function(ptr, fp, ip, pcode_build_record_option_load_function, 2, ia, result);
4575 }
4576
4577 static void thunk_init_run(pointer_t *ptr, unsigned n)
4578 {
4579 while (n--) {
4580 *ptr = pointer_empty();
4581 ptr++;
4582 }
4583 }
4584
4585 static void thunk_free_run(pointer_t *ptr, unsigned n)
4586 {
4587 while (n--) {
4588 if (!pointer_is_empty(*ptr))
4589 pointer_dereference(*ptr);
4590 ptr++;
4591 }
4592 }
4593
4594 void name(pcode_init)(void)
4595 {
4596 unsigned i;
4597
4598 for (i = 0; i < TYPE_FIXED_N + uzero; i++) thunk_init_run(fixed_op_thunk[i], OPCODE_FIXED_OP_N);
4599 for (i = 0; i < TYPE_INT_N; i++) thunk_init_run(int_op_thunk[i], OPCODE_INT_OP_N);
4600 for (i = 0; i < TYPE_REAL_N + uzero; i++) thunk_init_run(real_op_thunk[i], OPCODE_REAL_OP_N);
4601 thunk_init_run(&is_exception_thunk, 1);
4602 thunk_init_run(get_exception_thunk, n_array_elements(get_exception_thunk));
4603 thunk_init_run(bool_op_thunk, OPCODE_BOOL_OP_N);
4604 thunk_init_run(&array_load_thunk, 1);
4605 thunk_init_run(&array_len_thunk, 1);
4606 thunk_init_run(&array_len_greater_than_thunk, 1);
4607 thunk_init_run(&array_sub_thunk, 1);
4608 thunk_init_run(&array_skip_thunk, 1);
4609 thunk_init_run(&array_append_thunk, 1);
4610 thunk_init_run(&option_ord_thunk, 1);
4611 tree_init(&pcode_functions);
4612 rwlock_init(&pcode_functions_mutex);
4613 }
4614
4615 void name(pcode_done)(void)
4616 {
4617 unsigned i;
4618 for (i = 0; i < TYPE_FIXED_N + uzero; i++) thunk_free_run(fixed_op_thunk[i], OPCODE_FIXED_OP_N);
4619 for (i = 0; i < TYPE_INT_N; i++) thunk_free_run(int_op_thunk[i], OPCODE_INT_OP_N);
4620 for (i = 0; i < TYPE_REAL_N + uzero; i++) thunk_free_run(real_op_thunk[i], OPCODE_REAL_OP_N);
4621 thunk_free_run(&is_exception_thunk, 1);
4622 thunk_free_run(get_exception_thunk, n_array_elements(get_exception_thunk));
4623 thunk_free_run(bool_op_thunk, OPCODE_BOOL_OP_N);
4624 thunk_free_run(&array_load_thunk, 1);
4625 thunk_free_run(&array_len_thunk, 1);
4626 thunk_free_run(&array_len_greater_than_thunk, 1);
4627 thunk_free_run(&array_sub_thunk, 1);
4628 thunk_free_run(&array_skip_thunk, 1);
4629 thunk_free_run(&array_append_thunk, 1);
4630 thunk_free_run(&option_ord_thunk, 1);
4631 while (!tree_is_empty(&pcode_functions)) {
4632 struct pcode_function *rl = get_struct(tree_any(&pcode_functions), struct pcode_function, entry);
4633 if (!pointer_is_empty(rl->ptr))
4634 pointer_dereference(rl->ptr);
4635 tree_delete(&rl->entry);
4636 mem_free(rl);
4637 }
4638 rwlock_done(&pcode_functions_mutex);
4639 }
4640
4641 #endif
Ajla - a purely functional programming language