vm/math.c

   1 #include "master.h"
   2
   3 /* Fixnums */
   4 F_FIXNUM to_fixnum(CELL tagged)
   5 {
   6         switch(TAG(tagged))
   7         {
   8         case FIXNUM_TYPE:
   9                 return untag_fixnum_fast(tagged);
  10         case BIGNUM_TYPE:
  11                 return bignum_to_fixnum(untag_object(tagged));
  12         default:
  13                 type_error(FIXNUM_TYPE,tagged);
  14                 return -1; /* can't happen */
  15         }
  16 }
  17
  18 CELL to_cell(CELL tagged)
  19 {
  20         return (CELL)to_fixnum(tagged);
  21 }
  22
  23 void primitive_bignum_to_fixnum(void)
  24 {
  25         drepl(tag_fixnum(bignum_to_fixnum(untag_object(dpeek()))));
  26 }
  27
  28 void primitive_float_to_fixnum(void)
  29 {
  30         drepl(tag_fixnum(float_to_fixnum(dpeek())));
  31 }
  32
  33 /* The fixnum+, fixnum- and fixnum* primitives are defined in cpu_*.S. On
  34 overflow, they call these functions. */
  35 F_FASTCALL void overflow_fixnum_add(F_FIXNUM x, F_FIXNUM y)
  36 {
  37         drepl(tag_bignum(fixnum_to_bignum(
  38                 untag_fixnum_fast(x) + untag_fixnum_fast(y))));
  39 }
  40
  41 F_FASTCALL void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y)
  42 {
  43         drepl(tag_bignum(fixnum_to_bignum(
  44                 untag_fixnum_fast(x) - untag_fixnum_fast(y))));
  45 }
  46
  47 F_FASTCALL void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y)
  48 {
  49         F_ARRAY *bx = fixnum_to_bignum(x);
  50         REGISTER_BIGNUM(bx);
  51         F_ARRAY *by = fixnum_to_bignum(y);
  52         UNREGISTER_BIGNUM(bx);
  53         drepl(tag_bignum(bignum_multiply(bx,by)));
  54 }
  55
  56 /* Division can only overflow when we are dividing the most negative fixnum
  57 by -1. */
  58 void primitive_fixnum_divint(void)
  59 {
  60         F_FIXNUM y = untag_fixnum_fast(dpop()); \
  61         F_FIXNUM x = untag_fixnum_fast(dpeek());
  62         F_FIXNUM result = x / y;
  63         if(result == -FIXNUM_MIN)
  64                 drepl(allot_integer(-FIXNUM_MIN));
  65         else
  66                 drepl(tag_fixnum(result));
  67 }
  68
  69 void primitive_fixnum_divmod(void)
  70 {
  71         F_FIXNUM y = get(ds);
  72         F_FIXNUM x = get(ds - CELLS);
  73         if(y == tag_fixnum(-1) && x == tag_fixnum(FIXNUM_MIN))
  74         {
  75                 put(ds - CELLS,allot_integer(-FIXNUM_MIN));
  76                 put(ds,tag_fixnum(0));
  77         }
  78         else
  79         {
  80                 put(ds - CELLS,tag_fixnum(x / y));
  81                 put(ds,x % y);
  82         }
  83 }
  84
  85 /*
  86  * If we're shifting right by n bits, we won't overflow as long as none of the
  87  * high WORD_SIZE-TAG_BITS-n bits are set.
  88  */
  89 #define SIGN_MASK(x) ((x) >> (WORD_SIZE - 1))
  90 #define BRANCHLESS_MAX(x,y) ((x) - (((x) - (y)) & SIGN_MASK((x) - (y))))
  91 #define BRANCHLESS_ABS(x) ((x ^ SIGN_MASK(x)) - SIGN_MASK(x))
  92
  93 void primitive_fixnum_shift(void)
  94 {
  95         F_FIXNUM y = untag_fixnum_fast(dpop()); \
  96         F_FIXNUM x = untag_fixnum_fast(dpeek());
  97
  98         if(x == 0)
  99                 return;
 100         else if(y < 0)
 101         {
 102                 y = BRANCHLESS_MAX(y,-WORD_SIZE + 1);
 103                 drepl(tag_fixnum(x >> -y));
 104                 return;
 105         }
 106         else if(y < WORD_SIZE - TAG_BITS)
 107         {
 108                 F_FIXNUM mask = -((F_FIXNUM)1 << (WORD_SIZE - 1 - TAG_BITS - y));
 109                 if(!(BRANCHLESS_ABS(x) & mask))
 110                 {
 111                         drepl(tag_fixnum(x << y));
 112                         return;
 113                 }
 114         }
 115
 116         drepl(tag_bignum(bignum_arithmetic_shift(
 117                 fixnum_to_bignum(x),y)));
 118 }
 119
 120 /* Bignums */
 121 void primitive_fixnum_to_bignum(void)
 122 {
 123         drepl(tag_bignum(fixnum_to_bignum(untag_fixnum_fast(dpeek()))));
 124 }
 125
 126 void primitive_float_to_bignum(void)
 127 {
 128         drepl(tag_bignum(float_to_bignum(dpeek())));
 129 }
 130
 131 #define POP_BIGNUMS(x,y) \
 132         F_ARRAY *y = untag_object(dpop()); \
 133         F_ARRAY *x = untag_object(dpop());
 134
 135 void primitive_bignum_eq(void)
 136 {
 137         POP_BIGNUMS(x,y);
 138         box_boolean(bignum_equal_p(x,y));
 139 }
 140
 141 void primitive_bignum_add(void)
 142 {
 143         POP_BIGNUMS(x,y);
 144         dpush(tag_bignum(bignum_add(x,y)));
 145 }
 146
 147 void primitive_bignum_subtract(void)
 148 {
 149         POP_BIGNUMS(x,y);
 150         dpush(tag_bignum(bignum_subtract(x,y)));
 151 }
 152
 153 void primitive_bignum_multiply(void)
 154 {
 155         POP_BIGNUMS(x,y);
 156         dpush(tag_bignum(bignum_multiply(x,y)));
 157 }
 158
 159 void primitive_bignum_divint(void)
 160 {
 161         POP_BIGNUMS(x,y);
 162         dpush(tag_bignum(bignum_quotient(x,y)));
 163 }
 164
 165 void primitive_bignum_divmod(void)
 166 {
 167         F_ARRAY *q, *r;
 168         POP_BIGNUMS(x,y);
 169         bignum_divide(x,y,&q,&r);
 170         dpush(tag_bignum(q));
 171         dpush(tag_bignum(r));
 172 }
 173
 174 void primitive_bignum_mod(void)
 175 {
 176         POP_BIGNUMS(x,y);
 177         dpush(tag_bignum(bignum_remainder(x,y)));
 178 }
 179
 180 void primitive_bignum_and(void)
 181 {
 182         POP_BIGNUMS(x,y);
 183         dpush(tag_bignum(bignum_bitwise_and(x,y)));
 184 }
 185
 186 void primitive_bignum_or(void)
 187 {
 188         POP_BIGNUMS(x,y);
 189         dpush(tag_bignum(bignum_bitwise_ior(x,y)));
 190 }
 191
 192 void primitive_bignum_xor(void)
 193 {
 194         POP_BIGNUMS(x,y);
 195         dpush(tag_bignum(bignum_bitwise_xor(x,y)));
 196 }
 197
 198 void primitive_bignum_shift(void)
 199 {
 200         F_FIXNUM y = untag_fixnum_fast(dpop());
 201         F_ARRAY* x = untag_object(dpop());
 202         dpush(tag_bignum(bignum_arithmetic_shift(x,y)));
 203 }
 204
 205 void primitive_bignum_less(void)
 206 {
 207         POP_BIGNUMS(x,y);
 208         box_boolean(bignum_compare(x,y) == bignum_comparison_less);
 209 }
 210
 211 void primitive_bignum_lesseq(void)
 212 {
 213         POP_BIGNUMS(x,y);
 214         box_boolean(bignum_compare(x,y) != bignum_comparison_greater);
 215 }
 216
 217 void primitive_bignum_greater(void)
 218 {
 219         POP_BIGNUMS(x,y);
 220         box_boolean(bignum_compare(x,y) == bignum_comparison_greater);
 221 }
 222
 223 void primitive_bignum_greatereq(void)
 224 {
 225         POP_BIGNUMS(x,y);
 226         box_boolean(bignum_compare(x,y) != bignum_comparison_less);
 227 }
 228
 229 void primitive_bignum_not(void)
 230 {
 231         drepl(tag_bignum(bignum_bitwise_not(untag_object(dpeek()))));
 232 }
 233
 234 void primitive_bignum_bitp(void)
 235 {
 236         F_FIXNUM bit = to_fixnum(dpop());
 237         F_ARRAY *x = untag_object(dpop());
 238         box_boolean(bignum_logbitp(bit,x));
 239 }
 240
 241 void primitive_bignum_log2(void)
 242 {
 243         drepl(tag_bignum(bignum_integer_length(untag_object(dpeek()))));
 244 }
 245
 246 unsigned int bignum_producer(unsigned int digit)
 247 {
 248         unsigned char *ptr = alien_offset(dpeek());
 249         return *(ptr + digit);
 250 }
 251
 252 void primitive_byte_array_to_bignum(void)
 253 {
 254         type_check(BYTE_ARRAY_TYPE,dpeek());
 255         CELL n_digits = array_capacity(untag_object(dpeek()));
 256         bignum_type bignum = digit_stream_to_bignum(
 257                 n_digits,bignum_producer,0x100,0);
 258         drepl(tag_bignum(bignum));
 259 }
 260
 261 void box_signed_1(s8 n)
 262 {
 263         dpush(tag_fixnum(n));
 264 }
 265
 266 void box_unsigned_1(u8 n)
 267 {
 268         dpush(tag_fixnum(n));
 269 }
 270
 271 void box_signed_2(s16 n)
 272 {
 273         dpush(tag_fixnum(n));
 274 }
 275
 276 void box_unsigned_2(u16 n)
 277 {
 278         dpush(tag_fixnum(n));
 279 }
 280
 281 void box_signed_4(s32 n)
 282 {
 283         dpush(allot_integer(n));
 284 }
 285
 286 void box_unsigned_4(u32 n)
 287 {
 288         dpush(allot_cell(n));
 289 }
 290
 291 void box_signed_cell(F_FIXNUM integer)
 292 {
 293         dpush(allot_integer(integer));
 294 }
 295
 296 void box_unsigned_cell(CELL cell)
 297 {
 298         dpush(allot_cell(cell));
 299 }
 300
 301 void box_signed_8(s64 n)
 302 {
 303         if(n < FIXNUM_MIN || n > FIXNUM_MAX)
 304                 dpush(tag_bignum(long_long_to_bignum(n)));
 305         else
 306                 dpush(tag_fixnum(n));
 307 }
 308
 309 s64 to_signed_8(CELL obj)
 310 {
 311         switch(type_of(obj))
 312         {
 313         case FIXNUM_TYPE:
 314                 return untag_fixnum_fast(obj);
 315         case BIGNUM_TYPE:
 316                 return bignum_to_long_long(untag_object(obj));
 317         default:
 318                 type_error(BIGNUM_TYPE,obj);
 319                 return -1;
 320         }
 321 }
 322
 323 void box_unsigned_8(u64 n)
 324 {
 325         if(n > FIXNUM_MAX)
 326                 dpush(tag_bignum(ulong_long_to_bignum(n)));
 327         else
 328                 dpush(tag_fixnum(n));
 329 }
 330
 331 u64 to_unsigned_8(CELL obj)
 332 {
 333         switch(type_of(obj))
 334         {
 335         case FIXNUM_TYPE:
 336                 return untag_fixnum_fast(obj);
 337         case BIGNUM_TYPE:
 338                 return bignum_to_ulong_long(untag_object(obj));
 339         default:
 340                 type_error(BIGNUM_TYPE,obj);
 341                 return -1;
 342         }
 343 }
 344
 345 CELL unbox_array_size(void)
 346 {
 347         switch(type_of(dpeek()))
 348         {
 349         case FIXNUM_TYPE:
 350                 {
 351                         F_FIXNUM n = untag_fixnum_fast(dpeek());
 352                         if(n >= 0 && n < ARRAY_SIZE_MAX)
 353                         {
 354                                 dpop();
 355                                 return n;
 356                         }
 357                         break;
 358                 }
 359         case BIGNUM_TYPE:
 360                 {
 361                         bignum_type zero = untag_object(bignum_zero);
 362                         bignum_type max = cell_to_bignum(ARRAY_SIZE_MAX);
 363                         bignum_type n = untag_object(dpeek());
 364                         if(bignum_compare(n,zero) != bignum_comparison_less
 365                                 && bignum_compare(n,max) == bignum_comparison_less)
 366                         {
 367                                 dpop();
 368                                 return bignum_to_cell(n);
 369                         }
 370                         break;
 371                 }
 372         }
 373
 374         general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(ARRAY_SIZE_MAX),NULL);
 375         return 0; /* can't happen */
 376 }
 377
 378 /* Ratios */
 379
 380 /* Does not reduce to lowest terms, so should only be used by math
 381 library implementation, to avoid breaking invariants. */
 382 void primitive_from_fraction(void)
 383 {
 384         F_RATIO* ratio = allot_object(RATIO_TYPE,sizeof(F_RATIO));
 385         ratio->denominator = dpop();
 386         ratio->numerator = dpop();
 387         dpush(RETAG(ratio,RATIO_TYPE));
 388 }
 389
 390 /* Floats */
 391 void primitive_fixnum_to_float(void)
 392 {
 393         drepl(allot_float(fixnum_to_float(dpeek())));
 394 }
 395
 396 void primitive_bignum_to_float(void)
 397 {
 398         drepl(allot_float(bignum_to_float(dpeek())));
 399 }
 400
 401 void primitive_str_to_float(void)
 402 {
 403         char *c_str, *end;
 404         double f;
 405         F_STRING *str = untag_string(dpeek());
 406         CELL capacity = string_capacity(str);
 407
 408         c_str = to_char_string(str,false);
 409         end = c_str;
 410         f = strtod(c_str,&end);
 411         if(end != c_str + capacity)
 412                 drepl(F);
 413         else
 414                 drepl(allot_float(f));
 415 }
 416
 417 void primitive_float_to_str(void)
 418 {
 419         char tmp[33];
 420         snprintf(tmp,32,"%.16g",untag_float(dpop()));
 421         tmp[32] = '\0';
 422         box_char_string(tmp);
 423 }
 424
 425 #define POP_FLOATS(x,y) \
 426         double y = untag_float_fast(dpop()); \
 427         double x = untag_float_fast(dpop());
 428
 429 void primitive_float_eq(void)
 430 {
 431         POP_FLOATS(x,y);
 432         box_boolean(x == y);
 433 }
 434
 435 void primitive_float_add(void)
 436 {
 437         POP_FLOATS(x,y);
 438         box_double(x + y);
 439 }
 440
 441 void primitive_float_subtract(void)
 442 {
 443         POP_FLOATS(x,y);
 444         box_double(x - y);
 445 }
 446
 447 void primitive_float_multiply(void)
 448 {
 449         POP_FLOATS(x,y);
 450         box_double(x * y);
 451 }
 452
 453 void primitive_float_divfloat(void)
 454 {
 455         POP_FLOATS(x,y);
 456         box_double(x / y);
 457 }
 458
 459 void primitive_float_mod(void)
 460 {
 461         POP_FLOATS(x,y);
 462         box_double(fmod(x,y));
 463 }
 464
 465 void primitive_float_less(void)
 466 {
 467         POP_FLOATS(x,y);
 468         box_boolean(x < y);
 469 }
 470
 471 void primitive_float_lesseq(void)
 472 {
 473         POP_FLOATS(x,y);
 474         box_boolean(x <= y);
 475 }
 476
 477 void primitive_float_greater(void)
 478 {
 479         POP_FLOATS(x,y);
 480         box_boolean(x > y);
 481 }
 482
 483 void primitive_float_greatereq(void)
 484 {
 485         POP_FLOATS(x,y);
 486         box_boolean(x >= y);
 487 }
 488
 489 void primitive_float_bits(void)
 490 {
 491         box_unsigned_4(float_bits(untag_float(dpop())));
 492 }
 493
 494 void primitive_bits_float(void)
 495 {
 496         box_float(bits_float(to_cell(dpop())));
 497 }
 498
 499 void primitive_double_bits(void)
 500 {
 501         box_unsigned_8(double_bits(untag_float(dpop())));
 502 }
 503
 504 void primitive_bits_double(void)
 505 {
 506         box_double(bits_double(to_unsigned_8(dpop())));
 507 }
 508
 509 float to_float(CELL value)
 510 {
 511         return untag_float(value);
 512 }
 513
 514 double to_double(CELL value)
 515 {
 516         return untag_float(value);
 517 }
 518
 519 void box_float(float flo)
 520 {
 521         dpush(allot_float(flo));
 522 }
 523
 524 void box_double(double flo)
 525 {
 526         dpush(allot_float(flo));
 527 }
 528
 529 /* Complex numbers */
 530
 531 void primitive_from_rect(void)
 532 {
 533         F_COMPLEX* complex = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX));
 534         complex->imaginary = dpop();
 535         complex->real = dpop();
 536         dpush(RETAG(complex,COMPLEX_TYPE));
 537 }