vm-i-scheme.c 29 KB

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