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