newlib/compiler/parser/gen2.ajla

   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 unit compiler.parser.gen2;
  20
  21 uses compiler.parser.dict;
  22 uses compiler.parser.type;
  23
  24 fn generate_function_id(id : function_unique_id) : list(pcode_t);
  25
  26 fn generate_Load_Fn(ctx : function_context, fd : function_definition, t : tokens) : (function_context, int);
  27 fn pcode_Load_Fn_get_n_curried_args(ins : instruction) : int;
  28 fn pcode_Load_Fn_get_unique_id(ins : instruction) : function_unique_id;
  29
  30 fn generate_Curry(ctx : function_context, cc : compare_context, typ : int, fnx : int, args : list(int), t : tokens) : (function_context, int);
  31 fn pcode_Curry_get_n_curried_args(ins : instruction) : int;
  32 fn pcode_Curry_get_fn_variable(ins : instruction) : int;
  33 fn pcode_Curry_get_arg(ins : instruction, i : int) : int;
  34
  35 fn generate_Call_Indirect(ctx : function_context, call_mode : int, fnx : int, t : tokens) : (function_context, list(int));
  36 fn pcode_Call_Indirect_get_n_return_values(ins : instruction) : int;
  37 fn pcode_Call_Indirect_get_n_args(ins : instruction) : int;
  38 fn pcode_Call_Indirect_get_fn_variable(ins : instruction) : int;
  39 fn pcode_Call_Indirect_get_return_value(ins : instruction, i : int) : int;
  40 fn pcode_Call_Indirect_find_return_index(ins : instruction, ret_var : int) : int;
  41
  42 fn generate_Call(ctx : function_context, call_mode : int, fd : function_definition, args : list(int), t : tokens) : (function_context, list(int));
  43 fn pcode_Call_get_n_return_values(ins : instruction) : int;
  44 fn pcode_Call_get_n_args(ins : instruction) : int;
  45 fn pcode_Call_get_unique_id(ins : instruction) : function_unique_id;
  46 fn pcode_Call_get_arg(ins : instruction, i : int) : int;
  47 fn pcode_Call_get_return_value(ins : instruction, i : int) : int;
  48 fn pcode_Call_find_return_index(ins : instruction, ret_var : int) : int;
  49 fn pcode_Call_quick_compare(in1 in2 : instruction) : bool;
  50
  51 fn integer_to_blob(val : int) : list(pcode_t);
  52 fn constant_to_blob(str : bytes) : (list(pcode_t), int);
  53 fn generate_Load_Const(ctx : function_context, typ : int, blob : list(pcode_t)) : (function_context, int);
  54 fn pcode_Load_Const_get_blob(ins : instruction) : list(pcode_t);
  55
  56 fn generate_Bool(ctx : function_context) : (function_context, int);
  57 fn generate_Byte(ctx : function_context) : (function_context, int);
  58 fn generate_Bytes(ctx : function_context) : (function_context, int);
  59 fn generate_String(ctx : function_context) : (function_context, int);
  60
  61 fn start_Structured_Write(v : int) : list(pcode_t);
  62 fn append_Structured_Array(m : list(pcode_t), idx local_type : int) : list(pcode_t);
  63 fn append_Structured_Record(m : list(pcode_t), idx local_type : int) : list(pcode_t);
  64 fn append_Structured_Option(m : list(pcode_t), idx : int) : list(pcode_t);
  65 fn generate_Structured_Write(ctx : function_context, instr : list(pcode_t), scalar : int) : function_context;
  66
  67 fn generate_Record_Type(ctx : function_context, fields : list(int), result : int) : function_context;
  68 fn generate_Option_Type(ctx : function_context, fields : list(int), result : int) : function_context;
  69
  70 fn generate_Record_Create(ctx : function_context, at : int, fields : list(int)) : (function_context, int);
  71 fn pcode_Record_Create_get_n_args(ins : instruction) : int;
  72 fn pcode_Record_Create_get_arg(ins : instruction, arg : int) : int;
  73 fn generate_record_entry_type(ctx : function_context, ar idx : int, rec_cc : compare_context, t : tokens) : (function_context, compare_context, int);
  74 fn generate_Record_Load(ctx : function_context, a idx : int, t : tokens) : (function_context, int);
  75 fn pcode_Record_Load_get_record(ins : instruction) : int;
  76 fn pcode_Record_Load_get_index(ins : instruction) : int;
  77
  78 fn generate_Option_Create(ctx : function_context, at idx ar : int) : (function_context, int);
  79 fn pcode_Option_Create_get_index(ins : instruction) : int;
  80 fn pcode_Option_Create_get_arg(ins : instruction) : int;
  81 fn generate_Option_Load(ctx : function_context, ar idx : int, t : tokens) : (function_context, int);
  82 fn pcode_Option_Load_get_option(ins : instruction) : int;
  83 fn pcode_Option_Load_get_index(ins : instruction) : int;
  84 fn generate_Option_Test(ctx : function_context, ar idx : int) : (function_context, int);
  85 fn pcode_Option_Test_get_option(ins : instruction) : int;
  86 fn pcode_Option_Test_get_index(ins : instruction) : int;
  87 fn generate_Option_Ord(ctx : function_context, ar : int) : (function_context, int);
  88 fn pcode_Option_Ord_get_option(ins : instruction) : int;
  89
  90 fn generate_Array_Create(ctx : function_context, lt at : int, ae : list(int), t : tokens) : (function_context, int);
  91 fn pcode_Array_Create_get_length(ins : instruction) : int;
  92 fn pcode_Array_Create_get_arg(ins : instruction, arg : int) : int;
  93 fn generate_Array_String(ctx : function_context, blob : list(pcode_t)) : (function_context, int);
  94 fn pcode_Array_String_get_blob(ins : instruction) : list(pcode_t);
  95 fn generate_Array_Unicode(ctx : function_context, blob : list(pcode_t)) : (function_context, int);
  96 fn pcode_Array_Unicode_get_blob(ins : instruction) : list(pcode_t);
  97 fn generate_Array_Load(ctx : function_context, aa ai : int, t : tokens) : (function_context, int);
  98 fn pcode_Array_Load_get_array(ins : instruction) : int;
  99 fn pcode_Array_Load_get_index(ins : instruction) : int;
 100 fn generate_Array_Sub(ctx : function_context, aa am an : int) : (function_context, int);
 101 fn pcode_Array_Sub_get_array(ins : instruction) : int;
 102 fn pcode_Array_Sub_get_start(ins : instruction) : int;
 103 fn pcode_Array_Sub_get_end(ins : instruction) : int;
 104 fn generate_Array_Skip(ctx : function_context, aa am : int) : (function_context, int);
 105 fn pcode_Array_Skip_get_array(ins : instruction) : int;
 106 fn pcode_Array_Skip_get_start(ins : instruction) : int;
 107
 108 fn generate_Line_Info(ctx : function_context, line : int) : function_context;
 109 fn generate_Line_Info_Full(ctx : function_context, un func : bytes, line : int) : function_context;
 110
 111 implementation
 112
 113 uses pcode;
 114 uses private.show;
 115 uses compiler.parser.type;
 116 uses compiler.parser.alloc;
 117 uses compiler.parser.gen;
 118 uses compiler.parser.util;
 119 uses compiler.common.gvn;
 120
 121 fn variable_is_suitable_for_gvn(ctx : function_context, v : int) : bool
 122 [
 123         if v < 0 then
 124                 return true;
 125         if ctx.variables[v].defined_at = defined_multiple or
 126            ctx.variables[v].mut then
 127                 return false;
 128         return true;
 129 ]
 130
 131 fn generate_function_id(id : function_unique_id) : list(pcode_t)
 132 [
 133         var result := list(pcode_t).[ (id.path_index shl 1) + select(id.program, 0, 1) ];
 134         result += blob_generate(i_decode(id.unit_string));
 135         result +<= len(id.function_index);
 136         for i := 0 to len(id.function_index) do
 137                 result +<= id.function_index[i];
 138         return result;
 139 ]
 140
 141 fn decode_function_id(p : list(pcode_t)) : function_unique_id
 142 [
 143         var fui := function_unique_id.[
 144                 path_index : p[0] shr 1,
 145                 program : (p[0] and 1) <> 0,
 146                 unit_string : i_encode(blob_decode(p[1 .. ])),
 147                 function_index : fill(0, p[1 + blob_get_length(p[1 .. ])]),
 148         ];
 149         for i := 0 to len(fui.function_index) do
 150                 fui.function_index[i] := p[1 + blob_get_length(p[1 .. ]) + 1 + i];
 151         return fui;
 152 ]
 153
 154 fn length_of_function_id(p : list(pcode_t)) : int
 155 [
 156         var bl := blob_get_length(p[1 .. ]);
 157         return 1 + bl + 1 + p[1 + bl];
 158 ]
 159
 160 fn generate_Load_Fn(ctx : function_context, fd : function_definition, t : tokens) : (function_context, int)
 161 [
 162         var value := -1;        // avoid uninitialized error
 163         var gvn_args := list(pcode_t).[ ctx.gvn_seq, P_Load_Fn, fd.call_mode ] + generate_function_id(fd.signature.id);
 164         value := gvn_encode(gvn_args);
 165         if ctx.gvn[value] <> -1 then [
 166                 return ctx, ctx.gvn[value];
 167         ]
 168
 169         var fn_def : int;
 170         ctx, fn_def := alloc_local_variable(ctx, T_Type, false, false);
 171
 172         var cc := new_compare_context_from_function(fd.signature);
 173
 174         var args := fill(T_InvalidType, fd.signature.n_arguments + fd.signature.n_return_values);
 175
 176         for i := 0 to fd.signature.n_arguments + fd.signature.n_return_values do [
 177                 var typ : int;
 178                 ctx, typ := evaluate_type(ctx, cc, fd.signature.variables[i].type_idx, empty(compare_fn_stack), t);
 179                 args[i] := typ;
 180
 181                 var l : int;
 182                 ctx, l := alloc_local_variable(ctx, typ, true, false);
 183                 cc.args +<= new_compare_argument(empty_compare_context, l);
 184                 ctx := generate_Load_Local_Type(ctx, fn_def, i, l);
 185
 186                 // TODO: quadratic complexity
 187                 var my_cc := new_compare_context(ctx);
 188                 for j := 0 to i + 1 do
 189                         cc.args[j].cc := my_cc;
 190         ]
 191
 192         ctx := set_defined_here(ctx, fn_def);
 193         ctx := generate_Fn(ctx, args[ .. fd.signature.n_arguments], args[fd.signature.n_arguments .. ], fn_def);
 194
 195         var fnx : int;
 196         ctx, fnx := alloc_local_variable(ctx, fn_def, true, false);
 197
 198         var pcode_args := list(pcode_t).[ fnx, 0, fd.call_mode ];
 199         pcode_args += generate_function_id(fd.signature.id);
 200         ctx := generate_instruction(ctx, P_Load_Fn, pcode_args);
 201
 202         ctx.gvn[value] := fnx;
 203
 204         return ctx, fnx;
 205 ]
 206
 207 fn pcode_Load_Fn_get_n_curried_args(ins : instruction) : int
 208 [
 209         xeval assert(ins.opcode = P_Load_Fn, "pcode_Load_Fn_get_n_curried_args: invalid instruction");
 210         return ins.args[1];
 211 ]
 212
 213 fn pcode_Load_Fn_get_unique_id(ins : instruction) : function_unique_id
 214 [
 215         xeval assert(ins.opcode = P_Load_Fn, "pcode_Load_Fn_get_unique_id: invalid instruction");
 216         return decode_function_id(ins.args[3 .. ]);
 217 ]
 218
 219 fn generate_Curry(ctx : function_context, cc : compare_context, typ : int, af : int, args : list(int), t : tokens) : (function_context, int)
 220 [
 221         var use_gvn := variable_is_suitable_for_gvn(ctx, af);
 222         var value := -1;        // avoid uninitialized error
 223         if use_gvn then [
 224                 var gvn_args := list(pcode_t).[ ctx.gvn_seq, P_Curry, af ];
 225                 for i := 0 to len(args) do [
 226                         gvn_args +<= args[i];
 227                         use_gvn and= variable_is_suitable_for_gvn(ctx, args[i]);
 228                 ]
 229                 if use_gvn then [
 230                         value := gvn_encode(gvn_args);
 231                         if ctx.gvn[value] <> -1 then [
 232                                 return ctx, ctx.gvn[value];
 233                         ]
 234                 ]
 235         ]
 236
 237         var instr := get_defined(cc, typ);
 238         var my_cc := new_compare_context(ctx);
 239
 240         var n_args := pcode_Fn_get_n_args(instr);
 241         var n_return_values := pcode_Fn_get_n_return_values(instr);
 242         var provided_args := len(args);
 243
 244         var fn_def : int;
 245         ctx, fn_def := alloc_local_variable(ctx, T_Type, false, false);
 246
 247         var type_args := fill(T_InvalidType, n_args + n_return_values);
 248
 249         for i := provided_args to n_args + n_return_values do [
 250                 var type_arg_idx : int;
 251                 if i < n_args then [
 252                         type_arg_idx := pcode_Fn_get_argument(instr, i);
 253                 ] else [
 254                         type_arg_idx := pcode_Fn_get_return_value(instr, i - n_args);
 255                 ]
 256                 var tp : int;
 257                 ctx, tp := evaluate_type(ctx, cc, type_arg_idx, empty(compare_fn_stack), t);
 258                 type_args[i] := tp;
 259
 260                 var l : int;
 261                 ctx, l := alloc_local_variable(ctx, tp, true, false);
 262                 ctx := generate_Load_Local_Type(ctx, fn_def, i - provided_args, l);
 263                 cc.llt_redirect +<= new_compare_argument(my_cc, l);
 264                 // TODO: quadratic complexity
 265                 for j := 0 to i + 1 do [
 266                         cc.llt_redirect[j].cc.ctx := ctx;
 267                 ]
 268         ]
 269
 270         ctx := set_defined_here(ctx, fn_def);
 271         ctx := generate_Fn(ctx, type_args[provided_args .. n_args], type_args[n_args .. ], fn_def);
 272
 273         var fnx : int;
 274         ctx, fnx := alloc_local_variable(ctx, fn_def, true, false);
 275
 276         var pcode_args := list(pcode_t).[ fnx, provided_args, 0, af ];
 277         for i := 0 to provided_args do [
 278                 pcode_args +<= 0;
 279                 pcode_args +<= args[i];
 280         ]
 281
 282         ctx := generate_instruction(ctx, P_Curry, pcode_args);
 283
 284         if use_gvn then [
 285                 ctx.gvn[value] := fnx;
 286         ]
 287
 288         return ctx, fnx;
 289 ]
 290
 291 fn pcode_Curry_get_n_curried_args(ins : instruction) : int
 292 [
 293         xeval assert(ins.opcode = P_Curry, "pcode_Curry_get_n_curried_args: invalid instruction");
 294         return ins.args[1];
 295 ]
 296
 297 fn pcode_Curry_get_fn_variable(ins : instruction) : int
 298 [
 299         xeval assert(ins.opcode = P_Curry, "pcode_Curry_get_fn_variable: invalid instruction");
 300         return ins.args[3];
 301 ]
 302
 303 fn pcode_Curry_get_arg(ins : instruction, i : int) : int
 304 [
 305         xeval assert(ins.opcode = P_Curry, "pcode_Curry_get_arg: invalid instruction");
 306         return ins.args[5 + i * 2];
 307 ]
 308
 309 fn generate_Call_Indirect(ctx : function_context, call_mode : int, fnx : int, t : tokens) : (function_context, list(int))
 310 [
 311         var cc, typ := get_deep_type_of_var(ctx, fnx);
 312
 313         cc := set_llt_main(cc, typ);
 314
 315         var instr := get_defined(cc, typ);
 316
 317         var my_cc := new_compare_context(ctx);
 318
 319         var n_args := pcode_Fn_get_n_args(instr);
 320         if n_args <> 0 then
 321                 abort internal("the number of arguments is " + ntos(n_args));
 322
 323         var n_return_values := pcode_Fn_get_n_return_values(instr);
 324
 325         var return_vector := empty(int);
 326
 327         var use_gvn := variable_is_suitable_for_gvn(ctx, fnx);
 328         var value := -1;        // avoid uninitialized error
 329         var gvn_args := list(pcode_t).[ ctx.gvn_seq, P_Call_Indirect, fnx, call_mode ];
 330         if use_gvn then [
 331                 value := gvn_encode(gvn_args +< 0);
 332                 if ctx.gvn[value] <> -1 then [
 333                         for i := 0 to n_return_values do [
 334                                 var v : int;
 335                                 if i = 0 then
 336                                         v := value;
 337                                 else
 338                                         v := gvn_encode(gvn_args +< i);
 339                                 return_vector +<= ctx.gvn[v];
 340                         ]
 341                         return ctx, return_vector;
 342                 ]
 343         ]
 344
 345         var pcode_args := list(pcode_t).[ call_mode, n_return_values, n_args, 0, fnx ];
 346
 347         for i := 0 to n_return_values do [
 348                 var l : int;
 349                 ctx, l := alloc_local_variable(ctx, T_InvalidType, true, false);
 350                 pcode_args +<= l;
 351                 cc.llt_redirect +<= new_compare_argument(my_cc, l);
 352                 return_vector +<= l;
 353                 if use_gvn then [
 354                         var v : int;
 355                         if i = 0 then
 356                                 v := value;
 357                         else
 358                                 v := gvn_encode(gvn_args +< i);
 359                         ctx.gvn[v] := l;
 360                 ]
 361         ]
 362
 363         ctx := generate_instruction(ctx, P_Call_Indirect, pcode_args);
 364
 365         for i := 0 to n_return_values do [
 366                 var typ : int;
 367                 ctx, typ := evaluate_type(ctx, cc, pcode_Fn_get_return_value(instr, i), empty(compare_fn_stack), t);
 368                 ctx := set_variable_type(ctx, return_vector[i], typ);
 369                 // TODO: quadratic complexity
 370                 for j := 0 to i + 1 do
 371                         cc.llt_redirect[j].cc.ctx := ctx;
 372         ]
 373
 374         return ctx, return_vector;
 375 ]
 376
 377 fn pcode_Call_Indirect_get_n_return_values(ins : instruction) : int
 378 [
 379         xeval assert(ins.opcode = P_Call_Indirect, "pcode_Call_Indirect_get_n_args: invalid instruction");
 380         return ins.args[1];
 381 ]
 382
 383 fn pcode_Call_Indirect_get_n_args(ins : instruction) : int
 384 [
 385         xeval assert(ins.opcode = P_Call_Indirect, "pcode_Call_Indirect_get_n_args: invalid instruction");
 386         return ins.args[2];
 387 ]
 388
 389 fn pcode_Call_Indirect_get_fn_variable(ins : instruction) : int
 390 [
 391         xeval assert(ins.opcode = P_Call_Indirect, "pcode_Call_Indirect_get_fn_variable: invalid instruction");
 392         return ins.args[4];
 393 ]
 394
 395 fn pcode_Call_Indirect_get_return_value(ins : instruction, i : int) : int
 396 [
 397         xeval assert(ins.opcode = P_Call_Indirect, "pcode_Call_Indirect_get_return_value: invalid instruction");
 398         return ins.args[5 + pcode_Call_Indirect_get_n_args(ins) * 2 + i];
 399 ]
 400
 401 fn pcode_Call_Indirect_find_return_index(ins : instruction, ret_var : int) : int
 402 [
 403         xeval assert(ins.opcode = P_Call_Indirect, "pcode_Call_Indirect_get_return_value: invalid instruction");
 404         for i := 0 to pcode_Call_Indirect_get_n_return_values(ins) do [
 405                 if pcode_Call_Indirect_get_return_value(ins, i) = ret_var then
 406                         return i;
 407         ]
 408         abort internal("Variable not found in return values");
 409 ]
 410
 411 fn generate_Call(ctx : function_context, call_mode : int, fd : function_definition, args : list(int), t : tokens) : (function_context, list(int))
 412 [
 413         if fd.call_mode = Call_Mode_Type or fd.call_mode = Call_Mode_Flat then
 414                 call_mode := fd.call_mode;
 415         else if call_mode = Call_Mode_Unspecified then
 416                 call_mode := fd.call_mode;
 417         var n_arguments := len(args);
 418         if n_arguments <> fd.signature.n_arguments then
 419                 abort internal("The number of arguments doesn't match");
 420         var n_return_values := fd.signature.n_return_values;
 421
 422         var return_vector := empty(int);
 423         var pcode_args := list(pcode_t).[ call_mode, n_return_values, n_arguments ];
 424         pcode_args += generate_function_id(fd.signature.id);
 425
 426         var use_gvn := true;
 427         var fn_cc := new_compare_context_from_function(fd.signature);
 428         for i := 0 to n_arguments do [
 429                 pcode_args += list(pcode_t).[ 0, args[i] ];
 430                 fn_cc.args +<= new_compare_argument(new_compare_context(ctx), args[i]);
 431                 use_gvn and= variable_is_suitable_for_gvn(ctx, args[i]);
 432         ]
 433
 434         var value := -1;        // avoid uninitialized error
 435         var gvn_args := list(pcode_t).[ ctx.gvn_seq, P_Call ] + pcode_args;
 436         if use_gvn then [
 437                 value := gvn_encode(gvn_args +< 0);
 438                 if ctx.gvn[value] <> -1 then [
 439                         //eval debug("gvn hit");
 440                         for i := 0 to n_return_values do [
 441                                 var v : int;
 442                                 if i = 0 then
 443                                         v := value;
 444                                 else
 445                                         v := gvn_encode(gvn_args +< i);
 446                                 return_vector +<= ctx.gvn[v];
 447                         ]
 448                         return ctx, return_vector;
 449                 ]
 450                 //eval debug("gvn miss");
 451         ]
 452
 453         var my_cc := new_compare_context(ctx);
 454
 455         for i := 0 to n_return_values do [
 456                 var l : int;
 457                 ctx, l := alloc_local_variable(ctx, T_InvalidType, true, false);
 458                 pcode_args +<= l;
 459                 fn_cc.return_redirect +<= new_compare_argument(my_cc, l);
 460                 return_vector +<= l;
 461
 462                 if use_gvn then [
 463                         var v : int;
 464                         if i = 0 then
 465                                 v := value;
 466                         else
 467                                 v := gvn_encode(gvn_args +< i);
 468                         ctx.gvn[v] := l;
 469                 ]
 470         ]
 471
 472         ctx := generate_instruction(ctx, P_Call, pcode_args);
 473
 474         for i := 0 to n_return_values do [
 475                 var typ : int;
 476                 ctx, typ := evaluate_type(ctx, fn_cc, fd.signature.variables[n_arguments + i].type_idx, empty(compare_fn_stack), t);
 477                 ctx := set_variable_type(ctx, return_vector[i], typ);
 478                 // TODO: quadratic complexity
 479                 for j := 0 to i + 1 do
 480                         fn_cc.return_redirect[j].cc.ctx := ctx;
 481         ]
 482
 483         return ctx, return_vector;
 484 ]
 485
 486 fn pcode_Call_get_n_return_values(ins : instruction) : int
 487 [
 488         xeval assert(ins.opcode = P_Call, "pcode_Call_get_n_args: invalid instruction");
 489         return ins.args[1];
 490 ]
 491
 492 fn pcode_Call_get_n_args(ins : instruction) : int
 493 [
 494         xeval assert(ins.opcode = P_Call, "pcode_Call_get_n_args: invalid instruction");
 495         return ins.args[2];
 496 ]
 497
 498 fn pcode_Call_get_unique_id(ins : instruction) : function_unique_id
 499 [
 500         xeval assert(ins.opcode = P_Call, "pcode_Call_get_unique_id: invalid instruction");
 501         return decode_function_id(ins.args[3 .. ]);
 502 ]
 503
 504 fn pcode_Call_get_arg(ins : instruction, i : int) : int
 505 [
 506         xeval assert(ins.opcode = P_Call, "pcode_Call_get_arg: invalid instruction");
 507         return ins.args[3 + length_of_function_id(ins.args[3 .. ]) + 1 + i * 2];
 508 ]
 509
 510 fn pcode_Call_get_return_value(ins : instruction, i : int) : int
 511 [
 512         xeval assert(ins.opcode = P_Call, "pcode_Call_get_return_value: invalid instruction");
 513         return ins.args[3 + length_of_function_id(ins.args[3 .. ]) + pcode_Call_get_n_args(ins) * 2 + i];
 514 ]
 515
 516 fn pcode_Call_quick_compare(in1 in2 : instruction) : bool
 517 [
 518         xeval assert(in1.opcode = P_Call, "pcode_Call_quick_compare: invalid instruction");
 519         xeval assert(in2.opcode = P_Call, "pcode_Call_quick_compare: invalid instruction");
 520         return in1.args[3] <> in2.args[3] or in1.args[4] <> in2.args[4];
 521 ]
 522
 523 fn pcode_Call_find_return_index(ins : instruction, ret_var : int) : int
 524 [
 525         xeval assert(ins.opcode = P_Call, "pcode_Call_get_return_value: invalid instruction");
 526         for i := 0 to pcode_Call_get_n_return_values(ins) do [
 527                 if pcode_Call_get_return_value(ins, i) = ret_var then
 528                         return i;
 529         ]
 530         abort internal("Variable not found in return values");
 531 ]
 532
 533 fn integer_to_blob(val : int) : list(pcode_t)
 534 [
 535         var buffer := empty(byte);
 536         var by : byte := 0;
 537
 538         while val <> 0, val <> -1 do [
 539                 by := val and #ff;
 540                 val shr= 8;
 541                 buffer +<= by;
 542         ]
 543
 544         if val >= 0 then [
 545                 if (by and #80) <> 0 then
 546                         buffer +<= 0;
 547         ] else [
 548                 if (by and #80) <> #80 then
 549                         buffer +<= #ff;
 550         ]
 551
 552         return blob_generate(buffer);
 553 ]
 554
 555 fn bytes_to_float(t : type, implicit c : class_real_number(t), a : bytes) : t
 556 [
 557         if a[0] = '#' then
 558                 return bytes_to_real_hex(t, c, a[1 .. ]);
 559         else
 560                 return bytes_to_real_base(t, c, a, 10);
 561 ]
 562
 563 fn real_to_blob(str : bytes) : (list(pcode_t), int)
 564 [
 565         var last := str[len(str) - 1] and #df;
 566         var t : int;
 567         var ex_bits sig_bits : int;
 568
 569         if last = 'H' then [
 570                 ex_bits := 5;
 571                 sig_bits := 11;
 572                 t := T_Real16;
 573         ] else if last = 'S' then [
 574                 ex_bits := 8;
 575                 sig_bits := 24;
 576                 t := T_Real32;
 577         ] else if last = 'L' then [
 578                 ex_bits := 15;
 579                 sig_bits := 64;
 580                 t := T_Real80;
 581         ] else if last = 'Q' then [
 582                 ex_bits := 15;
 583                 sig_bits := 113;
 584                 t := T_Real128;
 585         ] else [
 586                 ex_bits := 11;
 587                 sig_bits := 53;
 588                 t := T_Real64;
 589         ]
 590
 591         if t <> T_Real64 then
 592                 str := str[ .. len(str) - 1];
 593
 594         const eb := ex_bits;
 595         const sb := sig_bits;
 596         var f := bytes_to_float(floating(eb, sb), instance_real_number_floating(eb, sb), str);
 597         var fb := floating_internal(eb, sb, f);
 598         return integer_to_blob(fb), t;
 599 ]
 600
 601 fn constant_to_blob(str : bytes) : (list(pcode_t), int)
 602 [
 603         var last := str[len(str) - 1] and #df;
 604         if list_search(str, '.') >= 0 or
 605            str[0] <> '#' and (list_search(str, 'e') >= 0 or list_search(str, 'E') >= 0) or
 606            str[0] = '#' and (list_search(str, 'p') >= 0 or list_search(str, 'P') >= 0) or
 607            last = 'H' or last = 'S' or last = 'L' or last = 'Q' then [
 608                 return real_to_blob(str);
 609         ]
 610
 611         var base := 10;
 612         if str[0] = '#' then [
 613                 base := 16;
 614                 str := str[1 .. ];
 615         ]
 616         var val := 0;
 617         for i := 0 to len(str) do [
 618                 var v : int;
 619                 var ch := str[i];
 620                 if ch >= '0' and ch <= '9' then
 621                         v := ch - '0';
 622                 else if (ch and #df) >= 'A' and (ch and #df) <= 'F' then
 623                         v := (ch and #df) - 'A' + 10;
 624                 else
 625                         abort internal("invalid number: '" + str + "'");
 626                 val := val * base + v;
 627         ]
 628
 629         return integer_to_blob(val), T_Integer;
 630 ]
 631
 632 fn generate_Load_Const(ctx : function_context, typ : int, blob : list(pcode_t)) : (function_context, int)
 633 [
 634         var l : int;
 635         ctx, l := alloc_local_variable(ctx, typ, true, false);
 636
 637         var pcode_args := list(pcode_t).[ l ];
 638
 639         pcode_args += blob;
 640
 641         ctx := generate_instruction(ctx, P_Load_Const, pcode_args);
 642
 643         return ctx, l;
 644 ]
 645
 646 fn pcode_Load_Const_get_blob(ins : instruction) : list(pcode_t)
 647 [
 648         xeval assert(ins.opcode = P_Load_Const, "pcode_Load_Const_get_blob: invalid instruction");
 649         return ins.args[1 .. ];
 650 ]
 651
 652
 653 fn generate_std(ctx : function_context, index : int) : (function_context, int)
 654 [
 655         var f_id := function_unique_id.[ path_index : 0, unit_string : i_encode("system"), program : false, function_index : [ index ] ];
 656         var fd := search_function_from_id(ctx, f_id);
 657
 658         var q : list(int);
 659         ctx, q := generate_Call(ctx, Call_Mode_Inline, fd, empty(int), empty(token));
 660
 661         if len(q) <> 1 then
 662                 abort compiler_error("bool returns multiple values", empty(token));
 663
 664         return ctx, q[0];
 665 ]
 666
 667 fn generate_Bool(ctx : function_context) : (function_context, int)
 668 [
 669         return generate_std(ctx, predefined_bool);
 670 ]
 671
 672 fn generate_Byte(ctx : function_context) : (function_context, int)
 673 [
 674         return generate_std(ctx, predefined_byte);
 675 ]
 676
 677 fn generate_Bytes(ctx : function_context) : (function_context, int)
 678 [
 679         return generate_std(ctx, predefined_bytes);
 680 ]
 681
 682 fn generate_String(ctx : function_context) : (function_context, int)
 683 [
 684         return generate_std(ctx, predefined_string);
 685 ]
 686
 687
 688 fn start_Structured_Write(v : int) : list(pcode_t)
 689 [
 690         return list(pcode_t).[ 0, v, 0, v, 0, -1 ];
 691 ]
 692
 693 fn append_Structured_Array(m : list(pcode_t), idx local_type : int) : list(pcode_t)
 694 [
 695         m[0] += 1;
 696         m += list(pcode_t).[ Structured_Array, idx, local_type ];
 697         return m;
 698 ]
 699
 700 fn append_Structured_Record(m : list(pcode_t), idx local_type : int) : list(pcode_t)
 701 [
 702         m[0] += 1;
 703         m += list(pcode_t).[ Structured_Record, local_type, idx ];
 704         return m;
 705 ]
 706
 707 fn append_Structured_Option(m : list(pcode_t), idx : int) : list(pcode_t)
 708 [
 709         m[0] += 1;
 710         m += list(pcode_t).[ Structured_Option, idx ];
 711         return m;
 712 ]
 713
 714 fn generate_Structured_Write(ctx : function_context, pcode_args : list(pcode_t), scalar : int) : function_context
 715 [
 716         pcode_args[5] := scalar;
 717         ctx := generate_instruction(ctx, P_Structured_Write, pcode_args);
 718         return ctx;
 719 ]
 720
 721
 722 fn generate_Record_Option_Type(ctx : function_context, instr : pcode_t, fields : list(int), result : int) : function_context
 723 [
 724         var pcode_args := list(pcode_t).[ result, len(fields) ];
 725         for i := 0 to len(fields) do
 726                 pcode_args +<= fields[i];
 727         pcode_args += generate_function_id(ctx.id);
 728         ctx := generate_instruction(ctx, instr, pcode_args);
 729         return ctx;
 730 ]
 731
 732 fn generate_Record_Type(ctx : function_context, fields : list(int), result : int) : function_context
 733 [
 734         return generate_Record_Option_Type(ctx, P_Record_Type, fields, result);
 735 ]
 736
 737 fn generate_Option_Type(ctx : function_context, fields : list(int), result : int) : function_context
 738 [
 739         return generate_Record_Option_Type(ctx, P_Option_Type, fields, result);
 740 ]
 741
 742
 743 fn generate_Record_Create(ctx : function_context, at : int, fields : list(int)) : (function_context, int)
 744 [
 745         var l : int;
 746         ctx, l := alloc_local_variable(ctx, at, true, false);
 747
 748         var pcode_args := list(pcode_t).[ l, len(fields) ];
 749         for i := 0 to len(fields) do [
 750                 pcode_args +<= 0;
 751                 pcode_args +<= fields[i];
 752         ]
 753
 754         ctx := generate_instruction(ctx, P_Record_Create, pcode_args);
 755
 756         return ctx, l;
 757 ]
 758
 759 fn pcode_Record_Create_get_n_args(ins : instruction) : int
 760 [
 761         xeval assert(ins.opcode = P_Record_Create, "pcode_Record_Create_get_n_args: invalid instruction");
 762         return ins.args[1];
 763 ]
 764
 765 fn pcode_Record_Create_get_arg(ins : instruction, arg : int) : int
 766 [
 767         xeval assert(ins.opcode = P_Record_Create, "pcode_Record_Create_get_arg: invalid instruction");
 768         return ins.args[2 + arg * 2 + 1];
 769 ]
 770
 771 fn generate_record_option_load(ctx : function_context, pc : pcode_t, ae ar idx : int) : (function_context, int)
 772 [
 773         var l : int;
 774         ctx, l := alloc_local_variable(ctx, ae, true, false);
 775         var pcode_args := list(pcode_t).[ l, 0, ar, idx ];
 776         ctx := generate_instruction(ctx, pc, pcode_args);
 777         return ctx, l;
 778 ]
 779
 780 fn generate_record_entry_type(ctx : function_context, ar idx : int, rec_cc : compare_context, t : tokens) : (function_context, compare_context, int)
 781 [
 782         var my_cc := new_compare_context(ctx);
 783
 784         rec_cc := set_llt_main(rec_cc, -1);
 785         var rec_def := rec_cc.ctx.record_def.j;
 786
 787         for i := 0 to idx do [
 788                 if rec_def.entries[i].cnst, rec_def.entries[idx].type_idx >= 0 then [
 789                         var ae : int;
 790                         ctx, ae := evaluate_type(ctx, rec_cc, rec_def.entries[i].type_idx, empty(compare_fn_stack), t);
 791                         var l : int;
 792                         ctx, l := generate_record_option_load(ctx, P_Record_Load, ae, ar, i);
 793                         rec_cc.llt_redirect +<= new_compare_argument(my_cc, l);
 794                 ] else [
 795                         rec_cc.llt_redirect +<= new_compare_argument(empty_compare_context, T_InvalidType);
 796                 ]
 797                 // TODO: quadratic complexity
 798                 for j := 0 to i + 1 do [
 799                         rec_cc.llt_redirect[j].cc.ctx := ctx;
 800                 ]
 801         ]
 802
 803         return ctx, rec_cc, rec_def.entries[idx].type_idx;
 804 ]
 805
 806 fn generate_Record_Load(ctx : function_context, ar idx : int, t : tokens) : (function_context, int)
 807 [
 808         var rec_cc, ign := get_deep_type_of_var(ctx, ar);
 809
 810         var cc : compare_context;
 811         var typ : int;
 812         ctx, cc, typ := generate_record_entry_type(ctx, ar, idx, rec_cc, t);
 813
 814         var at : int;
 815         ctx, at := evaluate_type(ctx, cc, typ, empty(compare_fn_stack), t);
 816
 817         var l : int;
 818         ctx, l := generate_record_option_load(ctx, P_Record_Load, at, ar, idx);
 819
 820         return ctx, l;
 821 ]
 822
 823 fn pcode_Record_Load_get_record(ins : instruction) : int
 824 [
 825         xeval assert(ins.opcode = P_Record_Load, "pcode_Record_Load_get_record: invalid instruction");
 826         return ins.args[2];
 827 ]
 828
 829 fn pcode_Record_Load_get_index(ins : instruction) : int
 830 [
 831         xeval assert(ins.opcode = P_Record_Load, "pcode_Record_Load_get_index: invalid instruction");
 832         return ins.args[3];
 833 ]
 834
 835 fn generate_Option_Create(ctx : function_context, at idx ar : int) : (function_context, int)
 836 [
 837         var l : int;
 838         ctx, l := alloc_local_variable(ctx, at, true, false);
 839
 840         var pcode_args := list(pcode_t).[ l, idx, 0, ar ];
 841
 842         ctx := generate_instruction(ctx, P_Option_Create, pcode_args);
 843
 844         return ctx, l;
 845 ]
 846
 847 fn pcode_Option_Create_get_index(ins : instruction) : int
 848 [
 849         xeval assert(ins.opcode = P_Option_Create, "pcode_Option_Create_get_index: invalid instruction");
 850         return ins.args[1];
 851 ]
 852
 853 fn pcode_Option_Create_get_arg(ins : instruction) : int
 854 [
 855         xeval assert(ins.opcode = P_Option_Create, "pcode_Option_Create_get_arg: invalid instruction");
 856         return ins.args[3];
 857 ]
 858
 859 fn generate_Option_Load(ctx : function_context, ar idx : int, t : tokens) : (function_context, int)
 860 [
 861         var cc, ign := get_deep_type_of_var(ctx, ar);
 862         var rec_def := cc.ctx.record_def.j;
 863
 864         var at : int;
 865         ctx, at := evaluate_type(ctx, cc, rec_def.entries[idx].type_idx, empty(compare_fn_stack), t);
 866
 867         var l : int;
 868         ctx, l := generate_record_option_load(ctx, P_Option_Load, at, ar, idx);
 869
 870         return ctx, l;
 871 ]
 872
 873 fn pcode_Option_Load_get_option(ins : instruction) : int
 874 [
 875         xeval assert(ins.opcode = P_Option_Load, "pcode_Option_Load_get_option: invalid instruction");
 876         return ins.args[2];
 877 ]
 878
 879 fn pcode_Option_Load_get_index(ins : instruction) : int
 880 [
 881         xeval assert(ins.opcode = P_Option_Load, "pcode_Option_Load_get_index: invalid instruction");
 882         return ins.args[3];
 883 ]
 884
 885 fn generate_Option_Test(ctx : function_context, ar idx : int) : (function_context, int)
 886 [
 887         var ab l : int;
 888         ctx, ab := generate_Bool(ctx);
 889         ctx, l := alloc_local_variable(ctx, ab, true, false);
 890         var pcode_args := list(pcode_t).[ l, ar, idx ];
 891         ctx := generate_instruction(ctx, P_Option_Test, pcode_args);
 892         return ctx, l;
 893 ]
 894
 895 fn pcode_Option_Test_get_option(ins : instruction) : int
 896 [
 897         xeval assert(ins.opcode = P_Option_Test, "pcode_Option_Test_option: invalid instruction");
 898         return ins.args[1];
 899 ]
 900
 901 fn pcode_Option_Test_get_index(ins : instruction) : int
 902 [
 903         xeval assert(ins.opcode = P_Option_Test, "pcode_Option_Test_idx: invalid instruction");
 904         return ins.args[2];
 905 ]
 906
 907 fn generate_Option_Ord(ctx : function_context, ar : int) : (function_context, int)
 908 [
 909         var l : int;
 910         ctx, l := alloc_local_variable(ctx, T_Integer, true, false);
 911         var pcode_args := list(pcode_t).[ l, ar ];
 912         ctx := generate_instruction(ctx, P_Option_Ord, pcode_args);
 913         return ctx, l;
 914 ]
 915
 916 fn pcode_Option_Ord_get_option(ins : instruction) : int
 917 [
 918         xeval assert(ins.opcode = P_Option_Ord, "pcode_Option_Ord_get_option: invalid instruction");
 919         return ins.args[1];
 920 ]
 921
 922
 923 fn generate_Array_Create(ctx : function_context, lt at : int, fields : list(int), t : tokens) : (function_context, int)
 924 [
 925         var array_length := len(fields);
 926         var blob := integer_to_blob(array_length);
 927         var c l : int;
 928         ctx, c := generate_Load_Const(ctx, T_Integer, blob);
 929         ctx, l := alloc_local_variable(ctx, at, true, false);
 930
 931         var pcode_args := list(pcode_t).[ l, lt, array_length, c ];
 932
 933         for i := 0 to array_length do [
 934                 pcode_args +<= 0;
 935                 pcode_args +<= fields[i];
 936         ]
 937
 938         ctx := generate_instruction(ctx, P_Array_Create, pcode_args);
 939
 940         return ctx, l;
 941 ]
 942
 943 fn pcode_Array_Create_get_length(ins : instruction) : int
 944 [
 945         xeval assert(ins.opcode = P_Array_Create, "pcode_Array_Create_get_length: invalid instruction");
 946         return ins.args[2];
 947 ]
 948
 949 fn pcode_Array_Create_get_arg(ins : instruction, arg : int) : int
 950 [
 951         xeval assert(ins.opcode = P_Array_Create, "pcode_Array_Create_get_arg: invalid instruction");
 952         return ins.args[4 + arg * 2 + 1];
 953 ]
 954
 955 fn generate_Array_String(ctx : function_context, blob : list(pcode_t)) : (function_context, int)
 956 [
 957         var lb l : int;
 958         ctx, lb := generate_Bytes(ctx);
 959         ctx, l := alloc_local_variable(ctx, lb, true, false);
 960         var pcode_args := list(pcode_t).[ l ];
 961         pcode_args += blob;
 962         ctx := generate_instruction(ctx, P_Array_String, pcode_args);
 963         return ctx, l;
 964 ]
 965
 966 fn pcode_Array_String_get_blob(ins : instruction) : list(pcode_t)
 967 [
 968         xeval assert(ins.opcode = P_Array_String, "pcode_Array_String_get_blob: invalid instruction");
 969         return ins.args[1 .. ];
 970 ]
 971
 972 fn generate_Array_Unicode(ctx : function_context, blob : list(pcode_t)) : (function_context, int)
 973 [
 974         var lb l : int;
 975         ctx, lb := generate_String(ctx);
 976         ctx, l := alloc_local_variable(ctx, lb, true, false);
 977         var pcode_args := list(pcode_t).[ l ];
 978         pcode_args += blob;
 979         ctx := generate_instruction(ctx, P_Array_Unicode, pcode_args);
 980         return ctx, l;
 981 ]
 982
 983 fn pcode_Array_Unicode_get_blob(ins : instruction) : list(pcode_t)
 984 [
 985         xeval assert(ins.opcode = P_Array_Unicode, "pcode_Array_Unicode_get_blob: invalid instruction");
 986         return ins.args[1 .. ];
 987 ]
 988
 989 fn generate_Array_Load(ctx : function_context, aa ai : int, t : tokens) : (function_context, int)
 990 [
 991         var at l : int;
 992         ctx, at := evaluate_list_type(ctx, aa, t);
 993         ctx, l := alloc_local_variable(ctx, at, true, false);
 994         var pcode_args := list(pcode_t).[ l, 0, aa, ai ];
 995         ctx := generate_instruction(ctx, P_Array_Load, pcode_args);
 996         return ctx, l;
 997 ]
 998
 999 fn pcode_Array_Load_get_array(ins : instruction) : int
1000 [
1001         xeval assert(ins.opcode = P_Array_Load, "pcode_Array_Load_get_array: invalid instruction");
1002         return ins.args[2];
1003 ]
1004
1005 fn pcode_Array_Load_get_index(ins : instruction) : int
1006 [
1007         xeval assert(ins.opcode = P_Array_Load, "pcode_Array_Load_get_index: invalid instruction");
1008         return ins.args[3];
1009 ]
1010
1011 fn generate_Array_Sub(ctx : function_context, aa am an : int) : (function_context, int)
1012 [
1013         var at l : int;
1014         at := get_type_of_var(ctx, aa);
1015         ctx, l := alloc_local_variable(ctx, at, true, false);
1016         var pcode_args := list(pcode_t).[ l, 0, aa, am, an ];
1017         ctx := generate_instruction(ctx, P_Array_Sub, pcode_args);
1018         return ctx, l;
1019 ]
1020
1021 fn pcode_Array_Sub_get_array(ins : instruction) : int
1022 [
1023         xeval assert(ins.opcode = P_Array_Sub, "pcode_Array_Sub_get_array: invalid instruction");
1024         return ins.args[2];
1025 ]
1026
1027 fn pcode_Array_Sub_get_start(ins : instruction) : int
1028 [
1029         xeval assert(ins.opcode = P_Array_Sub, "pcode_Array_Sub_get_start: invalid instruction");
1030         return ins.args[3];
1031 ]
1032
1033 fn pcode_Array_Sub_get_end(ins : instruction) : int
1034 [
1035         xeval assert(ins.opcode = P_Array_Sub, "pcode_Array_Sub_get_end: invalid instruction");
1036         return ins.args[3];
1037 ]
1038
1039 fn generate_Array_Skip(ctx : function_context, aa am : int) : (function_context, int)
1040 [
1041         var at l : int;
1042         at := get_type_of_var(ctx, aa);
1043         ctx, l := alloc_local_variable(ctx, at, true, false);
1044         var pcode_args := list(pcode_t).[ l, 0, aa, am ];
1045         ctx := generate_instruction(ctx, P_Array_Skip, pcode_args);
1046         return ctx, l;
1047 ]
1048
1049 fn pcode_Array_Skip_get_array(ins : instruction) : int
1050 [
1051         xeval assert(ins.opcode = P_Array_Skip, "pcode_Array_Skip_get_array: invalid instruction");
1052         return ins.args[2];
1053 ]
1054
1055 fn pcode_Array_Skip_get_start(ins : instruction) : int
1056 [
1057         xeval assert(ins.opcode = P_Array_Skip, "pcode_Array_Skip_get_index: invalid instruction");
1058         return ins.args[3];
1059 ]
1060
1061 fn generate_Line_Info(ctx : function_context, line : int) : function_context
1062 [
1063         if line < 0 then
1064                 abort internal("generate_Line_Info: negative line " + ntos(line));
1065         var args := list(pcode_t).[ line ];
1066         return generate_instruction(ctx, P_Line_Info, args);
1067 ]
1068
1069 fn generate_Line_Info_Full(ctx : function_context, un func : bytes, line : int) : function_context
1070 [
1071         if line < 0 then
1072                 abort internal("generate_Line_Info_Full: negative line " + ntos(line));
1073         var args := empty(pcode_t);
1074         args +<= 1;
1075         args += blob_generate(un);
1076         args += blob_generate(func);
1077         args +<= line;
1078         return generate_instruction(ctx, P_Line_Info_Full, args);
1079 ]