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