frames.c 9.5 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390
  1. /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014, 2015 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. #if HAVE_CONFIG_H
  19. # include <config.h>
  20. #endif
  21. #include <stdlib.h>
  22. #include <string.h>
  23. #include "_scm.h"
  24. #include "frames.h"
  25. #include "vm.h"
  26. SCM
  27. scm_c_make_frame (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
  28. {
  29. struct scm_frame *p = scm_gc_malloc (sizeof (struct scm_frame),
  30. "vmframe");
  31. p->stack_holder = frame->stack_holder;
  32. p->fp_offset = frame->fp_offset;
  33. p->sp_offset = frame->sp_offset;
  34. p->ip = frame->ip;
  35. return scm_cell (scm_tc7_frame | (kind << 8), (scm_t_bits)p);
  36. }
  37. void
  38. scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
  39. {
  40. scm_puts_unlocked ("#<frame ", port);
  41. scm_uintprint (SCM_UNPACK (frame), 16, port);
  42. scm_putc_unlocked (' ', port);
  43. scm_write (scm_frame_procedure (frame), port);
  44. /* don't write args, they can get us into trouble. */
  45. scm_puts_unlocked (">", port);
  46. }
  47. static union scm_vm_stack_element*
  48. frame_stack_top (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
  49. {
  50. switch (kind)
  51. {
  52. case SCM_VM_FRAME_KIND_CONT:
  53. {
  54. struct scm_vm_cont *cont = frame->stack_holder;
  55. return cont->stack_bottom + cont->stack_size;
  56. }
  57. case SCM_VM_FRAME_KIND_VM:
  58. return ((struct scm_vm *) frame->stack_holder)->stack_top;
  59. default:
  60. abort ();
  61. }
  62. }
  63. static scm_t_ptrdiff
  64. frame_offset (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
  65. {
  66. switch (kind)
  67. {
  68. case SCM_VM_FRAME_KIND_CONT:
  69. return ((struct scm_vm_cont *) frame->stack_holder)->reloc;
  70. case SCM_VM_FRAME_KIND_VM:
  71. return 0;
  72. default:
  73. abort ();
  74. }
  75. }
  76. union scm_vm_stack_element*
  77. scm_i_frame_stack_top (SCM frame)
  78. #define FUNC_NAME "frame-stack-top"
  79. {
  80. SCM_VALIDATE_VM_FRAME (1, frame);
  81. return frame_stack_top (SCM_VM_FRAME_KIND (frame),
  82. SCM_VM_FRAME_DATA (frame));
  83. }
  84. #undef FUNC_NAME
  85. scm_t_ptrdiff
  86. scm_i_frame_offset (SCM frame)
  87. #define FUNC_NAME "frame-offset"
  88. {
  89. SCM_VALIDATE_VM_FRAME (1, frame);
  90. return frame_offset (SCM_VM_FRAME_KIND (frame),
  91. SCM_VM_FRAME_DATA (frame));
  92. }
  93. #undef FUNC_NAME
  94. /* Scheme interface */
  95. SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
  96. (SCM obj),
  97. "")
  98. #define FUNC_NAME s_scm_frame_p
  99. {
  100. return scm_from_bool (SCM_VM_FRAME_P (obj));
  101. }
  102. #undef FUNC_NAME
  103. /* Retrieve the local in slot 0, which may or may not actually be a
  104. procedure, and may or may not actually be the procedure being
  105. applied. If you want the procedure, look it up from the IP. */
  106. SCM
  107. scm_c_frame_closure (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
  108. {
  109. union scm_vm_stack_element *fp, *sp;
  110. fp = frame_stack_top (kind, frame) - frame->fp_offset;
  111. sp = frame_stack_top (kind, frame) - frame->sp_offset;
  112. if (SCM_FRAME_NUM_LOCALS (fp, sp) > 0)
  113. return SCM_FRAME_LOCAL (fp, 0);
  114. return SCM_BOOL_F;
  115. }
  116. SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
  117. (SCM frame),
  118. "")
  119. #define FUNC_NAME s_scm_frame_procedure
  120. {
  121. SCM_VALIDATE_VM_FRAME (1, frame);
  122. /* FIXME: Retrieve procedure from address? */
  123. return scm_c_frame_closure (SCM_VM_FRAME_KIND (frame),
  124. SCM_VM_FRAME_DATA (frame));
  125. }
  126. #undef FUNC_NAME
  127. static SCM frame_arguments_var;
  128. static void
  129. init_frame_arguments_var (void)
  130. {
  131. frame_arguments_var
  132. = scm_c_private_lookup ("system vm frame", "frame-arguments");
  133. }
  134. SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
  135. (SCM frame),
  136. "")
  137. #define FUNC_NAME s_scm_frame_arguments
  138. {
  139. static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
  140. scm_i_pthread_once (&once, init_frame_arguments_var);
  141. SCM_VALIDATE_VM_FRAME (1, frame);
  142. return scm_call_1 (scm_variable_ref (frame_arguments_var), frame);
  143. }
  144. #undef FUNC_NAME
  145. static SCM frame_call_representation_var;
  146. static void
  147. init_frame_call_representation_var (void)
  148. {
  149. frame_call_representation_var
  150. = scm_c_private_lookup ("system vm frame", "frame-call-representation");
  151. }
  152. SCM scm_frame_call_representation (SCM frame)
  153. #define FUNC_NAME "frame-call-representation"
  154. {
  155. static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
  156. scm_i_pthread_once (&once, init_frame_call_representation_var);
  157. SCM_VALIDATE_VM_FRAME (1, frame);
  158. return scm_call_1 (scm_variable_ref (frame_call_representation_var), frame);
  159. }
  160. #undef FUNC_NAME
  161. SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
  162. (SCM frame),
  163. "")
  164. #define FUNC_NAME s_scm_frame_source
  165. {
  166. SCM_VALIDATE_VM_FRAME (1, frame);
  167. return scm_find_source_for_addr (scm_frame_instruction_pointer (frame));
  168. }
  169. #undef FUNC_NAME
  170. SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0,
  171. (SCM frame),
  172. "")
  173. #define FUNC_NAME s_scm_frame_num_locals
  174. {
  175. union scm_vm_stack_element *fp, *sp;
  176. SCM_VALIDATE_VM_FRAME (1, frame);
  177. fp = SCM_VM_FRAME_FP (frame);
  178. sp = SCM_VM_FRAME_SP (frame);
  179. return scm_from_ptrdiff_t (SCM_FRAME_NUM_LOCALS (fp, sp));
  180. }
  181. #undef FUNC_NAME
  182. SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
  183. (SCM frame, SCM index),
  184. "")
  185. #define FUNC_NAME s_scm_frame_local_ref
  186. {
  187. union scm_vm_stack_element *fp, *sp;
  188. unsigned int i;
  189. SCM_VALIDATE_VM_FRAME (1, frame);
  190. SCM_VALIDATE_UINT_COPY (2, index, i);
  191. fp = SCM_VM_FRAME_FP (frame);
  192. sp = SCM_VM_FRAME_SP (frame);
  193. if (i < SCM_FRAME_NUM_LOCALS (fp, sp))
  194. return SCM_FRAME_LOCAL (fp, i);
  195. SCM_OUT_OF_RANGE (SCM_ARG2, index);
  196. }
  197. #undef FUNC_NAME
  198. /* Need same not-yet-active frame logic here as in frame-num-locals */
  199. SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
  200. (SCM frame, SCM index, SCM val),
  201. "")
  202. #define FUNC_NAME s_scm_frame_local_set_x
  203. {
  204. union scm_vm_stack_element *fp, *sp;
  205. unsigned int i;
  206. SCM_VALIDATE_VM_FRAME (1, frame);
  207. SCM_VALIDATE_UINT_COPY (2, index, i);
  208. fp = SCM_VM_FRAME_FP (frame);
  209. sp = SCM_VM_FRAME_SP (frame);
  210. if (i < SCM_FRAME_NUM_LOCALS (fp, sp))
  211. {
  212. SCM_FRAME_LOCAL (fp, i) = val;
  213. return SCM_UNSPECIFIED;
  214. }
  215. SCM_OUT_OF_RANGE (SCM_ARG2, index);
  216. }
  217. #undef FUNC_NAME
  218. SCM_DEFINE (scm_frame_address, "frame-address", 1, 0, 0,
  219. (SCM frame),
  220. "Return the frame pointer for @var{frame}.")
  221. #define FUNC_NAME s_scm_frame_address
  222. {
  223. SCM_VALIDATE_VM_FRAME (1, frame);
  224. return scm_from_ptrdiff_t (SCM_VM_FRAME_FP_OFFSET (frame));
  225. }
  226. #undef FUNC_NAME
  227. SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer", 1, 0, 0,
  228. (SCM frame),
  229. "")
  230. #define FUNC_NAME s_scm_frame_stack_pointer
  231. {
  232. SCM_VALIDATE_VM_FRAME (1, frame);
  233. return scm_from_ptrdiff_t (SCM_VM_FRAME_SP_OFFSET (frame));
  234. }
  235. #undef FUNC_NAME
  236. SCM_DEFINE (scm_frame_instruction_pointer, "frame-instruction-pointer", 1, 0, 0,
  237. (SCM frame),
  238. "")
  239. #define FUNC_NAME s_scm_frame_instruction_pointer
  240. {
  241. SCM_VALIDATE_VM_FRAME (1, frame);
  242. return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_IP (frame));
  243. }
  244. #undef FUNC_NAME
  245. SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
  246. (SCM frame),
  247. "")
  248. #define FUNC_NAME s_scm_frame_return_address
  249. {
  250. SCM_VALIDATE_VM_FRAME (1, frame);
  251. return scm_from_uintptr_t ((scm_t_uintptr) (SCM_FRAME_RETURN_ADDRESS
  252. (SCM_VM_FRAME_FP (frame))));
  253. }
  254. #undef FUNC_NAME
  255. SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
  256. (SCM frame),
  257. "")
  258. #define FUNC_NAME s_scm_frame_dynamic_link
  259. {
  260. SCM_VALIDATE_VM_FRAME (1, frame);
  261. /* fixme: munge fp if holder is a continuation */
  262. return scm_from_uintptr_t
  263. ((scm_t_uintptr)
  264. SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame)));
  265. }
  266. #undef FUNC_NAME
  267. int
  268. scm_c_frame_previous (enum scm_vm_frame_kind kind, struct scm_frame *frame)
  269. {
  270. union scm_vm_stack_element *this_fp, *new_fp, *new_sp;
  271. union scm_vm_stack_element *stack_top = frame_stack_top (kind, frame);
  272. again:
  273. this_fp = stack_top - frame->fp_offset;
  274. if (this_fp == stack_top)
  275. return 0;
  276. new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
  277. if (new_fp >= stack_top)
  278. return 0;
  279. new_sp = SCM_FRAME_PREVIOUS_SP (this_fp);
  280. frame->fp_offset = stack_top - new_fp;
  281. frame->sp_offset = stack_top - new_sp;
  282. frame->ip = SCM_FRAME_RETURN_ADDRESS (this_fp);
  283. {
  284. SCM proc = scm_c_frame_closure (kind, frame);
  285. if (SCM_PROGRAM_P (proc) && SCM_PROGRAM_IS_BOOT (proc))
  286. goto again;
  287. }
  288. return 1;
  289. }
  290. SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
  291. (SCM frame),
  292. "")
  293. #define FUNC_NAME s_scm_frame_previous
  294. {
  295. enum scm_vm_frame_kind kind;
  296. struct scm_frame tmp;
  297. SCM_VALIDATE_VM_FRAME (1, frame);
  298. kind = SCM_VM_FRAME_KIND (frame);
  299. memcpy (&tmp, SCM_VM_FRAME_DATA (frame), sizeof tmp);
  300. if (!scm_c_frame_previous (SCM_VM_FRAME_KIND (frame), &tmp))
  301. return SCM_BOOL_F;
  302. return scm_c_make_frame (kind, &tmp);
  303. }
  304. #undef FUNC_NAME
  305. void
  306. scm_init_frames (void)
  307. {
  308. #ifndef SCM_MAGIC_SNARFER
  309. #include "libguile/frames.x"
  310. #endif
  311. }
  312. /*
  313. Local Variables:
  314. c-file-style: "gnu"
  315. End:
  316. */