bignums.c

   1 /* file: "bignums.c" */
   2
   3 /*
   4  * Copyright 2004-2009 by Marc Feeley and Vincent St-Amour, All Rights Reserved.
   5  */
   6
   7 #include "picobit-vm.h"
   8
   9 #ifdef INFINITE_PRECISION_BIGNUMS
  10
  11 integer make_integer (digit lo, integer hi) {
  12   return alloc_ram_cell_init (BIGNUM_FIELD0 | (hi >> 8), hi, lo >> 8, lo);
  13 }
  14
  15 integer integer_hi (integer x) {
  16   if (IN_RAM(x))
  17     return ram_get_car (x);
  18   else if (IN_ROM(x))
  19     return rom_get_car (x);
  20   else if (x < (MIN_FIXNUM_ENCODING - MIN_FIXNUM))
  21     return NEG1; /* negative fixnum */
  22   else
  23     return ZERO; /* nonnegative fixnum */
  24 }
  25
  26 digit integer_lo (integer x) {
  27   if (IN_RAM(x))
  28     return (((digit)ram_get_field2 (x)) << 8) + ram_get_field3 (x);
  29   else if (IN_ROM(x))
  30     return (((digit)rom_get_field2 (x)) << 8) + rom_get_field3 (x);
  31   else
  32     return DECODE_FIXNUM(x);
  33 }
  34
  35 integer norm (obj prefix, integer n) {
  36   /* norm(prefix,n) returns a normalized integer whose value is the
  37      integer n prefixed with the digits in prefix (a list of digits) */
  38
  39   while (prefix != NIL) {
  40     digit d = integer_lo (prefix);
  41     obj temp = prefix;
  42
  43     prefix = integer_hi (temp);
  44
  45     if (obj_eq (n, ZERO)) {
  46       if (d <= MAX_FIXNUM) {
  47         n = ENCODE_FIXNUM ((uint8)d);
  48         continue; // TODO with cast to unsigned, will it work for negative numbers ? or is it only handled in the next branch ?
  49       }
  50     }
  51     else if (obj_eq (n, NEG1)) {
  52       if (d >= (1<<digit_width) + MIN_FIXNUM) {
  53         n = ENCODE_FIXNUM (d - (1<<digit_width)); // TODO had a cast, origianlly to int8, changed to uint8 which didn't work (obviously, we use -1 here), is a cast necessary at all ?
  54         continue;
  55       }
  56     }
  57
  58     integer_hi_set (temp, n);
  59     n = temp;
  60   }
  61
  62   return n;
  63 }
  64
  65 uint8 negp (integer x) {
  66   /* negp(x) returns true iff x is negative */
  67
  68   do {
  69     x = integer_hi (x);
  70     if (obj_eq (x, ZERO)) return false;
  71   } while (!obj_eq (x, NEG1));
  72
  73   return true;
  74 }
  75
  76 int8 cmp (integer x, integer y) {
  77   /* cmp(x,y) return -1 when x<y, 1 when x>y, and 0 when x=y */
  78
  79   int8 result = 0;
  80   digit xlo;
  81   digit ylo;
  82
  83   for (;;) {
  84     if (obj_eq (x, ZERO) || obj_eq (x, NEG1)) {
  85       if (!obj_eq (x, y))
  86         { if (negp (y)) result = 1; else result = -1; }
  87       break;
  88     }
  89
  90     if (obj_eq (y, ZERO) || obj_eq (y, NEG1)) {
  91       if (negp (x)) result = -1; else result = 1;
  92       break;
  93     }
  94
  95     xlo = integer_lo (x);
  96     ylo = integer_lo (y);
  97    x = integer_hi (x);
  98     y = integer_hi (y);
  99     if (xlo != ylo)
 100       { if (xlo < ylo) result = -1; else result = 1; }
 101   }
 102   return result;
 103 }
 104
 105 uint16 integer_length (integer x) {
 106   /* integer_length(x) returns the number of bits in the binary
 107      representation of the nonnegative integer x */
 108
 109   uint16 result = 0;
 110   integer next;
 111   digit d;
 112
 113   while (!obj_eq ((next = integer_hi (x)), ZERO)) {
 114     result += digit_width;
 115     x = next;
 116   }
 117
 118   d = integer_lo (x);
 119
 120   while (d > 0) {
 121     result++;
 122     d >>= 1;
 123   }
 124
 125   return result;
 126 }
 127
 128 integer shr (integer x) { // TODO have shift_right
 129   /* shr(x) returns the integer x shifted one bit to the right */
 130
 131   obj result = NIL;
 132   digit d;
 133
 134   for (;;) {
 135     if (obj_eq (x, ZERO) || obj_eq (x, NEG1)) {
 136       result = norm (result, x);
 137       break;
 138     }
 139
 140     d = integer_lo (x);
 141     x = integer_hi (x);
 142     result = make_integer ((d >> 1) |
 143                            ((integer_lo (x) & 1) ? (1<<(digit_width-1)) : 0),
 144                            result);
 145   }
 146
 147   return result;
 148 }
 149
 150 integer negative_carry (integer carry) {
 151   if (carry)
 152     return NEG1;
 153   else
 154     return ZERO;
 155 }
 156
 157 integer shl (integer x) {
 158   /* shl(x) returns the integer x shifted one bit to the left */
 159
 160   integer negc = ZERO; /* negative carry */
 161   integer temp;
 162   obj result = NIL;
 163   digit d;
 164
 165   for (;;) {
 166     if (obj_eq (x, negc)) {
 167       result = norm (result, x);
 168       break;
 169     }
 170
 171     d = integer_lo (x);
 172     x = integer_hi (x);
 173     temp = negc;
 174     negc = negative_carry (d & (1<<(digit_width-1))); // TODO right side is constant, and sixpic has no constant folding
 175     result = make_integer ((d << 1) | obj_eq (temp, NEG1), result);
 176   }
 177
 178   return result;
 179 }
 180
 181 integer shift_left (integer x, uint16 n) { // TODO have the primitves been changed for this and right ?
 182   /* shift_left(x,n) returns the integer x shifted n bits to the left */
 183
 184   if (obj_eq (x, ZERO))
 185     return x;
 186
 187   while (n & (digit_width-1)) {
 188     x = shl (x);
 189     n--;
 190   }
 191
 192   while (n > 0) {
 193     x = make_integer (0, x);
 194     n -= digit_width;
 195   }
 196
 197   return x;
 198 }
 199
 200 integer add (integer x, integer y) {
 201   /* add(x,y) returns the sum of the integers x and y */
 202
 203   integer negc = ZERO; /* negative carry */
 204   obj result = NIL; /* nil terminated for the norm function */
 205   digit dx;
 206   digit dy;
 207
 208   for (;;) {
 209     if (obj_eq (x, negc)) {
 210       result = norm (result, y);
 211       break;
 212     }
 213
 214     if (obj_eq (y, negc)) {
 215       result = norm (result, x);
 216       break;
 217     }
 218
 219     dx = integer_lo (x);
 220     dy = integer_lo (y);
 221     dx = dx + dy; /* may wrap around */
 222
 223     if (obj_eq (negc, ZERO))
 224       negc = negative_carry (dx < dy);
 225     else {
 226       dx++; /* may wrap around */
 227       negc = negative_carry (dx <= dy);
 228     }
 229
 230     x = integer_hi (x);
 231     y = integer_hi (y);
 232
 233     result = make_integer (dx, result);
 234   }
 235
 236   return result;
 237 }
 238
 239 integer invert (integer x) {
 240   if (obj_eq (x, ZERO))
 241     return NEG1;
 242   else
 243     return ZERO;
 244 }
 245
 246 integer sub (integer x, integer y) {
 247   /* sub(x,y) returns the difference of the integers x and y */
 248   integer negc = NEG1; /* negative carry */
 249   obj result = NIL;
 250   digit dx;
 251   digit dy;
 252
 253   for (;;) {
 254     if (obj_eq (x, negc) && (obj_eq (y, ZERO) || obj_eq (y, NEG1))) {
 255       result = norm (result, invert (y));
 256       break;
 257     }
 258
 259     if (obj_eq (y, invert (negc))) {
 260       result = norm (result, x);
 261       break;
 262     }
 263
 264     dx = integer_lo (x);
 265     dy = ~integer_lo (y);
 266     dx = dx + dy; /* may wrap around */
 267
 268     if (obj_eq (negc, ZERO))
 269       negc = negative_carry (dx < dy);
 270     else {
 271       dx++; /* may wrap around */
 272       negc = negative_carry (dx <= dy);
 273     }
 274
 275     x = integer_hi (x);
 276     y = integer_hi (y);
 277
 278     result = make_integer (dx, result);
 279   }
 280
 281   return result;
 282 }
 283
 284 integer neg (integer x) {
 285   /* neg(x) returns the integer -x */
 286
 287   return sub (ZERO, x);
 288 }
 289
 290 integer scale (digit n, integer x) {
 291   /* scale(n,x) returns the integer n*x */
 292
 293   obj result;
 294   digit carry;
 295   two_digit m;
 296
 297   if ((n == 0) || obj_eq (x, ZERO))
 298     return ZERO;
 299
 300   if (n == 1)
 301     return x;
 302
 303   result = NIL;
 304   carry = 0;
 305
 306   for (;;) {
 307     if (obj_eq (x, ZERO)){
 308       if (carry <= MAX_FIXNUM)
 309         result = norm (result, ENCODE_FIXNUM ((uint8)carry));
 310       else
 311         result = norm (result, make_integer (carry, ZERO));
 312       break;
 313     }
 314
 315     if (obj_eq (x, NEG1)) {
 316       carry = carry - n;
 317       if (carry >= ((1<<digit_width) + MIN_FIXNUM))
 318         result = norm (result, ENCODE_FIXNUM ((uint8)carry));
 319       else
 320         result = norm (result, make_integer (carry, NEG1));
 321       break;
 322     }
 323
 324     m = (two_digit)integer_lo (x) * n + carry;
 325
 326     x = integer_hi (x);
 327     carry = m >> digit_width;
 328     result = make_integer ((digit)m, result);
 329   }
 330
 331   return result;
 332 }
 333
 334 integer mulnonneg (integer x, integer y) {
 335   /* mulnonneg(x,y) returns the product of the integers x and y
 336      where x is nonnegative */
 337
 338   obj result = NIL;
 339   integer s = scale (integer_lo (x), y);
 340
 341   for (;;) {
 342     result = make_integer (integer_lo (s), result);
 343     s = integer_hi (s);
 344     x = integer_hi (x);
 345
 346     if (obj_eq (x, ZERO))
 347       break;
 348
 349     s = add (s, scale (integer_lo (x), y));
 350   }
 351
 352   return norm (result, s);
 353 }
 354
 355 // TODO have functions mul and div that handle negative arguments ? currently, the logic is in prim_mul and prim_div
 356 integer divnonneg (integer x, integer y) {
 357   /* divnonneg(x,y) returns the quotient and remainder of
 358      the integers x and y where x and y are nonnegative */
 359
 360   integer result = ZERO;
 361   uint16 lx = integer_length (x);
 362   uint16 ly = integer_length (y);
 363
 364   if (lx >= ly) {
 365     lx = lx - ly;
 366
 367     y = shift_left (y, lx);
 368
 369     do {
 370       result = shl (result);
 371       if (cmp (x, y) >= 0) {
 372         x = sub (x, y);
 373         result = add (POS1, result);
 374       }
 375       y = shr (y);
 376     } while (lx-- != 0);
 377   }
 378
 379   return result;
 380 }
 381
 382 integer bitwise_ior (integer x, integer y) {
 383   /* returns the bitwise inclusive or of x and y */
 384
 385   obj result = NIL;
 386
 387   for (;;){
 388     if (obj_eq(x, ZERO))
 389       return norm(result, y);
 390     if (obj_eq(x, NEG1))
 391       return norm(result, x);
 392     result = make_integer(integer_lo(x) | integer_lo(y),
 393                           result);
 394     x = integer_hi(x);
 395     y = integer_hi(y);
 396   }
 397 }
 398
 399 integer bitwise_xor (integer x, integer y) { // TODO similar to ior (only diff is the test), abstract ?
 400   /* returns the bitwise inclusive or of x and y */
 401
 402   obj result = NIL;
 403
 404   for (;;){
 405     if (obj_eq(x, ZERO))
 406       return norm(result, y);
 407     if (obj_eq(x, NEG1))
 408       return norm(result, x);
 409     result = make_integer(integer_lo(x) ^ integer_lo(y),
 410                           result);
 411     x = integer_hi(x);
 412     y = integer_hi(y);
 413   }
 414 }
 415
 416 // used only in primitives that use small numbers only
 417 // for example, vector primitives
 418 int32 decode_int (obj o) {
 419   int8 result;
 420   if (o < MIN_FIXNUM_ENCODING)
 421     TYPE_ERROR("decode_int.0", "integer");
 422
 423   if (o <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM)))
 424     return DECODE_FIXNUM(o);
 425
 426   if (IN_RAM(o)) {
 427     if (!RAM_BIGNUM(o))
 428       TYPE_ERROR("decode_int.1", "integer");
 429     return ram_get_field3 (o);
 430   }
 431   else if (IN_ROM(o)) {
 432     if (!ROM_BIGNUM(o))
 433       TYPE_ERROR("decode_int.2", "integer");
 434     return rom_get_field3 (o);
 435   }
 436   else
 437     TYPE_ERROR("decode_int.3", "integer");
 438 }
 439
 440 // same purpose as decode_int
 441 obj encode_int (int32 n) {
 442   if (n >= MIN_FIXNUM && n <= MAX_FIXNUM) {
 443     return ENCODE_FIXNUM(n);
 444   }
 445
 446   return alloc_ram_cell_init (BIGNUM_FIELD0, ENCODE_FIXNUM(0), n >> 8, n);
 447 }
 448
 449 #else
 450
 451 // regular (finite, 24 bits) bignums
 452
 453 int32 decode_int (obj o) {
 454   uint8 u;
 455   uint8 h;
 456   uint8 l;
 457
 458   if (o < MIN_FIXNUM_ENCODING)
 459     TYPE_ERROR("decode_int.0", "integer");
 460
 461   if (o <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM)))
 462     return DECODE_FIXNUM(o);
 463
 464   if (IN_RAM(o)) {
 465     if (!RAM_BIGNUM(o))
 466       TYPE_ERROR("decode_int.1", "integer");
 467
 468     u = ram_get_field1 (o);
 469     h = ram_get_field2 (o);
 470     l = ram_get_field3 (o);
 471   }
 472   else if (IN_ROM(o)) {
 473     if (!ROM_BIGNUM(o))
 474       TYPE_ERROR("decode_int.2", "integer");
 475
 476     u = rom_get_field1 (o);
 477     h = rom_get_field2 (o);
 478     l = rom_get_field3 (o);
 479   }
 480   else
 481     TYPE_ERROR("decode_int.3", "integer");
 482
 483   if (u >= 128) // negative
 484     return ((int32)((((int16)u - 256) << 8) + h) << 8) + l;
 485
 486   return ((int32)(((int16)u << 8) + h) << 8) + l;
 487 }
 488
 489 obj encode_int (int32 n) {
 490   if (n >= MIN_FIXNUM && n <= MAX_FIXNUM)
 491     return ENCODE_FIXNUM(n);
 492
 493   return alloc_ram_cell_init (BIGNUM_FIELD0, n >> 16, n >> 8, n);
 494 }
 495
 496 #endif
 497
 498 // useful for some primitives
 499 void decode_2_int_args (void) {
 500   a1 = decode_int (arg1);
 501   a2 = decode_int (arg2);
 502 }