HCoop / bpt / guile.git / blob
? search:


fc32ec5a8765c59f1217173591c0713e8decf6a6
[bpt/guile.git] / 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 #undef INUM_STEP
211 #define INUM_MAX \
212 ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)))
213 #define INUM_MIN \
214 ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)))
215 #define INUM_STEP \
216 ((scm_t_signed_bits) SCM_UNPACK (SCM_INUM1) \
217 - (scm_t_signed_bits) SCM_UNPACK (SCM_INUM0))
218
219 #undef FUNC2
220 #define FUNC2(CFUNC,SFUNC) \
221 { \
222 ARGS2 (x, y); \
223 if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
224 { \
225 scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y);\
226 if (SCM_FIXABLE (n)) \
227 RETURN (SCM_I_MAKINUM (n)); \
228 } \
229 SYNC_REGISTER (); \
230 RETURN (SFUNC (x, y)); \
231 }
232
233 /* Assembly tagged integer arithmetic routines. This code uses the
234 `asm goto' feature introduced in GCC 4.5. */
235
236 #if SCM_GNUC_PREREQ (4, 5) && (defined __x86_64__ || defined __i386__)
237
238 # undef _CX
239 # ifdef __x86_64__
240 # define _CX "rcx"
241 # else
242 # define _CX "ecx"
243 # endif
244
245 /* The macros below check the CPU's overflow flag to improve fixnum
246 arithmetic. The _CX register (%rcx or %ecx) is explicitly
247 clobbered because `asm goto' can't have outputs, in which case the
248 `r' constraint could be used to let the register allocator choose a
249 register.
250
251 TODO: Use `cold' label attribute in GCC 4.6.
252 http://gcc.gnu.org/ml/gcc-patches/2010-10/msg01777.html */
253
254 # define ASM_ADD(x, y) \
255 { \
256 asm volatile goto ("mov %1, %%"_CX"; " \
257 "test %[tag], %%cl; je %l[slow_add]; " \
258 "test %[tag], %0; je %l[slow_add]; " \
259 "sub %[tag], %%"_CX"; " \
260 "add %0, %%"_CX"; jo %l[slow_add]; " \
261 "mov %%"_CX", (%[vsp])\n" \
262 : /* no outputs */ \
263 : "r" (x), "r" (y), \
264 [vsp] "r" (sp), [tag] "i" (scm_tc2_int) \
265 : _CX, "memory", "cc" \
266 : slow_add); \
267 NEXT; \
268 } \
269 slow_add: \
270 do { } while (0)
271
272 # define ASM_SUB(x, y) \
273 { \
274 asm volatile goto ("mov %0, %%"_CX"; " \
275 "test %[tag], %%cl; je %l[slow_sub]; " \
276 "test %[tag], %1; je %l[slow_sub]; " \
277 "sub %1, %%"_CX"; jo %l[slow_sub]; " \
278 "add %[tag], %%"_CX"; " \
279 "mov %%"_CX", (%[vsp])\n" \
280 : /* no outputs */ \
281 : "r" (x), "r" (y), \
282 [vsp] "r" (sp), [tag] "i" (scm_tc2_int) \
283 : _CX, "memory", "cc" \
284 : slow_sub); \
285 NEXT; \
286 } \
287 slow_sub: \
288 do { } while (0)
289
290 # define ASM_MUL(x, y) \
291 { \
292 scm_t_signed_bits xx = SCM_I_INUM (x); \
293 asm volatile goto ("mov %1, %%"_CX"; " \
294 "test %[tag], %%cl; je %l[slow_mul]; " \
295 "sub %[tag], %%"_CX"; " \
296 "test %[tag], %0; je %l[slow_mul]; " \
297 "imul %2, %%"_CX"; jo %l[slow_mul]; " \
298 "add %[tag], %%"_CX"; " \
299 "mov %%"_CX", (%[vsp])\n" \
300 : /* no outputs */ \
301 : "r" (x), "r" (y), "r" (xx), \
302 [vsp] "r" (sp), [tag] "i" (scm_tc2_int) \
303 : _CX, "memory", "cc" \
304 : slow_mul); \
305 NEXT; \
306 } \
307 slow_mul: \
308 do { } while (0)
309
310 #endif
311
312 #if SCM_GNUC_PREREQ (4, 5) && defined __arm__
313
314 # define ASM_ADD(x, y) \
315 if (SCM_LIKELY (SCM_I_INUMP (x) && SCM_I_INUMP (y))) \
316 { \
317 asm volatile goto ("adds r0, %0, %1; bvs %l[slow_add]; " \
318 "str r0, [%[vsp]]\n" \
319 : /* no outputs */ \
320 : "r" (x), "r" (y - scm_tc2_int), \
321 [vsp] "r" (sp) \
322 : "r0", "memory", "cc" \
323 : slow_add); \
324 NEXT; \
325 } \
326 slow_add: \
327 do { } while (0)
328
329 # define ASM_SUB(x, y) \
330 if (SCM_LIKELY (SCM_I_INUMP (x) && SCM_I_INUMP (y))) \
331 { \
332 asm volatile goto ("subs r0, %0, %1; bvs %l[slow_sub]; " \
333 "str r0, [%[vsp]]\n" \
334 : /* no outputs */ \
335 : "r" (x), "r" (y - scm_tc2_int), \
336 [vsp] "r" (sp) \
337 : "r0", "memory", "cc" \
338 : slow_sub); \
339 NEXT; \
340 } \
341 slow_sub: \
342 do { } while (0)
343
344 # if defined (__ARM_ARCH_3M__) || defined (__ARM_ARCH_4__) \
345 || defined (__ARM_ARCH_4T__) || defined (__ARM_ARCH_5__) \
346 || defined (__ARM_ARCH_5T__) || defined (__ARM_ARCH_5E__) \
347 || defined (__ARM_ARCH_5TE__) || defined (__ARM_ARCH_5TEJ__) \
348 || defined (__ARM_ARCH_6__) || defined (__ARM_ARCH_6J__) \
349 || defined (__ARM_ARCH_6K__) || defined (__ARM_ARCH_6Z__) \
350 || defined (__ARM_ARCH_6ZK__) || defined (__ARM_ARCH_6T2__) \
351 || defined (__ARM_ARCH_6M__) || defined (__ARM_ARCH_7__) \
352 || defined (__ARM_ARCH_7A__) || defined (__ARM_ARCH_7R__) \
353 || defined (__ARM_ARCH_7M__) || defined (__ARM_ARCH_7EM__) \
354 || defined (__ARM_ARCH_8A__)
355
356 /* The ARM architectures listed above support the SMULL instruction */
357
358 # define ASM_MUL(x, y) \
359 if (SCM_LIKELY (SCM_I_INUMP (x) && SCM_I_INUMP (y))) \
360 { \
361 scm_t_signed_bits rlo, rhi; \
362 asm ("smull %0, %1, %2, %3\n" \
363 : "=r" (rlo), "=r" (rhi) \
364 : "r" (SCM_UNPACK (x) - scm_tc2_int), \
365 "r" (SCM_I_INUM (y))); \
366 if (SCM_LIKELY (SCM_SRS (rlo, 31) == rhi)) \
367 RETURN (SCM_PACK (rlo + scm_tc2_int)); \
368 } \
369 do { } while (0)
370
371 # endif
372
373 #endif
374
375 VM_DEFINE_FUNCTION (150, add, "add", 2)
376 {
377 #ifndef ASM_ADD
378 FUNC2 (+, scm_sum);
379 #else
380 ARGS2 (x, y);
381 ASM_ADD (x, y);
382 SYNC_REGISTER ();
383 RETURN (scm_sum (x, y));
384 #endif
385 }
386
387 VM_DEFINE_FUNCTION (151, add1, "add1", 1)
388 {
389 ARGS1 (x);
390
391 /* Check for overflow. We must avoid overflow in the signed
392 addition below, even if X is not an inum. */
393 if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) <= INUM_MAX - INUM_STEP))
394 {
395 SCM result;
396
397 /* Add 1 to the integer without untagging. */
398 result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) + INUM_STEP);
399
400 if (SCM_LIKELY (SCM_I_INUMP (result)))
401 RETURN (result);
402 }
403
404 SYNC_REGISTER ();
405 RETURN (scm_sum (x, SCM_I_MAKINUM (1)));
406 }
407
408 VM_DEFINE_FUNCTION (152, sub, "sub", 2)
409 {
410 #ifndef ASM_SUB
411 FUNC2 (-, scm_difference);
412 #else
413 ARGS2 (x, y);
414 ASM_SUB (x, y);
415 SYNC_REGISTER ();
416 RETURN (scm_difference (x, y));
417 #endif
418 }
419
420 VM_DEFINE_FUNCTION (153, sub1, "sub1", 1)
421 {
422 ARGS1 (x);
423
424 /* Check for overflow. We must avoid overflow in the signed
425 subtraction below, even if X is not an inum. */
426 if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) >= INUM_MIN + INUM_STEP))
427 {
428 SCM result;
429
430 /* Substract 1 from the integer without untagging. */
431 result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) - INUM_STEP);
432
433 if (SCM_LIKELY (SCM_I_INUMP (result)))
434 RETURN (result);
435 }
436
437 SYNC_REGISTER ();
438 RETURN (scm_difference (x, SCM_I_MAKINUM (1)));
439 }
440
441 VM_DEFINE_FUNCTION (154, mul, "mul", 2)
442 {
443 ARGS2 (x, y);
444 #ifdef ASM_MUL
445 ASM_MUL (x, y);
446 #endif
447 SYNC_REGISTER ();
448 RETURN (scm_product (x, y));
449 }
450
451 # undef ASM_ADD
452 # undef ASM_SUB
453 # undef ASM_MUL
454
455 VM_DEFINE_FUNCTION (155, div, "div", 2)
456 {
457 ARGS2 (x, y);
458 SYNC_REGISTER ();
459 RETURN (scm_divide (x, y));
460 }
461
462 VM_DEFINE_FUNCTION (156, quo, "quo", 2)
463 {
464 ARGS2 (x, y);
465 SYNC_REGISTER ();
466 RETURN (scm_quotient (x, y));
467 }
468
469 VM_DEFINE_FUNCTION (157, rem, "rem", 2)
470 {
471 ARGS2 (x, y);
472 SYNC_REGISTER ();
473 RETURN (scm_remainder (x, y));
474 }
475
476 VM_DEFINE_FUNCTION (158, mod, "mod", 2)
477 {
478 ARGS2 (x, y);
479 SYNC_REGISTER ();
480 RETURN (scm_modulo (x, y));
481 }
482
483 VM_DEFINE_FUNCTION (159, ash, "ash", 2)
484 {
485 ARGS2 (x, y);
486 if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
487 {
488 if (SCM_I_INUM (y) < 0)
489 /* Right shift, will be a fixnum. */
490 RETURN (SCM_I_MAKINUM
491 (SCM_SRS (SCM_I_INUM (x),
492 (-SCM_I_INUM (y) <= SCM_I_FIXNUM_BIT-1)
493 ? -SCM_I_INUM (y) : SCM_I_FIXNUM_BIT-1)));
494 else
495 /* Left shift. See comments in scm_ash. */
496 {
497 scm_t_signed_bits nn, bits_to_shift;
498
499 nn = SCM_I_INUM (x);
500 bits_to_shift = SCM_I_INUM (y);
501
502 if (bits_to_shift < SCM_I_FIXNUM_BIT-1
503 && ((scm_t_bits)
504 (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
505 <= 1))
506 RETURN (SCM_I_MAKINUM (nn << bits_to_shift));
507 /* fall through */
508 }
509 /* fall through */
510 }
511 SYNC_REGISTER ();
512 RETURN (scm_ash (x, y));
513 }
514
515 VM_DEFINE_FUNCTION (160, logand, "logand", 2)
516 {
517 ARGS2 (x, y);
518 if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
519 /* Compute bitwise AND without untagging */
520 RETURN (SCM_PACK (SCM_UNPACK (x) & SCM_UNPACK (y)));
521 SYNC_REGISTER ();
522 RETURN (scm_logand (x, y));
523 }
524
525 VM_DEFINE_FUNCTION (161, logior, "logior", 2)
526 {
527 ARGS2 (x, y);
528 if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
529 /* Compute bitwise OR without untagging */
530 RETURN (SCM_PACK (SCM_UNPACK (x) | SCM_UNPACK (y)));
531 SYNC_REGISTER ();
532 RETURN (scm_logior (x, y));
533 }
534
535 VM_DEFINE_FUNCTION (162, logxor, "logxor", 2)
536 {
537 ARGS2 (x, y);
538 if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
539 RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) ^ SCM_I_INUM (y)));
540 SYNC_REGISTER ();
541 RETURN (scm_logxor (x, y));
542 }
543
544 \f
545 /*
546 * Vectors and arrays
547 */
548
549 VM_DEFINE_FUNCTION (163, vector_ref, "vector-ref", 2)
550 {
551 scm_t_signed_bits i = 0;
552 ARGS2 (vect, idx);
553 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
554 && SCM_I_INUMP (idx)
555 && ((i = SCM_I_INUM (idx)) >= 0)
556 && i < SCM_I_VECTOR_LENGTH (vect)))
557 RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
558 else
559 {
560 SYNC_REGISTER ();
561 RETURN (scm_vector_ref (vect, idx));
562 }
563 }
564
565 VM_DEFINE_INSTRUCTION (164, vector_set, "vector-set", 0, 3, 0)
566 {
567 scm_t_signed_bits i = 0;
568 SCM vect, idx, val;
569 POP3 (val, idx, vect);
570 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
571 && SCM_I_INUMP (idx)
572 && ((i = SCM_I_INUM (idx)) >= 0)
573 && i < SCM_I_VECTOR_LENGTH (vect)))
574 SCM_I_VECTOR_WELTS (vect)[i] = val;
575 else
576 {
577 SYNC_REGISTER ();
578 scm_vector_set_x (vect, idx, val);
579 }
580 NEXT;
581 }
582
583 VM_DEFINE_INSTRUCTION (165, make_array, "make-array", 3, -1, 1)
584 {
585 scm_t_uint32 len;
586 SCM shape, ret;
587
588 len = FETCH ();
589 len = (len << 8) + FETCH ();
590 len = (len << 8) + FETCH ();
591 POP (shape);
592 SYNC_REGISTER ();
593 PRE_CHECK_UNDERFLOW (len);
594 ret = scm_from_contiguous_array (shape, sp - len + 1, len);
595 DROPN (len);
596 PUSH (ret);
597 NEXT;
598 }
599
600 \f
601 /*
602 * Structs
603 */
604 #define VM_VALIDATE_STRUCT(obj, proc) \
605 VM_ASSERT (SCM_STRUCTP (obj), vm_error_not_a_struct (proc, obj))
606
607 VM_DEFINE_FUNCTION (166, struct_p, "struct?", 1)
608 {
609 ARGS1 (obj);
610 RETURN (scm_from_bool (SCM_STRUCTP (obj)));
611 }
612
613 VM_DEFINE_FUNCTION (167, struct_vtable, "struct-vtable", 1)
614 {
615 ARGS1 (obj);
616 VM_VALIDATE_STRUCT (obj, "struct_vtable");
617 RETURN (SCM_STRUCT_VTABLE (obj));
618 }
619
620 VM_DEFINE_INSTRUCTION (168, make_struct, "make-struct", 2, -1, 1)
621 {
622 unsigned h = FETCH ();
623 unsigned l = FETCH ();
624 scm_t_bits n = ((h << 8U) + l);
625 SCM vtable = sp[-(n - 1)];
626 const SCM *inits = sp - n + 2;
627 SCM ret;
628
629 SYNC_REGISTER ();
630
631 if (SCM_LIKELY (SCM_STRUCTP (vtable)
632 && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
633 && (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size) + 1
634 == n)
635 && !SCM_VTABLE_INSTANCE_FINALIZER (vtable)))
636 {
637 /* Verily, we are making a simple struct with the right number of
638 initializers, and no finalizer. */
639 ret = scm_words ((scm_t_bits)SCM_STRUCT_DATA (vtable) | scm_tc3_struct,
640 n + 1);
641 SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
642 memcpy (SCM_STRUCT_DATA (ret), inits, (n - 1) * sizeof (SCM));
643 }
644 else
645 ret = scm_c_make_structv (vtable, 0, n - 1, (scm_t_bits *) inits);
646
647 DROPN (n);
648 PUSH (ret);
649
650 NEXT;
651 }
652
653 VM_DEFINE_FUNCTION (169, struct_ref, "struct-ref", 2)
654 {
655 ARGS2 (obj, pos);
656
657 if (SCM_LIKELY (SCM_STRUCTP (obj)
658 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
659 SCM_VTABLE_FLAG_SIMPLE)
660 && SCM_I_INUMP (pos)))
661 {
662 SCM vtable;
663 scm_t_bits index, len;
664
665 /* True, an inum is a signed value, but cast to unsigned it will
666 certainly be more than the length, so we will fall through if
667 index is negative. */
668 index = SCM_I_INUM (pos);
669 vtable = SCM_STRUCT_VTABLE (obj);
670 len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
671
672 if (SCM_LIKELY (index < len))
673 {
674 scm_t_bits *data = SCM_STRUCT_DATA (obj);
675 RETURN (SCM_PACK (data[index]));
676 }
677 }
678
679 SYNC_REGISTER ();
680 RETURN (scm_struct_ref (obj, pos));
681 }
682
683 VM_DEFINE_FUNCTION (170, struct_set, "struct-set", 3)
684 {
685 ARGS3 (obj, pos, val);
686
687 if (SCM_LIKELY (SCM_STRUCTP (obj)
688 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
689 SCM_VTABLE_FLAG_SIMPLE)
690 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
691 SCM_VTABLE_FLAG_SIMPLE_RW)
692 && SCM_I_INUMP (pos)))
693 {
694 SCM vtable;
695 scm_t_bits index, len;
696
697 /* See above regarding index being >= 0. */
698 index = SCM_I_INUM (pos);
699 vtable = SCM_STRUCT_VTABLE (obj);
700 len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
701 if (SCM_LIKELY (index < len))
702 {
703 scm_t_bits *data = SCM_STRUCT_DATA (obj);
704 data[index] = SCM_UNPACK (val);
705 RETURN (val);
706 }
707 }
708
709 SYNC_REGISTER ();
710 RETURN (scm_struct_set_x (obj, pos, val));
711 }
712
713 \f
714 /*
715 * GOOPS support
716 */
717 VM_DEFINE_FUNCTION (171, class_of, "class-of", 1)
718 {
719 ARGS1 (obj);
720 if (SCM_INSTANCEP (obj))
721 RETURN (SCM_CLASS_OF (obj));
722 SYNC_REGISTER ();
723 RETURN (scm_class_of (obj));
724 }
725
726 /* FIXME: No checking whatsoever. */
727 VM_DEFINE_FUNCTION (172, slot_ref, "slot-ref", 2)
728 {
729 size_t slot;
730 ARGS2 (instance, idx);
731 slot = SCM_I_INUM (idx);
732 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
733 }
734
735 /* FIXME: No checking whatsoever. */
736 VM_DEFINE_INSTRUCTION (173, slot_set, "slot-set", 0, 3, 0)
737 {
738 SCM instance, idx, val;
739 size_t slot;
740 POP3 (val, idx, instance);
741 slot = SCM_I_INUM (idx);
742 SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val);
743 NEXT;
744 }
745
746 \f
747 /*
748 * Bytevectors
749 */
750 #define VM_VALIDATE_BYTEVECTOR(x, proc) \
751 VM_ASSERT (SCM_BYTEVECTOR_P (x), vm_error_not_a_bytevector (proc, x))
752
753 #define BV_REF_WITH_ENDIANNESS(stem, fn_stem) \
754 { \
755 SCM endianness; \
756 POP (endianness); \
757 if (scm_is_eq (endianness, scm_i_native_endianness)) \
758 goto VM_LABEL (bv_##stem##_native_ref); \
759 { \
760 ARGS2 (bv, idx); \
761 SYNC_REGISTER (); \
762 RETURN (scm_bytevector_##fn_stem##_ref (bv, idx, endianness)); \
763 } \
764 }
765
766 /* Return true (non-zero) if PTR has suitable alignment for TYPE. */
767 #define ALIGNED_P(ptr, type) \
768 ((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
769
770 VM_DEFINE_FUNCTION (174, bv_u16_ref, "bv-u16-ref", 3)
771 BV_REF_WITH_ENDIANNESS (u16, u16)
772 VM_DEFINE_FUNCTION (175, bv_s16_ref, "bv-s16-ref", 3)
773 BV_REF_WITH_ENDIANNESS (s16, s16)
774 VM_DEFINE_FUNCTION (176, bv_u32_ref, "bv-u32-ref", 3)
775 BV_REF_WITH_ENDIANNESS (u32, u32)
776 VM_DEFINE_FUNCTION (177, bv_s32_ref, "bv-s32-ref", 3)
777 BV_REF_WITH_ENDIANNESS (s32, s32)
778 VM_DEFINE_FUNCTION (178, bv_u64_ref, "bv-u64-ref", 3)
779 BV_REF_WITH_ENDIANNESS (u64, u64)
780 VM_DEFINE_FUNCTION (179, bv_s64_ref, "bv-s64-ref", 3)
781 BV_REF_WITH_ENDIANNESS (s64, s64)
782 VM_DEFINE_FUNCTION (180, bv_f32_ref, "bv-f32-ref", 3)
783 BV_REF_WITH_ENDIANNESS (f32, ieee_single)
784 VM_DEFINE_FUNCTION (181, bv_f64_ref, "bv-f64-ref", 3)
785 BV_REF_WITH_ENDIANNESS (f64, ieee_double)
786
787 #undef BV_REF_WITH_ENDIANNESS
788
789 #define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
790 { \
791 scm_t_signed_bits i; \
792 const scm_t_ ## type *int_ptr; \
793 ARGS2 (bv, idx); \
794 \
795 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
796 i = SCM_I_INUM (idx); \
797 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
798 \
799 if (SCM_LIKELY (SCM_I_INUMP (idx) \
800 && (i >= 0) \
801 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
802 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
803 RETURN (SCM_I_MAKINUM (*int_ptr)); \
804 else \
805 { \
806 SYNC_REGISTER (); \
807 RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \
808 } \
809 }
810
811 #define BV_INT_REF(stem, type, size) \
812 { \
813 scm_t_signed_bits i; \
814 const scm_t_ ## type *int_ptr; \
815 ARGS2 (bv, idx); \
816 \
817 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
818 i = SCM_I_INUM (idx); \
819 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
820 \
821 if (SCM_LIKELY (SCM_I_INUMP (idx) \
822 && (i >= 0) \
823 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
824 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
825 { \
826 scm_t_ ## type x = *int_ptr; \
827 if (SCM_FIXABLE (x)) \
828 RETURN (SCM_I_MAKINUM (x)); \
829 else \
830 { \
831 SYNC_REGISTER (); \
832 RETURN (scm_from_ ## type (x)); \
833 } \
834 } \
835 else \
836 { \
837 SYNC_REGISTER (); \
838 RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \
839 } \
840 }
841
842 #define BV_FLOAT_REF(stem, fn_stem, type, size) \
843 { \
844 scm_t_signed_bits i; \
845 const type *float_ptr; \
846 ARGS2 (bv, idx); \
847 \
848 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
849 i = SCM_I_INUM (idx); \
850 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
851 \
852 SYNC_REGISTER (); \
853 if (SCM_LIKELY (SCM_I_INUMP (idx) \
854 && (i >= 0) \
855 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
856 && (ALIGNED_P (float_ptr, type)))) \
857 RETURN (scm_from_double (*float_ptr)); \
858 else \
859 RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
860 }
861
862 VM_DEFINE_FUNCTION (182, bv_u8_ref, "bv-u8-ref", 2)
863 BV_FIXABLE_INT_REF (u8, u8, uint8, 1)
864 VM_DEFINE_FUNCTION (183, bv_s8_ref, "bv-s8-ref", 2)
865 BV_FIXABLE_INT_REF (s8, s8, int8, 1)
866 VM_DEFINE_FUNCTION (184, bv_u16_native_ref, "bv-u16-native-ref", 2)
867 BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2)
868 VM_DEFINE_FUNCTION (185, bv_s16_native_ref, "bv-s16-native-ref", 2)
869 BV_FIXABLE_INT_REF (s16, s16_native, int16, 2)
870 VM_DEFINE_FUNCTION (186, bv_u32_native_ref, "bv-u32-native-ref", 2)
871 #if SIZEOF_VOID_P > 4
872 BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4)
873 #else
874 BV_INT_REF (u32, uint32, 4)
875 #endif
876 VM_DEFINE_FUNCTION (187, bv_s32_native_ref, "bv-s32-native-ref", 2)
877 #if SIZEOF_VOID_P > 4
878 BV_FIXABLE_INT_REF (s32, s32_native, int32, 4)
879 #else
880 BV_INT_REF (s32, int32, 4)
881 #endif
882 VM_DEFINE_FUNCTION (188, bv_u64_native_ref, "bv-u64-native-ref", 2)
883 BV_INT_REF (u64, uint64, 8)
884 VM_DEFINE_FUNCTION (189, bv_s64_native_ref, "bv-s64-native-ref", 2)
885 BV_INT_REF (s64, int64, 8)
886 VM_DEFINE_FUNCTION (190, bv_f32_native_ref, "bv-f32-native-ref", 2)
887 BV_FLOAT_REF (f32, ieee_single, float, 4)
888 VM_DEFINE_FUNCTION (191, bv_f64_native_ref, "bv-f64-native-ref", 2)
889 BV_FLOAT_REF (f64, ieee_double, double, 8)
890
891 #undef BV_FIXABLE_INT_REF
892 #undef BV_INT_REF
893 #undef BV_FLOAT_REF
894
895
896
897 #define BV_SET_WITH_ENDIANNESS(stem, fn_stem) \
898 { \
899 SCM endianness; \
900 POP (endianness); \
901 if (scm_is_eq (endianness, scm_i_native_endianness)) \
902 goto VM_LABEL (bv_##stem##_native_set); \
903 { \
904 SCM bv, idx, val; POP3 (val, idx, bv); \
905 SYNC_REGISTER (); \
906 scm_bytevector_##fn_stem##_set_x (bv, idx, val, endianness); \
907 NEXT; \
908 } \
909 }
910
911 VM_DEFINE_INSTRUCTION (192, bv_u16_set, "bv-u16-set", 0, 4, 0)
912 BV_SET_WITH_ENDIANNESS (u16, u16)
913 VM_DEFINE_INSTRUCTION (193, bv_s16_set, "bv-s16-set", 0, 4, 0)
914 BV_SET_WITH_ENDIANNESS (s16, s16)
915 VM_DEFINE_INSTRUCTION (194, bv_u32_set, "bv-u32-set", 0, 4, 0)
916 BV_SET_WITH_ENDIANNESS (u32, u32)
917 VM_DEFINE_INSTRUCTION (195, bv_s32_set, "bv-s32-set", 0, 4, 0)
918 BV_SET_WITH_ENDIANNESS (s32, s32)
919 VM_DEFINE_INSTRUCTION (196, bv_u64_set, "bv-u64-set", 0, 4, 0)
920 BV_SET_WITH_ENDIANNESS (u64, u64)
921 VM_DEFINE_INSTRUCTION (197, bv_s64_set, "bv-s64-set", 0, 4, 0)
922 BV_SET_WITH_ENDIANNESS (s64, s64)
923 VM_DEFINE_INSTRUCTION (198, bv_f32_set, "bv-f32-set", 0, 4, 0)
924 BV_SET_WITH_ENDIANNESS (f32, ieee_single)
925 VM_DEFINE_INSTRUCTION (199, bv_f64_set, "bv-f64-set", 0, 4, 0)
926 BV_SET_WITH_ENDIANNESS (f64, ieee_double)
927
928 #undef BV_SET_WITH_ENDIANNESS
929
930 #define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
931 { \
932 scm_t_signed_bits i, j = 0; \
933 SCM bv, idx, val; \
934 scm_t_ ## type *int_ptr; \
935 \
936 POP3 (val, idx, bv); \
937 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
938 i = SCM_I_INUM (idx); \
939 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
940 \
941 if (SCM_LIKELY (SCM_I_INUMP (idx) \
942 && (i >= 0) \
943 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
944 && (ALIGNED_P (int_ptr, scm_t_ ## type)) \
945 && (SCM_I_INUMP (val)) \
946 && ((j = SCM_I_INUM (val)) >= min) \
947 && (j <= max))) \
948 *int_ptr = (scm_t_ ## type) j; \
949 else \
950 { \
951 SYNC_REGISTER (); \
952 scm_bytevector_ ## fn_stem ## _set_x (bv, idx, val); \
953 } \
954 NEXT; \
955 }
956
957 #define BV_INT_SET(stem, type, size) \
958 { \
959 scm_t_signed_bits i = 0; \
960 SCM bv, idx, val; \
961 scm_t_ ## type *int_ptr; \
962 \
963 POP3 (val, idx, bv); \
964 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
965 i = SCM_I_INUM (idx); \
966 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
967 \
968 if (SCM_LIKELY (SCM_I_INUMP (idx) \
969 && (i >= 0) \
970 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
971 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
972 *int_ptr = scm_to_ ## type (val); \
973 else \
974 { \
975 SYNC_REGISTER (); \
976 scm_bytevector_ ## stem ## _native_set_x (bv, idx, val); \
977 } \
978 NEXT; \
979 }
980
981 #define BV_FLOAT_SET(stem, fn_stem, type, size) \
982 { \
983 scm_t_signed_bits i = 0; \
984 SCM bv, idx, val; \
985 type *float_ptr; \
986 \
987 POP3 (val, idx, bv); \
988 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
989 i = SCM_I_INUM (idx); \
990 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
991 \
992 if (SCM_LIKELY (SCM_I_INUMP (idx) \
993 && (i >= 0) \
994 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
995 && (ALIGNED_P (float_ptr, type)))) \
996 *float_ptr = scm_to_double (val); \
997 else \
998 { \
999 SYNC_REGISTER (); \
1000 scm_bytevector_ ## fn_stem ## _native_set_x (bv, idx, val); \
1001 } \
1002 NEXT; \
1003 }
1004
1005 VM_DEFINE_INSTRUCTION (200, bv_u8_set, "bv-u8-set", 0, 3, 0)
1006 BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1)
1007 VM_DEFINE_INSTRUCTION (201, bv_s8_set, "bv-s8-set", 0, 3, 0)
1008 BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1)
1009 VM_DEFINE_INSTRUCTION (202, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
1010 BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2)
1011 VM_DEFINE_INSTRUCTION (203, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
1012 BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2)
1013 VM_DEFINE_INSTRUCTION (204, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
1014 #if SIZEOF_VOID_P > 4
1015 BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4)
1016 #else
1017 BV_INT_SET (u32, uint32, 4)
1018 #endif
1019 VM_DEFINE_INSTRUCTION (205, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
1020 #if SIZEOF_VOID_P > 4
1021 BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4)
1022 #else
1023 BV_INT_SET (s32, int32, 4)
1024 #endif
1025 VM_DEFINE_INSTRUCTION (206, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
1026 BV_INT_SET (u64, uint64, 8)
1027 VM_DEFINE_INSTRUCTION (207, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
1028 BV_INT_SET (s64, int64, 8)
1029 VM_DEFINE_INSTRUCTION (208, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
1030 BV_FLOAT_SET (f32, ieee_single, float, 4)
1031 VM_DEFINE_INSTRUCTION (209, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
1032 BV_FLOAT_SET (f64, ieee_double, double, 8)
1033
1034 #undef BV_FIXABLE_INT_SET
1035 #undef BV_INT_SET
1036 #undef BV_FLOAT_SET
1037
1038 /*
1039 (defun renumber-ops ()
1040 "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
1041 (interactive "")
1042 (save-excursion
1043 (let ((counter 127)) (goto-char (point-min))
1044 (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
1045 (replace-match
1046 (number-to-string (setq counter (1+ counter)))
1047 t t nil 1)))))
1048 */
1049
1050 /*
1051 Local Variables:
1052 c-file-style: "gnu"
1053 End:
1054 */
Unnamed repository; edit this file 'description' to name the repository.