vmpp/math.cpp

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