stacks.c 14 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478
  1. /* Copyright 1996-1997,2000-2001,2006-2015,2017-2019
  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. #ifdef HAVE_CONFIG_H
  16. # include <config.h>
  17. #endif
  18. #include "boolean.h"
  19. #include "continuations.h"
  20. #include "control.h"
  21. #include "debug.h"
  22. #include "eval.h"
  23. #include "fluids.h"
  24. #include "frames.h" /* vm frames */
  25. #include "gsubr.h"
  26. #include "list.h"
  27. #include "macros.h"
  28. #include "modules.h"
  29. #include "numbers.h"
  30. #include "pairs.h"
  31. #include "private-options.h"
  32. #include "procprop.h"
  33. #include "strings.h"
  34. #include "struct.h"
  35. #include "symbols.h"
  36. #include "threads.h"
  37. #include "vm.h" /* to capture vm stacks */
  38. #include "stacks.h"
  39. static SCM scm_sys_stacks;
  40. /* {Stacks}
  41. *
  42. * The stack is represented as a struct that holds a frame. The frame itself is
  43. * linked to the next frame, or #f.
  44. *
  45. * Stacks
  46. * Constructor
  47. * make-stack
  48. * Selectors
  49. * stack-id
  50. * stack-ref
  51. * Inspector
  52. * stack-length
  53. */
  54. /* Count number of debug info frames on a stack, beginning with FRAME.
  55. */
  56. static long
  57. stack_depth (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
  58. {
  59. struct scm_frame tmp;
  60. long n = 1;
  61. memcpy (&tmp, frame, sizeof tmp);
  62. while (scm_c_frame_previous (kind, &tmp))
  63. ++n;
  64. return n;
  65. }
  66. /* Narrow STACK by cutting away stackframes (mutatingly).
  67. *
  68. * Inner frames (most recent) are cut by advancing the frames pointer.
  69. * Outer frames are cut by decreasing the recorded length.
  70. *
  71. * Cut maximally INNER inner frames and OUTER outer frames using
  72. * the keys INNER_KEY and OUTER_KEY.
  73. *
  74. * Frames are cut away starting at the end points and moving towards
  75. * the center of the stack. The key is normally compared to the
  76. * operator in application frames. Frames up to and including the key
  77. * are cut.
  78. *
  79. * If INNER_KEY is #t a different scheme is used for inner frames:
  80. *
  81. * Frames up to but excluding the first source frame originating from
  82. * a user module are cut, except for possible application frames
  83. * between the user frame and the last system frame previously
  84. * encountered.
  85. */
  86. static ptrdiff_t
  87. find_prompt (SCM key)
  88. {
  89. ptrdiff_t fp_offset;
  90. if (!scm_dynstack_find_prompt (&SCM_I_CURRENT_THREAD->dynstack, key,
  91. NULL, &fp_offset, NULL, NULL, NULL, NULL))
  92. scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack",
  93. scm_list_1 (key));
  94. return fp_offset;
  95. }
  96. static long
  97. narrow_stack (long len, enum scm_vm_frame_kind kind, struct scm_frame *frame,
  98. SCM inner_cut, SCM outer_cut)
  99. {
  100. /* Resolve procedure cuts to address ranges, if possible. If the
  101. debug information has been stripped, this might not be
  102. possible. */
  103. if (scm_is_true (scm_program_p (inner_cut)))
  104. {
  105. SCM addr_range = scm_program_address_range (inner_cut);
  106. if (scm_is_pair (addr_range))
  107. inner_cut = addr_range;
  108. }
  109. if (scm_is_true (scm_program_p (outer_cut)))
  110. {
  111. SCM addr_range = scm_program_address_range (outer_cut);
  112. if (scm_is_pair (addr_range))
  113. outer_cut = addr_range;
  114. }
  115. /* Cut inner part. */
  116. if (scm_is_true (scm_procedure_p (inner_cut)))
  117. {
  118. /* Cut until the given procedure is seen. */
  119. for (; len ;)
  120. {
  121. SCM proc = scm_c_frame_closure (kind, frame);
  122. len--;
  123. scm_c_frame_previous (kind, frame);
  124. if (scm_is_eq (proc, inner_cut))
  125. break;
  126. }
  127. }
  128. else if (scm_is_pair (inner_cut)
  129. && scm_is_integer (scm_car (inner_cut))
  130. && scm_is_integer (scm_cdr (inner_cut)))
  131. {
  132. /* Cut until an IP within the given range is found. */
  133. uintptr_t low_pc, high_pc, pc;
  134. low_pc = scm_to_uintptr_t (scm_car (inner_cut));
  135. high_pc = scm_to_uintptr_t (scm_cdr (inner_cut));
  136. for (; len ;)
  137. {
  138. pc = (uintptr_t) frame->ip;
  139. len--;
  140. scm_c_frame_previous (kind, frame);
  141. if (low_pc <= pc && pc < high_pc)
  142. break;
  143. }
  144. }
  145. else if (scm_is_integer (inner_cut))
  146. {
  147. /* Cut specified number of frames. */
  148. long inner = scm_to_int (inner_cut);
  149. for (; inner && len; --inner)
  150. {
  151. len--;
  152. scm_c_frame_previous (kind, frame);
  153. }
  154. }
  155. else
  156. {
  157. /* Cut until the given prompt tag is seen. */
  158. ptrdiff_t fp_offset = find_prompt (inner_cut);
  159. for (; len; len--, scm_c_frame_previous (kind, frame))
  160. if (fp_offset == frame->fp_offset)
  161. break;
  162. }
  163. /* Cut outer part. */
  164. if (scm_is_true (scm_procedure_p (outer_cut)))
  165. {
  166. long i, new_len;
  167. struct scm_frame tmp;
  168. memcpy (&tmp, frame, sizeof tmp);
  169. /* Cut until the given procedure is seen. */
  170. for (new_len = i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
  171. if (scm_is_eq (scm_c_frame_closure (kind, &tmp), outer_cut))
  172. new_len = i;
  173. len = new_len;
  174. }
  175. else if (scm_is_pair (outer_cut)
  176. && scm_is_integer (scm_car (outer_cut))
  177. && scm_is_integer (scm_cdr (outer_cut)))
  178. {
  179. /* Cut until an IP within the given range is found. */
  180. uintptr_t low_pc, high_pc, pc;
  181. long i, new_len;
  182. struct scm_frame tmp;
  183. low_pc = scm_to_uintptr_t (scm_car (outer_cut));
  184. high_pc = scm_to_uintptr_t (scm_cdr (outer_cut));
  185. memcpy (&tmp, frame, sizeof tmp);
  186. /* Cut until the given procedure is seen. */
  187. for (new_len = i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
  188. {
  189. pc = (uintptr_t) tmp.ip;
  190. if (low_pc <= pc && pc < high_pc)
  191. new_len = i;
  192. }
  193. len = new_len;
  194. }
  195. else if (scm_is_integer (outer_cut))
  196. {
  197. /* Cut specified number of frames. */
  198. long outer = scm_to_int (outer_cut);
  199. if (outer < len)
  200. len -= outer;
  201. else
  202. len = 0;
  203. }
  204. else
  205. {
  206. /* Cut until the given prompt tag is seen. */
  207. long i;
  208. struct scm_frame tmp;
  209. ptrdiff_t fp_offset = find_prompt (outer_cut);
  210. memcpy (&tmp, frame, sizeof tmp);
  211. for (i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
  212. if (tmp.fp_offset == fp_offset)
  213. break;
  214. if (i < len)
  215. len = i;
  216. else
  217. len = 0;
  218. }
  219. return len;
  220. }
  221. /* Stacks
  222. */
  223. SCM scm_stack_type;
  224. SCM_DEFINE (scm_stack_p, "stack?", 1, 0, 0,
  225. (SCM obj),
  226. "Return @code{#t} if @var{obj} is a calling stack.")
  227. #define FUNC_NAME s_scm_stack_p
  228. {
  229. return scm_from_bool(SCM_STACKP (obj));
  230. }
  231. #undef FUNC_NAME
  232. SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
  233. (SCM obj, SCM args),
  234. "Create a new stack. If @var{obj} is @code{#t}, the current\n"
  235. "evaluation stack is used for creating the stack frames,\n"
  236. "otherwise the frames are taken from @var{obj} (which must be\n"
  237. "a continuation or a frame object).\n"
  238. "\n"
  239. "@var{args} should be a list containing any combination of\n"
  240. "integer, procedure, address range, prompt tag and @code{#t}\n"
  241. "values.\n"
  242. "\n"
  243. "These values specify various ways of cutting away uninteresting\n"
  244. "stack frames from the top and bottom of the stack that\n"
  245. "@code{make-stack} returns. They come in pairs like this:\n"
  246. "@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n"
  247. "@var{outer_cut_2} @dots{})}.\n"
  248. "\n"
  249. "Each @var{inner_cut_i} can be an integer, a procedure, an\n"
  250. "address range, or a prompt tag. An integer means to cut away\n"
  251. "exactly that number of frames. A procedure means to cut\n"
  252. "away all frames up to but excluding the frame whose procedure\n"
  253. "matches the specified one. An address range is a pair of\n"
  254. "integers indicating the low and high addresses of a procedure's\n"
  255. "code, and is the same as cutting away to a procedure (though\n"
  256. "with less work). Anything else is interpreted as a prompt tag\n"
  257. "which cuts away all frames that are inside a prompt with the\n"
  258. "given tag.\n"
  259. "\n"
  260. "Each @var{outer_cut_i} can be an integer, a procedure, an\n"
  261. "address range, or a prompt tag. An integer means to cut away\n"
  262. "that number of frames. A procedure means to cut away frames\n"
  263. "down to but excluding the frame whose procedure matches the\n"
  264. "specified one. An address range is the same, but with the\n"
  265. "procedure's code specified as an address range. Anything else\n"
  266. "is taken to be a prompt tag, which cuts away all frames that are\n"
  267. "outside a prompt with the given tag.\n"
  268. "\n"
  269. "If the @var{outer_cut_i} of the last pair is missing, it is\n"
  270. "taken as 0.")
  271. #define FUNC_NAME s_scm_make_stack
  272. {
  273. long n;
  274. SCM inner_cut, outer_cut;
  275. enum scm_vm_frame_kind kind;
  276. struct scm_frame frame;
  277. /* Extract a pointer to the innermost frame of whatever object
  278. scm_make_stack was given. */
  279. if (scm_is_eq (obj, SCM_BOOL_T))
  280. {
  281. SCM cont;
  282. struct scm_vm_cont *c;
  283. cont = scm_i_capture_current_stack ();
  284. c = SCM_VM_CONT_DATA (cont);
  285. kind = SCM_VM_FRAME_KIND_CONT;
  286. frame.stack_holder = c;
  287. frame.fp_offset = c->fp_offset;
  288. frame.sp_offset = c->stack_size;
  289. frame.ip = c->vra;
  290. }
  291. else if (SCM_VM_FRAME_P (obj))
  292. {
  293. kind = SCM_VM_FRAME_KIND (obj);
  294. memcpy (&frame, SCM_VM_FRAME_DATA (obj), sizeof frame);
  295. }
  296. else if (SCM_CONTINUATIONP (obj))
  297. /* FIXME: Narrowing to prompt tags should narrow with respect to the prompts
  298. that were in place when the continuation was captured. */
  299. {
  300. kind = SCM_VM_FRAME_KIND_CONT;
  301. if (!scm_i_continuation_to_frame (obj, &frame))
  302. return SCM_BOOL_F;
  303. }
  304. else if (SCM_PROGRAM_P (obj) && SCM_PROGRAM_IS_PARTIAL_CONTINUATION (obj))
  305. {
  306. kind = SCM_VM_FRAME_KIND_CONT;
  307. if (!scm_i_vm_cont_to_frame (SCM_PROGRAM_FREE_VARIABLE_REF (obj, 0),
  308. &frame))
  309. return SCM_BOOL_F;
  310. }
  311. else
  312. {
  313. SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
  314. /* not reached */
  315. }
  316. /* Skip initial boot frame, if any. This is possible if the frame
  317. originates from a captured continuation. */
  318. if (scm_i_vm_is_boot_continuation_code (frame.ip)
  319. && !scm_c_frame_previous (kind, &frame))
  320. return SCM_BOOL_F;
  321. /* Count number of frames. Also get stack id tag and check whether
  322. there are more stackframes than we want to record
  323. (SCM_BACKTRACE_MAXDEPTH). */
  324. n = stack_depth (kind, &frame);
  325. /* Narrow the stack according to the arguments given to scm_make_stack. */
  326. SCM_VALIDATE_REST_ARGUMENT (args);
  327. while (n > 0 && !scm_is_null (args))
  328. {
  329. inner_cut = SCM_CAR (args);
  330. args = SCM_CDR (args);
  331. if (scm_is_null (args))
  332. {
  333. outer_cut = SCM_INUM0;
  334. }
  335. else
  336. {
  337. outer_cut = SCM_CAR (args);
  338. args = SCM_CDR (args);
  339. }
  340. n = narrow_stack (n, kind, &frame, inner_cut, outer_cut);
  341. }
  342. if (n > 0)
  343. {
  344. /* Make the stack object. */
  345. SCM stack = scm_make_struct_no_tail (scm_stack_type, SCM_EOL);
  346. SCM_SET_STACK_LENGTH (stack, n);
  347. SCM_SET_STACK_ID (stack, scm_stack_id (obj));
  348. SCM_SET_STACK_FRAME (stack, scm_c_make_frame (kind, &frame));
  349. return stack;
  350. }
  351. else
  352. return SCM_BOOL_F;
  353. }
  354. #undef FUNC_NAME
  355. SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
  356. (SCM stack),
  357. "Return the identifier given to @var{stack} by @code{start-stack}.")
  358. #define FUNC_NAME s_scm_stack_id
  359. {
  360. if (scm_is_eq (stack, SCM_BOOL_T)
  361. /* FIXME: frame case assumes frame still live on the stack, and no
  362. intervening start-stack. Hmm... */
  363. || SCM_VM_FRAME_P (stack))
  364. {
  365. /* Fetch most recent start-stack tag. */
  366. SCM stacks = scm_fluid_ref (scm_sys_stacks);
  367. return scm_is_pair (stacks) ? scm_car (stacks) : SCM_BOOL_F;
  368. }
  369. else if (SCM_CONTINUATIONP (stack))
  370. /* FIXME: implement me */
  371. return SCM_BOOL_F;
  372. else if (SCM_PROGRAM_P (stack) && SCM_PROGRAM_IS_PARTIAL_CONTINUATION (stack))
  373. /* FIXME: implement me */
  374. return SCM_BOOL_F;
  375. else
  376. {
  377. SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
  378. /* not reached */
  379. }
  380. }
  381. #undef FUNC_NAME
  382. SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
  383. (SCM stack, SCM index),
  384. "Return the @var{index}'th frame from @var{stack}.")
  385. #define FUNC_NAME s_scm_stack_ref
  386. {
  387. unsigned long int c_index;
  388. SCM frame;
  389. SCM_VALIDATE_STACK (1, stack);
  390. c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1);
  391. frame = SCM_STACK_FRAME (stack);
  392. while (c_index--)
  393. frame = scm_frame_previous (frame);
  394. return frame;
  395. }
  396. #undef FUNC_NAME
  397. SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
  398. (SCM stack),
  399. "Return the length of @var{stack}.")
  400. #define FUNC_NAME s_scm_stack_length
  401. {
  402. SCM_VALIDATE_STACK (1, stack);
  403. return scm_from_long (SCM_STACK_LENGTH (stack));
  404. }
  405. #undef FUNC_NAME
  406. void
  407. scm_init_stacks ()
  408. {
  409. scm_sys_stacks = scm_make_thread_local_fluid (SCM_BOOL_F);
  410. scm_c_define ("%stacks", scm_sys_stacks);
  411. scm_stack_type = scm_make_vtable (scm_from_utf8_string (SCM_STACK_LAYOUT),
  412. SCM_UNDEFINED);
  413. scm_set_struct_vtable_name_x (scm_stack_type,
  414. scm_from_utf8_symbol ("stack"));
  415. #include "stacks.x"
  416. }