?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
x86-64: hack the ABI of cg_upcall_ipret_copy_variable_to_pointer
[ajla.git] / pcode.c
blobcbd955bf35d09f3ec1b8ee465a82fd04d2ef94be
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(greater), fx(ugreater), in(greater), re(greater), bo(greater), },
80 { fx(greater_equal), fx(ugreater_equal), in(greater_equal), re(greater_equal), bo(greater_equal),},
81 { fx(bt), fx(bt), in(bt), NO_OPCODE, NO_OPCODE, },
82 { fx(not), fx(not), in(not), NO_OPCODE, bo(not), },
83 { fx(neg), fx(neg), in(neg), re(neg), 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, true, 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, true, 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, cnst;
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_BinaryConstOp:
2465 op = u_pcode_get();
2466 ajla_assert_lo(Op_IsBinary(op), (file_line, "P_BinaryConstOp(%s): invalid binary op %"PRIdMAX"", function_name(ctx), (intmax_t)op));
2467 res = u_pcode_get();
2468 flags1 = u_pcode_get();
2469 a1 = pcode_get();
2470 cnst = pcode_get();
2471 if (unlikely(var_elided(res))) {
2472 if (flags1 & Flag_Free_Argument)
2473 pcode_free(ctx, a1);
2474 break;
2475 }
2476 tr = get_var_type(ctx, res);
2477 t1 = get_var_type(ctx, a1);
2478 ajla_assert_lo(type_is_equal(tr->type, (Op_IsBool(op) ? type_get_flat_option() : t1->type)), (file_line, "P_BinaryConstOp(%s): invalid types for binary operation %"PRIdMAX": %u, %u", function_name(ctx), (intmax_t)op, t1->type->tag, tr->type->tag));
2479 fflags = 0;
2480 if (flags1 & Flag_Fused_Bin_Jmp)
2481 fflags |= OPCODE_FLAG_FUSED;
2482 am = INIT_ARG_MODE;
2483 get_arg_mode(am, t1->slot);
2484 get_arg_mode(am, (frame_t)cnst);
2485 get_arg_mode(am, tr->slot);
2486 code = get_code(op, t1->type) + (TYPE_TAG_IS_FIXED(t1->type->tag) ? OPCODE_FIXED_OP_C : OPCODE_INT_OP_C) + am * OPCODE_MODE_MULT;
2487 gen_code(code);
2488 gen_am_two(am, t1->slot, (frame_t)cnst);
2489 gen_am_two(am, tr->slot, fflags);
2490 if (flags1 & Flag_Free_Argument) {
2491 if (t1->slot != tr->slot)
2492 pcode_free(ctx, a1);
2493 }
2494 break;
2495 case P_UnaryOp:
2496 op = u_pcode_get();
2497 ajla_assert_lo(op >= Op_N || Op_IsUnary(op), (file_line, "P_UnaryOp(%s): invalid unary op %"PRIdMAX"", function_name(ctx), (intmax_t)op));
2498 res = u_pcode_get();
2499 flags1 = u_pcode_get();
2500 a1 = pcode_get();
2501 if (unlikely(var_elided(res))) {
2502 if (flags1 & Flag_Free_Argument)
2503 pcode_free(ctx, a1);
2504 break;
2505 }
2506 tr = get_var_type(ctx, res);
2507 t1 = get_var_type(ctx, a1);
2508 ajla_assert_lo(op >= Op_N || op == Un_ConvertFromInt ||
2509 type_is_equal(tr->type, (Op_IsBool(op) ? type_get_flat_option()
2510 : Op_IsInt(op) ? type_get_int(INT_DEFAULT_N)
2511 : 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));
2512 if (NEED_OP_EMULATION && (unlikely(t1->extra_type) || unlikely(tr->extra_type))) {
2513 if (unlikely(!pcode_op_to_call(ctx, op, tr, t1, flags1, NULL, 0, false)))
2514 goto exception;
2515 break;
2516 }
2517 am = INIT_ARG_MODE;
2518 get_arg_mode(am, t1->slot);
2519 get_arg_mode(am, tr->slot);
2520 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);
2521 gen_code(code);
2522 gen_am_two(am, t1->slot, tr->slot);
2523 gen_am(am, flags1 & Flag_Op_Strict ? OPCODE_OP_FLAG_STRICT : 0);
2524 if (flags1 & Flag_Free_Argument) {
2525 if (t1->slot != tr->slot)
2526 pcode_free(ctx, a1);
2527 }
2528 break;
2529 case P_Copy:
2530 case P_Copy_Type_Cast:
2531 res = u_pcode_get();
2532 pcode_get_var_deref(&a1, &a1_deref);
2533 if (unlikely(var_elided(res))) {
2534 if (a1_deref) {
2535 if (unlikely(!pcode_free(ctx, a1)))
2536 goto exception;
2537 }
2538 break;
2539 }
2540 if (unlikely(!pcode_copy(ctx, instr != P_Copy, res, a1, a1_deref)))
2541 goto exception;
2542 break;
2543 case P_Free:
2544 res = u_pcode_get();
2545 if (unlikely(!pcode_free(ctx, res)))
2546 goto exception;
2547 break;
2548 case P_Eval:
2549 a1 = pcode_get();
2550 if (unlikely(var_elided(a1)))
2551 break;
2552 t1 = get_var_type(ctx, a1);
2553 am = INIT_ARG_MODE;
2554 get_arg_mode(am, t1->slot);
2555 code = OPCODE_EVAL;
2556 code += am * OPCODE_MODE_MULT;
2557 gen_code(code);
2558 gen_am(am, t1->slot);
2559 break;
2560 case P_Keep:
2561 a1 = pcode_get();
2562 break;
2563 case P_Fn:
2564 res = u_pcode_get();
2565 ajla_assert_lo(var_elided(res), (file_line, "P_Fn(%s): Fn result is not elided", function_name(ctx)));
2566 a1 = u_pcode_get();
2567 a2 = u_pcode_get();
2568 for (p = 0; p < a1; p++)
2569 pcode_get();
2570 for (p = 0; p < a2; p++)
2571 pcode_get();
2572 break;
2573 case P_Load_Local_Type:
2574 res = u_pcode_get();
2575 ajla_assert_lo(var_elided(res), (file_line, "P_Load_Local_Type(%s): Load_Local_Type result is not elided", function_name(ctx)));
2576 pcode_get();
2577 u_pcode_get();
2578 break;
2579 case P_Load_Fn:
2580 case P_Curry:
2581 case P_Call_Indirect:
2582 case P_Call:
2583 if (unlikely(!pcode_call(ctx, instr)))
2584 goto exception;
2585 #if 0
2586 if (instr == P_Call || instr == P_Call_Indirect) {
2587 pcode_t next, next_params;
2588 pcode_position_save_t s;
2589 pcode_position_save(ctx, &s);
2590 next_one:
2591 pcode_get_instr(ctx, &next, &next_params);
2592 if (next == P_Line_Info) {
2593 ctx->pcode = ctx->pcode_instr_end;
2594 goto next_one;
2595 }
2596 pcode_position_restore(ctx, &s);
2597 //ajla_assert_lo(next == P_Checkpoint, (file_line, "%s: is followed by %"PRIdMAX"", instr == P_Call ? "P_Call" : "P_Call_Indirect", (intmax_t)next));
2598 debug("%d", next);
2599 ctx->pcode_instr_end = ctx->pcode;
2600 }
2601 #endif
2602 break;
2603 case P_Load_Const:
2604 if (unlikely(!pcode_load_constant(ctx)))
2605 goto exception;
2606 break;
2607 case P_Structured_Write:
2608 if (unlikely(!pcode_structured_write(ctx)))
2609 goto exception;
2610 break;
2611 case P_Record_Type:
2612 case P_Option_Type:
2613 for (p = 0; p < instr_params; p++)
2614 pcode_get();
2615 break;
2616 case P_Record_Create:
2617 if (unlikely(!pcode_record_create(ctx)))
2618 goto exception;
2619 break;
2620 case P_Record_Load_Slot:
2621 res = u_pcode_get();
2622 a1 = u_pcode_get();
2623 op = u_pcode_get();
2624 tr = get_var_type(ctx, res);
2625 t1 = get_var_type(ctx, a1);
2626 am = INIT_ARG_MODE;
2627 get_arg_mode(am, tr->slot);
2628 get_arg_mode(am, t1->slot);
2629 get_arg_mode(am, op);
2630 code = OPCODE_RECORD_LOAD;
2631 code += am * OPCODE_MODE_MULT;
2632 gen_code(code);
2633 gen_am_two(am, t1->slot, op);
2634 gen_am_two(am, tr->slot, OPCODE_OP_FLAG_STRICT);
2635 break;
2636 case P_Record_Load:
2637 res = u_pcode_get();
2638 flags = u_pcode_get();
2639 a1 = u_pcode_get();
2640 op = u_pcode_get();
2641 if (unlikely(var_elided(res)))
2642 break;
2643 tr = get_var_type(ctx, res);
2644 t1 = get_var_type(ctx, a1);
2645 if (TYPE_IS_FLAT(tr->type))
2646 flags &= ~Flag_Borrow;
2647 if (t1->type->tag == TYPE_TAG_flat_record) {
2648 def = type_def(type_def(t1->type,flat_record)->base,record);
2649 } else {
2650 def = type_def(t1->type,record);
2651 }
2652 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));
2653 op = record_definition_slot(def, op);
2654 am = INIT_ARG_MODE;
2655 get_arg_mode(am, tr->slot);
2656 get_arg_mode(am, t1->slot);
2657 get_arg_mode(am, op);
2658 code = OPCODE_RECORD_LOAD;
2659 code += am * OPCODE_MODE_MULT;
2660 gen_code(code);
2661 gen_am_two(am, t1->slot, op);
2662 gen_am_two(am, tr->slot,
2663 (flags & Flag_Evaluate ? OPCODE_OP_FLAG_STRICT : 0) |
2664 (flags & Flag_Borrow ? OPCODE_STRUCT_MAY_BORROW : 0));
2665 if (flags & Flag_Borrow)
2666 ctx->local_variables_flags[tr->slot].may_be_borrowed = true;
2667 break;
2668 case P_Option_Load:
2669 res = u_pcode_get();
2670 flags = u_pcode_get();
2671 a1 = u_pcode_get();
2672 op = u_pcode_get();
2673 if (unlikely(var_elided(res)))
2674 break;
2675 tr = get_var_type(ctx, res);
2676 t1 = get_var_type(ctx, a1);
2677 if (TYPE_IS_FLAT(tr->type))
2678 flags &= ~Flag_Borrow;
2679 am = INIT_ARG_MODE;
2680 get_arg_mode(am, tr->slot);
2681 get_arg_mode(am, t1->slot);
2682 get_arg_mode(am, op);
2683 code = OPCODE_OPTION_LOAD;
2684 code += am * OPCODE_MODE_MULT;
2685 gen_code(code);
2686 gen_am_two(am, t1->slot, op);
2687 gen_am_two(am, tr->slot,
2688 (flags & Flag_Evaluate ? OPCODE_OP_FLAG_STRICT : 0) |
2689 (flags & Flag_Borrow ? OPCODE_STRUCT_MAY_BORROW : 0));
2690 if (flags & Flag_Borrow)
2691 ctx->local_variables_flags[tr->slot].may_be_borrowed = true;
2692 break;
2693 case P_Option_Create:
2694 res = u_pcode_get();
2695 op = u_pcode_get();
2696 pcode_get_var_deref(&a1, &a1_deref);
2697 if (unlikely(var_elided(res))) {
2698 if (a1_deref) {
2699 if (unlikely(!pcode_free(ctx, a1)))
2700 goto exception;
2701 }
2702 break;
2703 }
2704 tr = get_var_type(ctx, res);
2705 t1 = get_var_type(ctx, a1);
2706 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));
2707 am = INIT_ARG_MODE;
2708 get_arg_mode(am, tr->slot);
2709 get_arg_mode(am, t1->slot);
2710 get_arg_mode(am, op);
2711 if (unlikely(op != (pcode_t)(ajla_option_t)op))
2712 goto exception_overflow;
2713 code = OPCODE_OPTION_CREATE;
2714 code += am * OPCODE_MODE_MULT;
2715 gen_code(code);
2716 gen_am_two(am, tr->slot, op);
2717 gen_am_two(am, t1->slot, a1_deref ? OPCODE_FLAG_FREE_ARGUMENT : 0);
2718 break;
2719 case P_Option_Test:
2720 res = u_pcode_get();
2721 a1 = u_pcode_get();
2722 op = u_pcode_get();
2723 if (unlikely(var_elided(res)))
2724 break;
2725 tr = get_var_type(ctx, res);
2726 t1 = get_var_type(ctx, a1);
2727 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));
2728 am = INIT_ARG_MODE;
2729 get_arg_mode(am, tr->slot);
2730 get_arg_mode(am, t1->slot);
2731 get_arg_mode(am, op);
2732 if (unlikely(op != (pcode_t)(ajla_option_t)op))
2733 goto exception_overflow;
2734 if (t1->type->tag == TYPE_TAG_flat_option)
2735 code = OPCODE_OPTION_TEST_FLAT;
2736 else
2737 code = OPCODE_OPTION_TEST;
2738 code += am * OPCODE_MODE_MULT;
2739 gen_code(code);
2740 gen_am_two(am, t1->slot, op);
2741 gen_am(am, tr->slot);
2742 break;
2743 case P_Option_Ord:
2744 res = u_pcode_get();
2745 a1 = u_pcode_get();
2746 if (unlikely(var_elided(res)))
2747 break;
2748 tr = get_var_type(ctx, res);
2749 t1 = get_var_type(ctx, a1);
2750 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));
2751 am = INIT_ARG_MODE;
2752 get_arg_mode(am, tr->slot);
2753 get_arg_mode(am, t1->slot);
2754 if (t1->type->tag == TYPE_TAG_flat_option)
2755 code = OPCODE_OPTION_ORD_FLAT;
2756 else
2757 code = OPCODE_OPTION_ORD;
2758 code += am * OPCODE_MODE_MULT;
2759 gen_code(code);
2760 gen_am_two(am, t1->slot, tr->slot);
2761 break;
2762 case P_Array_Flexible:
2763 case P_Array_Fixed:
2764 res = u_pcode_get();
2765 ajla_assert_lo(var_elided(res), (file_line, "P_Array_Flexible(%s): P_Array_Flexible result is not elided", function_name(ctx)));
2766 a1 = pcode_get();
2767 ajla_assert_lo(var_elided(a1), (file_line, "P_Array_Flexible(%s): P_Array_Flexible argument is not elided", function_name(ctx)));
2768 if (instr == P_Array_Fixed)
2769 pcode_get();
2770 break;
2771 case P_Array_Create:
2772 if (unlikely(!pcode_array_create(ctx)))
2773 goto exception;
2774 break;
2775 case P_Array_Fill:
2776 res = u_pcode_get();
2777 pcode_get(); /* local type */
2778 op = u_pcode_get();
2779 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));
2780 a1 = pcode_get();
2781 a2 = pcode_get();
2782 if (unlikely(var_elided(res)))
2783 break;
2784 tr = get_var_type(ctx, res);
2785 t1 = get_var_type(ctx, a1);
2786 t2 = get_var_type(ctx, a2);
2787 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));
2788 am = INIT_ARG_MODE;
2789 get_arg_mode(am, t1->slot);
2790 get_arg_mode(am, t2->slot);
2791 get_arg_mode(am, tr->slot);
2792 gen_code(OPCODE_ARRAY_FILL + am * OPCODE_MODE_MULT);
2793 gen_am_two(am, t1->slot,
2794 ((op & Flag_Free_Argument) ? OPCODE_FLAG_FREE_ARGUMENT : 0) |
2795 ((op & Flag_Array_Fill_Sparse) ? OPCODE_ARRAY_FILL_FLAG_SPARSE : 0)
2796 );
2797 gen_am_two(am, t2->slot, tr->slot);
2798 break;
2799 case P_Array_String:
2800 if (unlikely(!pcode_array_string(ctx)))
2801 goto exception;
2802 break;
2803 case P_Array_Unicode:
2804 if (unlikely(!pcode_array_unicode(ctx)))
2805 goto exception;
2806 break;
2807 case P_Array_Load:
2808 res = u_pcode_get();
2809 flags = u_pcode_get();
2810 a1 = u_pcode_get();
2811 a2 = u_pcode_get();
2812 if (unlikely(var_elided(res)))
2813 break;
2814 tr = get_var_type(ctx, res);
2815 t1 = get_var_type(ctx, a1);
2816 t2 = get_var_type(ctx, a2);
2817 if (TYPE_IS_FLAT(tr->type))
2818 flags &= ~Flag_Borrow;
2819 am = INIT_ARG_MODE;
2820 get_arg_mode(am, tr->slot);
2821 get_arg_mode(am, t1->slot);
2822 get_arg_mode(am, t2->slot);
2823 code = OPCODE_ARRAY_LOAD;
2824 code += am * OPCODE_MODE_MULT;
2825 gen_code(code);
2826 gen_am_two(am, t1->slot, t2->slot);
2827 gen_am_two(am, tr->slot,
2828 (flags & Flag_Evaluate ? OPCODE_OP_FLAG_STRICT : 0) |
2829 (flags & Flag_Borrow ? OPCODE_STRUCT_MAY_BORROW : 0) |
2830 (flags & Flag_Index_In_Range ? OPCODE_ARRAY_INDEX_IN_RANGE : 0));
2831 if (flags & Flag_Borrow)
2832 ctx->local_variables_flags[tr->slot].may_be_borrowed = true;
2833 break;
2834 case P_Array_Len:
2835 res = u_pcode_get();
2836 a1 = u_pcode_get();
2837 flags = u_pcode_get();
2838 ajla_assert_lo(!(flags & ~Flag_Evaluate), (file_line, "P_Array_Len(%s): invalid flags %"PRIuMAX"", function_name(ctx), (uintmax_t)flags));
2839 if (unlikely(var_elided(res)))
2840 break;
2841 tr = get_var_type(ctx, res);
2842 t1 = get_var_type(ctx, a1);
2843 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));
2844 if (TYPE_IS_FLAT(t1->type)) {
2845 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));
2846 if (unlikely(!pcode_generate_constant(ctx, res, (int_default_t)type_def(t1->type,flat_array)->n_elements)))
2847 goto exception;
2848 } else {
2849 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));
2850 am = INIT_ARG_MODE;
2851 get_arg_mode(am, t1->slot);
2852 get_arg_mode(am, tr->slot);
2853 gen_code(OPCODE_ARRAY_LEN + am * OPCODE_MODE_MULT);
2854 gen_am_two(am, t1->slot, tr->slot);
2855 gen_am(am, flags & Flag_Evaluate ? OPCODE_OP_FLAG_STRICT : 0);
2856 }
2857 break;
2858 case P_Array_Len_Greater_Than:
2859 res = u_pcode_get();
2860 a1 = u_pcode_get();
2861 a2 = u_pcode_get();
2862 flags = u_pcode_get();
2863 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));
2864 if (unlikely(var_elided(res)))
2865 break;
2866 tr = get_var_type(ctx, res);
2867 t1 = get_var_type(ctx, a1);
2868 t2 = get_var_type(ctx, a2);
2869 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));
2870 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));
2871
2872 fflags = 0;
2873 if (unlikely(flags & Flag_Evaluate) != 0)
2874 fflags |= OPCODE_OP_FLAG_STRICT;
2875 if (flags & Flag_Fused_Bin_Jmp)
2876 fflags |= OPCODE_FLAG_FUSED;
2877 am = INIT_ARG_MODE;
2878 get_arg_mode(am, t1->slot);
2879 get_arg_mode(am, t2->slot);
2880 get_arg_mode(am, tr->slot);
2881 gen_code(OPCODE_ARRAY_LEN_GREATER_THAN + am * OPCODE_MODE_MULT);
2882 gen_am_two(am, t1->slot, t2->slot);
2883 gen_am_two(am, tr->slot, fflags);
2884 break;
2885 case P_Array_Sub:
2886 res = u_pcode_get();
2887 flags = u_pcode_get();
2888 aa = u_pcode_get();
2889 a1 = u_pcode_get();
2890 a2 = u_pcode_get();
2891 ajla_assert_lo(!(flags & ~(Flag_Free_Argument | Flag_Evaluate)), (file_line, "P_Array_Sub(%s): invalid flags %"PRIuMAX"", function_name(ctx), (uintmax_t)flags));
2892 if (unlikely(var_elided(res)))
2893 break;
2894 tr = get_var_type(ctx, res);
2895 ta = get_var_type(ctx, aa);
2896 t1 = get_var_type(ctx, a1);
2897 t2 = get_var_type(ctx, a2);
2898 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));
2899 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));
2900
2901 am = INIT_ARG_MODE;
2902 get_arg_mode(am, ta->slot);
2903 get_arg_mode(am, t1->slot);
2904 get_arg_mode(am, t2->slot);
2905 get_arg_mode(am, tr->slot);
2906 gen_code(OPCODE_ARRAY_SUB + am * OPCODE_MODE_MULT);
2907 gen_am_two(am, ta->slot, t1->slot);
2908 gen_am_two(am, t2->slot, tr->slot);
2909 gen_am(am,
2910 (flags & Flag_Free_Argument ? OPCODE_FLAG_FREE_ARGUMENT : 0) |
2911 (flags & Flag_Evaluate ? OPCODE_OP_FLAG_STRICT : 0)
2912 );
2913 break;
2914 case P_Array_Skip:
2915 res = u_pcode_get();
2916 flags = u_pcode_get();
2917 aa = u_pcode_get();
2918 a1 = u_pcode_get();
2919 ajla_assert_lo(!(flags & ~(Flag_Free_Argument | Flag_Evaluate)), (file_line, "P_Array_Skip(%s): invalid flags %"PRIuMAX"", function_name(ctx), (uintmax_t)flags));
2920 if (unlikely(var_elided(res)))
2921 break;
2922 tr = get_var_type(ctx, res);
2923 ta = get_var_type(ctx, aa);
2924 t1 = get_var_type(ctx, a1);
2925 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));
2926
2927 am = INIT_ARG_MODE;
2928 get_arg_mode(am, ta->slot);
2929 get_arg_mode(am, t1->slot);
2930 get_arg_mode(am, tr->slot);
2931 gen_code(OPCODE_ARRAY_SKIP + am * OPCODE_MODE_MULT);
2932 gen_am_two(am, ta->slot, t1->slot);
2933 gen_am_two(am, tr->slot,
2934 (flags & Flag_Free_Argument ? OPCODE_FLAG_FREE_ARGUMENT : 0) |
2935 (flags & Flag_Evaluate ? OPCODE_OP_FLAG_STRICT : 0)
2936 );
2937 break;
2938 case P_Array_Append:
2939 case P_Array_Append_One:
2940 res = u_pcode_get();
2941 pcode_get_var_deref(&a1, &a1_deref);
2942 pcode_get_var_deref(&a2, &a2_deref);
2943 if (unlikely(var_elided(res)))
2944 break;
2945 tr = get_var_type(ctx, res);
2946 t1 = get_var_type(ctx, a1);
2947 t2 = get_var_type(ctx, a2);
2948 am = INIT_ARG_MODE;
2949 get_arg_mode(am, tr->slot);
2950 get_arg_mode(am, t1->slot);
2951 get_arg_mode(am, t2->slot);
2952 if (instr == P_Array_Append) {
2953 gen_code(OPCODE_ARRAY_APPEND + am * OPCODE_MODE_MULT);
2954 } else {
2955 if (TYPE_IS_FLAT(t2->type)) {
2956 gen_code(OPCODE_ARRAY_APPEND_ONE_FLAT + am * OPCODE_MODE_MULT);
2957 } else {
2958 gen_code(OPCODE_ARRAY_APPEND_ONE + am * OPCODE_MODE_MULT);
2959 }
2960 }
2961 gen_am_two(am, tr->slot, (a1_deref ? OPCODE_FLAG_FREE_ARGUMENT : 0) | (a2_deref ? OPCODE_FLAG_FREE_ARGUMENT_2 : 0));
2962 gen_am_two(am, t1->slot, t2->slot);
2963 break;
2964 case P_Array_Flatten:
2965 res = u_pcode_get();
2966 pcode_get_var_deref(&a1, &a1_deref);
2967 if (unlikely(var_elided(res)))
2968 break;
2969 tr = get_var_type(ctx, res);
2970 t1 = get_var_type(ctx, a1);
2971 am = INIT_ARG_MODE;
2972 get_arg_mode(am, tr->slot);
2973 get_arg_mode(am, t1->slot);
2974 gen_code(OPCODE_ARRAY_FLATTEN + am * OPCODE_MODE_MULT);
2975 gen_am_two(am, tr->slot, (a1_deref ? OPCODE_FLAG_FREE_ARGUMENT : 0));
2976 gen_am(am, t1->slot);
2977 break;
2978 case P_Jmp:
2979 res = u_pcode_get();
2980 ajla_assert_lo(res < ctx->n_labels, (file_line, "P_Jmp(%s): invalid label %"PRIdMAX"", function_name(ctx), (intmax_t)res));
2981 #if SIZEOF_IP_T > 2
2982 if (ctx->labels[res] != no_label) {
2983 uint32_t target;
2984 target = (uint32_t)((ctx->code_len - ctx->labels[res]) * sizeof(code_t));
2985 if (likely(target < 0x10000)) {
2986 gen_code(OPCODE_JMP_BACK_16);
2987 gen_code((code_t)target);
2988 break;
2989 }
2990 }
2991 #endif
2992 gen_code(OPCODE_JMP);
2993 gen_relative_jump(res, SIZEOF_IP_T);
2994 break;
2995 case P_Jmp_False:
2996 res = pcode_get();
2997 tr = get_var_type(ctx, res);
2998 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));
2999
3000 a1 = u_pcode_get();
3001 a2 = u_pcode_get();
3002
3003 am = INIT_ARG_MODE;
3004 get_arg_mode(am, tr->slot);
3005 code = OPCODE_JMP_FALSE + am * OPCODE_MODE_MULT;
3006 gen_code(code);
3007 gen_am(am, tr->slot);
3008 gen_relative_jump(a1, SIZEOF_IP_T * 2);
3009 gen_relative_jump(a2, SIZEOF_IP_T);
3010 break;
3011 case P_Label:
3012 gen_code(OPCODE_LABEL);
3013 res = u_pcode_get();
3014 ajla_assert_lo(res < ctx->n_labels, (file_line, "P_Label(%s): invalid label %"PRIdMAX"", function_name(ctx), (intmax_t)res));
3015 ajla_assert_lo(ctx->labels[res] == no_label, (file_line, "P_Label(%s): label %"PRIdMAX" already defined", function_name(ctx), (intmax_t)res));
3016 ctx->labels[res] = ctx->code_len;
3017 break;
3018 case P_IO:
3019 if (unlikely(!pcode_io(ctx)))
3020 goto exception;
3021 break;
3022 case P_Args:
3023 ctx->pcode = ctx->pcode_instr_end;
3024 break;
3025 case P_Return_Vars:
3026 for (p = 0; p < instr_params; p++)
3027 pcode_get();
3028 break;
3029 case P_Return:
3030 if (unlikely(!pcode_return(ctx)))
3031 goto exception;
3032 break;
3033 case P_Checkpoint:
3034 if (unlikely(!gen_checkpoint(ctx, ctx->pcode, instr_params, true)))
3035 goto exception;
3036 for (p = 0; p < instr_params; p++)
3037 u_pcode_get();
3038 break;
3039 case P_Line_Info:
3040 lp.line = u_pcode_get();
3041 lp.ip = ctx->code_len;
3042 if (unlikely(!array_add_mayfail(struct line_position, &ctx->lp, &ctx->lp_size, lp, NULL, ctx->err)))
3043 goto exception;
3044 break;
3045 default:
3046 internal(file_line, "pcode_generate_instructions(%s): invalid pcode %"PRIdMAX"", function_name(ctx), (intmax_t)instr);
3047 }
3048
3049 if (unlikely(ctx->pcode != ctx->pcode_instr_end)) {
3050 const pcode_t *pp;
3051 char *s;
3052 size_t l;
3053 str_init(&s, &l);
3054 for (pp = ctx->pcode_instr_end - instr_params - 2; pp < ctx->pcode; pp++) {
3055 str_add_char(&s, &l, ' ');
3056 str_add_signed(&s, &l, *pp, 10);
3057 }
3058 str_finish(&s, &l);
3059 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);
3060 }
3061 }
3062 if (unlikely(ctx->code_len > sign_bit(ip_t) / sizeof(code_t) + uzero))
3063 goto exception_overflow;
3064 return true;
3065
3066 exception_overflow:
3067 *ctx->err = error_ajla(EC_ASYNC, AJLA_ERROR_SIZE_OVERFLOW);
3068 exception:
3069 return false;
3070 }
3071
3072 static bool pcode_generate_record(struct build_function_context *ctx)
3073 {
3074 arg_t ai;
3075 frame_t layout_idx;
3076 struct record_definition *def;
3077 if (unlikely(!array_init_mayfail(frame_t, &ctx->record_entries, &ctx->record_entries_len, ctx->err)))
3078 goto exception;
3079
3080 ctx->layout = layout_start(slot_bits, frame_flags_per_slot_bits, slot_size, data_record_offset, ctx->err);
3081 if (unlikely(!ctx->layout))
3082 goto exception;
3083
3084 for (; ctx->pcode != ctx->pcode_limit; ctx->pcode = ctx->pcode_instr_end) {
3085 pcode_t instr, instr_params;
3086 pcode_get_instr(ctx, &instr, &instr_params);
3087
3088 if (instr == P_Load_Local_Type) {
3089 pcode_t var, fn_var;
3090 pcode_t attr_unused idx;
3091 const struct pcode_type *p;
3092 const struct type *t;
3093
3094 ajla_assert_lo(instr_params == 3, (file_line, "pcode_generate_record(%s): invalid number of parameters %"PRIdMAX"", function_name(ctx), (intmax_t)instr_params));
3095
3096 var = u_pcode_get();
3097 fn_var = pcode_get();
3098 idx = u_pcode_get();
3099 if (unlikely(fn_var != -1))
3100 continue;
3101 if (unlikely(var != (pcode_t)(frame_t)var))
3102 goto exception_overflow;
3103 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));
3104
3105 if (unlikely(!array_add_mayfail(frame_t, &ctx->record_entries, &ctx->record_entries_len, var, NULL, ctx->err)))
3106 goto exception;
3107
3108 if (var_elided(var))
3109 continue;
3110
3111 p = get_var_type(ctx, var);
3112 t = p->type;
3113
3114 if (unlikely(!layout_add(ctx->layout, maximum(t->size, 1), t->align, ctx->err)))
3115 goto exception;
3116 }
3117 }
3118
3119 array_finish(frame_t, &ctx->record_entries, &ctx->record_entries_len);
3120
3121 if (unlikely(ctx->record_entries_len != (size_t)(arg_t)ctx->record_entries_len))
3122 goto exception_overflow;
3123
3124 if (unlikely(!layout_compute(ctx->layout, false, ctx->err)))
3125 goto exception;
3126
3127
3128 def = type_alloc_record_definition(layout_size(ctx->layout), ctx->err);
3129 if (unlikely(!def))
3130 goto exception;
3131 def->n_slots = layout_size(ctx->layout);
3132 def->alignment = maximum(layout_alignment(ctx->layout), frame_align);
3133 def->n_entries = (arg_t)ctx->record_entries_len;
3134
3135 layout_idx = 0;
3136 for (ai = 0; ai < ctx->record_entries_len; ai++) {
3137 frame_t var, slot;
3138 const struct pcode_type *te;
3139 var = ctx->record_entries[ai];
3140 if (var_elided((pcode_t)var)) {
3141 ctx->record_entries[ai] = NO_FRAME_T;
3142 continue;
3143 }
3144 slot = layout_get(ctx->layout, layout_idx++);
3145 ctx->record_entries[ai] = slot;
3146 te = get_var_type(ctx, (pcode_t)var);
3147 def->types[slot] = te->type;
3148 }
3149
3150 def->idx_to_frame = ctx->record_entries, ctx->record_entries = NULL;
3151 ctx->record_definition = def;
3152
3153 layout_free(ctx->layout), ctx->layout = NULL;
3154
3155 return true;
3156
3157 exception_overflow:
3158 *ctx->err = error_ajla(EC_ASYNC, AJLA_ERROR_SIZE_OVERFLOW);
3159 exception:
3160 return false;
3161 }
3162
3163 /*
3164 * pointer_empty -> ret_ex
3165 * poitner_mark -> err
3166 * other -> thunk(error) or data(function)
3167 */
3168 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)
3169 {
3170 frame_t v;
3171 pcode_t p, q, subfns;
3172
3173 size_t is;
3174
3175 struct data *ft, *fn;
3176 struct function_descriptor *sfd;
3177 bool is_saved;
3178
3179 #if defined(HAVE_CODEGEN)
3180 union internal_arg ia[1];
3181 #endif
3182
3183 struct build_function_context ctx_;
3184 struct build_function_context *ctx = &ctx_;
3185
3186 init_ctx(ctx);
3187 ctx->err = err;
3188 ctx->pcode = pcode;
3189 ctx->pcode_limit = pcode + size;
3190 ctx->is_eval = !fp;
3191
3192 q = u_pcode_get() & Fn_Mask;
3193 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));
3194 ctx->function_type = q;
3195
3196 u_pcode_get(); /* call mode - used by the optimizer */
3197
3198 subfns = u_pcode_get();
3199
3200 ctx->n_local_types = u_pcode_get();
3201
3202 q = u_pcode_get();
3203 ctx->n_local_variables = (frame_t)q;
3204 if (unlikely(q != (pcode_t)ctx->n_local_variables))
3205 goto exception_overflow;
3206
3207 q = u_pcode_get();
3208 ctx->n_arguments = (arg_t)q;
3209 ajla_assert_lo(q == (pcode_t)ctx->n_arguments, (file_line, "pcode_build_function_core: overflow in n_arguments"));
3210
3211 q = u_pcode_get();
3212 ctx->n_return_values = (arg_t)q;
3213 ajla_assert_lo(q == (pcode_t)ctx->n_return_values, (file_line, "pcode_build_function_core: overflow in n_return_values"));
3214
3215 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"));
3216
3217 q = u_pcode_get();
3218 ctx->n_real_return_values = (arg_t)q;
3219 ajla_assert_lo(ctx->n_real_return_values <= ctx->n_return_values, (file_line, "pcode_build_function_core: invalid n_real_return_values"));
3220
3221 ctx->n_labels = u_pcode_get();
3222
3223 if (unlikely(!pcode_load_blob(ctx, &ctx->function_name, &is)))
3224 goto exception;
3225 if (unlikely(!array_add_mayfail(uint8_t, &ctx->function_name, &is, 0, NULL, ctx->err)))
3226 goto exception;
3227 array_finish(uint8_t, &ctx->function_name, &is);
3228
3229 while (subfns--) {
3230 q = u_pcode_get();
3231 while (q--)
3232 pcode_get();
3233 }
3234
3235 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);
3236 if (unlikely(!ctx->local_types))
3237 goto exception;
3238
3239 for (p = 0; p < ctx->n_local_types; p++) {
3240 pointer_t *ptr;
3241 struct data *rec_fn;
3242 const struct record_definition *def;
3243 pcode_t base_idx, n_elements;
3244 struct type_entry *flat_rec;
3245 arg_t ai;
3246 const struct type *tt, *tp;
3247
3248 q = pcode_get();
3249 switch (q) {
3250 case Local_Type_Record:
3251 ptr = pcode_module_load_function(ctx);
3252 if (unlikely(!ptr))
3253 goto exception;
3254 pointer_follow(ptr, false, rec_fn, PF_WAIT, fp, ip,
3255 *ret_ex = ex_;
3256 ctx->ret_val = pointer_empty();
3257 goto ret,
3258 thunk_reference(thunk_);
3259 ctx->ret_val = pointer_thunk(thunk_);
3260 goto ret;
3261 );
3262 ajla_assert_lo(da(rec_fn,function)->record_definition != NULL, (file_line, "pcode_build_function_core(%s): record has no definition", function_name(ctx)));
3263 def = type_def(da(rec_fn,function)->record_definition,record);
3264 tt = &def->type;
3265 break;
3266 case Local_Type_Flat_Record:
3267 base_idx = u_pcode_get();
3268 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));
3269 n_elements = u_pcode_get();
3270 def = type_def(ctx->local_types[base_idx].type,record);
3271 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));
3272 flat_rec = type_prepare_flat_record(&def->type, ctx->err);
3273 if (unlikely(!flat_rec))
3274 goto record_not_flattened;
3275 for (ai = 0; ai < def->n_entries; ai++) {
3276 pcode_t typ = pcode_get();
3277 tp = pcode_to_type(ctx, typ, NULL);
3278 if (unlikely(!TYPE_IS_FLAT(tp))) {
3279 type_free_flat_record(flat_rec);
3280 goto record_not_flattened;
3281 }
3282 type_set_flat_record_entry(flat_rec, ai, tp);
3283 }
3284 tt = type_get_flat_record(flat_rec, ctx->err);
3285 if (unlikely(!tt))
3286 goto record_not_flattened;
3287 break;
3288 record_not_flattened:
3289 tt = &def->type;
3290 break;
3291 case Local_Type_Flat_Array:
3292 base_idx = pcode_get();
3293 n_elements = pcode_get();
3294 tp = pcode_to_type(ctx, base_idx, NULL);
3295 if (unlikely(!TYPE_IS_FLAT(tp)))
3296 goto array_not_flattened;
3297 if (unlikely(n_elements > signed_maximum(int_default_t) + zero))
3298 goto array_not_flattened;
3299 tt = type_get_flat_array(tp, n_elements, ctx->err);
3300 if (unlikely(!tt))
3301 goto array_not_flattened;
3302 break;
3303 array_not_flattened:
3304 tt = type_get_unknown();
3305 break;
3306 default:
3307 internal(file_line, "pcode_build_function_core(%s): invalid local type %"PRIdMAX"", function_name(ctx), (intmax_t)q);
3308 }
3309 ctx->local_types[p].type = tt;
3310 ctx->local_types[p].type_index = no_type_index;
3311 }
3312
3313 ctx->layout = layout_start(slot_bits, frame_flags_per_slot_bits, frame_align, frame_offset, ctx->err);
3314 if (unlikely(!ctx->layout))
3315 goto exception;
3316
3317 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);
3318 if (unlikely(!ctx->pcode_types))
3319 goto exception;
3320
3321 if (unlikely(!array_init_mayfail(struct color, &ctx->colors, &ctx->n_colors, ctx->err)))
3322 goto exception;
3323 is = 0;
3324 for (v = 0; v < ctx->n_local_variables; v++) {
3325 struct pcode_type *pt;
3326 pcode_t typ, color, varflags;
3327
3328 pcode_get();
3329 typ = pcode_get();
3330 color = pcode_get();
3331 varflags = u_pcode_get();
3332 pcode_load_blob(ctx, NULL, NULL);
3333 pt = &ctx->pcode_types[v];
3334 pt->argument = NULL;
3335 pt->extra_type = 0;
3336 pt->varflags = varflags;
3337
3338 if (color == -1) {
3339 pt->type = NULL;
3340 } else {
3341 const struct type *t = pcode_to_type(ctx, typ, NULL);
3342 struct color empty_color = { 0, 0, false };
3343 is++;
3344
3345 pt->type = t;
3346 pt->color = color;
3347 if (typ < 0 && !pcode_get_type(typ))
3348 pt->extra_type = typ;
3349 while ((size_t)color >= ctx->n_colors)
3350 if (unlikely(!array_add_mayfail(struct color, &ctx->colors, &ctx->n_colors, empty_color, NULL, ctx->err)))
3351 goto exception;
3352
3353
3354 if (!ctx->colors[color].align) {
3355 ctx->colors[color].size = t->size;
3356 ctx->colors[color].align = t->align;
3357 } else {
3358 ajla_assert_lo(ctx->colors[color].size == t->size &&
3359 ctx->colors[color].align == t->align,
3360 (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));
3361 }
3362
3363 }
3364 }
3365 /*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);*/
3366
3367 for (is = 0; is < ctx->n_colors; is++) {
3368 const struct color *c = &ctx->colors[is];
3369 if (c->align) {
3370 if (unlikely(!layout_add(ctx->layout, maximum(c->size, 1), c->align, ctx->err)))
3371 goto exception;
3372 } else {
3373 if (unlikely(!layout_add(ctx->layout, 0, 1, ctx->err)))
3374 goto exception;
3375 }
3376 }
3377
3378 if (unlikely(!layout_compute(ctx->layout, false, ctx->err)))
3379 goto exception;
3380
3381 ctx->n_slots = layout_size(ctx->layout);
3382
3383 ctx->local_variables = mem_alloc_array_mayfail(mem_calloc_mayfail, struct local_variable *, 0, 0, ctx->n_slots, sizeof(struct local_variable), ctx->err);
3384 if (unlikely(!ctx->local_variables))
3385 goto exception;
3386
3387 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);
3388 if (unlikely(!ctx->local_variables_flags))
3389 goto exception;
3390
3391 for (v = 0; v < ctx->n_local_variables; v++) {
3392 struct pcode_type *pt = &ctx->pcode_types[v];
3393 if (!pt->type) {
3394 pt->slot = NO_FRAME_T;
3395 } else {
3396 pt->slot = layout_get(ctx->layout, pt->color);
3397 ctx->local_variables[pt->slot].type = pt->type;
3398 /*ctx->local_variables_flags[pt->slot].may_be_borrowed = false;*/
3399 /*if (pt->type->tag == TYPE_TAG_flat_option && !(pt->varflags & VarFlag_Must_Be_Flat))
3400 debug("non-flat variable in %s", function_name(ctx));*/
3401 ctx->local_variables_flags[pt->slot].must_be_flat = !!(pt->varflags & VarFlag_Must_Be_Flat);
3402 ctx->local_variables_flags[pt->slot].must_be_data = !!(pt->varflags & VarFlag_Must_Be_Data);
3403 }
3404 }
3405
3406 layout_free(ctx->layout), ctx->layout = NULL;
3407
3408 #if 0
3409 {
3410 unsigned n_elided = 0;
3411 for (v = 0; v < ctx->n_local_variables; v++) {
3412 struct pcode_type *pt = &ctx->pcode_types[v];
3413 if (!pt->type)
3414 n_elided++;
3415 }
3416 debug("function, elided %d/%d", n_elided, ctx->n_local_variables);
3417 }
3418 #endif
3419
3420 if (unlikely(!array_init_mayfail(pointer_t *, &ctx->ld, &ctx->ld_len, ctx->err)))
3421 goto exception;
3422
3423 if (unlikely(!pcode_preload_ld(ctx)))
3424 goto exception;
3425
3426 if (md) {
3427 sfd = save_find_function_descriptor(md, fd);
3428 } else {
3429 sfd = NULL;
3430 }
3431
3432 is_saved = false;
3433 if (sfd) {
3434 ctx->code = sfd->code;
3435 ctx->code_len = sfd->code_size;
3436 ft = sfd->types;
3437 is_saved = true;
3438 goto skip_codegen;
3439 }
3440
3441 ctx->labels = mem_alloc_array_mayfail(mem_alloc_mayfail, size_t *, 0, 0, ctx->n_labels, sizeof(size_t), ctx->err);
3442 if (unlikely(!ctx->labels))
3443 goto exception;
3444 for (p = 0; p < ctx->n_labels; p++)
3445 ctx->labels[p] = no_label;
3446
3447 if (unlikely(!array_init_mayfail(struct label_ref, &ctx->label_ref, &ctx->label_ref_len, ctx->err)))
3448 goto exception;
3449
3450 if (unlikely(!array_init_mayfail(const struct type *, &ctx->types, &ctx->types_len, ctx->err)))
3451 goto exception;
3452
3453 if (unlikely(!array_init_mayfail(code_t, &ctx->code, &ctx->code_len, ctx->err)))
3454 goto exception;
3455
3456 if (unlikely(!array_init_mayfail(struct line_position, &ctx->lp, &ctx->lp_size, ctx->err)))
3457 goto exception;
3458
3459 if (unlikely(ctx->function_type == Fn_Record) || unlikely(ctx->function_type == Fn_Option)) {
3460 if (ctx->function_type == Fn_Record) {
3461 if (unlikely(!pcode_generate_record(ctx)))
3462 goto exception;
3463 }
3464 gen_code(OPCODE_UNREACHABLE);
3465 } else {
3466 if (unlikely(!pcode_generate_instructions(ctx)))
3467 goto exception;
3468 }
3469
3470 array_finish(code_t, &ctx->code, &ctx->code_len);
3471 array_finish(struct line_position, &ctx->lp, &ctx->lp_size);
3472
3473 for (is = 0; is < ctx->label_ref_len; is++) {
3474 uint32_t diff;
3475 struct label_ref *lr = &ctx->label_ref[is];
3476 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));
3477 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));
3478 diff = ((uint32_t)ctx->labels[lr->label] - (uint32_t)lr->code_pos) * sizeof(code_t);
3479 if (SIZEOF_IP_T == 2) {
3480 ctx->code[lr->code_pos] += (code_t)diff;
3481 } else if (SIZEOF_IP_T == 4 && !CODE_ENDIAN) {
3482 uint32_t val = ctx->code[lr->code_pos] | ((uint32_t)ctx->code[lr->code_pos + 1] << 16);
3483 val += diff;
3484 ctx->code[lr->code_pos] = val & 0xffff;
3485 ctx->code[lr->code_pos + 1] = val >> 16;
3486 } else if (SIZEOF_IP_T == 4 && CODE_ENDIAN) {
3487 uint32_t val = ((uint32_t)ctx->code[lr->code_pos] << 16) | ctx->code[lr->code_pos + 1];
3488 val += diff;
3489 ctx->code[lr->code_pos] = val >> 16;
3490 ctx->code[lr->code_pos + 1] = val & 0xffff;
3491 } else {
3492 not_reached();
3493 }
3494 }
3495
3496 mem_free(ctx->labels), ctx->labels = NULL;
3497 mem_free(ctx->label_ref), ctx->label_ref = NULL;
3498
3499 ft = data_alloc_flexible(function_types, types, ctx->types_len, ctx->err);
3500 if (unlikely(!ft))
3501 goto exception;
3502 da(ft,function_types)->n_types = ctx->types_len;
3503 memcpy(da(ft,function_types)->types, ctx->types, ctx->types_len * sizeof(const struct type *));
3504 mem_free(ctx->types);
3505 ctx->types = NULL;
3506 ctx->ft_free = ft;
3507
3508 skip_codegen:
3509
3510 mem_free(ctx->colors), ctx->colors = NULL;
3511 mem_free(ctx->pcode_types), ctx->pcode_types = NULL;
3512 mem_free(ctx->local_types), ctx->local_types = NULL;
3513 free_ld_tree(ctx);
3514 array_finish(pointer_t *, &ctx->ld, &ctx->ld_len);
3515
3516 if (profiling_escapes) {
3517 ctx->escape_data = mem_alloc_array_mayfail(mem_calloc_mayfail, struct escape_data *, 0, 0, ctx->code_len, sizeof(struct escape_data), ctx->err);
3518 if (unlikely(!ctx->escape_data))
3519 goto exception;
3520 }
3521
3522 fn = data_alloc_flexible(function, local_directory, ctx->ld_len, ctx->err);
3523 if (unlikely(!fn))
3524 goto exception;
3525
3526 da(fn,function)->frame_slots = frame_offset / slot_size + ctx->n_slots;
3527 da(fn,function)->n_bitmap_slots = bitmap_slots(ctx->n_slots);
3528 da(fn,function)->n_arguments = ctx->n_real_arguments;
3529 da(fn,function)->n_return_values = ctx->n_real_return_values;
3530 da(fn,function)->code = ctx->code;
3531 da(fn,function)->code_size = ctx->code_len;
3532 da(fn,function)->local_variables = ctx->local_variables;
3533 if (!is_saved) {
3534 da(fn,function)->local_variables_flags = ctx->local_variables_flags;
3535 } else {
3536 mem_free(ctx->local_variables_flags);
3537 da(fn,function)->local_variables_flags = sfd->local_variables_flags;
3538 }
3539 da(fn,function)->args = ctx->args;
3540 da(fn,function)->types_ptr = pointer_data(ft);
3541 da(fn,function)->record_definition = ctx->record_definition ? &ctx->record_definition->type : NULL;
3542 da(fn,function)->function_name = cast_ptr(char *, ctx->function_name);
3543 da(fn,function)->module_designator = md;
3544 da(fn,function)->function_designator = fd;
3545 if (!is_saved) {
3546 da(fn,function)->lp = ctx->lp;
3547 da(fn,function)->lp_size = ctx->lp_size;
3548 } else {
3549 da(fn,function)->lp = sfd->lp;
3550 da(fn,function)->lp_size = sfd->lp_size;
3551 }
3552 memcpy(da(fn,function)->local_directory, ctx->ld, ctx->ld_len * sizeof(pointer_t *));
3553 da(fn,function)->local_directory_size = ctx->ld_len;
3554 mem_free(ctx->ld);
3555 #ifdef HAVE_CODEGEN
3556 ia[0].ptr = fn;
3557 da(fn,function)->codegen = function_build_internal_thunk(codegen_fn, 1, ia);
3558 store_relaxed(&da(fn,function)->codegen_failed, 0);
3559 #endif
3560 function_init_common(fn);
3561
3562 if (sfd) {
3563 /*if (memcmp(ctx->code, sfd->code, ctx->code_len * sizeof(code_t))) internal(file_line, "code mismatch");*/
3564 da(fn,function)->loaded_cache = sfd->data_saved_cache;
3565 /*if (da(fn,function)->loaded_cache) debug("loaded cache: %s", function_name(ctx));*/
3566 }
3567
3568 da(fn,function)->escape_data = ctx->escape_data;
3569 da(fn,function)->leaf = ctx->leaf;
3570 da(fn,function)->is_saved = is_saved;
3571
3572 ipret_prefetch_functions(fn);
3573
3574 return pointer_data(fn);
3575
3576 exception_overflow:
3577 *ctx->err = error_ajla(EC_ASYNC, AJLA_ERROR_SIZE_OVERFLOW);
3578 exception:
3579 ctx->ret_val = pointer_mark();
3580 ret:
3581 done_ctx(ctx);
3582 return ctx->ret_val;
3583 }
3584
3585 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)
3586 {
3587 pointer_t ptr;
3588 void *ex;
3589 ajla_error_t err;
3590 ptr = pcode_build_function_core(fp, ip, pcode, size, md, fd, &ex, &err);
3591 if (unlikely(pointer_is_empty(ptr)))
3592 return ex;
3593 if (unlikely(pointer_is_mark(ptr)))
3594 return function_return(fp, pointer_error(err, NULL, NULL pass_file_line));
3595 return function_return(fp, ptr);
3596 }
3597
3598 void *pcode_build_function_from_builtin(frame_s *fp, const code_t *ip, union internal_arg arguments[])
3599 {
3600 const pcode_t *start;
3601 size_t size;
3602 struct module_designator *md = arguments[0].ptr;
3603 struct function_designator *fd = arguments[1].ptr;
3604 builtin_find_function(md->path, md->path_len, fd->n_entries, fd->entries, &start, &size);
3605 return pcode_build_function(fp, ip, start, size, md, arguments[1].ptr);
3606 }
3607
3608 void *pcode_build_function_from_array(frame_s *fp, const code_t *ip, union internal_arg arguments[])
3609 {
3610 pointer_t *ptr;
3611 void *ex;
3612 struct thunk *thunk;
3613 char *bytes;
3614 size_t bytes_l;
3615 const struct function_designator *fd;
3616 const pcode_t *start;
3617 size_t size;
3618
3619 ptr = arguments[0].ptr;
3620 ex = pointer_deep_eval(ptr, fp, ip, &thunk);
3621 if (unlikely(ex != POINTER_FOLLOW_THUNK_GO)) {
3622 if (ex == POINTER_FOLLOW_THUNK_EXCEPTION) {
3623 return function_return(fp, pointer_thunk(thunk));
3624 }
3625 return ex;
3626 }
3627
3628 array_to_bytes(ptr, &bytes, &bytes_l);
3629 bytes_l--;
3630
3631 if (unlikely(bytes_l % sizeof(pcode_t) != 0))
3632 internal(file_line, "pcode_build_function_from_array: invalid length: %lu", (unsigned long)bytes_l);
3633
3634 start = cast_ptr(const pcode_t *, bytes);
3635 size = bytes_l / sizeof(pcode_t);
3636 fd = arguments[2].ptr;
3637
3638 /*builtin_walk_nested(&start, &size, fd->n_entries, fd->entries);*/
3639
3640 ex = pcode_build_function(fp, ip, start, size, arguments[1].ptr, fd);
3641
3642 mem_free(bytes);
3643
3644 return ex;
3645 }
3646
3647 void *pcode_array_from_builtin(frame_s *fp, const code_t attr_unused *ip, union internal_arg arguments[])
3648 {
3649 const struct type *t;
3650 struct data *d;
3651 ajla_error_t err;
3652 const pcode_t *start;
3653 size_t size;
3654 struct module_designator *md = arguments[0].ptr;
3655 struct function_designator *fd = arguments[1].ptr;
3656
3657 builtin_find_function(md->path, md->path_len, fd->n_entries, fd->entries, &start, &size);
3658
3659 t = type_get_fixed(log_2(sizeof(pcode_t)), false);
3660 d = data_alloc_array_flat_mayfail(t, size, size, false, &err pass_file_line);
3661 if (unlikely(!d)) {
3662 return function_return(fp, pointer_thunk(thunk_alloc_exception_error(err, NULL, NULL, NULL pass_file_line)));
3663 }
3664
3665 memcpy(da_array_flat(d), start, size * sizeof(pcode_t));
3666
3667 return function_return(fp, pointer_data(d));
3668 }
3669
3670
3671 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)
3672 {
3673 pcode_t *pc = NULL;
3674 size_t pc_l;
3675 unsigned n_local_variables;
3676 unsigned n_arguments;
3677 unsigned i;
3678 pointer_t ptr;
3679
3680 if (unlikely(!array_init_mayfail(pcode_t, &pc, &pc_l, err)))
3681 goto ret_err;
3682 #define add(x) \
3683 do { \
3684 if (unlikely(!array_add_mayfail(pcode_t, &pc, &pc_l, x, NULL, err)))\
3685 goto ret_err; \
3686 } while (0)
3687 #define addstr(x, l) \
3688 do { \
3689 if (unlikely(!array_add_multiple_mayfail(pcode_t, &pc, &pc_l, x, l, NULL, err)))\
3690 goto ret_err; \
3691 } while (0)
3692
3693 n_local_variables = Op_IsUnary(op) ? 2 : 3;
3694 n_arguments = n_local_variables - 1;
3695
3696 add(Fn_Function);
3697 add(Call_Mode_Strict);
3698 add(0);
3699 add(0);
3700 add(n_local_variables);
3701 add(0);
3702 add(1);
3703 add(1);
3704 add(0);
3705 add(0);
3706
3707 for (i = 0; i < n_local_variables; i++) {
3708 pcode_t t = i < n_arguments ? src_type : dest_type;
3709 add(t);
3710 add(t);
3711 add(i);
3712 add(0);
3713 add(0);
3714 }
3715
3716 add(P_Args);
3717 add(0);
3718
3719 add(P_Load_Const);
3720 add(1 + blob_1_len);
3721 add(0);
3722 addstr(blob_1, blob_1_len);
3723 if (n_arguments == 2) {
3724 add(P_Load_Const);
3725 add(1 + blob_2_len);
3726 add(1);
3727 addstr(blob_2, blob_2_len);
3728 }
3729
3730 add(Op_IsUnary(op) ? P_UnaryOp : P_BinaryOp);
3731 add(Op_IsUnary(op) ? 4 : 6);
3732 add(op);
3733 add(n_arguments);
3734 add(Flag_Free_Argument | Flag_Op_Strict);
3735 add(0);
3736 if (n_arguments == 2) {
3737 add(Flag_Free_Argument);
3738 add(1);
3739 }
3740
3741 add(P_Return);
3742 add(2);
3743 add(Flag_Free_Argument);
3744 add(n_arguments);
3745
3746 #undef add
3747 #undef addstr
3748
3749 ptr = pcode_build_function_core(NULL, NULL, pc, pc_l, NULL, NULL, NULL, err);
3750
3751 mem_free(pc);
3752
3753 return ptr;
3754
3755 ret_err:
3756 if (pc)
3757 mem_free(pc);
3758 return pointer_empty();
3759 }
3760
3761
3762 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)
3763 {
3764 struct data *function;
3765 pointer_t fn_thunk;
3766
3767 #ifdef POINTER_FOLLOW_IS_LOCKLESS
3768 const addrlock_depth lock_depth = DEPTH_THUNK;
3769 #else
3770 const addrlock_depth lock_depth = DEPTH_POINTER;
3771 #endif
3772
3773 again:
3774 pointer_follow(ptr, false, function, PF_WAIT, fp, ip,
3775 return ex_,
3776 *result = ptr;
3777 return POINTER_FOLLOW_THUNK_RETRY);
3778
3779 if (likely(function != NULL)) {
3780 *result = ptr;
3781 return POINTER_FOLLOW_THUNK_RETRY;
3782 }
3783
3784 fn_thunk = function_build_internal_thunk(build_fn, n_arguments, ia);
3785
3786 barrier_write_before_lock();
3787 address_lock(ptr, lock_depth);
3788 if (likely(pointer_is_empty(*pointer_volatile(ptr)))) {
3789 *pointer_volatile(ptr) = fn_thunk;
3790 address_unlock(ptr, lock_depth);
3791 } else {
3792 address_unlock(ptr, lock_depth);
3793 pointer_dereference(fn_thunk);
3794 }
3795
3796 goto again;
3797 }
3798
3799 static void *pcode_build_op_function(frame_s *fp, const code_t *ip, union internal_arg a[])
3800 {
3801 pcode_t src_type = (pcode_t)a[0].i;
3802 pcode_t dest_type = (pcode_t)a[1].i;
3803 pcode_t op = (pcode_t)a[2].i;
3804 unsigned flags = (unsigned)a[3].i;
3805 unsigned i;
3806 unsigned n_local_variables;
3807 unsigned n_arguments;
3808 pcode_t pcode[41];
3809 pcode_t *pc = pcode;
3810
3811 n_local_variables = flags & PCODE_FIND_OP_UNARY ? 2 : 3;
3812 n_arguments = n_local_variables - 1;
3813
3814 *pc++ = Fn_Function;
3815 *pc++ = Call_Mode_Strict;
3816 *pc++ = 0;
3817 *pc++ = 0;
3818 *pc++ = (pcode_t)n_local_variables;
3819 *pc++ = (pcode_t)n_arguments;
3820 *pc++ = 1;
3821 *pc++ = 1;
3822 *pc++ = 0;
3823 *pc++ = 0;
3824
3825 for (i = 0; i < n_local_variables; i++) {
3826 pcode_t t = i < n_arguments ? src_type : dest_type;
3827 *pc++ = t;
3828 *pc++ = t;
3829 *pc++ = i;
3830 *pc++ = 0;
3831 *pc++ = 0;
3832 }
3833
3834 *pc++ = P_Args;
3835 *pc++ = n_arguments;
3836 for (i = 0; i < n_arguments; i++)
3837 *pc++ = i;
3838
3839 *pc++ = (pcode_t)(flags & PCODE_FIND_OP_UNARY ? P_UnaryOp : P_BinaryOp);
3840 *pc++ = (pcode_t)(flags & PCODE_FIND_OP_UNARY ? 4 : 6);
3841 *pc++ = op;
3842 *pc++ = (pcode_t)n_arguments;
3843 *pc++ = Flag_Free_Argument | Flag_Op_Strict;
3844 *pc++ = 0;
3845 if (!(flags & PCODE_FIND_OP_UNARY)) {
3846 *pc++ = Flag_Free_Argument;
3847 *pc++ = 1;
3848 }
3849
3850 *pc++ = P_Return;
3851 *pc++ = 2;
3852 *pc++ = Flag_Free_Argument;
3853 *pc++ = n_arguments;
3854
3855 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));
3856
3857 return pcode_build_function(fp, ip, pcode, pc - pcode, NULL, NULL);
3858 }
3859
3860 static pointer_t fixed_op_thunk[TYPE_FIXED_N][OPCODE_FIXED_OP_N];
3861 static pointer_t int_op_thunk[TYPE_INT_N][OPCODE_INT_OP_N];
3862 static pointer_t real_op_thunk[TYPE_REAL_N][OPCODE_REAL_OP_N];
3863 static pointer_t bool_op_thunk[OPCODE_BOOL_TYPE_MULT];
3864
3865 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)
3866 {
3867 union internal_arg ia[4];
3868 pointer_t *ptr;
3869
3870 type_tag_t tag = likely(!(flags & PCODE_CONVERT_FROM_INT)) ? type->tag : rtype->tag;
3871
3872 if (TYPE_TAG_IS_FIXED(tag)) {
3873 unsigned idx = (code - OPCODE_FIXED_OP - (TYPE_TAG_IDX_FIXED(tag) >> 1) * OPCODE_FIXED_TYPE_MULT) / OPCODE_FIXED_OP_MULT;
3874 ajla_assert(idx < OPCODE_FIXED_OP_N, (file_line, "pcode_find_op_function: invalid parameters, type %u, code %04x", tag, code));
3875 ptr = &fixed_op_thunk[TYPE_TAG_IDX_FIXED(tag) >> 1][idx];
3876 } else if (TYPE_TAG_IS_INT(tag)) {
3877 unsigned idx = (code - OPCODE_INT_OP - TYPE_TAG_IDX_INT(tag) * OPCODE_INT_TYPE_MULT) / OPCODE_INT_OP_MULT;
3878 if (idx >= OPCODE_INT_OP_C && idx < OPCODE_INT_OP_UNARY)
3879 idx -= OPCODE_INT_OP_C;
3880 ajla_assert(idx < OPCODE_INT_OP_N, (file_line, "pcode_find_op_function: invalid parameters, type %u, code %04x", tag, code));
3881 ptr = &int_op_thunk[TYPE_TAG_IDX_INT(tag)][idx];
3882 ajla_assert(is_power_of_2(type->size), (file_line, "pcode_find_op_function: invalid integer type size %"PRIuMAX"", (uintmax_t)type->size));
3883 } else if (TYPE_TAG_IS_REAL(tag)) {
3884 unsigned idx = (code - OPCODE_REAL_OP - TYPE_TAG_IDX_REAL(tag) * OPCODE_REAL_TYPE_MULT) / OPCODE_REAL_OP_MULT;
3885 ajla_assert(idx < OPCODE_REAL_OP_N, (file_line, "pcode_find_op_function: invalid parameters, type %u, code %04x", tag, code));
3886 ptr = &real_op_thunk[TYPE_TAG_IDX_REAL(tag)][idx];
3887 } else if (tag) {
3888 unsigned idx = (code - OPCODE_BOOL_OP) / OPCODE_BOOL_OP_MULT;
3889 ajla_assert(idx < OPCODE_BOOL_OP_N, (file_line, "pcode_find_op_function: invalid parameters, type %u, code %04x", tag, code));
3890 ptr = &bool_op_thunk[idx];
3891 } else {
3892 internal(file_line, "pcode_find_op_function: invalid type %u", tag);
3893 }
3894
3895 ia[0].i = type_to_pcode(type);
3896 ia[1].i = type_to_pcode(rtype);
3897 ia[2].i = code + Op_N;
3898 ia[3].i = flags;
3899
3900 return pcode_alloc_op_function(ptr, fp, ip, pcode_build_op_function, 4, ia, result);
3901 }
3902
3903 static void *pcode_build_is_exception_function(frame_s *fp, const code_t *ip, union internal_arg attr_unused a[])
3904 {
3905 pcode_t pcode[36];
3906 pcode_t *pc = pcode;
3907
3908 *pc++ = Fn_Function;
3909 *pc++ = Call_Mode_Strict;
3910 *pc++ = 0;
3911 *pc++ = 0;
3912 *pc++ = 2;
3913 *pc++ = 1;
3914 *pc++ = 1;
3915 *pc++ = 1;
3916 *pc++ = 0;
3917 *pc++ = 0;
3918
3919 *pc++ = T_Undetermined;
3920 *pc++ = T_Undetermined;
3921 *pc++ = 0;
3922 *pc++ = 0;
3923 *pc++ = 0;
3924
3925 *pc++ = T_FlatOption;
3926 *pc++ = T_FlatOption;
3927 *pc++ = 1;
3928 *pc++ = 0;
3929 *pc++ = 0;
3930
3931 *pc++ = P_Args;
3932 *pc++ = 1;
3933 *pc++ = 0;
3934
3935 *pc++ = P_UnaryOp;
3936 *pc++ = 4;
3937 *pc++ = Un_IsException;
3938 *pc++ = 1;
3939 *pc++ = Flag_Free_Argument | Flag_Op_Strict;
3940 *pc++ = 0;
3941
3942 *pc++ = P_Free;
3943 *pc++ = 1;
3944 *pc++ = 0;
3945
3946 *pc++ = P_Return;
3947 *pc++ = 2;
3948 *pc++ = Flag_Free_Argument;
3949 *pc++ = 1;
3950
3951 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)));
3952
3953 return pcode_build_function(fp, ip, pcode, pc - pcode, NULL, NULL);
3954 }
3955
3956 static pointer_t is_exception_thunk;
3957
3958 void * attr_fastcall pcode_find_is_exception(frame_s *fp, const code_t *ip, pointer_t **result)
3959 {
3960 return pcode_alloc_op_function(&is_exception_thunk, fp, ip, pcode_build_is_exception_function, 0, NULL, result);
3961 }
3962
3963 static void *pcode_build_get_exception_function(frame_s *fp, const code_t *ip, union internal_arg a[])
3964 {
3965 pcode_t pcode[36];
3966 pcode_t *pc = pcode;
3967
3968 *pc++ = Fn_Function;
3969 *pc++ = Call_Mode_Strict;
3970 *pc++ = 0;
3971 *pc++ = 0;
3972 *pc++ = 2;
3973 *pc++ = 1;
3974 *pc++ = 1;
3975 *pc++ = 1;
3976 *pc++ = 0;
3977 *pc++ = 0;
3978
3979 *pc++ = T_Undetermined;
3980 *pc++ = T_Undetermined;
3981 *pc++ = 0;
3982 *pc++ = 0;
3983 *pc++ = 0;
3984
3985 *pc++ = T_Integer;
3986 *pc++ = T_Integer;
3987 *pc++ = 1;
3988 *pc++ = 0;
3989 *pc++ = 0;
3990
3991 *pc++ = P_Args;
3992 *pc++ = 1;
3993 *pc++ = 0;
3994
3995 *pc++ = P_UnaryOp;
3996 *pc++ = 4;
3997 *pc++ = Un_ExceptionClass + a[0].i;
3998 *pc++ = 1;
3999 *pc++ = Flag_Free_Argument | Flag_Op_Strict;
4000 *pc++ = 0;
4001
4002 *pc++ = P_Free;
4003 *pc++ = 1;
4004 *pc++ = 0;
4005
4006 *pc++ = P_Return;
4007 *pc++ = 2;
4008 *pc++ = Flag_Free_Argument;
4009 *pc++ = 1;
4010
4011 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)));
4012
4013 return pcode_build_function(fp, ip, pcode, pc - pcode, NULL, NULL);
4014 }
4015
4016 static pointer_t get_exception_thunk[3];
4017
4018 void * attr_fastcall pcode_find_get_exception(unsigned mode, frame_s *fp, const code_t *ip, pointer_t **result)
4019 {
4020 union internal_arg ia[1];
4021 ia[0].i = mode;
4022 return pcode_alloc_op_function(&get_exception_thunk[mode], fp, ip, pcode_build_get_exception_function, 1, ia, result);
4023 }
4024
4025 static void *pcode_build_array_load_function(frame_s *fp, const code_t *ip, union internal_arg attr_unused a[])
4026 {
4027 pcode_t pcode[45];
4028 pcode_t *pc = pcode;
4029
4030 *pc++ = Fn_Function;
4031 *pc++ = Call_Mode_Strict;
4032 *pc++ = 0;
4033 *pc++ = 0;
4034 *pc++ = 3;
4035 *pc++ = 2;
4036 *pc++ = 1;
4037 *pc++ = 1;
4038 *pc++ = 0;
4039 *pc++ = 0;
4040
4041 *pc++ = T_Undetermined;
4042 *pc++ = T_Undetermined;
4043 *pc++ = 0;
4044 *pc++ = 0;
4045 *pc++ = 0;
4046
4047 *pc++ = T_Integer;
4048 *pc++ = T_Integer;
4049 *pc++ = 1;
4050 *pc++ = 0;
4051 *pc++ = 0;
4052
4053 *pc++ = T_Undetermined;
4054 *pc++ = T_Undetermined;
4055 *pc++ = 2;
4056 *pc++ = 0;
4057 *pc++ = 0;
4058
4059 *pc++ = P_Args;
4060 *pc++ = 2;
4061 *pc++ = 0;
4062 *pc++ = 1;
4063
4064 *pc++ = P_Array_Load;
4065 *pc++ = 4;
4066 *pc++ = 2;
4067 *pc++ = Flag_Evaluate;
4068 *pc++ = 0;
4069 *pc++ = 1;
4070
4071 *pc++ = P_Free;
4072 *pc++ = 1;
4073 *pc++ = 0;
4074
4075 *pc++ = P_Free;
4076 *pc++ = 1;
4077 *pc++ = 1;
4078
4079 *pc++ = P_Return;
4080 *pc++ = 2;
4081 *pc++ = Flag_Free_Argument;
4082 *pc++ = 2;
4083
4084 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)));
4085
4086 return pcode_build_function(fp, ip, pcode, pc - pcode, NULL, NULL);
4087 }
4088
4089 static pointer_t array_load_thunk;
4090
4091 void * attr_fastcall pcode_find_array_load_function(frame_s *fp, const code_t *ip, pointer_t **result)
4092 {
4093 return pcode_alloc_op_function(&array_load_thunk, fp, ip, pcode_build_array_load_function, 0, NULL, result);
4094 }
4095
4096 static void *pcode_build_array_len_function(frame_s *fp, const code_t *ip, union internal_arg attr_unused a[])
4097 {
4098 pcode_t pcode[35];
4099 pcode_t *pc = pcode;
4100
4101 *pc++ = Fn_Function;
4102 *pc++ = Call_Mode_Strict;
4103 *pc++ = 0;
4104 *pc++ = 0;
4105 *pc++ = 2;
4106 *pc++ = 1;
4107 *pc++ = 1;
4108 *pc++ = 1;
4109 *pc++ = 0;
4110 *pc++ = 0;
4111
4112 *pc++ = T_Undetermined;
4113 *pc++ = T_Undetermined;
4114 *pc++ = 0;
4115 *pc++ = 0;
4116 *pc++ = 0;
4117
4118 *pc++ = T_Integer;
4119 *pc++ = T_Integer;
4120 *pc++ = 1;
4121 *pc++ = 0;
4122 *pc++ = 0;
4123
4124 *pc++ = P_Args;
4125 *pc++ = 1;
4126 *pc++ = 0;
4127
4128 *pc++ = P_Array_Len;
4129 *pc++ = 3;
4130 *pc++ = 1;
4131 *pc++ = 0;
4132 *pc++ = Flag_Evaluate;
4133
4134 *pc++ = P_Free;
4135 *pc++ = 1;
4136 *pc++ = 0;
4137
4138 *pc++ = P_Return;
4139 *pc++ = 2;
4140 *pc++ = Flag_Free_Argument;
4141 *pc++ = 1;
4142
4143 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)));
4144
4145 return pcode_build_function(fp, ip, pcode, pc - pcode, NULL, NULL);
4146 }
4147
4148 static pointer_t array_len_thunk;
4149
4150 void * attr_fastcall pcode_find_array_len_function(frame_s *fp, const code_t *ip, pointer_t **result)
4151 {
4152 return pcode_alloc_op_function(&array_len_thunk, fp, ip, pcode_build_array_len_function, 0, NULL, result);
4153 }
4154
4155 static void *pcode_build_array_len_greater_than_function(frame_s *fp, const code_t *ip, union internal_arg attr_unused a[])
4156 {
4157 pcode_t pcode[45];
4158 pcode_t *pc = pcode;
4159
4160 *pc++ = Fn_Function;
4161 *pc++ = Call_Mode_Strict;
4162 *pc++ = 0;
4163 *pc++ = 0;
4164 *pc++ = 3;
4165 *pc++ = 2;
4166 *pc++ = 1;
4167 *pc++ = 1;
4168 *pc++ = 0;
4169 *pc++ = 0;
4170
4171 *pc++ = T_Undetermined;
4172 *pc++ = T_Undetermined;
4173 *pc++ = 0;
4174 *pc++ = 0;
4175 *pc++ = 0;
4176
4177 *pc++ = T_Integer;
4178 *pc++ = T_Integer;
4179 *pc++ = 1;
4180 *pc++ = 0;
4181 *pc++ = 0;
4182
4183 *pc++ = T_FlatOption;
4184 *pc++ = T_FlatOption;
4185 *pc++ = 2;
4186 *pc++ = 0;
4187 *pc++ = 0;
4188
4189 *pc++ = P_Args;
4190 *pc++ = 2;
4191 *pc++ = 0;
4192 *pc++ = 1;
4193
4194 *pc++ = P_Array_Len_Greater_Than;
4195 *pc++ = 4;
4196 *pc++ = 2;
4197 *pc++ = 0;
4198 *pc++ = 1;
4199 *pc++ = Flag_Evaluate;
4200
4201 *pc++ = P_Free;
4202 *pc++ = 1;
4203 *pc++ = 0;
4204
4205 *pc++ = P_Free;
4206 *pc++ = 1;
4207 *pc++ = 1;
4208
4209 *pc++ = P_Return;
4210 *pc++ = 2;
4211 *pc++ = Flag_Free_Argument;
4212 *pc++ = 2;
4213
4214 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)));
4215
4216 return pcode_build_function(fp, ip, pcode, pc - pcode, NULL, NULL);
4217 }
4218
4219 static pointer_t array_len_greater_than_thunk;
4220
4221 void * attr_fastcall pcode_find_array_len_greater_than_function(frame_s *fp, const code_t *ip, pointer_t **result)
4222 {
4223 return pcode_alloc_op_function(&array_len_greater_than_thunk, fp, ip, pcode_build_array_len_greater_than_function, 0, NULL, result);
4224 }
4225
4226 static void *pcode_build_array_sub_function(frame_s *fp, const code_t *ip, union internal_arg attr_unused a[])
4227 {
4228 pcode_t pcode[55];
4229 pcode_t *pc = pcode;
4230
4231 *pc++ = Fn_Function;
4232 *pc++ = Call_Mode_Strict;
4233 *pc++ = 0;
4234 *pc++ = 0;
4235 *pc++ = 4;
4236 *pc++ = 3;
4237 *pc++ = 1;
4238 *pc++ = 1;
4239 *pc++ = 0;
4240 *pc++ = 0;
4241
4242 *pc++ = T_Undetermined;
4243 *pc++ = T_Undetermined;
4244 *pc++ = 0;
4245 *pc++ = 0;
4246 *pc++ = 0;
4247
4248 *pc++ = T_Integer;
4249 *pc++ = T_Integer;
4250 *pc++ = 1;
4251 *pc++ = 0;
4252 *pc++ = 0;
4253
4254 *pc++ = T_Integer;
4255 *pc++ = T_Integer;
4256 *pc++ = 2;
4257 *pc++ = 0;
4258 *pc++ = 0;
4259
4260 *pc++ = T_Undetermined;
4261 *pc++ = T_Undetermined;
4262 *pc++ = 3;
4263 *pc++ = 0;
4264 *pc++ = 0;
4265
4266 *pc++ = P_Args;
4267 *pc++ = 3;
4268 *pc++ = 0;
4269 *pc++ = 1;
4270 *pc++ = 2;
4271
4272 *pc++ = P_Array_Sub;
4273 *pc++ = 5;
4274 *pc++ = 3;
4275 *pc++ = Flag_Evaluate;
4276 *pc++ = 0;
4277 *pc++ = 1;
4278 *pc++ = 2;
4279
4280 *pc++ = P_Free;
4281 *pc++ = 1;
4282 *pc++ = 0;
4283
4284 *pc++ = P_Free;
4285 *pc++ = 1;
4286 *pc++ = 1;
4287
4288 *pc++ = P_Free;
4289 *pc++ = 1;
4290 *pc++ = 2;
4291
4292 *pc++ = P_Return;
4293 *pc++ = 2;
4294 *pc++ = Flag_Free_Argument;
4295 *pc++ = 3;
4296
4297 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)));
4298
4299 return pcode_build_function(fp, ip, pcode, pc - pcode, NULL, NULL);
4300 }
4301
4302 static pointer_t array_sub_thunk;
4303
4304 void * attr_fastcall pcode_find_array_sub_function(frame_s *fp, const code_t *ip, pointer_t **result)
4305 {
4306 return pcode_alloc_op_function(&array_sub_thunk, fp, ip, pcode_build_array_sub_function, 0, NULL, result);
4307 }
4308
4309 static void *pcode_build_array_skip_function(frame_s *fp, const code_t *ip, union internal_arg attr_unused a[])
4310 {
4311 pcode_t pcode[45];
4312 pcode_t *pc = pcode;
4313
4314 *pc++ = Fn_Function;
4315 *pc++ = Call_Mode_Strict;
4316 *pc++ = 0;
4317 *pc++ = 0;
4318 *pc++ = 3;
4319 *pc++ = 2;
4320 *pc++ = 1;
4321 *pc++ = 1;
4322 *pc++ = 0;
4323 *pc++ = 0;
4324
4325 *pc++ = T_Undetermined;
4326 *pc++ = T_Undetermined;
4327 *pc++ = 0;
4328 *pc++ = 0;
4329 *pc++ = 0;
4330
4331 *pc++ = T_Integer;
4332 *pc++ = T_Integer;
4333 *pc++ = 1;
4334 *pc++ = 0;
4335 *pc++ = 0;
4336
4337 *pc++ = T_Undetermined;
4338 *pc++ = T_Undetermined;
4339 *pc++ = 2;
4340 *pc++ = 0;
4341 *pc++ = 0;
4342
4343 *pc++ = P_Args;
4344 *pc++ = 2;
4345 *pc++ = 0;
4346 *pc++ = 1;
4347
4348 *pc++ = P_Array_Skip;
4349 *pc++ = 4;
4350 *pc++ = 2;
4351 *pc++ = Flag_Evaluate;
4352 *pc++ = 0;
4353 *pc++ = 1;
4354
4355 *pc++ = P_Free;
4356 *pc++ = 1;
4357 *pc++ = 0;
4358
4359 *pc++ = P_Free;
4360 *pc++ = 1;
4361 *pc++ = 1;
4362
4363 *pc++ = P_Return;
4364 *pc++ = 2;
4365 *pc++ = Flag_Free_Argument;
4366 *pc++ = 2;
4367
4368 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)));
4369
4370 return pcode_build_function(fp, ip, pcode, pc - pcode, NULL, NULL);
4371 }
4372
4373 static pointer_t array_skip_thunk;
4374
4375 void * attr_fastcall pcode_find_array_skip_function(frame_s *fp, const code_t *ip, pointer_t **result)
4376 {
4377 return pcode_alloc_op_function(&array_skip_thunk, fp, ip, pcode_build_array_skip_function, 0, NULL, result);
4378 }
4379
4380 static void *pcode_build_array_append_function(frame_s *fp, const code_t *ip, union internal_arg attr_unused a[])
4381 {
4382 pcode_t pcode[43];
4383 pcode_t *pc = pcode;
4384
4385 *pc++ = Fn_Function;
4386 *pc++ = Call_Mode_Strict;
4387 *pc++ = 0;
4388 *pc++ = 0;
4389 *pc++ = 3;
4390 *pc++ = 2;
4391 *pc++ = 1;
4392 *pc++ = 1;
4393 *pc++ = 0;
4394 *pc++ = 0;
4395
4396 *pc++ = T_Undetermined;
4397 *pc++ = T_Undetermined;
4398 *pc++ = 0;
4399 *pc++ = 0;
4400 *pc++ = 0;
4401
4402 *pc++ = T_Undetermined;
4403 *pc++ = T_Undetermined;
4404 *pc++ = 1;
4405 *pc++ = 0;
4406 *pc++ = 0;
4407
4408 *pc++ = T_Undetermined;
4409 *pc++ = T_Undetermined;
4410 *pc++ = 2;
4411 *pc++ = 0;
4412 *pc++ = 0;
4413
4414 *pc++ = P_Args;
4415 *pc++ = 2;
4416 *pc++ = 0;
4417 *pc++ = 1;
4418
4419 *pc++ = P_Eval;
4420 *pc++ = 1;
4421 *pc++ = 0;
4422
4423 #if 0
4424 *pc++ = P_Eval;
4425 *pc++ = 1;
4426 *pc++ = 1;
4427 #endif
4428
4429 *pc++ = P_Array_Append;
4430 *pc++ = 5;
4431 *pc++ = 2;
4432 *pc++ = Flag_Free_Argument;
4433 *pc++ = 0;
4434 *pc++ = Flag_Free_Argument;
4435 *pc++ = 1;
4436
4437 *pc++ = P_Return;
4438 *pc++ = 2;
4439 *pc++ = Flag_Free_Argument;
4440 *pc++ = 2;
4441 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)));
4442
4443 return pcode_build_function(fp, ip, pcode, pc - pcode, NULL, NULL);
4444 }
4445
4446 static pointer_t array_append_thunk;
4447
4448 void * attr_fastcall pcode_find_array_append_function(frame_s *fp, const code_t *ip, pointer_t **result)
4449 {
4450 return pcode_alloc_op_function(&array_append_thunk, fp, ip, pcode_build_array_append_function, 0, NULL, result);
4451 }
4452
4453
4454 static void *pcode_build_option_ord_function(frame_s *fp, const code_t *ip, union internal_arg attr_unused a[])
4455 {
4456 pcode_t pcode[37];
4457 pcode_t *pc = pcode;
4458
4459 *pc++ = Fn_Function;
4460 *pc++ = Call_Mode_Strict;
4461 *pc++ = 0;
4462 *pc++ = 0;
4463 *pc++ = 2;
4464 *pc++ = 1;
4465 *pc++ = 1;
4466 *pc++ = 1;
4467 *pc++ = 0;
4468 *pc++ = 0;
4469
4470 *pc++ = T_Undetermined;
4471 *pc++ = T_Undetermined;
4472 *pc++ = 0;
4473 *pc++ = 0;
4474 *pc++ = 0;
4475
4476 *pc++ = T_Integer;
4477 *pc++ = T_Integer;
4478 *pc++ = 1;
4479 *pc++ = 0;
4480 *pc++ = 0;
4481
4482 *pc++ = P_Args;
4483 *pc++ = 1;
4484 *pc++ = 0;
4485
4486 *pc++ = P_Eval;
4487 *pc++ = 1;
4488 *pc++ = 0;
4489
4490 *pc++ = P_Option_Ord;
4491 *pc++ = 2;
4492 *pc++ = 1;
4493 *pc++ = 0;
4494
4495 *pc++ = P_Free;
4496 *pc++ = 1;
4497 *pc++ = 0;
4498
4499 *pc++ = P_Return;
4500 *pc++ = 2;
4501 *pc++ = Flag_Free_Argument;
4502 *pc++ = 1;
4503
4504 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)));
4505
4506 return pcode_build_function(fp, ip, pcode, pc - pcode, NULL, NULL);
4507 }
4508
4509 static pointer_t option_ord_thunk;
4510
4511 void * attr_fastcall pcode_find_option_ord_function(frame_s *fp, const code_t *ip, pointer_t **result)
4512 {
4513 return pcode_alloc_op_function(&option_ord_thunk, fp, ip, pcode_build_option_ord_function, 0, NULL, result);
4514 }
4515
4516
4517 struct function_key {
4518 unsigned char tag;
4519 frame_t id;
4520 };
4521
4522 static void *pcode_build_record_option_load_function(frame_s *fp, const code_t *ip, union internal_arg a[])
4523 {
4524 pcode_t pcode[38];
4525 pcode_t *pc = pcode;
4526 pcode_t result_type = a[0].i == PCODE_FUNCTION_OPTION_TEST ? T_FlatOption : T_Undetermined;
4527
4528 *pc++ = Fn_Function;
4529 *pc++ = Call_Mode_Strict;
4530 *pc++ = 0;
4531 *pc++ = 0;
4532 *pc++ = 2;
4533 *pc++ = 1;
4534 *pc++ = 1;
4535 *pc++ = 1;
4536 *pc++ = 0;
4537 *pc++ = 0;
4538
4539 *pc++ = T_Undetermined;
4540 *pc++ = T_Undetermined;
4541 *pc++ = 0;
4542 *pc++ = 0;
4543 *pc++ = 0;
4544
4545 *pc++ = result_type;
4546 *pc++ = result_type;
4547 *pc++ = 1;
4548 *pc++ = 0;
4549 *pc++ = 0;
4550
4551 *pc++ = P_Args;
4552 *pc++ = 1;
4553 *pc++ = 0;
4554
4555 switch (a[0].i) {
4556 case PCODE_FUNCTION_RECORD_LOAD:
4557 /* P_Record_Load_Slot already sets Flag_Evaluate */
4558 *pc++ = P_Record_Load_Slot;
4559 *pc++ = 3;
4560 *pc++ = 1;
4561 *pc++ = 0;
4562 *pc++ = (pcode_t)a[1].i;
4563 break;
4564 case PCODE_FUNCTION_OPTION_LOAD:
4565 *pc++ = P_Option_Load;
4566 *pc++ = 4;
4567 *pc++ = 1;
4568 *pc++ = Flag_Evaluate;
4569 *pc++ = 0;
4570 *pc++ = (pcode_t)a[1].i;
4571 break;
4572 case PCODE_FUNCTION_OPTION_TEST:
4573 *pc++ = P_Eval;
4574 *pc++ = 1;
4575 *pc++ = 0;
4576 *pc++ = P_Option_Test;
4577 *pc++ = 3;
4578 *pc++ = 1;
4579 *pc++ = 0;
4580 *pc++ = (pcode_t)a[1].i;
4581 break;
4582 default:
4583 internal(file_line, "pcode_build_record_option_load_function: invalid operation %"PRIuMAX"", (uintmax_t)a[0].i);
4584 }
4585
4586 *pc++ = P_Free;
4587 *pc++ = 1;
4588 *pc++ = 0;
4589
4590 *pc++ = P_Return;
4591 *pc++ = 2;
4592 *pc++ = Flag_Free_Argument;
4593 *pc++ = 1;
4594
4595 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)));
4596
4597 return pcode_build_function(fp, ip, pcode, pc - pcode, NULL, NULL);
4598 }
4599
4600 struct pcode_function {
4601 struct tree_entry entry;
4602 struct function_key key;
4603 pointer_t ptr;
4604 };
4605
4606 shared_var struct tree pcode_functions;
4607 rwlock_decl(pcode_functions_mutex);
4608
4609 static int record_option_load_compare(const struct tree_entry *e1, uintptr_t e2)
4610 {
4611 struct pcode_function *rl = get_struct(e1, struct pcode_function, entry);
4612 struct function_key *key = cast_cpp(struct function_key *, num_to_ptr(e2));
4613 if (rl->key.tag != key->tag)
4614 return (int)rl->key.tag - key->tag;
4615 if (rl->key.id < key->id)
4616 return -1;
4617 if (rl->key.id > key->id)
4618 return -1;
4619 return 0;
4620 }
4621
4622 static pointer_t *pcode_find_function_for_key(struct function_key *key)
4623 {
4624 struct tree_entry *e;
4625
4626 rwlock_lock_read(&pcode_functions_mutex);
4627 e = tree_find(&pcode_functions, record_option_load_compare, ptr_to_num(key));
4628 rwlock_unlock_read(&pcode_functions_mutex);
4629 if (unlikely(!e)) {
4630 struct tree_insert_position ins;
4631 rwlock_lock_write(&pcode_functions_mutex);
4632 e = tree_find_for_insert(&pcode_functions, record_option_load_compare, ptr_to_num(key), &ins);
4633 if (likely(!e)) {
4634 ajla_error_t sink;
4635 struct pcode_function *rl;
4636 rl = mem_alloc_mayfail(struct pcode_function *, sizeof(struct pcode_function), &sink);
4637 if (unlikely(!rl)) {
4638 rwlock_unlock_write(&pcode_functions_mutex);
4639 return NULL;
4640 }
4641 rl->key = *key;
4642 rl->ptr = pointer_empty();
4643 e = &rl->entry;
4644 tree_insert_after_find(e, &ins);
4645 }
4646 rwlock_unlock_write(&pcode_functions_mutex);
4647 }
4648 return &get_struct(e, struct pcode_function, entry)->ptr;
4649 }
4650
4651 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)
4652 {
4653 struct function_key key;
4654 pointer_t *ptr;
4655 union internal_arg ia[2];
4656
4657 if (unlikely((uintmax_t)slot > (uintmax_t)signed_maximum(pcode_t) + zero)) {
4658 *result = out_of_memory_ptr;
4659 return POINTER_FOLLOW_THUNK_RETRY;
4660 }
4661
4662 key.tag = tag;
4663 key.id = slot;
4664
4665 ptr = pcode_find_function_for_key(&key);
4666 if (unlikely(!ptr)) {
4667 *result = out_of_memory_ptr;
4668 return POINTER_FOLLOW_THUNK_RETRY;
4669 }
4670
4671 ia[0].i = tag;
4672 ia[1].i = slot;
4673 return pcode_alloc_op_function(ptr, fp, ip, pcode_build_record_option_load_function, 2, ia, result);
4674 }
4675
4676 static void thunk_init_run(pointer_t *ptr, unsigned n)
4677 {
4678 while (n--) {
4679 *ptr = pointer_empty();
4680 ptr++;
4681 }
4682 }
4683
4684 static void thunk_free_run(pointer_t *ptr, unsigned n)
4685 {
4686 while (n--) {
4687 if (!pointer_is_empty(*ptr))
4688 pointer_dereference(*ptr);
4689 ptr++;
4690 }
4691 }
4692
4693 void name(pcode_init)(void)
4694 {
4695 unsigned i;
4696
4697 for (i = 0; i < TYPE_FIXED_N + uzero; i++) thunk_init_run(fixed_op_thunk[i], OPCODE_FIXED_OP_N);
4698 for (i = 0; i < TYPE_INT_N; i++) thunk_init_run(int_op_thunk[i], OPCODE_INT_OP_N);
4699 for (i = 0; i < TYPE_REAL_N + uzero; i++) thunk_init_run(real_op_thunk[i], OPCODE_REAL_OP_N);
4700 thunk_init_run(&is_exception_thunk, 1);
4701 thunk_init_run(get_exception_thunk, n_array_elements(get_exception_thunk));
4702 thunk_init_run(bool_op_thunk, OPCODE_BOOL_OP_N);
4703 thunk_init_run(&array_load_thunk, 1);
4704 thunk_init_run(&array_len_thunk, 1);
4705 thunk_init_run(&array_len_greater_than_thunk, 1);
4706 thunk_init_run(&array_sub_thunk, 1);
4707 thunk_init_run(&array_skip_thunk, 1);
4708 thunk_init_run(&array_append_thunk, 1);
4709 thunk_init_run(&option_ord_thunk, 1);
4710 tree_init(&pcode_functions);
4711 rwlock_init(&pcode_functions_mutex);
4712 }
4713
4714 void name(pcode_done)(void)
4715 {
4716 unsigned i;
4717 for (i = 0; i < TYPE_FIXED_N + uzero; i++) thunk_free_run(fixed_op_thunk[i], OPCODE_FIXED_OP_N);
4718 for (i = 0; i < TYPE_INT_N; i++) thunk_free_run(int_op_thunk[i], OPCODE_INT_OP_N);
4719 for (i = 0; i < TYPE_REAL_N + uzero; i++) thunk_free_run(real_op_thunk[i], OPCODE_REAL_OP_N);
4720 thunk_free_run(&is_exception_thunk, 1);
4721 thunk_free_run(get_exception_thunk, n_array_elements(get_exception_thunk));
4722 thunk_free_run(bool_op_thunk, OPCODE_BOOL_OP_N);
4723 thunk_free_run(&array_load_thunk, 1);
4724 thunk_free_run(&array_len_thunk, 1);
4725 thunk_free_run(&array_len_greater_than_thunk, 1);
4726 thunk_free_run(&array_sub_thunk, 1);
4727 thunk_free_run(&array_skip_thunk, 1);
4728 thunk_free_run(&array_append_thunk, 1);
4729 thunk_free_run(&option_ord_thunk, 1);
4730 while (!tree_is_empty(&pcode_functions)) {
4731 struct pcode_function *rl = get_struct(tree_any(&pcode_functions), struct pcode_function, entry);
4732 if (!pointer_is_empty(rl->ptr))
4733 pointer_dereference(rl->ptr);
4734 tree_delete(&rl->entry);
4735 mem_free(rl);
4736 }
4737 rwlock_done(&pcode_functions_mutex);
4738 }
4739
4740 #endif
Ajla - a purely functional programming language