ipret.c

   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 "data.h"
  25 #include "array.h"
  26 #include "code-op.h"
  27 #include "funct.h"
  28 #include "arithm-b.h"
  29 #include "arithm-i.h"
  30 #include "arithm-r.h"
  31 #include "tick.h"
  32 #include "task.h"
  33 #include "ipfn.h"
  34 #include "ipio.h"
  35 #include "util.h"
  36 #include "codegen.h"
  37
  38 #include "ipret.h"
  39
  40 #if defined(HAVE_COMPUTED_GOTO) && !defined(DEBUG_TRACE)
  41 #define COMPUTED_GOTO
  42 /*#define COMPUTED_GOTO_RELATIVE*/
  43 #endif
  44
  45 #if defined(C_LITTLE_ENDIAN)
  46 #define get_lo(p)       (((const unsigned char *)(p))[0])
  47 #elif defined(C_BIG_ENDIAN)
  48 #define get_lo(p)       (((const unsigned char *)(p))[1])
  49 #else
  50 #define get_lo(p)       (*(p) & 0xff)
  51 #endif
  52
  53 #if defined(C_LITTLE_ENDIAN)
  54 #define get_hi(p)       (((const unsigned char *)(p))[1])
  55 #elif defined(C_BIG_ENDIAN)
  56 #define get_hi(p)       (((const unsigned char *)(p))[0])
  57 #else
  58 #define get_hi(p)       (*(p) >> 8)
  59 #endif
  60
  61 #define ADVANCE_IP(n)           (ip += (n))
  62
  63
  64 #define op_add(type, utype, op1, op2)           op1 + op2
  65 #define op_subtract(type, utype, op1, op2)      op1 - op2
  66 #define op_multiply(type, utype, op1, op2)      op1 * op2
  67 #define op_divide(type, utype, op1, op2)        op1 / op2
  68 /* EMX has a bug - fmod doesn't return NaN */
  69 #if defined(_MSC_VER)
  70 #define op_modulo(type, utype, op1, op2)        (!isnan_any(type, op1, op2) && cat(isfinite_,type)(op1) && !cat(isfinite_,type)(op2) ? op1 :\
  71                                                 !isnan_any(type, op1, op2) && op1 == 0 && op2 != 0 ? op1 :\
  72                                                 cat(mathfunc_,type)(fmod)(op1, op2))
  73 #elif defined(HAVE_BUGGY_FMOD)
  74 #define op_modulo(type, utype, op1, op2)        (op2 == 0 ? 0./0. : cat(mathfunc_,type)(fmod)(op1, op2))
  75 #else
  76 #define op_modulo(type, utype, op1, op2)        cat(mathfunc_,type)(fmod)(op1, op2)
  77 #endif
  78 #define op_atan2(type, utype, op1, op2)         cat(mathfunc_,type)(atan2)(op1, op2)
  79 #define op_and(type, utype, op1, op2)           op1 & op2
  80 #define op_or(type, utype, op1, op2)            op1 | op2
  81 #define op_xor(type, utype, op1, op2)           op1 ^ op2
  82 #define op_shl(type, utype, op1, op2)           op1 << (op2 & (sizeof(utype) * 8 - 1))
  83 #define op_shr(type, utype, op1, op2)                                   \
  84         RIGHT_SHIFT_KEEPS_SIGN || (type)op1 >= 0 ?                      \
  85                 (utype)((type)op1 >> (op2 & (sizeof(utype) * 8 - 1)))   \
  86         :                                                               \
  87                 ~(~(utype)op1 >> (op2 & (sizeof(utype) * 8 - 1)))
  88 #define op_ushr(type, utype, op1, op2)          op1 >> (op2 & (sizeof(utype) * 8 - 1))
  89 #define op_equal(type, utype, op1, op2)         op1 == op2
  90 #define op_not_equal(type, utype, op1, op2)     op1 != op2
  91 #define op_less(type, utype, op1, op2)          (type)op1 < (type)op2
  92 #define op_less_equal(type, utype, op1, op2)    (type)op1 <= (type)op2
  93 #define op_greater(type, utype, op1, op2)       (type)op1 > (type)op2
  94 #define op_greater_equal(type, utype, op1, op2) (type)op1 >= (type)op2
  95 #define op_uless(type, utype, op1, op2)         op1 < op2
  96 #define op_uless_equal(type, utype, op1, op2)   op1 <= op2
  97 #define op_ugreater(type, utype, op1, op2)      op1 > op2
  98 #define op_ugreater_equal(type, utype, op1, op2) op1 >= op2
  99 #define op_not(type, utype, op1)                ~op1
 100 #define op_neg(type, utype, op1)                -op1
 101 #define op_sqrt(type, utype, op1)               cat(mathfunc_,type)(sqrt)(op1)
 102 #define op_cbrt(type, utype, op1)               cat(mathfunc_,type)(cbrt)(op1)
 103 #define op_sin(type, utype, op1)                cat(mathfunc_,type)(sin)(op1)
 104 #define op_cos(type, utype, op1)                cat(mathfunc_,type)(cos)(op1)
 105 #define op_tan(type, utype, op1)                cat(mathfunc_,type)(tan)(op1)
 106 #define op_asin(type, utype, op1)               cat(mathfunc_,type)(asin)(op1)
 107 #define op_acos(type, utype, op1)               cat(mathfunc_,type)(acos)(op1)
 108 #define op_atan(type, utype, op1)               cat(mathfunc_,type)(atan)(op1)
 109 #define op_sinh(type, utype, op1)               cat(mathfunc_,type)(sinh)(op1)
 110 #define op_cosh(type, utype, op1)               cat(mathfunc_,type)(cosh)(op1)
 111 #define op_tanh(type, utype, op1)               cat(mathfunc_,type)(tanh)(op1)
 112 #define op_asinh(type, utype, op1)              cat(mathfunc_,type)(asinh)(op1)
 113 #define op_acosh(type, utype, op1)              cat(mathfunc_,type)(acosh)(op1)
 114 #define op_atanh(type, utype, op1)              cat(mathfunc_,type)(atanh)(op1)
 115 #define op_exp2(type, utype, op1)               cat(mathfunc_,type)(exp2)(op1)
 116 #define op_exp(type, utype, op1)                cat(mathfunc_,type)(exp)(op1)
 117 #define op_exp10(type, utype, op1)              cat(mathfunc_,type)(exp10)(op1)
 118 #define op_log2(type, utype, op1)               cat(mathfunc_,type)(log2)(op1)
 119 #define op_log(type, utype, op1)                cat(mathfunc_,type)(log)(op1)
 120 #define op_log10(type, utype, op1)              cat(mathfunc_,type)(log10)(op1)
 121 #define op_round(type, utype, op1)              cat(mathfunc_,type)(rint)(op1)
 122 #define op_ceil(type, utype, op1)               cat(mathfunc_,type)(ceil)(op1)
 123 #define op_floor(type, utype, op1)              cat(mathfunc_,type)(floor)(op1)
 124 #define op_trunc(type, utype, op1)              cat(mathfunc_,type)(trunc)(op1)
 125 #define op_fract(type, utype, op1)              cat(mathfunc_,type)(fract)(op1)
 126 #define op_mantissa(type, utype, op1)           cat(mathfunc_,type)(mantissa)(op1)
 127 #define op_exponent(type, utype, op1)           cat(mathfunc_,type)(exponent)(op1)
 128
 129 #define generate_fixed_binary(type, utype, op)                          \
 130 static ipret_inline bool cat4(FIXED_binary_,op,_,type)                  \
 131                                 (const utype *op1, const utype *op2, utype *res)\
 132 {                                                                       \
 133         *(utype *)res = cat(op_,op)(type, utype, (*(const utype *)op1), (*(const utype *)op2));\
 134         return true;                                                    \
 135 }
 136
 137 #define generate_fixed_binary_logical(type, utype, op)                  \
 138 static ipret_inline bool cat4(FIXED_binary_,op,_,type)                  \
 139                                 (const utype *op1, const utype *op2, ajla_flat_option_t *res)\
 140 {                                                                       \
 141         *(ajla_flat_option_t *)res = cat(op_,op)(type, utype, (*(const utype *)op1), (*(const utype *)op2));\
 142         return true;                                                    \
 143 }
 144
 145 #define generate_fixed_unary(type, utype, op)                           \
 146 static ipret_inline void cat4(FIXED_unary_,op,_,type)                   \
 147                                 (const utype *op1, utype *res)          \
 148 {                                                                       \
 149         *(utype *)res = cat(op_,op)(type, utype, (*(utype *)op1));      \
 150 }
 151
 152 #define generate_fixed_ldc(type, utype, sz, bits)                       \
 153 static ipret_inline ip_t cat(fixed_ldc_,type)                           \
 154                                 (utype *res, const code_t *ip, bool small)\
 155 {                                                                       \
 156         if (small && sz > 2) {                                          \
 157                 *res = (utype)(int16_t)ip[0];                           \
 158                 return 1;                                               \
 159         }                                                               \
 160         *res = (utype)cat(get_unaligned_,bits)(ip);                     \
 161         return (sz + 1) / 2;                                            \
 162 }
 163
 164 #define generate_fixed_functions(n, type, utype, sz, bits)              \
 165 generate_fixed_binary(type, utype, add)                                 \
 166 generate_fixed_binary(type, utype, subtract)                            \
 167 generate_fixed_binary(type, utype, multiply)                            \
 168 generate_fixed_binary(type, utype, and)                                 \
 169 generate_fixed_binary(type, utype, or)                                  \
 170 generate_fixed_binary(type, utype, xor)                                 \
 171 generate_fixed_binary(type, utype, shl)                                 \
 172 generate_fixed_binary(type, utype, shr)                                 \
 173 generate_fixed_binary(type, utype, ushr)                                \
 174 generate_fixed_binary_logical(type, utype, equal)                       \
 175 generate_fixed_binary_logical(type, utype, not_equal)                   \
 176 generate_fixed_binary_logical(type, utype, less)                        \
 177 generate_fixed_binary_logical(type, utype, less_equal)                  \
 178 generate_fixed_binary_logical(type, utype, greater)                     \
 179 generate_fixed_binary_logical(type, utype, greater_equal)               \
 180 generate_fixed_binary_logical(type, utype, uless)                       \
 181 generate_fixed_binary_logical(type, utype, uless_equal)                 \
 182 generate_fixed_binary_logical(type, utype, ugreater)                    \
 183 generate_fixed_binary_logical(type, utype, ugreater_equal)              \
 184 generate_fixed_unary(type, utype, not)                                  \
 185 generate_fixed_unary(type, utype, neg)                                  \
 186 generate_fixed_ldc(type, utype, sz, bits)
 187 for_all_fixed(generate_fixed_functions)
 188 #undef generate_fixed_functions
 189
 190
 191 #define generate_int_binary(type, utype, op, operator)                  \
 192 static ipret_inline bool                                                \
 193         cat4(INT_binary_,op,_,type)(const void *op1, const void *op2, void *res)\
 194 {                                                                       \
 195         *cast_ptr(type *, res) =                                        \
 196                 *cast_ptr(const type *, op1) operator                   \
 197                 *cast_ptr(const type *, op2);                           \
 198         return true;                                                    \
 199 }
 200
 201 #define generate_int_binary_logical(type, utype, op, operator)          \
 202 static ipret_inline bool                                                \
 203         cat4(INT_binary_,op,_,type)(const void *op1, const void *op2, ajla_flat_option_t *res)\
 204 {                                                                       \
 205         *res = *cast_ptr(const type *, op1) operator                    \
 206                 *cast_ptr(const type *, op2);                           \
 207         return true;                                                    \
 208 }
 209
 210 #define generate_int_ldc(type, utype, bits)                             \
 211 static ipret_inline ip_t cat(int_ldc_,type)                             \
 212                                 (type *res, const code_t *ip, bool small)\
 213 {                                                                       \
 214         return cat(fixed_ldc_,type)(cast_ptr(utype *, res), ip, small); \
 215 }
 216
 217
 218 #define generate_int_functions(typeid, type, utype, sz, bits)           \
 219 generate_int_binary(type, utype, and, &)                                \
 220 generate_int_binary(type, utype, or, |)                                 \
 221 generate_int_binary(type, utype, xor, ^)                                \
 222 generate_int_binary_logical(type, utype, equal, ==)                     \
 223 generate_int_binary_logical(type, utype, not_equal, !=)                 \
 224 generate_int_binary_logical(type, utype, less, <)                       \
 225 generate_int_binary_logical(type, utype, less_equal, <=)                \
 226 generate_int_binary_logical(type, utype, greater, >)                    \
 227 generate_int_binary_logical(type, utype, greater_equal, >=)             \
 228 generate_int_ldc(type, utype, bits)
 229 for_all_int(generate_int_functions, for_all_empty)
 230 #undef generate_int_binary_functions
 231
 232
 233 #if defined(use_is_macros)
 234 #ifdef HAVE_REAL_GNUC
 235 #define isnan_any(type, a, b)   (unlikely(isunordered(b, a)))
 236 #else
 237 #define isnan_any(type, a, b)   (unlikely(isunordered(a, b)))
 238 #endif
 239 #else
 240 #define isnan_any(type, a, b)   (unlikely(cat(isnan_,type)(a)) || unlikely(cat(isnan_,type)(b)))
 241 #endif
 242
 243 #if REAL_MASK & 0x1
 244 static attr_always_inline bool do_nextafter_real16_t(real16_t attr_unused x, int attr_unused dir, real16_t attr_unused *res)
 245 {
 246         return false;
 247 }
 248 #endif
 249
 250 #if REAL_MASK & 0x2
 251 static attr_always_inline bool do_nextafter_real32_t(real32_t attr_unused x, int attr_unused dir, real32_t attr_unused *res)
 252 {
 253 #ifdef HAVE_NEXTAFTERF
 254         *res = nextafterf(x, HUGE_VALF * dir);
 255         return true;
 256 #else
 257         return false;
 258 #endif
 259 }
 260 #endif
 261
 262 #if REAL_MASK & 0x4
 263 static attr_always_inline bool do_nextafter_real64_t(real64_t attr_unused x, int attr_unused dir, real64_t attr_unused *res)
 264 {
 265 #ifdef HAVE_NEXTAFTER
 266         *res = nextafter(x, HUGE_VAL * dir);
 267         return true;
 268 #else
 269         return false;
 270 #endif
 271 }
 272 #endif
 273
 274 #if REAL_MASK & 0x8
 275 static attr_always_inline bool do_nextafter_real80_t(real80_t attr_unused x, int dir, real80_t attr_unused *res)
 276 {
 277 #ifdef HAVE_NEXTAFTERL
 278         *res = nextafterl(x, HUGE_VALL * dir);
 279         return true;
 280 #else
 281         return false;
 282 #endif
 283 }
 284 #endif
 285
 286 #if REAL_MASK & 0x10
 287 static attr_always_inline bool do_nextafter_real128_t(real128_t attr_unused x, int dir, real128_t attr_unused *res)
 288 {
 289 #ifndef HAVE_NATIVE_FLOAT128
 290 #ifdef HAVE_NEXTAFTERL
 291         *res = nextafterl(x, HUGE_VALL * dir);
 292         return true;
 293 #else
 294         return false;
 295 #endif
 296 #else
 297         *res = nextafterq(x, HUGE_VAL * dir);
 298         return true;
 299 #endif
 300 }
 301 #endif
 302
 303 #define generate_real_binary(type, ntype, pack, unpack, op)             \
 304 static ipret_inline bool cat4(REAL_binary_,op,_,type)                   \
 305                                 (const type *op1, const type *op2, type *res)\
 306 {                                                                       \
 307         *res = pack(cat(op_,op)(ntype, ntype, (unpack(*op1)), (unpack(*op2))));\
 308         return true;                                                    \
 309 }
 310
 311 #define generate_real_binary_logical(type, ntype, pack, unpack, op)     \
 312 static ipret_inline bool cat4(REAL_binary_,op,_,type)                   \
 313                                 (const type *op1, const type *op2, ajla_flat_option_t *res)\
 314 {                                                                       \
 315         ntype o1 = unpack(*op1);                                        \
 316         ntype o2 = unpack(*op2);                                        \
 317         if (isnan_any(ntype, o1, o2))                                   \
 318                 return false;                                           \
 319         *res = cat(op_real_,op)(ntype, ntype, o1, o2);                  \
 320         return true;                                                    \
 321 }
 322
 323 #define generate_real_unary(n, type, ntype, pack, unpack, op, op_n)     \
 324 static ipret_inline void cat4(REAL_unary_,op,_,type)                    \
 325                                 (const type *op1, type *res)            \
 326 {                                                                       \
 327         if (!n && REAL16_T_IS_UINT16_T) {                               \
 328                 if (!op_n) {                                            \
 329                         *(uint16_t *)res = *(uint16_t *)op1 ^ 0x8000U;  \
 330                         return;                                         \
 331                 }                                                       \
 332         }                                                               \
 333         *res = pack(cat(op_,op)(type, type, (unpack(*op1))));           \
 334 }
 335
 336 /* EMX has a bug - modf(infinity) return NaN instead of 0. */
 337 #ifdef HAVE_BUGGY_MODF
 338 #define need_modf_hack true
 339 #else
 340 #define need_modf_hack false
 341 #endif
 342
 343 #define generate_real_fns(n, type, ntype, pack, unpack)                 \
 344 static ipret_inline bool cat(REAL_binary_power_,type)                   \
 345                                 (const type *op1, const type *op2, type *res)\
 346 {                                                                       \
 347         ntype o1 = unpack(*op1);                                        \
 348         ntype o2 = unpack(*op2);                                        \
 349         ntype r;                                                        \
 350         if (unlikely(isnan_any(ntype, o1, o2)))                         \
 351                 return false;                                           \
 352         r = cat(mathfunc_,type)(pow)(o1, o2);                           \
 353         *res = pack(r);                                                 \
 354         return true;                                                    \
 355 }                                                                       \
 356 static ipret_inline bool cat(REAL_binary_ldexp_,type)                   \
 357                                 (const type *op1, const type *op2, type *res)\
 358 {                                                                       \
 359         ntype m;                                                        \
 360         ntype o1 = unpack(*op1);                                        \
 361         ntype o2 = unpack(*op2);                                        \
 362         if (unlikely(isnan_any(ntype, o1, o2)))                         \
 363                 return false;                                           \
 364         if (likely(o2 >= (ntype)sign_bit(int)) && likely(o2 <= (ntype)signed_maximum(int)) && likely(o2 == (int)o2)) {\
 365                 *res = pack(cat(mathfunc_,type)(ldexp)(o1, (int)o2));   \
 366         } else {                                                        \
 367                 m = cat(mathfunc_,type)(exp2)(o2);                      \
 368                 m *= o1;                                                \
 369                 *res = pack(m);                                         \
 370         }                                                               \
 371         return true;                                                    \
 372 }                                                                       \
 373 static ipret_inline void cat(REAL_unary_fract_,type)                    \
 374                                 (const type *op1, type *res)            \
 375 {                                                                       \
 376         ntype m = unpack(*op1);                                         \
 377         union {                                                         \
 378                 ntype i;                                                \
 379                 float f;                                                \
 380         } u;                                                            \
 381         if (need_modf_hack) {                                           \
 382                 if (likely(!cat(isnan_,ntype)(m)) && unlikely(!cat(isfinite_,ntype)(m))) {\
 383                         *res = pack(m >= 0 ? 0. : -0.);                 \
 384                         return;                                         \
 385                 }                                                       \
 386         }                                                               \
 387         *res = pack(cat(mathfunc_,type)(modf)(m, (void *)&u));          \
 388 }                                                                       \
 389 static ipret_inline void cat(REAL_unary_mantissa_,type)                 \
 390                                 (const type *op1, type *res)            \
 391 {                                                                       \
 392         int i;                                                          \
 393         *res = pack(cat(mathfunc_,type)(frexp)(unpack(*op1), &i));      \
 394 }                                                                       \
 395 static ipret_inline void cat(REAL_unary_exponent_,type)                 \
 396                                 (const type *op1, type *res)            \
 397 {                                                                       \
 398         int i;                                                          \
 399         ntype m = cat(mathfunc_,type)(frexp)(unpack(*op1), &i);         \
 400         if (unlikely(cat(isnan_,ntype)(m))) {                           \
 401                 *res = pack(m);                                         \
 402                 return;                                                 \
 403         }                                                               \
 404         if (unlikely(!cat(isfinite_,ntype)(m))) {                       \
 405                 *res = pack((ntype)0.);                                 \
 406                 return;                                                 \
 407         }                                                               \
 408         *res = pack((ntype)i);                                          \
 409 }                                                                       \
 410 static ipret_inline type cat(REAL_unary_next_prev_number_,type)         \
 411                                 (type op1, int dir)                     \
 412 {                                                                       \
 413         int ex, bit;                                                    \
 414         volatile ntype m, mm, n1;                                       \
 415         volatile type res, o;                                           \
 416         if (unlikely(cat(isnan_,type)(op1)))                            \
 417                 return op1;                                             \
 418         n1 = unpack(op1);                                               \
 419         if (unlikely(!cat(isfinite_,type)(op1))) {                      \
 420                 if ((n1 >= 0) == (dir >= 0))                            \
 421                         return op1;                                     \
 422                 m = cat(mathfunc_,ntype)(ldexp)(1, cat(bits_,type)) - 1;\
 423                 while (1) {                                             \
 424                         mm = m * 2;                                     \
 425                         res = pack(mm);                                 \
 426                         if (unlikely(!cat(isfinite_,type)(res)))        \
 427                                 break;                                  \
 428                         m = mm;                                         \
 429                 }                                                       \
 430                 return pack(m * -dir);                                  \
 431         }                                                               \
 432         if (unlikely(!n1)) {                                            \
 433                 res = pack(1);                                          \
 434                 o = pack(1);                                            \
 435                 while (1) {                                             \
 436                         o = pack(unpack(o) * 0.5);                      \
 437                         m = unpack(o);                                  \
 438                         if (m == 0)                                     \
 439                                 break;                                  \
 440                         res = o;                                        \
 441                 }                                                       \
 442                 return pack(unpack(res) * dir);                         \
 443         }                                                               \
 444         m = cat(mathfunc_,type)(frexp)(n1, &ex);                        \
 445         bit = cat(bits_,type);                                          \
 446 again:                                                                  \
 447         mm = m + cat(mathfunc_,ntype)(ldexp)(dir, -bit);                \
 448         o = pack(cat(mathfunc_,ntype)(ldexp)(mm, ex));                  \
 449         res = o;                                                        \
 450         if (unpack(res) == n1) {                                        \
 451                 bit--;                                                  \
 452                 goto again;                                             \
 453         }                                                               \
 454         return res;                                                     \
 455 }                                                                       \
 456 static ipret_inline void cat(REAL_unary_next_number_,type)              \
 457                                 (const type *op1, type *res)            \
 458 {                                                                       \
 459         if (cat(do_nextafter_,type)(*op1, 1, res))                      \
 460                 return;                                                 \
 461         *res = cat(REAL_unary_next_prev_number_,type)(*op1, 1);         \
 462 }                                                                       \
 463 static ipret_inline void cat(REAL_unary_prev_number_,type)              \
 464                                 (const type *op1, type *res)            \
 465 {                                                                       \
 466         if (cat(do_nextafter_,type)(*op1, -1, res))                     \
 467                 return;                                                 \
 468         *res = cat(REAL_unary_next_prev_number_,type)(*op1, -1);        \
 469 }
 470
 471 #define generate_real_unary_logical(n, type, ntype, pack, unpack, op, op_n)\
 472 static ipret_inline void cat4(REAL_unary_,op,_,type)                    \
 473                                 (const type *op1, ajla_flat_option_t *res)\
 474 {                                                                       \
 475         *res = cat(isnan_,type)(*op1);                                  \
 476 }
 477
 478 #define op_real_equal                                   op_equal
 479 #if defined(use_is_macros) && defined(ARCH_X86)
 480 #define op_real_not_equal(type, utype, op1, op2)        islessgreater(op1, op2)
 481 #else
 482 #define op_real_not_equal                               op_not_equal
 483 #endif
 484 #if defined(use_is_macros)
 485 #define op_real_less(type, utype, op1, op2)             isless(op1, op2)
 486 #else
 487 #define op_real_less                                    op_less
 488 #endif
 489 #if defined(use_is_macros)
 490 #define op_real_less_equal(type, utype, op1, op2)       islessequal(op1, op2)
 491 #else
 492 #define op_real_less_equal                              op_less_equal
 493 #endif
 494 #if defined(use_is_macros)
 495 #define op_real_greater(type, utype, op1, op2)          isgreater(op1, op2)
 496 #else
 497 #define op_real_greater                                 op_greater
 498 #endif
 499 #if defined(use_is_macros)
 500 #define op_real_greater_equal(type, utype, op1, op2)    isgreaterequal(op1, op2)
 501 #else
 502 #define op_real_greater_equal                           op_greater_equal
 503 #endif
 504
 505 #define generate_real_ldc(n, rtype, ntype, pack, unpack)                \
 506 static ipret_inline size_t cat(fixed_ldc_,rtype)                        \
 507                         (rtype *res, const code_t *ip, bool attr_unused shrt)\
 508 {                                                                       \
 509         memcpy(res, ip, sizeof(rtype));                                 \
 510         return round_up(sizeof(rtype), sizeof(code_t)) / sizeof(code_t);\
 511 }
 512
 513 #define generate_real_int(type, ntype, pack, unpack)                    \
 514 static ipret_inline bool cat(REAL_unary_to_int_,type)(const type *val, int_default_t *r)\
 515 {                                                                       \
 516         ntype val1;                                                     \
 517         val1 = unpack(*val);                                            \
 518         if (likely(val1 > (ntype)sign_bit(int_default_t)) && likely(val1 < (ntype)signed_maximum(int_default_t))) {\
 519                 *r = val1;                                              \
 520                 return true;                                            \
 521         }                                                               \
 522         return false;                                                   \
 523 }                                                                       \
 524 static ipret_inline void cat(REAL_unary_from_int_,type)(const int_default_t *val, type *r)\
 525 {                                                                       \
 526         *r = pack(*val);                                                \
 527 }
 528
 529 #define generate_real_functions(n, type, ntype, pack, unpack)           \
 530 generate_real_binary(type, ntype, pack, unpack, add)                    \
 531 generate_real_binary(type, ntype, pack, unpack, subtract)               \
 532 generate_real_binary(type, ntype, pack, unpack, multiply)               \
 533 generate_real_binary(type, ntype, pack, unpack, divide)                 \
 534 generate_real_binary(type, ntype, pack, unpack, modulo)                 \
 535 generate_real_binary(type, ntype, pack, unpack, atan2)                  \
 536 generate_real_binary_logical(type, ntype, pack, unpack, equal)          \
 537 generate_real_binary_logical(type, ntype, pack, unpack, not_equal)      \
 538 generate_real_binary_logical(type, ntype, pack, unpack, less)           \
 539 generate_real_binary_logical(type, ntype, pack, unpack, less_equal)     \
 540 generate_real_binary_logical(type, ntype, pack, unpack, greater)        \
 541 generate_real_binary_logical(type, ntype, pack, unpack, greater_equal)  \
 542 generate_real_unary(n, type, ntype, pack, unpack, neg, 0)               \
 543 generate_real_unary(n, type, ntype, pack, unpack, sqrt, 1)              \
 544 generate_real_unary(n, type, ntype, pack, unpack, cbrt, 1)              \
 545 generate_real_unary(n, type, ntype, pack, unpack, sin, 1)               \
 546 generate_real_unary(n, type, ntype, pack, unpack, cos, 1)               \
 547 generate_real_unary(n, type, ntype, pack, unpack, tan, 1)               \
 548 generate_real_unary(n, type, ntype, pack, unpack, asin, 1)              \
 549 generate_real_unary(n, type, ntype, pack, unpack, acos, 1)              \
 550 generate_real_unary(n, type, ntype, pack, unpack, atan, 1)              \
 551 generate_real_unary(n, type, ntype, pack, unpack, sinh, 1)              \
 552 generate_real_unary(n, type, ntype, pack, unpack, cosh, 1)              \
 553 generate_real_unary(n, type, ntype, pack, unpack, tanh, 1)              \
 554 generate_real_unary(n, type, ntype, pack, unpack, asinh, 1)             \
 555 generate_real_unary(n, type, ntype, pack, unpack, acosh, 1)             \
 556 generate_real_unary(n, type, ntype, pack, unpack, atanh, 1)             \
 557 generate_real_unary(n, type, ntype, pack, unpack, exp2, 1)              \
 558 generate_real_unary(n, type, ntype, pack, unpack, exp, 1)               \
 559 generate_real_unary(n, type, ntype, pack, unpack, exp10, 1)             \
 560 generate_real_unary(n, type, ntype, pack, unpack, log2, 1)              \
 561 generate_real_unary(n, type, ntype, pack, unpack, log, 1)               \
 562 generate_real_unary(n, type, ntype, pack, unpack, log10, 1)             \
 563 generate_real_unary(n, type, ntype, pack, unpack, round, 1)             \
 564 generate_real_unary(n, type, ntype, pack, unpack, ceil, 1)              \
 565 generate_real_unary(n, type, ntype, pack, unpack, floor, 1)             \
 566 generate_real_unary(n, type, ntype, pack, unpack, trunc, 1)             \
 567 generate_real_fns(n, type, ntype, pack, unpack)                         \
 568 generate_real_int(type, ntype, pack, unpack)                            \
 569 generate_real_unary_logical(n, type, ntype, pack, unpack, is_exception, 0)\
 570 generate_real_ldc(n, type, ntype, pack, unpack)
 571
 572 for_all_real(generate_real_functions, for_all_empty)
 573 #undef generate_real_functions
 574
 575
 576 static inline frame_s *frame_build(frame_s *fp, struct data *function, ajla_error_t *mayfail)
 577 {
 578         frame_t new_frame_slots = da(function,function)->frame_slots;
 579         if (likely(new_frame_slots <= get_frame(fp)->available_slots)) {
 580                 frame_s *new_fp = cast_ptr(frame_s *, cast_ptr(char *, fp) - new_frame_slots * slot_size);
 581                 get_frame(new_fp)->available_slots = get_frame(fp)->available_slots - new_frame_slots;
 582                 get_frame(new_fp)->function = function;
 583                 return new_fp;
 584         } else {
 585                 return stack_expand(fp, function, mayfail);
 586         }
 587 }
 588
 589
 590 #define ipret_checkpoint_forced                                         \
 591 do {                                                                    \
 592         void *ex_ = ipret_tick(fp, ip);                                 \
 593         RELOAD_EX_POSITION(ex_);                                        \
 594 } while (0)
 595
 596
 597 #define OPCODE_ARG_MODE(opcode) ((opcode) + ARG_MODE * OPCODE_MODE_MULT)
 598
 599 #define EMIT_FUNCTIONS
 600 #include "ipret.inc"
 601
 602 void attr_hot_fastcall run(frame_s *fp_, ip_t ip_)
 603 {
 604         ajla_error_t ajla_error;
 605         tick_stamp_t ts;
 606 #if defined(DEBUG) && !defined(COMPUTED_GOTO)
 607         const code_t *last_stack[20];
 608 #endif
 609
 610         register frame_s *fp
 611 #if ((defined(INLINE_ASM_GCC_I386) && !defined(__PIC__)) || defined(INLINE_ASM_GCC_X32)) && defined(__OPTIMIZE__) && defined(HAVE_REAL_GNUC)
 612         /*
 613          * GCC usually uses ebp for the variable fp. It is bad choice because
 614          * ebp can't be used as a base register without immediate offset. So,
 615          * the assembler adds offset 0 to every instruction using ebp as base.
 616          * Doing two additions and one shift in one instruction is too much and
 617          * it causes performance drop on both Intel and AMD architectures.
 618          */
 619                 __asm__("ebx")
 620 #endif
 621 #if defined(INLINE_ASM_GCC_X86_64) && defined(__OPTIMIZE__) && defined(HAVE_REAL_GNUC)
 622                 /*__asm__("rbx")*/
 623 #endif
 624 #if defined(INLINE_ASM_GCC_ARM_THUMB2) && defined(__OPTIMIZE__) && defined(HAVE_REAL_GNUC)
 625                 /* peg this to a register in lower bank to reduce code size and improve performance */
 626                 __asm__("r6")
 627 #endif
 628                 ;
 629         register const code_t *ip
 630 #if defined(INLINE_ASM_GCC_ARM_THUMB2) && defined(__OPTIMIZE__) && defined(HAVE_REAL_GNUC) && 0
 631                 /* don't use it for now, it causes too much register pressure */
 632                 __asm__("r5")
 633 #endif
 634                 ;
 635         code_t code;
 636
 637 #ifdef COMPUTED_GOTO
 638         const void *next_label;
 639 #ifdef COMPUTED_GOTO_RELATIVE
 640         static const int dispatch[OPCODE_MODE_MULT * ARG_MODE_N - (OPCODE_MODE_MULT - OPCODE_N)] = {
 641 #define DEFINE_OPCODE_START_LBL(opcode, lbl)                    \
 642                 [OPCODE_ARG_MODE(opcode)] = (const char *)&&cat(label_,lbl) - (const char *)&&label_unknown,
 643 #else
 644         static const void *dispatch[OPCODE_MODE_MULT * ARG_MODE_N - (OPCODE_MODE_MULT - OPCODE_N)] = {
 645 #define DEFINE_OPCODE_START_LBL(opcode, lbl)                    \
 646                 [OPCODE_ARG_MODE(opcode)] = &&cat(label_,lbl),
 647 #endif
 648 #include "ipret.inc"
 649 #ifdef COMPUTED_GOTO_RELATIVE
 650         };
 651 #else
 652         };
 653 #endif
 654 #endif
 655
 656 #if defined(DEBUG) && !defined(COMPUTED_GOTO)
 657         memset(last_stack, 0, sizeof last_stack);
 658 #endif
 659
 660         fp = fp_;
 661         ip = &da(get_frame(fp)->function,function)->code[ip_];
 662         tick_start(&ts);
 663
 664 #define RELOAD_EX_POSITION(ex)                                  \
 665 do {                                                            \
 666         if ((ex) != POINTER_FOLLOW_THUNK_EXIT) {                \
 667                 ajla_assert((ex) != POINTER_FOLLOW_THUNK_RETRY && (ex) != POINTER_FOLLOW_THUNK_EXCEPTION && (ex) != POINTER_FOLLOW_THUNK_GO, (file_line, "RELOAD_EX_POSITION: invalid pointer: %p", (ex)));\
 668                 fp = cast_ptr(struct execution_control *, (ex))->current_frame;\
 669                 ip = da(get_frame(fp)->function,function)->code + cast_ptr(struct execution_control *, (ex))->current_ip;\
 670                 tick_start(&ts);                                \
 671                 goto next_code;                                 \
 672         } else {                                                \
 673                 goto exit_ipret;                                \
 674         }                                                       \
 675 } while (0)
 676
 677 #ifdef COMPUTED_GOTO
 678
 679 #ifdef COMPUTED_GOTO_RELATIVE
 680 #define GOTO_NEXT(opcode)                                       \
 681         code = *ip;                                             \
 682         next_label = (const char *)&&label_unknown + dispatch[code & OPCODE_MASK];\
 683         ASM_PREVENT_JOIN(OPCODE_ARG_MODE(opcode));              \
 684         goto *(void *)next_label;
 685 #else
 686 #define GOTO_NEXT(opcode)                                       \
 687         code = *ip;                                             \
 688         next_label = dispatch[code & OPCODE_MASK];              \
 689         ASM_PREVENT_JOIN(OPCODE_ARG_MODE(opcode));              \
 690         goto *(void *)next_label;
 691 #endif
 692
 693         next_code:
 694 #define ARG_MODE 0
 695         GOTO_NEXT(-1);
 696 #undef ARG_MODE
 697
 698 #define EMIT_CODE
 699 #define START_BLOCK(declarations)                               { declarations
 700 #define END_BLOCK()                                             }
 701 #define DEFINE_LABEL(lbl, code)                                 \
 702         lbl: do {                                               \
 703                 code                                            \
 704         } while (0);                                            \
 705         GOTO_NEXT(-2);
 706 #define DEFINE_OPCODE_START_LBL(opcode, lbl)                    \
 707         cat(label_,lbl): do {
 708 #define DEFINE_OPCODE_END(opcode)                               \
 709         } while (0);                                            \
 710         GOTO_NEXT(OPCODE_ARG_MODE(opcode));
 711 #include "ipret.inc"
 712
 713 #ifdef COMPUTED_GOTO_RELATIVE
 714         label_unknown:
 715                 internal(file_line, "run: invalid opcode %04x", (int)code);
 716 #endif
 717
 718 #else
 719         next_code:
 720         code = *ip;
 721 #if defined(DEBUG) && !defined(COMPUTED_GOTO)
 722         memmove(last_stack + 1, last_stack, (sizeof last_stack) - sizeof(*last_stack));
 723         last_stack[0] = ip;
 724 #endif
 725 #ifdef DEBUG_TRACE
 726         if (unlikely(load_relaxed(&trace_enabled))) {
 727                 struct stack_trace st;
 728                 const char *fn = "";
 729                 unsigned ln = 0;
 730                 stack_trace_capture(&st, fp, ip, 1);
 731                 if (st.trace_n >= 1) {
 732                         fn = st.trace[0].function_name;
 733                         ln = st.trace[0].line;
 734                 }
 735 #define xip(n)  (frame_ip(fp, ip) + n >= da(get_frame(fp)->function,function)->code_size ? 0xffff : ip[n])
 736                 trace("%-24s %-5u %-32s at %u %p %p %04x %04x %04x %04x %04x %04x %04x %04x", fn, ln, decode_opcode(code, true), frame_ip(fp, ip), fp, frame_execution_control(fp), xip(1), xip(2), xip(3), xip(4), xip(5), xip(6), xip(7), xip(8));
 737 #undef xip
 738                 stack_trace_free(&st);
 739         }
 740 #endif
 741         switch (code & OPCODE_MASK) {
 742 #define EMIT_CODE
 743 #define START_BLOCK(declarations)                               { declarations
 744 #define END_BLOCK()                                             }
 745 #define DEFINE_LABEL(lbl, code)                                 \
 746         lbl: {                                                  \
 747                         code                                    \
 748                 }                                               \
 749                 break;
 750 #define DEFINE_OPCODE_START_LBL(opcode, lbl)                    \
 751         case OPCODE_ARG_MODE(opcode): {
 752 #define DEFINE_OPCODE_END(opcode)                               \
 753                 }                                               \
 754                 break;
 755 #include "ipret.inc"
 756                 default:
 757 #if defined(HAVE___BUILTIN_UNREACHABLE) && !defined(DEBUG)
 758                         __builtin_unreachable();
 759 #else
 760                         {
 761                                 ip_t l = ip - da(get_frame(fp)->function,function)->code;
 762                                 ip_t x;
 763                                 for (x = 0; x <= l; x++) {
 764                                         code_t v = da(get_frame(fp)->function,function)->code[x];
 765                                         const char *opc = decode_opcode(v, true);
 766                                         char c = ' ';
 767 #if defined(DEBUG) && !defined(COMPUTED_GOTO)
 768                                         size_t lso;
 769                                         for (lso = 0; lso < n_array_elements(last_stack); lso++)
 770                                                 if (&da(get_frame(fp)->function,function)->code[x] == last_stack[lso])
 771                                                         c = '*';
 772 #endif
 773                                         if (opc)
 774                                                 debug("%c %04x (%s)", c, v, opc);
 775                                         else
 776                                                 debug("%c %04x", c, v);
 777                                 }
 778                                 internal(file_line, "run: invalid opcode %04x (mode %x, int %x, real %x, bool %x, extra %x)", code, OPCODE_MODE_MULT, OPCODE_INT_OP, OPCODE_REAL_OP, OPCODE_BOOL_OP, OPCODE_EXTRA);
 779                         }
 780 #endif
 781         }
 782         goto next_code;
 783 #endif
 784
 785 exit_ipret:;
 786 }
 787
 788
 789 #ifdef HAVE_CODEGEN
 790
 791 static void cg_upcall_mem_copy(void *dest, const void *src, size_t size)
 792 {
 793         memcpy(dest, src, size);
 794 }
 795
 796 static void cg_upcall_mem_clear(void *ptr, size_t len)
 797 {
 798         memset(ptr, 0, len);
 799 }
 800
 801 static void cg_upcall_pointer_dereference(pointer_t_upcall ptr)
 802 {
 803         pointer_dereference(ptr);
 804 }
 805
 806 static void cg_upcall_pointer_reference_owned(pointer_t_upcall ptr)
 807 {
 808         pointer_reference_owned(ptr);
 809 }
 810
 811 static pointer_t cg_upcall_flat_to_data(frame_s *fp, uintptr_t slot, const unsigned char *flat)
 812 {
 813         const struct type *type = frame_get_type_of_local(fp, slot);
 814         return flat_to_data(type, flat);
 815 }
 816
 817 static unsigned char *cg_upcall_data_alloc_function_reference_mayfail(uintptr_t n_curried_arguments)
 818 {
 819         ajla_error_t sink;
 820         return cast_ptr(unsigned char *, data_alloc_function_reference_mayfail(n_curried_arguments, &sink pass_file_line));
 821 }
 822
 823 static unsigned char *cg_upcall_data_alloc_record_mayfail(frame_s *fp, uintptr_t slot)
 824 {
 825         ajla_error_t sink;
 826         const struct type *type = frame_get_type_of_local(fp, slot);
 827         return cast_ptr(unsigned char *, data_alloc_record_mayfail(type_def(type,record), &sink pass_file_line));
 828 }
 829
 830 static unsigned char *cg_upcall_data_alloc_option_mayfail(void)
 831 {
 832         ajla_error_t sink;
 833         return cast_ptr(unsigned char *, data_alloc(option, &sink));
 834 }
 835
 836 static unsigned char *cg_upcall_data_alloc_array_flat_tag_mayfail(uintptr_t tag, int_default_t_upcall n_entries)
 837 {
 838         ajla_error_t sink;
 839         const struct type *type = type_get_from_tag(tag);
 840         return cast_ptr(unsigned char *, data_alloc_array_flat_mayfail(type, n_entries, n_entries, false, &sink pass_file_line));
 841 }
 842
 843 static unsigned char *cg_upcall_data_alloc_array_flat_slot_mayfail(frame_s *fp, uintptr_t slot, int_default_t_upcall n_entries)
 844 {
 845         ajla_error_t sink;
 846         const struct type *type = frame_get_type_of_local(fp, slot);
 847         return cast_ptr(unsigned char *, data_alloc_array_flat_mayfail(type, n_entries, n_entries, false, &sink pass_file_line));
 848 }
 849
 850 static unsigned char *cg_upcall_data_alloc_array_flat_types_ptr_mayfail(frame_s *fp, uintptr_t local_type, int_default_t_upcall n_allocated, int_default_t_upcall n_used)
 851 {
 852         ajla_error_t sink;
 853         const struct type *type = da_type(get_frame(fp)->function, local_type);
 854         return cast_ptr(unsigned char *, data_alloc_array_flat_mayfail(type, n_allocated, n_used, false, &sink pass_file_line));
 855 }
 856
 857 static unsigned char *cg_upcall_data_alloc_array_pointers_mayfail(int_default_t_upcall n_allocated, int_default_t_upcall n_used)
 858 {
 859         ajla_error_t sink;
 860         return cast_ptr(unsigned char *, data_alloc_array_pointers_mayfail(n_allocated, n_used, &sink pass_file_line));
 861 }
 862
 863 static pointer_t cg_upcall_array_create_flat(frame_s *fp, int_default_t_upcall length, uintptr_t content_slot)
 864 {
 865         array_index_t idx;
 866         const struct type *content_type = frame_get_type_of_local(fp, content_slot);
 867         index_from_int(&idx, length);
 868         return array_create(idx, content_type, frame_var(fp, content_slot), pointer_empty());
 869 }
 870
 871 static pointer_t cg_upcall_array_create_pointers(frame_s *fp, uintptr_t ip_offset, uintptr_t length_slot, pointer_t_upcall ptr)
 872 {
 873         array_index_t idx;
 874         int_default_t length = *frame_slot(fp, length_slot, int_default_t);
 875         if (unlikely(length < 0)) {
 876                 code_t *ip;
 877                 pointer_dereference(ptr);
 878                 ip = da(get_frame(fp)->function,function)->code + ip_offset;
 879                 return pointer_error(error_ajla(EC_SYNC, AJLA_ERROR_NEGATIVE_INDEX), fp, ip pass_file_line);
 880         }
 881         index_from_int(&idx, length);
 882         return array_create(idx, NULL, NULL, ptr);
 883 }
 884
 885 static pointer_t cg_upcall_array_create_sparse(int_default_t_upcall length, pointer_t_upcall ptr)
 886 {
 887         array_index_t idx;
 888         index_from_int(&idx, length);
 889         return array_create_sparse(idx, ptr);
 890 }
 891
 892 static pointer_t cg_upcall_array_sub(pointer_t_upcall array, int_default_t_upcall start, int_default_t_upcall end, bool deref)
 893 {
 894         pointer_t res_ptr;
 895         ajla_error_t err;
 896         struct data *d, *s;
 897         array_index_t idx_start, idx_end, idx_len, idx_array_len;
 898         if (unlikely((start | end) < 0))
 899                 goto fail1;
 900         if (unlikely(start > end))
 901                 goto fail1;
 902         if (unlikely(pointer_is_thunk(array)))
 903                 goto fail1;
 904         index_from_int(&idx_start, start);
 905         index_from_int(&idx_end, end);
 906         index_from_int(&idx_len, end - start);
 907         d = pointer_get_data(array);
 908         if (unlikely(da_tag(d) == DATA_TAG_array_incomplete))
 909                 goto fail2;
 910         idx_array_len = array_len(d);
 911         if (unlikely(!index_ge_index(idx_array_len, idx_end))) {
 912                 index_free(&idx_array_len);
 913                 goto fail2;
 914         }
 915         index_free(&idx_array_len);
 916         index_free(&idx_end);
 917         s = array_sub(d, idx_start, idx_len, deref, &err);
 918         if (unlikely(!s)) {
 919                 res_ptr = pointer_error(err, NULL, 0 pass_file_line);
 920         } else {
 921                 res_ptr = pointer_data(s);
 922         }
 923         return res_ptr;
 924 fail2:
 925         index_free(&idx_start);
 926         index_free(&idx_end);
 927         index_free(&idx_len);
 928 fail1:
 929         return pointer_empty();
 930 }
 931
 932 static pointer_t cg_upcall_array_skip(pointer_t_upcall array, int_default_t_upcall start, bool deref)
 933 {
 934         pointer_t res_ptr;
 935         ajla_error_t err;
 936         struct data *d, *s;
 937         array_index_t idx_start, idx_array_len;
 938         if (unlikely(start < 0))
 939                 goto fail1;
 940         if (unlikely(pointer_is_thunk(array)))
 941                 goto fail1;
 942         d = pointer_get_data(array);
 943         if (unlikely(da_tag(d) == DATA_TAG_array_incomplete))
 944                 goto fail1;
 945         index_from_int(&idx_start, start);
 946         idx_array_len = array_len(d);
 947         if (unlikely(!index_ge_index(idx_array_len, idx_start))) {
 948                 goto fail2;
 949         }
 950         index_sub_int(&idx_array_len, start);
 951         s = array_sub(d, idx_start, idx_array_len, deref, &err);
 952         if (unlikely(!s)) {
 953                 res_ptr = pointer_error(err, NULL, 0 pass_file_line);
 954         } else {
 955                 res_ptr = pointer_data(s);
 956         }
 957         return res_ptr;
 958 fail2:
 959         index_free(&idx_array_len);
 960         index_free(&idx_start);
 961 fail1:
 962         return pointer_empty();
 963 }
 964
 965 static pointer_t cg_upcall_array_join(pointer_t_upcall ptr1, pointer_t_upcall ptr2)
 966 {
 967         ajla_error_t err;
 968         struct data *d1 = pointer_get_data(ptr1);
 969         struct data *d2 = pointer_get_data(ptr2);
 970         struct data *d = array_join(d1, d2, &err);
 971         if (unlikely(!d))
 972                 return pointer_error(err, NULL, NULL pass_file_line);
 973         return pointer_data(d);
 974 }
 975
 976 static void *cg_upcall_ipret_io(frame_s *fp, uintptr_t ip_offset, uintptr_t code_params)
 977 {
 978         void *ret;
 979         code_t *ip = da(get_frame(fp)->function,function)->code + ip_offset;
 980         unsigned char io_code = code_params >> 24;
 981         unsigned char n_outputs = code_params >> 16;
 982         unsigned char n_inputs = code_params >> 8;
 983         unsigned char n_params = code_params;
 984         /*debug("cg_upcall_ipret_io start: %p, %u %u %u %u", ip, io_code, n_outputs, n_inputs, n_params);*/
 985         ret = ipret_io(fp, ip, io_code, n_outputs, n_inputs, n_params);
 986         /*debug("cg_upcall_ipret_io end: %u %u %u %u -> %p", io_code, n_outputs, n_inputs, n_params, ret);*/
 987         return ret;
 988 }
 989
 990 static pointer_t cg_upcall_ipret_copy_variable_to_pointer(frame_s *src_fp, uintptr_t src_slot, bool deref)
 991 {
 992         return ipret_copy_variable_to_pointer(src_fp, src_slot, deref);
 993 }
 994
 995 static int_default_t cg_upcall_ipret_system_property(int_default_t_upcall idx)
 996 {
 997         return ipret_system_property(idx);
 998 }
 999
1000 #define f(n, s, u, sz, bits)                                            \
1001 static bool cat(INT_binary_const_,s)(const s *v1, int_default_t_upcall v2, s *r, bool (*op)(const void *, const void *, void *))\
1002 {                                                                       \
1003         s c = v2;                                                       \
1004         return op(v1, &c, r);                                           \
1005 }
1006 for_all_int(f, for_all_empty)
1007 #undef f
1008
1009 #define f(n, s, u, sz, bits)                                            \
1010 static bool cat(FIXED_uto_int_,s)(const u *v1, int_default_t *r)        \
1011 {                                                                       \
1012         int_default_t ret;                                              \
1013         ret = (int_default_t)*v1;                                       \
1014         if (unlikely((u)ret != *v1) || unlikely(ret < 0))               \
1015                 return false;                                           \
1016         *r = ret;                                                       \
1017         return true;                                                    \
1018 }                                                                       \
1019 static bool cat(FIXED_ufrom_int_,s)(const int_default_t *v1, u *r)      \
1020 {                                                                       \
1021         u ret;                                                          \
1022         ret = (u)*v1;                                                   \
1023         if (unlikely((int_default_t)ret != *v1) || unlikely(*v1 < 0))   \
1024                 return false;                                           \
1025         *r = ret;                                                       \
1026         return true;                                                    \
1027 }
1028 for_all_fixed(f)
1029 #undef f
1030
1031 #ifdef DEBUG_UPCALL
1032 static void cg_upcall_debug(unsigned long x1, unsigned long x2, unsigned long x3, unsigned long x4)
1033 {
1034         debug("cg upcall: %lx, %lx, %lx, %lx", x1, x2, x3, x4);
1035 }
1036 #endif
1037
1038 #endif
1039
1040 #define nf(n, t) NULL,
1041
1042 struct cg_upcall_vector_s cg_upcall_vector = {
1043         0,
1044 #ifdef HAVE_CODEGEN
1045         cg_upcall_mem_copy,
1046         cg_upcall_mem_clear,
1047         cg_upcall_pointer_dereference,
1048         cg_upcall_pointer_reference_owned,
1049         cg_upcall_flat_to_data,
1050         cg_upcall_data_alloc_function_reference_mayfail,
1051         cg_upcall_data_alloc_record_mayfail,
1052         cg_upcall_data_alloc_option_mayfail,
1053         cg_upcall_data_alloc_array_flat_tag_mayfail,
1054         cg_upcall_data_alloc_array_flat_slot_mayfail,
1055         cg_upcall_data_alloc_array_flat_types_ptr_mayfail,
1056         cg_upcall_data_alloc_array_pointers_mayfail,
1057         cg_upcall_array_create_flat,
1058         cg_upcall_array_create_pointers,
1059         cg_upcall_array_create_sparse,
1060         cg_upcall_array_sub,
1061         cg_upcall_array_skip,
1062         cg_upcall_array_join,
1063         cg_upcall_ipret_io,
1064         cg_upcall_ipret_copy_variable_to_pointer,
1065         cg_upcall_ipret_system_property,
1066 #define f(n, s, u, sz, bits) \
1067         cat(INT_binary_const_,s),
1068         for_all_int(f, for_all_empty)
1069 #undef f
1070         cat(FIXED_binary_add_,TYPE_INT_MAX),
1071         cat(FIXED_binary_subtract_,TYPE_INT_MAX),
1072 #define f(n, s, u, sz, bits) \
1073         cat(FIXED_binary_multiply_,s),
1074         for_all_fixed(f)
1075 #undef f
1076 #define f(n, s, u, sz, bits) \
1077         cat(FIXED_binary_divide_,s),
1078         for_all_fixed(f)
1079 #undef f
1080 #define f(n, s, u, sz, bits) \
1081         cat(FIXED_binary_udivide_,s),
1082         for_all_fixed(f)
1083 #undef f
1084 #define f(n, s, u, sz, bits) \
1085         cat(FIXED_binary_modulo_,s),
1086         for_all_fixed(f)
1087 #undef f
1088 #define f(n, s, u, sz, bits) \
1089         cat(FIXED_binary_umodulo_,s),
1090         for_all_fixed(f)
1091 #undef f
1092 #define f(n, s, u, sz, bits) \
1093         cat(FIXED_binary_power_,s),
1094         for_all_fixed(f)
1095 #undef f
1096         cat(FIXED_binary_shl_,TYPE_INT_MAX),
1097         cat(FIXED_binary_shr_,TYPE_INT_MAX),
1098         cat(FIXED_binary_ushr_,TYPE_INT_MAX),
1099         cat(FIXED_binary_rol_,TYPE_INT_MAX),
1100         cat(FIXED_binary_ror_,TYPE_INT_MAX),
1101         cat(FIXED_binary_bts_,TYPE_INT_MAX),
1102         cat(FIXED_binary_btr_,TYPE_INT_MAX),
1103         cat(FIXED_binary_btc_,TYPE_INT_MAX),
1104         cat(FIXED_binary_less_,TYPE_INT_MAX),
1105         cat(FIXED_binary_less_equal_,TYPE_INT_MAX),
1106         cat(FIXED_binary_greater_,TYPE_INT_MAX),
1107         cat(FIXED_binary_greater_equal_,TYPE_INT_MAX),
1108         cat(FIXED_binary_uless_,TYPE_INT_MAX),
1109         cat(FIXED_binary_uless_equal_,TYPE_INT_MAX),
1110         cat(FIXED_binary_ugreater_,TYPE_INT_MAX),
1111         cat(FIXED_binary_ugreater_equal_,TYPE_INT_MAX),
1112         cat(FIXED_binary_bt_,TYPE_INT_MAX),
1113         cat(FIXED_unary_neg_,TYPE_INT_MAX),
1114 #define f(n, s, u, sz, bits) \
1115         cat(FIXED_unary_bswap_,s),
1116         for_all_fixed(f)
1117 #undef f
1118 #define f(n, s, u, sz, bits) \
1119         cat(FIXED_unary_brev_,s),
1120         for_all_fixed(f)
1121 #undef f
1122 #define f(n, s, u, sz, bits) \
1123         cat(FIXED_unary_bsf_,s),
1124         for_all_fixed(f)
1125 #undef f
1126 #define f(n, s, u, sz, bits) \
1127         cat(FIXED_unary_bsr_,s),
1128         for_all_fixed(f)
1129 #undef f
1130 #define f(n, s, u, sz, bits) \
1131         cat(FIXED_unary_popcnt_,s),
1132         for_all_fixed(f)
1133 #undef f
1134 #define f(n, s, u, sz, bits) \
1135         cat(FIXED_uto_int_,s),
1136         for_all_fixed(f)
1137 #undef f
1138 #define f(n, s, u, sz, bits) \
1139         cat(FIXED_ufrom_int_,s),
1140         for_all_fixed(f)
1141 #undef f
1142         cat(INT_binary_add_,TYPE_INT_MAX),
1143         cat(INT_binary_subtract_,TYPE_INT_MAX),
1144 #define f(n, s, u, sz, bits) \
1145         cat(INT_binary_multiply_,s),
1146         for_all_int(f, for_all_empty)
1147 #undef f
1148 #define f(n, s, u, sz, bits) \
1149         cat(INT_binary_divide_,s),
1150         for_all_int(f, for_all_empty)
1151 #undef f
1152 #define f(n, s, u, sz, bits) \
1153         cat(INT_binary_modulo_,s),
1154         for_all_int(f, for_all_empty)
1155 #undef f
1156 #define f(n, s, u, sz, bits) \
1157         cat(INT_binary_power_,s),
1158         for_all_int(f, for_all_empty)
1159 #undef f
1160         cat(INT_binary_shl_,TYPE_INT_MAX),
1161         cat(INT_binary_shr_,TYPE_INT_MAX),
1162         cat(INT_binary_bts_,TYPE_INT_MAX),
1163         cat(INT_binary_btr_,TYPE_INT_MAX),
1164         cat(INT_binary_btc_,TYPE_INT_MAX),
1165         cat(INT_binary_bt_,TYPE_INT_MAX),
1166         cat(INT_unary_neg_,TYPE_INT_MAX),
1167 #define f(n, s, u, sz, bits) \
1168         cat(INT_unary_bsf_,s),
1169         for_all_int(f, for_all_empty)
1170 #undef f
1171 #define f(n, s, u, sz, bits) \
1172         cat(INT_unary_bsr_,s),
1173         for_all_int(f, for_all_empty)
1174 #undef f
1175 #define f(n, s, u, sz, bits) \
1176         cat(INT_unary_popcnt_,s),
1177         for_all_int(f, for_all_empty)
1178 #undef f
1179 #define f(n, t, nt, pack, unpack) \
1180         cat(REAL_binary_add_,t),
1181         for_all_real(f, nf)
1182 #undef f
1183 #define f(n, t, nt, pack, unpack) \
1184         cat(REAL_binary_subtract_,t),
1185         for_all_real(f, nf)
1186 #undef f
1187 #define f(n, t, nt, pack, unpack) \
1188         cat(REAL_binary_multiply_,t),
1189         for_all_real(f, nf)
1190 #undef f
1191 #define f(n, t, nt, pack, unpack) \
1192         cat(REAL_binary_divide_,t),
1193         for_all_real(f, nf)
1194 #undef f
1195 #define f(n, t, nt, pack, unpack) \
1196         cat(REAL_binary_modulo_,t),
1197         for_all_real(f, nf)
1198 #undef f
1199 #define f(n, t, nt, pack, unpack) \
1200         cat(REAL_binary_power_,t),
1201         for_all_real(f, nf)
1202 #undef f
1203 #define f(n, t, nt, pack, unpack) \
1204         cat(REAL_binary_ldexp_,t),
1205         for_all_real(f, nf)
1206 #undef f
1207 #define f(n, t, nt, pack, unpack) \
1208         cat(REAL_binary_atan2_,t),
1209         for_all_real(f, nf)
1210 #undef f
1211 #define f(n, t, nt, pack, unpack) \
1212         cat(REAL_binary_equal_,t),
1213         for_all_real(f, nf)
1214 #undef f
1215 #define f(n, t, nt, pack, unpack) \
1216         cat(REAL_binary_not_equal_,t),
1217         for_all_real(f, nf)
1218 #undef f
1219 #define f(n, t, nt, pack, unpack) \
1220         cat(REAL_binary_less_,t),
1221         for_all_real(f, nf)
1222 #undef f
1223 #define f(n, t, nt, pack, unpack) \
1224         cat(REAL_binary_less_equal_,t),
1225         for_all_real(f, nf)
1226 #undef f
1227 #define f(n, t, nt, pack, unpack) \
1228         cat(REAL_binary_greater_,t),
1229         for_all_real(f, nf)
1230 #undef f
1231 #define f(n, t, nt, pack, unpack) \
1232         cat(REAL_binary_greater_equal_,t),
1233         for_all_real(f, nf)
1234 #undef f
1235 #define f(n, t, nt, pack, unpack) \
1236         cat(REAL_unary_neg_,t),
1237         for_all_real(f, nf)
1238 #undef f
1239 #define f(n, t, nt, pack, unpack) \
1240         cat(REAL_unary_sqrt_,t),
1241         for_all_real(f, nf)
1242 #undef f
1243 #define f(n, t, nt, pack, unpack) \
1244         cat(REAL_unary_cbrt_,t),
1245         for_all_real(f, nf)
1246 #undef f
1247 #define f(n, t, nt, pack, unpack) \
1248         cat(REAL_unary_sin_,t),
1249         for_all_real(f, nf)
1250 #undef f
1251 #define f(n, t, nt, pack, unpack) \
1252         cat(REAL_unary_cos_,t),
1253         for_all_real(f, nf)
1254 #undef f
1255 #define f(n, t, nt, pack, unpack) \
1256         cat(REAL_unary_tan_,t),
1257         for_all_real(f, nf)
1258 #undef f
1259 #define f(n, t, nt, pack, unpack) \
1260         cat(REAL_unary_asin_,t),
1261         for_all_real(f, nf)
1262 #undef f
1263 #define f(n, t, nt, pack, unpack) \
1264         cat(REAL_unary_acos_,t),
1265         for_all_real(f, nf)
1266 #undef f
1267 #define f(n, t, nt, pack, unpack) \
1268         cat(REAL_unary_atan_,t),
1269         for_all_real(f, nf)
1270 #undef f
1271 #define f(n, t, nt, pack, unpack) \
1272         cat(REAL_unary_sinh_,t),
1273         for_all_real(f, nf)
1274 #undef f
1275 #define f(n, t, nt, pack, unpack) \
1276         cat(REAL_unary_cosh_,t),
1277         for_all_real(f, nf)
1278 #undef f
1279 #define f(n, t, nt, pack, unpack) \
1280         cat(REAL_unary_tanh_,t),
1281         for_all_real(f, nf)
1282 #undef f
1283 #define f(n, t, nt, pack, unpack) \
1284         cat(REAL_unary_asinh_,t),
1285         for_all_real(f, nf)
1286 #undef f
1287 #define f(n, t, nt, pack, unpack) \
1288         cat(REAL_unary_acosh_,t),
1289         for_all_real(f, nf)
1290 #undef f
1291 #define f(n, t, nt, pack, unpack) \
1292         cat(REAL_unary_atanh_,t),
1293         for_all_real(f, nf)
1294 #undef f
1295 #define f(n, t, nt, pack, unpack) \
1296         cat(REAL_unary_exp2_,t),
1297         for_all_real(f, nf)
1298 #undef f
1299 #define f(n, t, nt, pack, unpack) \
1300         cat(REAL_unary_exp_,t),
1301         for_all_real(f, nf)
1302 #undef f
1303 #define f(n, t, nt, pack, unpack) \
1304         cat(REAL_unary_exp10_,t),
1305         for_all_real(f, nf)
1306 #undef f
1307 #define f(n, t, nt, pack, unpack) \
1308         cat(REAL_unary_log2_,t),
1309         for_all_real(f, nf)
1310 #undef f
1311 #define f(n, t, nt, pack, unpack) \
1312         cat(REAL_unary_log_,t),
1313         for_all_real(f, nf)
1314 #undef f
1315 #define f(n, t, nt, pack, unpack) \
1316         cat(REAL_unary_log10_,t),
1317         for_all_real(f, nf)
1318 #undef f
1319 #define f(n, t, nt, pack, unpack) \
1320         cat(REAL_unary_round_,t),
1321         for_all_real(f, nf)
1322 #undef f
1323 #define f(n, t, nt, pack, unpack) \
1324         cat(REAL_unary_ceil_,t),
1325         for_all_real(f, nf)
1326 #undef f
1327 #define f(n, t, nt, pack, unpack) \
1328         cat(REAL_unary_floor_,t),
1329         for_all_real(f, nf)
1330 #undef f
1331 #define f(n, t, nt, pack, unpack) \
1332         cat(REAL_unary_trunc_,t),
1333         for_all_real(f, nf)
1334 #undef f
1335 #define f(n, t, nt, pack, unpack) \
1336         cat(REAL_unary_fract_,t),
1337         for_all_real(f, nf)
1338 #undef f
1339 #define f(n, t, nt, pack, unpack) \
1340         cat(REAL_unary_mantissa_,t),
1341         for_all_real(f, nf)
1342 #undef f
1343 #define f(n, t, nt, pack, unpack) \
1344         cat(REAL_unary_exponent_,t),
1345         for_all_real(f, nf)
1346 #undef f
1347 #define f(n, t, nt, pack, unpack) \
1348         cat(REAL_unary_next_number_,t),
1349         for_all_real(f, nf)
1350 #undef f
1351 #define f(n, t, nt, pack, unpack) \
1352         cat(REAL_unary_prev_number_,t),
1353         for_all_real(f, nf)
1354 #undef f
1355 #define f(n, t, nt, pack, unpack) \
1356         cat(REAL_unary_to_int_,t),
1357         for_all_real(f, nf)
1358 #undef f
1359 #define f(n, t, nt, pack, unpack) \
1360         cat(REAL_unary_from_int_,t),
1361         for_all_real(f, nf)
1362 #undef f
1363 #define f(n, t, nt, pack, unpack) \
1364         cat(REAL_unary_is_exception_,t),
1365         for_all_real(f, nf)
1366 #undef f
1367 #endif
1368 #ifdef DEBUG_UPCALL
1369         cg_upcall_debug,
1370 #endif
1371 };
1372
1373 void name(ipret_init)(void)
1374 {
1375 #if 0
1376         unsigned __int128 a = ((unsigned __int128)0x285C1889155FULL << 64) + 0xC6DCBCCF1106E0C5ULL;
1377         unsigned __int128 b = 0x374AC42721E9E9BFULL;
1378         unsigned __int128 c = 1;
1379         char *s;
1380         FIXED_binary_power_int128_t(&a, &b, &c);
1381         s = str_from_signed(c, 16);
1382         debug("%s", s);
1383         mem_free(s);
1384 #endif
1385 #if 0
1386         int i;
1387         for (i = 0; i < OPCODE_MODE_MULT * ARG_MODE_N - (OPCODE_MODE_MULT - OPCODE_N); i++) {
1388                 debug("%04x - %s", i, decode_opcode(i, true));
1389         }
1390 #endif
1391         tick_stamp_ptr = &tick_stamp;
1392 }
1393
1394 void name(ipret_done)(void)
1395 {
1396 }
1397
1398 #endif