frames.c 13 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498
  1. /* Copyright 2001,2009-2015,2018,2021
  2. Free Software Foundation, Inc.
  3. This file is part of Guile.
  4. Guile is free software: you can redistribute it and/or modify it
  5. under the terms of the GNU Lesser General Public License as published
  6. by the Free Software Foundation, either version 3 of the License, or
  7. (at your option) any later version.
  8. Guile is distributed in the hope that it will be useful, but WITHOUT
  9. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  10. FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
  11. License for more details.
  12. You should have received a copy of the GNU Lesser General Public
  13. License along with Guile. If not, see
  14. <https://www.gnu.org/licenses/>. */
  15. #if HAVE_CONFIG_H
  16. # include <config.h>
  17. #endif
  18. #include <stdlib.h>
  19. #include <string.h>
  20. #include "boolean.h"
  21. #include "eval.h"
  22. #include "extensions.h"
  23. #include "gsubr.h"
  24. #include "instructions.h"
  25. #include "modules.h"
  26. #include "numbers.h"
  27. #include "pairs.h"
  28. #include "ports.h"
  29. #include "symbols.h"
  30. #include "threads.h"
  31. #include "variable.h"
  32. #include "version.h"
  33. #include "vm.h"
  34. #include "frames.h"
  35. SCM
  36. scm_c_make_frame (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
  37. {
  38. struct scm_frame *p = scm_gc_malloc (sizeof (struct scm_frame),
  39. "vmframe");
  40. p->stack_holder = frame->stack_holder;
  41. p->fp_offset = frame->fp_offset;
  42. p->sp_offset = frame->sp_offset;
  43. p->ip = frame->ip;
  44. return scm_cell (scm_tc7_frame | (kind << 8), (scm_t_bits)p);
  45. }
  46. void
  47. scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
  48. {
  49. scm_puts ("#<frame ", port);
  50. scm_uintprint (SCM_UNPACK (frame), 16, port);
  51. if (scm_module_system_booted_p)
  52. {
  53. SCM name = scm_frame_procedure_name (frame);
  54. if (scm_is_true (name))
  55. {
  56. scm_putc (' ', port);
  57. scm_write (name, port);
  58. }
  59. }
  60. /* Don't write args, they can be ridiculously long. */
  61. scm_puts (">", port);
  62. }
  63. static union scm_vm_stack_element*
  64. frame_stack_top (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
  65. {
  66. switch (kind)
  67. {
  68. case SCM_VM_FRAME_KIND_CONT:
  69. {
  70. struct scm_vm_cont *cont = frame->stack_holder;
  71. return cont->stack_bottom + cont->stack_size;
  72. }
  73. case SCM_VM_FRAME_KIND_VM:
  74. return ((struct scm_vm *) frame->stack_holder)->stack_top;
  75. default:
  76. abort ();
  77. }
  78. }
  79. union scm_vm_stack_element*
  80. scm_i_frame_stack_top (SCM frame)
  81. #define FUNC_NAME "frame-stack-top"
  82. {
  83. SCM_VALIDATE_VM_FRAME (1, frame);
  84. return frame_stack_top (SCM_VM_FRAME_KIND (frame),
  85. SCM_VM_FRAME_DATA (frame));
  86. }
  87. #undef FUNC_NAME
  88. /* Scheme interface */
  89. SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
  90. (SCM obj),
  91. "")
  92. #define FUNC_NAME s_scm_frame_p
  93. {
  94. return scm_from_bool (SCM_VM_FRAME_P (obj));
  95. }
  96. #undef FUNC_NAME
  97. /* Retrieve the local in slot 0, which may or may not actually be a
  98. procedure, and may or may not actually be the procedure being
  99. applied. If you want the procedure, look it up from the IP. */
  100. SCM
  101. scm_c_frame_closure (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
  102. {
  103. union scm_vm_stack_element *fp, *sp;
  104. fp = frame_stack_top (kind, frame) - frame->fp_offset;
  105. sp = frame_stack_top (kind, frame) - frame->sp_offset;
  106. if (SCM_FRAME_NUM_LOCALS (fp, sp) > 0)
  107. return SCM_FRAME_LOCAL (fp, 0);
  108. return SCM_BOOL_F;
  109. }
  110. static SCM frame_procedure_name_var;
  111. static void
  112. init_frame_procedure_name_var (void)
  113. {
  114. frame_procedure_name_var
  115. = scm_c_private_lookup ("system vm frame", "frame-procedure-name");
  116. }
  117. SCM_DEFINE (scm_frame_procedure_name, "frame-procedure-name", 1, 0, 0,
  118. (SCM frame),
  119. "")
  120. #define FUNC_NAME s_scm_frame_procedure_name
  121. {
  122. static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
  123. scm_i_pthread_once (&once, init_frame_procedure_name_var);
  124. SCM_VALIDATE_VM_FRAME (1, frame);
  125. return scm_call_1 (scm_variable_ref (frame_procedure_name_var), frame);
  126. }
  127. #undef FUNC_NAME
  128. static SCM frame_arguments_var;
  129. static void
  130. init_frame_arguments_var (void)
  131. {
  132. frame_arguments_var
  133. = scm_c_private_lookup ("system vm frame", "frame-arguments");
  134. }
  135. SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
  136. (SCM frame),
  137. "")
  138. #define FUNC_NAME s_scm_frame_arguments
  139. {
  140. static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
  141. scm_i_pthread_once (&once, init_frame_arguments_var);
  142. SCM_VALIDATE_VM_FRAME (1, frame);
  143. return scm_call_1 (scm_variable_ref (frame_arguments_var), frame);
  144. }
  145. #undef FUNC_NAME
  146. static SCM frame_call_representation_var;
  147. static void
  148. init_frame_call_representation_var (void)
  149. {
  150. frame_call_representation_var
  151. = scm_c_private_lookup ("system vm frame", "frame-call-representation");
  152. }
  153. SCM scm_frame_call_representation (SCM frame)
  154. #define FUNC_NAME "frame-call-representation"
  155. {
  156. static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
  157. scm_i_pthread_once (&once, init_frame_call_representation_var);
  158. SCM_VALIDATE_VM_FRAME (1, frame);
  159. return scm_call_1 (scm_variable_ref (frame_call_representation_var), frame);
  160. }
  161. #undef FUNC_NAME
  162. SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
  163. (SCM frame),
  164. "")
  165. #define FUNC_NAME s_scm_frame_source
  166. {
  167. SCM_VALIDATE_VM_FRAME (1, frame);
  168. return scm_find_source_for_addr (scm_frame_instruction_pointer (frame));
  169. }
  170. #undef FUNC_NAME
  171. static const char s_scm_frame_num_locals[] = "frame-num-locals";
  172. static SCM
  173. scm_frame_num_locals (SCM frame)
  174. #define FUNC_NAME s_scm_frame_num_locals
  175. {
  176. union scm_vm_stack_element *fp, *sp;
  177. SCM_VALIDATE_VM_FRAME (1, frame);
  178. fp = SCM_VM_FRAME_FP (frame);
  179. sp = SCM_VM_FRAME_SP (frame);
  180. return scm_from_ptrdiff_t (SCM_FRAME_NUM_LOCALS (fp, sp));
  181. }
  182. #undef FUNC_NAME
  183. enum stack_item_representation
  184. {
  185. STACK_ITEM_SCM = 0,
  186. STACK_ITEM_F64 = 1,
  187. STACK_ITEM_U64 = 2,
  188. STACK_ITEM_S64 = 3,
  189. STACK_ITEM_PTR = 4
  190. };
  191. static enum stack_item_representation
  192. scm_to_stack_item_representation (SCM x, const char *subr, int pos)
  193. {
  194. if (scm_is_eq (x, scm_from_latin1_symbol ("scm")))
  195. return STACK_ITEM_SCM;
  196. if (scm_is_eq (x, scm_from_latin1_symbol ("f64")))
  197. return STACK_ITEM_F64;
  198. if (scm_is_eq (x, scm_from_latin1_symbol ("u64")))
  199. return STACK_ITEM_U64;
  200. if (scm_is_eq (x, scm_from_latin1_symbol ("s64")))
  201. return STACK_ITEM_S64;
  202. if (scm_is_eq (x, scm_from_latin1_symbol ("ptr")))
  203. return STACK_ITEM_PTR;
  204. scm_wrong_type_arg (subr, pos, x);
  205. return 0; /* Not reached. */
  206. }
  207. static const char s_scm_frame_local_ref[] = "frame-local-ref";
  208. static SCM
  209. scm_frame_local_ref (SCM frame, SCM index, SCM representation)
  210. #define FUNC_NAME s_scm_frame_local_ref
  211. {
  212. union scm_vm_stack_element *fp, *sp;
  213. unsigned int i;
  214. enum stack_item_representation repr;
  215. SCM_VALIDATE_VM_FRAME (1, frame);
  216. SCM_VALIDATE_UINT_COPY (2, index, i);
  217. repr = scm_to_stack_item_representation (representation, FUNC_NAME, SCM_ARG3);
  218. fp = SCM_VM_FRAME_FP (frame);
  219. sp = SCM_VM_FRAME_SP (frame);
  220. if (i < SCM_FRAME_NUM_LOCALS (fp, sp))
  221. {
  222. union scm_vm_stack_element *item = SCM_FRAME_SLOT (fp, i);
  223. switch (repr)
  224. {
  225. case STACK_ITEM_SCM:
  226. return item->as_scm;
  227. case STACK_ITEM_F64:
  228. return scm_from_double (item->as_f64);
  229. case STACK_ITEM_U64:
  230. return scm_from_uint64 (item->as_u64);
  231. case STACK_ITEM_S64:
  232. return scm_from_int64 (item->as_s64);
  233. case STACK_ITEM_PTR:
  234. return scm_from_uintptr_t (item->as_uint);
  235. default:
  236. abort();
  237. }
  238. }
  239. SCM_OUT_OF_RANGE (SCM_ARG2, index);
  240. }
  241. #undef FUNC_NAME
  242. static const char s_scm_frame_local_set_x[] = "frame-local-set!";
  243. static SCM
  244. scm_frame_local_set_x (SCM frame, SCM index, SCM val, SCM representation)
  245. #define FUNC_NAME s_scm_frame_local_set_x
  246. {
  247. union scm_vm_stack_element *fp, *sp;
  248. unsigned int i;
  249. enum stack_item_representation repr;
  250. SCM_VALIDATE_VM_FRAME (1, frame);
  251. SCM_VALIDATE_UINT_COPY (2, index, i);
  252. repr = scm_to_stack_item_representation (representation, FUNC_NAME, SCM_ARG3);
  253. fp = SCM_VM_FRAME_FP (frame);
  254. sp = SCM_VM_FRAME_SP (frame);
  255. if (i < SCM_FRAME_NUM_LOCALS (fp, sp))
  256. {
  257. union scm_vm_stack_element *item = SCM_FRAME_SLOT (fp, i);
  258. switch (repr)
  259. {
  260. case STACK_ITEM_SCM:
  261. item->as_scm = val;
  262. break;
  263. case STACK_ITEM_F64:
  264. item->as_f64 = scm_to_double (val);
  265. break;
  266. case STACK_ITEM_U64:
  267. item->as_u64 = scm_to_uint64 (val);
  268. break;
  269. case STACK_ITEM_S64:
  270. item->as_s64 = scm_to_int64 (val);
  271. break;
  272. case STACK_ITEM_PTR:
  273. item->as_uint = scm_to_uintptr_t (val);
  274. default:
  275. abort();
  276. }
  277. return SCM_UNSPECIFIED;
  278. }
  279. SCM_OUT_OF_RANGE (SCM_ARG2, index);
  280. }
  281. #undef FUNC_NAME
  282. static const char s_scm_frame_return_values[] = "frame-return-values";
  283. static SCM
  284. scm_frame_return_values (SCM frame)
  285. #define FUNC_NAME s_scm_frame_return_values
  286. {
  287. const uint32_t *ip;
  288. union scm_vm_stack_element *fp, *sp;
  289. SCM vals = SCM_EOL;
  290. size_t n;
  291. SCM_VALIDATE_VM_FRAME (1, frame);
  292. ip = SCM_VM_FRAME_IP (frame);
  293. fp = SCM_VM_FRAME_FP (frame);
  294. sp = SCM_VM_FRAME_SP (frame);
  295. if ((*ip & 0xff) != scm_op_return_values)
  296. scm_wrong_type_arg_msg (FUNC_NAME, 1, frame, "not a return frame");
  297. n = SCM_FRAME_NUM_LOCALS (fp, sp);
  298. while (n--)
  299. vals = scm_cons (SCM_FRAME_LOCAL (fp, n), vals);
  300. return vals;
  301. }
  302. #undef FUNC_NAME
  303. SCM_DEFINE (scm_frame_address, "frame-address", 1, 0, 0,
  304. (SCM frame),
  305. "Return the frame pointer for @var{frame}.")
  306. #define FUNC_NAME s_scm_frame_address
  307. {
  308. SCM_VALIDATE_VM_FRAME (1, frame);
  309. return scm_from_ptrdiff_t (SCM_VM_FRAME_FP_OFFSET (frame));
  310. }
  311. #undef FUNC_NAME
  312. SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer", 1, 0, 0,
  313. (SCM frame),
  314. "")
  315. #define FUNC_NAME s_scm_frame_stack_pointer
  316. {
  317. SCM_VALIDATE_VM_FRAME (1, frame);
  318. return scm_from_ptrdiff_t (SCM_VM_FRAME_SP_OFFSET (frame));
  319. }
  320. #undef FUNC_NAME
  321. SCM_DEFINE (scm_frame_instruction_pointer, "frame-instruction-pointer", 1, 0, 0,
  322. (SCM frame),
  323. "")
  324. #define FUNC_NAME s_scm_frame_instruction_pointer
  325. {
  326. SCM_VALIDATE_VM_FRAME (1, frame);
  327. return scm_from_uintptr_t ((uintptr_t) SCM_VM_FRAME_IP (frame));
  328. }
  329. #undef FUNC_NAME
  330. SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
  331. (SCM frame),
  332. "")
  333. #define FUNC_NAME s_scm_frame_return_address
  334. {
  335. SCM_VALIDATE_VM_FRAME (1, frame);
  336. return scm_from_uintptr_t ((uintptr_t) (SCM_FRAME_VIRTUAL_RETURN_ADDRESS
  337. (SCM_VM_FRAME_FP (frame))));
  338. }
  339. #undef FUNC_NAME
  340. SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
  341. (SCM frame),
  342. "")
  343. #define FUNC_NAME s_scm_frame_dynamic_link
  344. {
  345. SCM_VALIDATE_VM_FRAME (1, frame);
  346. /* fixme: munge fp if holder is a continuation */
  347. return scm_from_uintptr_t
  348. ((uintptr_t)
  349. SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame)));
  350. }
  351. #undef FUNC_NAME
  352. int
  353. scm_c_frame_previous (enum scm_vm_frame_kind kind, struct scm_frame *frame)
  354. {
  355. union scm_vm_stack_element *this_fp, *new_fp, *new_sp;
  356. union scm_vm_stack_element *stack_top = frame_stack_top (kind, frame);
  357. again:
  358. this_fp = stack_top - frame->fp_offset;
  359. if (this_fp == stack_top)
  360. return 0;
  361. new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
  362. if (new_fp >= stack_top)
  363. return 0;
  364. new_sp = SCM_FRAME_PREVIOUS_SP (this_fp);
  365. frame->fp_offset = stack_top - new_fp;
  366. frame->sp_offset = stack_top - new_sp;
  367. frame->ip = SCM_FRAME_VIRTUAL_RETURN_ADDRESS (this_fp);
  368. if (scm_i_vm_is_boot_continuation_code (frame->ip))
  369. goto again;
  370. return 1;
  371. }
  372. SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
  373. (SCM frame),
  374. "")
  375. #define FUNC_NAME s_scm_frame_previous
  376. {
  377. enum scm_vm_frame_kind kind;
  378. struct scm_frame tmp;
  379. SCM_VALIDATE_VM_FRAME (1, frame);
  380. kind = SCM_VM_FRAME_KIND (frame);
  381. memcpy (&tmp, SCM_VM_FRAME_DATA (frame), sizeof tmp);
  382. if (!scm_c_frame_previous (SCM_VM_FRAME_KIND (frame), &tmp))
  383. return SCM_BOOL_F;
  384. return scm_c_make_frame (kind, &tmp);
  385. }
  386. #undef FUNC_NAME
  387. static void
  388. scm_init_frames_builtins (void *unused)
  389. {
  390. scm_c_define_gsubr (s_scm_frame_num_locals, 1, 0, 0,
  391. (scm_t_subr) scm_frame_num_locals);
  392. scm_c_define_gsubr (s_scm_frame_local_ref, 3, 0, 0,
  393. (scm_t_subr) scm_frame_local_ref);
  394. scm_c_define_gsubr (s_scm_frame_local_set_x, 4, 0, 0,
  395. (scm_t_subr) scm_frame_local_set_x);
  396. scm_c_define_gsubr (s_scm_frame_return_values, 1, 0, 0,
  397. (scm_t_subr) scm_frame_return_values);
  398. }
  399. void
  400. scm_init_frames (void)
  401. {
  402. #ifndef SCM_MAGIC_SNARFER
  403. #include "frames.x"
  404. #endif
  405. scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
  406. "scm_init_frames_builtins",
  407. scm_init_frames_builtins,
  408. NULL);
  409. }