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