libguile/vm-i-scheme.c

   1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19 /* This file is included in vm_engine.c */
  20
  21 \f
  22 /*
  23  * Predicates
  24  */
  25
  26 #define ARGS1(a1)       SCM a1 = sp[0];
  27 #define ARGS2(a1,a2)    SCM a1 = sp[-1], a2 = sp[0]; sp--; NULLSTACK (1);
  28 #define ARGS3(a1,a2,a3) SCM a1 = sp[-2], a2 = sp[-1], a3 = sp[0]; sp -= 2; NULLSTACK (2);
  29
  30 #define RETURN(x)       do { *sp = x; NEXT; } while (0)
  31
  32 VM_DEFINE_FUNCTION (128, not, "not", 1)
  33 {
  34   ARGS1 (x);
  35   RETURN (scm_from_bool (scm_is_false (x)));
  36 }
  37
  38 VM_DEFINE_FUNCTION (129, not_not, "not-not", 1)
  39 {
  40   ARGS1 (x);
  41   RETURN (scm_from_bool (!scm_is_false (x)));
  42 }
  43
  44 VM_DEFINE_FUNCTION (130, eq, "eq?", 2)
  45 {
  46   ARGS2 (x, y);
  47   RETURN (scm_from_bool (scm_is_eq (x, y)));
  48 }
  49
  50 VM_DEFINE_FUNCTION (131, not_eq, "not-eq?", 2)
  51 {
  52   ARGS2 (x, y);
  53   RETURN (scm_from_bool (!scm_is_eq (x, y)));
  54 }
  55
  56 VM_DEFINE_FUNCTION (132, nullp, "null?", 1)
  57 {
  58   ARGS1 (x);
  59   RETURN (scm_from_bool (scm_is_null (x)));
  60 }
  61
  62 VM_DEFINE_FUNCTION (133, not_nullp, "not-null?", 1)
  63 {
  64   ARGS1 (x);
  65   RETURN (scm_from_bool (!scm_is_null (x)));
  66 }
  67
  68 VM_DEFINE_FUNCTION (134, eqv, "eqv?", 2)
  69 {
  70   ARGS2 (x, y);
  71   if (scm_is_eq (x, y))
  72     RETURN (SCM_BOOL_T);
  73   if (SCM_IMP (x) || SCM_IMP (y))
  74     RETURN (SCM_BOOL_F);
  75   SYNC_REGISTER ();
  76   RETURN (scm_eqv_p (x, y));
  77 }
  78
  79 VM_DEFINE_FUNCTION (135, equal, "equal?", 2)
  80 {
  81   ARGS2 (x, y);
  82   if (scm_is_eq (x, y))
  83     RETURN (SCM_BOOL_T);
  84   if (SCM_IMP (x) || SCM_IMP (y))
  85     RETURN (SCM_BOOL_F);
  86   SYNC_REGISTER ();
  87   RETURN (scm_equal_p (x, y));
  88 }
  89
  90 VM_DEFINE_FUNCTION (136, pairp, "pair?", 1)
  91 {
  92   ARGS1 (x);
  93   RETURN (scm_from_bool (scm_is_pair (x)));
  94 }
  95
  96 VM_DEFINE_FUNCTION (137, listp, "list?", 1)
  97 {
  98   ARGS1 (x);
  99   RETURN (scm_from_bool (scm_ilength (x) >= 0));
 100 }
 101
 102 VM_DEFINE_FUNCTION (138, symbolp, "symbol?", 1)
 103 {
 104   ARGS1 (x);
 105   RETURN (scm_from_bool (scm_is_symbol (x)));
 106 }
 107
 108 VM_DEFINE_FUNCTION (139, vectorp, "vector?", 1)
 109 {
 110   ARGS1 (x);
 111   RETURN (scm_from_bool (SCM_I_IS_VECTOR (x)));
 112 }
 113
 114 \f
 115 /*
 116  * Basic data
 117  */
 118
 119 VM_DEFINE_FUNCTION (140, cons, "cons", 2)
 120 {
 121   ARGS2 (x, y);
 122   CONS (x, x, y);
 123   RETURN (x);
 124 }
 125
 126 #define VM_VALIDATE_CONS(x, proc)               \
 127   VM_ASSERT (scm_is_pair (x), vm_error_not_a_pair (proc, x))
 128
 129 VM_DEFINE_FUNCTION (141, car, "car", 1)
 130 {
 131   ARGS1 (x);
 132   VM_VALIDATE_CONS (x, "car");
 133   RETURN (SCM_CAR (x));
 134 }
 135
 136 VM_DEFINE_FUNCTION (142, cdr, "cdr", 1)
 137 {
 138   ARGS1 (x);
 139   VM_VALIDATE_CONS (x, "cdr");
 140   RETURN (SCM_CDR (x));
 141 }
 142
 143 VM_DEFINE_INSTRUCTION (143, set_car, "set-car!", 0, 2, 0)
 144 {
 145   SCM x, y;
 146   POP2 (y, x);
 147   VM_VALIDATE_CONS (x, "set-car!");
 148   SCM_SETCAR (x, y);
 149   NEXT;
 150 }
 151
 152 VM_DEFINE_INSTRUCTION (144, set_cdr, "set-cdr!", 0, 2, 0)
 153 {
 154   SCM x, y;
 155   POP2 (y, x);
 156   VM_VALIDATE_CONS (x, "set-cdr!");
 157   SCM_SETCDR (x, y);
 158   NEXT;
 159 }
 160
 161 \f
 162 /*
 163  * Numeric relational tests
 164  */
 165
 166 #undef REL
 167 #define REL(crel,srel)                                                  \
 168   {                                                                     \
 169     ARGS2 (x, y);                                                       \
 170     if (SCM_I_INUMP (x) && SCM_I_INUMP (y))                             \
 171       RETURN (scm_from_bool (((scm_t_signed_bits) SCM_UNPACK (x))       \
 172                              crel ((scm_t_signed_bits) SCM_UNPACK (y)))); \
 173     SYNC_REGISTER ();                                                   \
 174     RETURN (srel (x, y));                                               \
 175   }
 176
 177 VM_DEFINE_FUNCTION (145, ee, "ee?", 2)
 178 {
 179   REL (==, scm_num_eq_p);
 180 }
 181
 182 VM_DEFINE_FUNCTION (146, lt, "lt?", 2)
 183 {
 184   REL (<, scm_less_p);
 185 }
 186
 187 VM_DEFINE_FUNCTION (147, le, "le?", 2)
 188 {
 189   REL (<=, scm_leq_p);
 190 }
 191
 192 VM_DEFINE_FUNCTION (148, gt, "gt?", 2)
 193 {
 194   REL (>, scm_gr_p);
 195 }
 196
 197 VM_DEFINE_FUNCTION (149, ge, "ge?", 2)
 198 {
 199   REL (>=, scm_geq_p);
 200 }
 201
 202 \f
 203 /*
 204  * Numeric functions
 205  */
 206
 207 /* The maximum/minimum tagged integers.  */
 208 #undef INUM_MAX
 209 #undef INUM_MIN
 210 #define INUM_MAX (INTPTR_MAX - 1)
 211 #define INUM_MIN (INTPTR_MIN + scm_tc2_int)
 212
 213 #undef FUNC2
 214 #define FUNC2(CFUNC,SFUNC)                              \
 215 {                                                       \
 216   ARGS2 (x, y);                                         \
 217   if (SCM_I_INUMP (x) && SCM_I_INUMP (y))               \
 218     {                                                   \
 219       scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y);\
 220       if (SCM_FIXABLE (n))                              \
 221         RETURN (SCM_I_MAKINUM (n));                     \
 222     }                                                   \
 223   SYNC_REGISTER ();                                     \
 224   RETURN (SFUNC (x, y));                                \
 225 }
 226
 227 /* Assembly tagged integer arithmetic routines.  This code uses the
 228    `asm goto' feature introduced in GCC 4.5.  */
 229
 230 #if defined __x86_64__ && SCM_GNUC_PREREQ (4, 5)
 231
 232 /* The macros below check the CPU's overflow flag to improve fixnum
 233    arithmetic.  The %rcx register is explicitly clobbered because `asm
 234    goto' can't have outputs, in which case the `r' constraint could be
 235    used to let the register allocator choose a register.
 236
 237    TODO: Use `cold' label attribute in GCC 4.6.
 238    http://gcc.gnu.org/ml/gcc-patches/2010-10/msg01777.html  */
 239
 240 # define ASM_ADD(x, y)                                                  \
 241     {                                                                   \
 242       asm volatile goto ("mov %1, %%rcx; "                              \
 243                          "test %[tag], %%cl; je %l[slow_add]; "         \
 244                          "test %[tag], %0;   je %l[slow_add]; "         \
 245                          "add %0, %%rcx;     jo %l[slow_add]; "         \
 246                          "sub %[tag], %%rcx; "                          \
 247                          "mov %%rcx, (%[vsp])\n"                        \
 248                          : /* no outputs */                             \
 249                          : "r" (x), "r" (y),                            \
 250                            [vsp] "r" (sp), [tag] "i" (scm_tc2_int)      \
 251                          : "rcx", "memory"                              \
 252                          : slow_add);                                   \
 253       NEXT;                                                             \
 254     }                                                                   \
 255   slow_add:                                                             \
 256     do { } while (0)
 257
 258 # define ASM_SUB(x, y)                                                  \
 259     {                                                                   \
 260       asm volatile goto ("mov %0, %%rcx; "                              \
 261                          "test %[tag], %%cl; je %l[slow_sub]; "         \
 262                          "test %[tag], %1;   je %l[slow_sub]; "         \
 263                          "sub %1, %%rcx;     jo %l[slow_sub]; "         \
 264                          "add %[tag], %%rcx; "                          \
 265                          "mov %%rcx, (%[vsp])\n"                        \
 266                          : /* no outputs */                             \
 267                          : "r" (x), "r" (y),                            \
 268                            [vsp] "r" (sp), [tag] "i" (scm_tc2_int)      \
 269                          : "rcx", "memory"                              \
 270                          : slow_sub);                                   \
 271       NEXT;                                                             \
 272     }                                                                   \
 273   slow_sub:                                                             \
 274     do { } while (0)
 275
 276 #endif
 277
 278
 279 VM_DEFINE_FUNCTION (150, add, "add", 2)
 280 {
 281 #ifndef ASM_ADD
 282   FUNC2 (+, scm_sum);
 283 #else
 284   ARGS2 (x, y);
 285   ASM_ADD (x, y);
 286   SYNC_REGISTER ();
 287   RETURN (scm_sum (x, y));
 288 #endif
 289 }
 290
 291 VM_DEFINE_FUNCTION (151, add1, "add1", 1)
 292 {
 293   ARGS1 (x);
 294
 295   /* Check for overflow.  */
 296   if (SCM_LIKELY ((scm_t_intptr) SCM_UNPACK (x) < INUM_MAX))
 297     {
 298       SCM result;
 299
 300       /* Add the integers without untagging.  */
 301       result = SCM_PACK ((scm_t_intptr) SCM_UNPACK (x)
 302                          + (scm_t_intptr) SCM_UNPACK (SCM_I_MAKINUM (1))
 303                          - scm_tc2_int);
 304
 305       if (SCM_LIKELY (SCM_I_INUMP (result)))
 306         RETURN (result);
 307     }
 308
 309   SYNC_REGISTER ();
 310   RETURN (scm_sum (x, SCM_I_MAKINUM (1)));
 311 }
 312
 313 VM_DEFINE_FUNCTION (152, sub, "sub", 2)
 314 {
 315 #ifndef ASM_SUB
 316   FUNC2 (-, scm_difference);
 317 #else
 318   ARGS2 (x, y);
 319   ASM_SUB (x, y);
 320   SYNC_REGISTER ();
 321   RETURN (scm_difference (x, y));
 322 #endif
 323 }
 324
 325 VM_DEFINE_FUNCTION (153, sub1, "sub1", 1)
 326 {
 327   ARGS1 (x);
 328
 329   /* Check for underflow.  */
 330   if (SCM_LIKELY ((scm_t_intptr) SCM_UNPACK (x) > INUM_MIN))
 331     {
 332       SCM result;
 333
 334       /* Substract the integers without untagging.  */
 335       result = SCM_PACK ((scm_t_intptr) SCM_UNPACK (x)
 336                          - (scm_t_intptr) SCM_UNPACK (SCM_I_MAKINUM (1))
 337                          + scm_tc2_int);
 338
 339       if (SCM_LIKELY (SCM_I_INUMP (result)))
 340         RETURN (result);
 341     }
 342
 343   SYNC_REGISTER ();
 344   RETURN (scm_difference (x, SCM_I_MAKINUM (1)));
 345 }
 346
 347 # undef ASM_ADD
 348 # undef ASM_SUB
 349
 350 VM_DEFINE_FUNCTION (154, mul, "mul", 2)
 351 {
 352   ARGS2 (x, y);
 353   SYNC_REGISTER ();
 354   RETURN (scm_product (x, y));
 355 }
 356
 357 VM_DEFINE_FUNCTION (155, div, "div", 2)
 358 {
 359   ARGS2 (x, y);
 360   SYNC_REGISTER ();
 361   RETURN (scm_divide (x, y));
 362 }
 363
 364 VM_DEFINE_FUNCTION (156, quo, "quo", 2)
 365 {
 366   ARGS2 (x, y);
 367   SYNC_REGISTER ();
 368   RETURN (scm_quotient (x, y));
 369 }
 370
 371 VM_DEFINE_FUNCTION (157, rem, "rem", 2)
 372 {
 373   ARGS2 (x, y);
 374   SYNC_REGISTER ();
 375   RETURN (scm_remainder (x, y));
 376 }
 377
 378 VM_DEFINE_FUNCTION (158, mod, "mod", 2)
 379 {
 380   ARGS2 (x, y);
 381   SYNC_REGISTER ();
 382   RETURN (scm_modulo (x, y));
 383 }
 384
 385 VM_DEFINE_FUNCTION (159, ash, "ash", 2)
 386 {
 387   ARGS2 (x, y);
 388   if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
 389     {
 390       if (SCM_I_INUM (y) < 0)
 391         /* Right shift, will be a fixnum. */
 392         RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) >> -SCM_I_INUM (y)));
 393       else
 394         /* Left shift. See comments in scm_ash. */
 395         {
 396           scm_t_signed_bits nn, bits_to_shift;
 397
 398           nn = SCM_I_INUM (x);
 399           bits_to_shift = SCM_I_INUM (y);
 400
 401           if (bits_to_shift < SCM_I_FIXNUM_BIT-1
 402               && ((scm_t_bits)
 403                   (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
 404                   <= 1))
 405             RETURN (SCM_I_MAKINUM (nn << bits_to_shift));
 406           /* fall through */
 407         }
 408       /* fall through */
 409     }
 410   SYNC_REGISTER ();
 411   RETURN (scm_ash (x, y));
 412 }
 413
 414 VM_DEFINE_FUNCTION (160, logand, "logand", 2)
 415 {
 416   ARGS2 (x, y);
 417   if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
 418     RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) & SCM_I_INUM (y)));
 419   SYNC_REGISTER ();
 420   RETURN (scm_logand (x, y));
 421 }
 422
 423 VM_DEFINE_FUNCTION (161, logior, "logior", 2)
 424 {
 425   ARGS2 (x, y);
 426   if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
 427     RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) | SCM_I_INUM (y)));
 428   SYNC_REGISTER ();
 429   RETURN (scm_logior (x, y));
 430 }
 431
 432 VM_DEFINE_FUNCTION (162, logxor, "logxor", 2)
 433 {
 434   ARGS2 (x, y);
 435   if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
 436     RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) ^ SCM_I_INUM (y)));
 437   SYNC_REGISTER ();
 438   RETURN (scm_logxor (x, y));
 439 }
 440
 441 \f
 442 /*
 443  * Vectors and arrays
 444  */
 445
 446 VM_DEFINE_FUNCTION (163, vector_ref, "vector-ref", 2)
 447 {
 448   scm_t_signed_bits i = 0;
 449   ARGS2 (vect, idx);
 450   if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
 451                   && SCM_I_INUMP (idx)
 452                   && ((i = SCM_I_INUM (idx)) >= 0)
 453                   && i < SCM_I_VECTOR_LENGTH (vect)))
 454     RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
 455   else
 456     {
 457       SYNC_REGISTER ();
 458       RETURN (scm_vector_ref (vect, idx));
 459     }
 460 }
 461
 462 VM_DEFINE_INSTRUCTION (164, vector_set, "vector-set", 0, 3, 0)
 463 {
 464   scm_t_signed_bits i = 0;
 465   SCM vect, idx, val;
 466   POP3 (val, idx, vect);
 467   if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
 468                   && SCM_I_INUMP (idx)
 469                   && ((i = SCM_I_INUM (idx)) >= 0)
 470                   && i < SCM_I_VECTOR_LENGTH (vect)))
 471     SCM_I_VECTOR_WELTS (vect)[i] = val;
 472   else
 473     {
 474       SYNC_REGISTER ();
 475       scm_vector_set_x (vect, idx, val);
 476     }
 477   NEXT;
 478 }
 479
 480 VM_DEFINE_INSTRUCTION (165, make_array, "make-array", 3, -1, 1)
 481 {
 482   scm_t_uint32 len;
 483   SCM shape, ret;
 484
 485   len = FETCH ();
 486   len = (len << 8) + FETCH ();
 487   len = (len << 8) + FETCH ();
 488   POP (shape);
 489   SYNC_REGISTER ();
 490   PRE_CHECK_UNDERFLOW (len);
 491   ret = scm_from_contiguous_array (shape, sp - len + 1, len);
 492   DROPN (len);
 493   PUSH (ret);
 494   NEXT;
 495 }
 496
 497 \f
 498 /*
 499  * Structs
 500  */
 501 #define VM_VALIDATE_STRUCT(obj, proc)           \
 502   VM_ASSERT (SCM_STRUCTP (obj), vm_error_not_a_struct (proc, obj))
 503
 504 VM_DEFINE_FUNCTION (166, struct_p, "struct?", 1)
 505 {
 506   ARGS1 (obj);
 507   RETURN (scm_from_bool (SCM_STRUCTP (obj)));
 508 }
 509
 510 VM_DEFINE_FUNCTION (167, struct_vtable, "struct-vtable", 1)
 511 {
 512   ARGS1 (obj);
 513   VM_VALIDATE_STRUCT (obj, "struct_vtable");
 514   RETURN (SCM_STRUCT_VTABLE (obj));
 515 }
 516
 517 VM_DEFINE_INSTRUCTION (168, make_struct, "make-struct", 2, -1, 1)
 518 {
 519   unsigned h = FETCH ();
 520   unsigned l = FETCH ();
 521   scm_t_bits n = ((h << 8U) + l);
 522   SCM vtable = sp[-(n - 1)];
 523   const SCM *inits = sp - n + 2;
 524   SCM ret;
 525
 526   SYNC_REGISTER ();
 527
 528   if (SCM_LIKELY (SCM_STRUCTP (vtable)
 529                   && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
 530                   && (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size) + 1
 531                       == n)
 532                   && !SCM_VTABLE_INSTANCE_FINALIZER (vtable)))
 533     {
 534       /* Verily, we are making a simple struct with the right number of
 535          initializers, and no finalizer. */
 536       ret = scm_words ((scm_t_bits)SCM_STRUCT_DATA (vtable) | scm_tc3_struct,
 537                        n + 1);
 538       SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
 539       memcpy (SCM_STRUCT_DATA (ret), inits, (n - 1) * sizeof (SCM));
 540     }
 541   else
 542     ret = scm_c_make_structv (vtable, 0, n - 1, (scm_t_bits *) inits);
 543
 544   DROPN (n);
 545   PUSH (ret);
 546
 547   NEXT;
 548 }
 549
 550 VM_DEFINE_FUNCTION (169, struct_ref, "struct-ref", 2)
 551 {
 552   ARGS2 (obj, pos);
 553
 554   if (SCM_LIKELY (SCM_STRUCTP (obj)
 555                   && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
 556                                                     SCM_VTABLE_FLAG_SIMPLE)
 557                   && SCM_I_INUMP (pos)))
 558     {
 559       SCM vtable;
 560       scm_t_bits index, len;
 561
 562       /* True, an inum is a signed value, but cast to unsigned it will
 563          certainly be more than the length, so we will fall through if
 564          index is negative. */
 565       index = SCM_I_INUM (pos);
 566       vtable = SCM_STRUCT_VTABLE (obj);
 567       len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
 568
 569       if (SCM_LIKELY (index < len))
 570         {
 571           scm_t_bits *data = SCM_STRUCT_DATA (obj);
 572           RETURN (SCM_PACK (data[index]));
 573         }
 574     }
 575
 576   SYNC_REGISTER ();
 577   RETURN (scm_struct_ref (obj, pos));
 578 }
 579
 580 VM_DEFINE_FUNCTION (170, struct_set, "struct-set", 3)
 581 {
 582   ARGS3 (obj, pos, val);
 583
 584   if (SCM_LIKELY (SCM_STRUCTP (obj)
 585                   && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
 586                                                     SCM_VTABLE_FLAG_SIMPLE)
 587                   && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
 588                                                     SCM_VTABLE_FLAG_SIMPLE_RW)
 589                   && SCM_I_INUMP (pos)))
 590     {
 591       SCM vtable;
 592       scm_t_bits index, len;
 593
 594       /* See above regarding index being >= 0. */
 595       index = SCM_I_INUM (pos);
 596       vtable = SCM_STRUCT_VTABLE (obj);
 597       len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
 598       if (SCM_LIKELY (index < len))
 599         {
 600           scm_t_bits *data = SCM_STRUCT_DATA (obj);
 601           data[index] = SCM_UNPACK (val);
 602           RETURN (val);
 603         }
 604     }
 605
 606   SYNC_REGISTER ();
 607   RETURN (scm_struct_set_x (obj, pos, val));
 608 }
 609
 610 \f
 611 /*
 612  * GOOPS support
 613  */
 614 VM_DEFINE_FUNCTION (171, class_of, "class-of", 1)
 615 {
 616   ARGS1 (obj);
 617   if (SCM_INSTANCEP (obj))
 618     RETURN (SCM_CLASS_OF (obj));
 619   SYNC_REGISTER ();
 620   RETURN (scm_class_of (obj));
 621 }
 622
 623 /* FIXME: No checking whatsoever. */
 624 VM_DEFINE_FUNCTION (172, slot_ref, "slot-ref", 2)
 625 {
 626   size_t slot;
 627   ARGS2 (instance, idx);
 628   slot = SCM_I_INUM (idx);
 629   RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
 630 }
 631
 632 /* FIXME: No checking whatsoever. */
 633 VM_DEFINE_INSTRUCTION (173, slot_set, "slot-set", 0, 3, 0)
 634 {
 635   SCM instance, idx, val;
 636   size_t slot;
 637   POP3 (val, idx, instance);
 638   slot = SCM_I_INUM (idx);
 639   SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val);
 640   NEXT;
 641 }
 642
 643 \f
 644 /*
 645  * Bytevectors
 646  */
 647 #define VM_VALIDATE_BYTEVECTOR(x, proc)         \
 648   VM_ASSERT (SCM_BYTEVECTOR_P (x), vm_error_not_a_bytevector (proc, x))
 649
 650 #define BV_REF_WITH_ENDIANNESS(stem, fn_stem)                           \
 651 {                                                                       \
 652   SCM endianness;                                                       \
 653   POP (endianness);                                                     \
 654   if (scm_is_eq (endianness, scm_i_native_endianness))                  \
 655     goto VM_LABEL (bv_##stem##_native_ref);                             \
 656   {                                                                     \
 657     ARGS2 (bv, idx);                                                    \
 658     SYNC_REGISTER ();                                                   \
 659     RETURN (scm_bytevector_##fn_stem##_ref (bv, idx, endianness));      \
 660   }                                                                     \
 661 }
 662
 663 /* Return true (non-zero) if PTR has suitable alignment for TYPE.  */
 664 #define ALIGNED_P(ptr, type)                    \
 665   ((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
 666
 667 VM_DEFINE_FUNCTION (174, bv_u16_ref, "bv-u16-ref", 3)
 668 BV_REF_WITH_ENDIANNESS (u16, u16)
 669 VM_DEFINE_FUNCTION (175, bv_s16_ref, "bv-s16-ref", 3)
 670 BV_REF_WITH_ENDIANNESS (s16, s16)
 671 VM_DEFINE_FUNCTION (176, bv_u32_ref, "bv-u32-ref", 3)
 672 BV_REF_WITH_ENDIANNESS (u32, u32)
 673 VM_DEFINE_FUNCTION (177, bv_s32_ref, "bv-s32-ref", 3)
 674 BV_REF_WITH_ENDIANNESS (s32, s32)
 675 VM_DEFINE_FUNCTION (178, bv_u64_ref, "bv-u64-ref", 3)
 676 BV_REF_WITH_ENDIANNESS (u64, u64)
 677 VM_DEFINE_FUNCTION (179, bv_s64_ref, "bv-s64-ref", 3)
 678 BV_REF_WITH_ENDIANNESS (s64, s64)
 679 VM_DEFINE_FUNCTION (180, bv_f32_ref, "bv-f32-ref", 3)
 680 BV_REF_WITH_ENDIANNESS (f32, ieee_single)
 681 VM_DEFINE_FUNCTION (181, bv_f64_ref, "bv-f64-ref", 3)
 682 BV_REF_WITH_ENDIANNESS (f64, ieee_double)
 683
 684 #undef BV_REF_WITH_ENDIANNESS
 685
 686 #define BV_FIXABLE_INT_REF(stem, fn_stem, type, size)                   \
 687 {                                                                       \
 688   scm_t_signed_bits i;                                                  \
 689   const scm_t_ ## type *int_ptr;                                        \
 690   ARGS2 (bv, idx);                                                      \
 691                                                                         \
 692   VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref");                      \
 693   i = SCM_I_INUM (idx);                                                 \
 694   int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i);      \
 695                                                                         \
 696   if (SCM_LIKELY (SCM_I_INUMP (idx)                                     \
 697                   && (i >= 0)                                           \
 698                   && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))           \
 699                   && (ALIGNED_P (int_ptr, scm_t_ ## type))))            \
 700     RETURN (SCM_I_MAKINUM (*int_ptr));                                  \
 701   else                                                                  \
 702     {                                                                   \
 703       SYNC_REGISTER ();                                                 \
 704       RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx));            \
 705     }                                                                   \
 706 }
 707
 708 #define BV_INT_REF(stem, type, size)                                    \
 709 {                                                                       \
 710   scm_t_signed_bits i;                                                  \
 711   const scm_t_ ## type *int_ptr;                                        \
 712   ARGS2 (bv, idx);                                                      \
 713                                                                         \
 714   VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref");                      \
 715   i = SCM_I_INUM (idx);                                                 \
 716   int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i);      \
 717                                                                         \
 718   if (SCM_LIKELY (SCM_I_INUMP (idx)                                     \
 719                   && (i >= 0)                                           \
 720                   && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))           \
 721                   && (ALIGNED_P (int_ptr, scm_t_ ## type))))            \
 722     {                                                                   \
 723       scm_t_ ## type x = *int_ptr;                                      \
 724       if (SCM_FIXABLE (x))                                              \
 725         RETURN (SCM_I_MAKINUM (x));                                     \
 726       else                                                              \
 727         {                                                               \
 728           SYNC_REGISTER ();                                             \
 729           RETURN (scm_from_ ## type (x));                               \
 730         }                                                               \
 731     }                                                                   \
 732   else                                                                  \
 733     {                                                                   \
 734       SYNC_REGISTER ();                                                 \
 735       RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx));        \
 736     }                                                                   \
 737 }
 738
 739 #define BV_FLOAT_REF(stem, fn_stem, type, size)                         \
 740 {                                                                       \
 741   scm_t_signed_bits i;                                                  \
 742   const type *float_ptr;                                                \
 743   ARGS2 (bv, idx);                                                      \
 744                                                                         \
 745   VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref");                      \
 746   i = SCM_I_INUM (idx);                                                 \
 747   float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i);              \
 748                                                                         \
 749   SYNC_REGISTER ();                                                     \
 750   if (SCM_LIKELY (SCM_I_INUMP (idx)                                     \
 751                   && (i >= 0)                                           \
 752                   && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))           \
 753                   && (ALIGNED_P (float_ptr, type))))                    \
 754     RETURN (scm_from_double (*float_ptr));                              \
 755   else                                                                  \
 756     RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx));       \
 757 }
 758
 759 VM_DEFINE_FUNCTION (182, bv_u8_ref, "bv-u8-ref", 2)
 760 BV_FIXABLE_INT_REF (u8, u8, uint8, 1)
 761 VM_DEFINE_FUNCTION (183, bv_s8_ref, "bv-s8-ref", 2)
 762 BV_FIXABLE_INT_REF (s8, s8, int8, 1)
 763 VM_DEFINE_FUNCTION (184, bv_u16_native_ref, "bv-u16-native-ref", 2)
 764 BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2)
 765 VM_DEFINE_FUNCTION (185, bv_s16_native_ref, "bv-s16-native-ref", 2)
 766 BV_FIXABLE_INT_REF (s16, s16_native, int16, 2)
 767 VM_DEFINE_FUNCTION (186, bv_u32_native_ref, "bv-u32-native-ref", 2)
 768 #if SIZEOF_VOID_P > 4
 769 BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4)
 770 #else
 771 BV_INT_REF (u32, uint32, 4)
 772 #endif
 773 VM_DEFINE_FUNCTION (187, bv_s32_native_ref, "bv-s32-native-ref", 2)
 774 #if SIZEOF_VOID_P > 4
 775 BV_FIXABLE_INT_REF (s32, s32_native, int32, 4)
 776 #else
 777 BV_INT_REF (s32, int32, 4)
 778 #endif
 779 VM_DEFINE_FUNCTION (188, bv_u64_native_ref, "bv-u64-native-ref", 2)
 780 BV_INT_REF (u64, uint64, 8)
 781 VM_DEFINE_FUNCTION (189, bv_s64_native_ref, "bv-s64-native-ref", 2)
 782 BV_INT_REF (s64, int64, 8)
 783 VM_DEFINE_FUNCTION (190, bv_f32_native_ref, "bv-f32-native-ref", 2)
 784 BV_FLOAT_REF (f32, ieee_single, float, 4)
 785 VM_DEFINE_FUNCTION (191, bv_f64_native_ref, "bv-f64-native-ref", 2)
 786 BV_FLOAT_REF (f64, ieee_double, double, 8)
 787
 788 #undef BV_FIXABLE_INT_REF
 789 #undef BV_INT_REF
 790 #undef BV_FLOAT_REF
 791
 792
 793
 794 #define BV_SET_WITH_ENDIANNESS(stem, fn_stem)                           \
 795 {                                                                       \
 796   SCM endianness;                                                       \
 797   POP (endianness);                                                     \
 798   if (scm_is_eq (endianness, scm_i_native_endianness))                  \
 799     goto VM_LABEL (bv_##stem##_native_set);                             \
 800   {                                                                     \
 801     SCM bv, idx, val; POP3 (val, idx, bv);                              \
 802     SYNC_REGISTER ();                                                   \
 803     scm_bytevector_##fn_stem##_set_x (bv, idx, val, endianness);        \
 804     NEXT;                                                               \
 805   }                                                                     \
 806 }
 807
 808 VM_DEFINE_INSTRUCTION (192, bv_u16_set, "bv-u16-set", 0, 4, 0)
 809 BV_SET_WITH_ENDIANNESS (u16, u16)
 810 VM_DEFINE_INSTRUCTION (193, bv_s16_set, "bv-s16-set", 0, 4, 0)
 811 BV_SET_WITH_ENDIANNESS (s16, s16)
 812 VM_DEFINE_INSTRUCTION (194, bv_u32_set, "bv-u32-set", 0, 4, 0)
 813 BV_SET_WITH_ENDIANNESS (u32, u32)
 814 VM_DEFINE_INSTRUCTION (195, bv_s32_set, "bv-s32-set", 0, 4, 0)
 815 BV_SET_WITH_ENDIANNESS (s32, s32)
 816 VM_DEFINE_INSTRUCTION (196, bv_u64_set, "bv-u64-set", 0, 4, 0)
 817 BV_SET_WITH_ENDIANNESS (u64, u64)
 818 VM_DEFINE_INSTRUCTION (197, bv_s64_set, "bv-s64-set", 0, 4, 0)
 819 BV_SET_WITH_ENDIANNESS (s64, s64)
 820 VM_DEFINE_INSTRUCTION (198, bv_f32_set, "bv-f32-set", 0, 4, 0)
 821 BV_SET_WITH_ENDIANNESS (f32, ieee_single)
 822 VM_DEFINE_INSTRUCTION (199, bv_f64_set, "bv-f64-set", 0, 4, 0)
 823 BV_SET_WITH_ENDIANNESS (f64, ieee_double)
 824
 825 #undef BV_SET_WITH_ENDIANNESS
 826
 827 #define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size)         \
 828 {                                                                       \
 829   scm_t_signed_bits i, j = 0;                                           \
 830   SCM bv, idx, val;                                                     \
 831   scm_t_ ## type *int_ptr;                                              \
 832                                                                         \
 833   POP3 (val, idx, bv);                                                  \
 834   VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set");                      \
 835   i = SCM_I_INUM (idx);                                                 \
 836   int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i);      \
 837                                                                         \
 838   if (SCM_LIKELY (SCM_I_INUMP (idx)                                     \
 839                   && (i >= 0)                                           \
 840                   && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))           \
 841                   && (ALIGNED_P (int_ptr, scm_t_ ## type))              \
 842                   && (SCM_I_INUMP (val))                                \
 843                   && ((j = SCM_I_INUM (val)) >= min)                    \
 844                   && (j <= max)))                                       \
 845     *int_ptr = (scm_t_ ## type) j;                                      \
 846   else                                                                  \
 847     {                                                                   \
 848       SYNC_REGISTER ();                                                 \
 849       scm_bytevector_ ## fn_stem ## _set_x (bv, idx, val);              \
 850     }                                                                   \
 851   NEXT;                                                                 \
 852 }
 853
 854 #define BV_INT_SET(stem, type, size)                                    \
 855 {                                                                       \
 856   scm_t_signed_bits i = 0;                                              \
 857   SCM bv, idx, val;                                                     \
 858   scm_t_ ## type *int_ptr;                                              \
 859                                                                         \
 860   POP3 (val, idx, bv);                                                  \
 861   VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set");                      \
 862   i = SCM_I_INUM (idx);                                                 \
 863   int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i);      \
 864                                                                         \
 865   if (SCM_LIKELY (SCM_I_INUMP (idx)                                     \
 866                   && (i >= 0)                                           \
 867                   && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))           \
 868                   && (ALIGNED_P (int_ptr, scm_t_ ## type))))            \
 869     *int_ptr = scm_to_ ## type (val);                                   \
 870   else                                                                  \
 871     {                                                                   \
 872       SYNC_REGISTER ();                                                 \
 873       scm_bytevector_ ## stem ## _native_set_x (bv, idx, val);          \
 874     }                                                                   \
 875   NEXT;                                                                 \
 876 }
 877
 878 #define BV_FLOAT_SET(stem, fn_stem, type, size)                         \
 879 {                                                                       \
 880   scm_t_signed_bits i = 0;                                              \
 881   SCM bv, idx, val;                                                     \
 882   type *float_ptr;                                                      \
 883                                                                         \
 884   POP3 (val, idx, bv);                                                  \
 885   VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set");                      \
 886   i = SCM_I_INUM (idx);                                                 \
 887   float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i);              \
 888                                                                         \
 889   if (SCM_LIKELY (SCM_I_INUMP (idx)                                     \
 890                   && (i >= 0)                                           \
 891                   && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))           \
 892                   && (ALIGNED_P (float_ptr, type))))                    \
 893     *float_ptr = scm_to_double (val);                                   \
 894   else                                                                  \
 895     {                                                                   \
 896       SYNC_REGISTER ();                                                 \
 897       scm_bytevector_ ## fn_stem ## _native_set_x (bv, idx, val);       \
 898     }                                                                   \
 899   NEXT;                                                                 \
 900 }
 901
 902 VM_DEFINE_INSTRUCTION (200, bv_u8_set, "bv-u8-set", 0, 3, 0)
 903 BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1)
 904 VM_DEFINE_INSTRUCTION (201, bv_s8_set, "bv-s8-set", 0, 3, 0)
 905 BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1)
 906 VM_DEFINE_INSTRUCTION (202, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
 907 BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2)
 908 VM_DEFINE_INSTRUCTION (203, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
 909 BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2)
 910 VM_DEFINE_INSTRUCTION (204, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
 911 #if SIZEOF_VOID_P > 4
 912 BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4)
 913 #else
 914 BV_INT_SET (u32, uint32, 4)
 915 #endif
 916 VM_DEFINE_INSTRUCTION (205, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
 917 #if SIZEOF_VOID_P > 4
 918 BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4)
 919 #else
 920 BV_INT_SET (s32, int32, 4)
 921 #endif
 922 VM_DEFINE_INSTRUCTION (206, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
 923 BV_INT_SET (u64, uint64, 8)
 924 VM_DEFINE_INSTRUCTION (207, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
 925 BV_INT_SET (s64, int64, 8)
 926 VM_DEFINE_INSTRUCTION (208, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
 927 BV_FLOAT_SET (f32, ieee_single, float, 4)
 928 VM_DEFINE_INSTRUCTION (209, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
 929 BV_FLOAT_SET (f64, ieee_double, double, 8)
 930
 931 #undef BV_FIXABLE_INT_SET
 932 #undef BV_INT_SET
 933 #undef BV_FLOAT_SET
 934
 935 /*
 936 (defun renumber-ops ()
 937   "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
 938   (interactive "")
 939   (save-excursion
 940     (let ((counter 127)) (goto-char (point-min))
 941       (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
 942         (replace-match
 943          (number-to-string (setq counter (1+ counter)))
 944           t t nil 1)))))
 945 */
 946
 947 /*
 948   Local Variables:
 949   c-file-style: "gnu"
 950   End:
 951 */