aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorStefan Monnier2013-06-03 05:01:53 -0400
committerStefan Monnier2013-06-03 05:01:53 -0400
commit2f592f95d2344d4a28eb946848330dca49e0f5ee (patch)
treea920b413f4367d49b7f7feeb3fdf63c5e9018dcb
parente5e4a94293d5a9a157557e53b4fea4e5d280673e (diff)
downloademacs-2f592f95d2344d4a28eb946848330dca49e0f5ee.tar.gz
emacs-2f592f95d2344d4a28eb946848330dca49e0f5ee.zip
Merge the specpdl and backtrace stacks. Make the structure of the
specpdl entries more obvious via a tagged union of structs. * src/lisp.h (BITS_PER_PTRDIFF_T): New constant. (enum specbind_tag): New enum. (struct specbinding): Make it a tagged union of structs. Add a case for backtrace records. (specpdl_symbol, specpdl_old_value, specpdl_where, specpdl_arg) (specpdl_func, backtrace_function, backtrace_nargs, backtrace_args) (backtrace_debug_on_exit): New accessors. (struct backtrace): Remove. (struct catchtag): Remove backlist field. * src/data.c (let_shadows_buffer_binding_p, let_shadows_global_binding_p): Move to eval.c. (Flocal_variable_p): Speed up the common case where the binding is already loaded. * src/eval.c (backtrace_list): Remove. (set_specpdl_symbol, set_specpdl_old_value): Remove. (set_backtrace_args, set_backtrace_nargs) (set_backtrace_debug_on_exit, backtrace_p, backtrace_top) (backtrace_next): New functions. (Fdefvaralias, Fdefvar): Adjust to new specpdl format. (unwind_to_catch, internal_lisp_condition_case) (internal_condition_case, internal_condition_case_1) (internal_condition_case_2, internal_condition_case_n): Don't bother with backtrace_list any more. (Fsignal): Adjust to new backtrace format. (grow_specpdl): Move up. (record_in_backtrace): New function. (eval_sub, Ffuncall): Use it. (apply_lambda): Adjust to new backtrace format. (let_shadows_buffer_binding_p, let_shadows_global_binding_p): Move from data.c. (specbind): Adjust to new specpdl format. Simplify. (record_unwind_protect, unbind_to): Adjust to new specpdl format. (Fbacktrace_debug, Fbacktrace, Fbacktrace_frame): Adjust to new backtrace format. (mark_backtrace): Remove. (mark_specpdl, get_backtrace, backtrace_top_function): New functions. * src/xdisp.c (redisplay_internal): Use record_in_backtrace. * src/alloc.c (Fgarbage_collect): Use record_in_backtrace. Use mark_specpdl. * src/profiler.c (record_backtrace): Use get_backtrace. (handle_profiler_signal): Use backtrace_top_function. * src/.gdbinit (xbacktrace, hookpost-backtrace): Use new backtrace accessor functions.
-rw-r--r--src/.gdbinit21
-rw-r--r--src/ChangeLog48
-rw-r--r--src/alloc.c17
-rw-r--r--src/data.c57
-rw-r--r--src/eval.c478
-rw-r--r--src/lisp.h105
-rw-r--r--src/profiler.c17
-rw-r--r--src/xdisp.c9
8 files changed, 421 insertions, 331 deletions
diff --git a/src/.gdbinit b/src/.gdbinit
index c4604e6e2b0..1bfc293c466 100644
--- a/src/.gdbinit
+++ b/src/.gdbinit
@@ -1150,17 +1150,18 @@ Print $ assuming it is a list font (font-spec, font-entity, or font-object).
1150end 1150end
1151 1151
1152define xbacktrace 1152define xbacktrace
1153 set $bt = backtrace_list 1153 set $bt = backtrace_top ()
1154 while $bt 1154 while backtrace_p ($bt)
1155 xgettype ($bt->function) 1155 set $fun = backtrace_function ($bt)
1156 xgettype $fun
1156 if $type == Lisp_Symbol 1157 if $type == Lisp_Symbol
1157 xprintsym ($bt->function) 1158 xprintsym $fun
1158 printf " (0x%x)\n", $bt->args 1159 printf " (0x%x)\n", backtrace_args ($bt)
1159 else 1160 else
1160 xgetptr $bt->function 1161 xgetptr $fun
1161 printf "0x%x ", $ptr 1162 printf "0x%x ", $ptr
1162 if $type == Lisp_Vectorlike 1163 if $type == Lisp_Vectorlike
1163 xgetptr ($bt->function) 1164 xgetptr $fun
1164 set $size = ((struct Lisp_Vector *) $ptr)->header.size 1165 set $size = ((struct Lisp_Vector *) $ptr)->header.size
1165 if ($size & PSEUDOVECTOR_FLAG) 1166 if ($size & PSEUDOVECTOR_FLAG)
1166 output (enum pvec_type) (($size & PVEC_TYPE_MASK) >> PSEUDOVECTOR_AREA_BITS) 1167 output (enum pvec_type) (($size & PVEC_TYPE_MASK) >> PSEUDOVECTOR_AREA_BITS)
@@ -1172,7 +1173,7 @@ define xbacktrace
1172 end 1173 end
1173 echo \n 1174 echo \n
1174 end 1175 end
1175 set $bt = $bt->next 1176 set $bt = backtrace_next ($bt)
1176 end 1177 end
1177end 1178end
1178document xbacktrace 1179document xbacktrace
@@ -1220,8 +1221,8 @@ end
1220 1221
1221# Show Lisp backtrace after normal backtrace. 1222# Show Lisp backtrace after normal backtrace.
1222define hookpost-backtrace 1223define hookpost-backtrace
1223 set $bt = backtrace_list 1224 set $bt = backtrace_top ()
1224 if $bt 1225 if backtrace_p ($bt)
1225 echo \n 1226 echo \n
1226 echo Lisp Backtrace:\n 1227 echo Lisp Backtrace:\n
1227 xbacktrace 1228 xbacktrace
diff --git a/src/ChangeLog b/src/ChangeLog
index a7791444e09..41687e07593 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,51 @@
12013-06-03 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 Merge the specpdl and backtrace stacks. Make the structure of the
4 specpdl entries more obvious via a tagged union of structs.
5 * lisp.h (BITS_PER_PTRDIFF_T): New constant.
6 (enum specbind_tag): New enum.
7 (struct specbinding): Make it a tagged union of structs.
8 Add a case for backtrace records.
9 (specpdl_symbol, specpdl_old_value, specpdl_where, specpdl_arg)
10 (specpdl_func, backtrace_function, backtrace_nargs, backtrace_args)
11 (backtrace_debug_on_exit): New accessors.
12 (struct backtrace): Remove.
13 (struct catchtag): Remove backlist field.
14 * data.c (let_shadows_buffer_binding_p, let_shadows_global_binding_p):
15 Move to eval.c.
16 (Flocal_variable_p): Speed up the common case where the binding is
17 already loaded.
18 * eval.c (backtrace_list): Remove.
19 (set_specpdl_symbol, set_specpdl_old_value): Remove.
20 (set_backtrace_args, set_backtrace_nargs)
21 (set_backtrace_debug_on_exit, backtrace_p, backtrace_top)
22 (backtrace_next): New functions.
23 (Fdefvaralias, Fdefvar): Adjust to new specpdl format.
24 (unwind_to_catch, internal_lisp_condition_case)
25 (internal_condition_case, internal_condition_case_1)
26 (internal_condition_case_2, internal_condition_case_n): Don't bother
27 with backtrace_list any more.
28 (Fsignal): Adjust to new backtrace format.
29 (grow_specpdl): Move up.
30 (record_in_backtrace): New function.
31 (eval_sub, Ffuncall): Use it.
32 (apply_lambda): Adjust to new backtrace format.
33 (let_shadows_buffer_binding_p, let_shadows_global_binding_p): Move from
34 data.c.
35 (specbind): Adjust to new specpdl format. Simplify.
36 (record_unwind_protect, unbind_to): Adjust to new specpdl format.
37 (Fbacktrace_debug, Fbacktrace, Fbacktrace_frame): Adjust to new
38 backtrace format.
39 (mark_backtrace): Remove.
40 (mark_specpdl, get_backtrace, backtrace_top_function): New functions.
41 * xdisp.c (redisplay_internal): Use record_in_backtrace.
42 * alloc.c (Fgarbage_collect): Use record_in_backtrace.
43 Use mark_specpdl.
44 * profiler.c (record_backtrace): Use get_backtrace.
45 (handle_profiler_signal): Use backtrace_top_function.
46 * .gdbinit (xbacktrace, hookpost-backtrace): Use new backtrace
47 accessor functions.
48
12013-06-02 Jan Djärv <jan.h.d@swipnet.se> 492013-06-02 Jan Djärv <jan.h.d@swipnet.se>
2 50
3 * process.h (catch_child_signal): Declare. 51 * process.h (catch_child_signal): Declare.
diff --git a/src/alloc.c b/src/alloc.c
index 7a56c78e2ba..cce0fff4fd4 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -5165,7 +5165,6 @@ returns nil, because real GC can't be done.
5165See Info node `(elisp)Garbage Collection'. */) 5165See Info node `(elisp)Garbage Collection'. */)
5166 (void) 5166 (void)
5167{ 5167{
5168 struct specbinding *bind;
5169 struct buffer *nextb; 5168 struct buffer *nextb;
5170 char stack_top_variable; 5169 char stack_top_variable;
5171 ptrdiff_t i; 5170 ptrdiff_t i;
@@ -5174,7 +5173,6 @@ See Info node `(elisp)Garbage Collection'. */)
5174 EMACS_TIME start; 5173 EMACS_TIME start;
5175 Lisp_Object retval = Qnil; 5174 Lisp_Object retval = Qnil;
5176 size_t tot_before = 0; 5175 size_t tot_before = 0;
5177 struct backtrace backtrace;
5178 5176
5179 if (abort_on_gc) 5177 if (abort_on_gc)
5180 emacs_abort (); 5178 emacs_abort ();
@@ -5185,12 +5183,7 @@ See Info node `(elisp)Garbage Collection'. */)
5185 return Qnil; 5183 return Qnil;
5186 5184
5187 /* Record this function, so it appears on the profiler's backtraces. */ 5185 /* Record this function, so it appears on the profiler's backtraces. */
5188 backtrace.next = backtrace_list; 5186 record_in_backtrace (Qautomatic_gc, &Qnil, 0);
5189 backtrace.function = Qautomatic_gc;
5190 backtrace.args = &Qnil;
5191 backtrace.nargs = 0;
5192 backtrace.debug_on_exit = 0;
5193 backtrace_list = &backtrace;
5194 5187
5195 check_cons_list (); 5188 check_cons_list ();
5196 5189
@@ -5257,11 +5250,7 @@ See Info node `(elisp)Garbage Collection'. */)
5257 for (i = 0; i < staticidx; i++) 5250 for (i = 0; i < staticidx; i++)
5258 mark_object (*staticvec[i]); 5251 mark_object (*staticvec[i]);
5259 5252
5260 for (bind = specpdl; bind != specpdl_ptr; bind++) 5253 mark_specpdl ();
5261 {
5262 mark_object (bind->symbol);
5263 mark_object (bind->old_value);
5264 }
5265 mark_terminals (); 5254 mark_terminals ();
5266 mark_kboards (); 5255 mark_kboards ();
5267 5256
@@ -5295,7 +5284,6 @@ See Info node `(elisp)Garbage Collection'. */)
5295 mark_object (handler->var); 5284 mark_object (handler->var);
5296 } 5285 }
5297 } 5286 }
5298 mark_backtrace ();
5299#endif 5287#endif
5300 5288
5301#ifdef HAVE_WINDOW_SYSTEM 5289#ifdef HAVE_WINDOW_SYSTEM
@@ -5486,7 +5474,6 @@ See Info node `(elisp)Garbage Collection'. */)
5486 malloc_probe (swept); 5474 malloc_probe (swept);
5487 } 5475 }
5488 5476
5489 backtrace_list = backtrace.next;
5490 return retval; 5477 return retval;
5491} 5478}
5492 5479
diff --git a/src/data.c b/src/data.c
index 6622088b648..b33d9656d57 100644
--- a/src/data.c
+++ b/src/data.c
@@ -1069,40 +1069,6 @@ DEFUN ("set", Fset, Sset, 2, 2, 0,
1069 return newval; 1069 return newval;
1070} 1070}
1071 1071
1072/* Return true if SYMBOL currently has a let-binding
1073 which was made in the buffer that is now current. */
1074
1075static bool
1076let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol)
1077{
1078 struct specbinding *p;
1079
1080 for (p = specpdl_ptr; p > specpdl; )
1081 if ((--p)->func == NULL
1082 && CONSP (p->symbol))
1083 {
1084 struct Lisp_Symbol *let_bound_symbol = XSYMBOL (XCAR (p->symbol));
1085 eassert (let_bound_symbol->redirect != SYMBOL_VARALIAS);
1086 if (symbol == let_bound_symbol
1087 && XBUFFER (XCDR (XCDR (p->symbol))) == current_buffer)
1088 return 1;
1089 }
1090
1091 return 0;
1092}
1093
1094static bool
1095let_shadows_global_binding_p (Lisp_Object symbol)
1096{
1097 struct specbinding *p;
1098
1099 for (p = specpdl_ptr; p > specpdl; )
1100 if ((--p)->func == NULL && EQ (p->symbol, symbol))
1101 return 1;
1102
1103 return 0;
1104}
1105
1106/* Store the value NEWVAL into SYMBOL. 1072/* Store the value NEWVAL into SYMBOL.
1107 If buffer/frame-locality is an issue, WHERE specifies which context to use. 1073 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1108 (nil stands for the current buffer/frame). 1074 (nil stands for the current buffer/frame).
@@ -1841,17 +1807,18 @@ BUFFER defaults to the current buffer. */)
1841 XSETBUFFER (tmp, buf); 1807 XSETBUFFER (tmp, buf);
1842 XSETSYMBOL (variable, sym); /* Update in case of aliasing. */ 1808 XSETSYMBOL (variable, sym); /* Update in case of aliasing. */
1843 1809
1844 for (tail = BVAR (buf, local_var_alist); CONSP (tail); tail = XCDR (tail)) 1810 if (EQ (blv->where, tmp)) /* The binding is already loaded. */
1845 { 1811 return blv_found (blv) ? Qt : Qnil;
1846 elt = XCAR (tail); 1812 else
1847 if (EQ (variable, XCAR (elt))) 1813 for (tail = BVAR (buf, local_var_alist); CONSP (tail); tail = XCDR (tail))
1848 { 1814 {
1849 eassert (!blv->frame_local); 1815 elt = XCAR (tail);
1850 eassert (blv_found (blv) || !EQ (blv->where, tmp)); 1816 if (EQ (variable, XCAR (elt)))
1851 return Qt; 1817 {
1852 } 1818 eassert (!blv->frame_local);
1853 } 1819 return Qt;
1854 eassert (!blv_found (blv) || !EQ (blv->where, tmp)); 1820 }
1821 }
1855 return Qnil; 1822 return Qnil;
1856 } 1823 }
1857 case SYMBOL_FORWARDED: 1824 case SYMBOL_FORWARDED:
diff --git a/src/eval.c b/src/eval.c
index 69483a9b205..fac71e34a22 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -32,8 +32,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
32#include "xterm.h" 32#include "xterm.h"
33#endif 33#endif
34 34
35struct backtrace *backtrace_list;
36
37#if !BYTE_MARK_STACK 35#if !BYTE_MARK_STACK
38static 36static
39#endif 37#endif
@@ -105,7 +103,7 @@ static EMACS_INT when_entered_debugger;
105 103
106/* The function from which the last `signal' was called. Set in 104/* The function from which the last `signal' was called. Set in
107 Fsignal. */ 105 Fsignal. */
108 106/* FIXME: We should probably get rid of this! */
109Lisp_Object Vsignaling_function; 107Lisp_Object Vsignaling_function;
110 108
111/* If non-nil, Lisp code must not be run since some part of Emacs is 109/* If non-nil, Lisp code must not be run since some part of Emacs is
@@ -117,20 +115,37 @@ Lisp_Object inhibit_lisp_code;
117static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *); 115static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *);
118static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args); 116static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args);
119 117
120/* Functions to set Lisp_Object slots of struct specbinding. */ 118/* Functions to modify slots of backtrace records. */
121 119
122static void 120static void set_backtrace_args (struct specbinding *pdl, Lisp_Object *args)
123set_specpdl_symbol (Lisp_Object symbol) 121{ eassert (pdl->kind == SPECPDL_BACKTRACE); pdl->v.bt.args = args; }
122
123static void set_backtrace_nargs (struct specbinding *pdl, ptrdiff_t n)
124{ eassert (pdl->kind == SPECPDL_BACKTRACE); pdl->v.bt.nargs = n; }
125
126void set_backtrace_debug_on_exit (struct specbinding *pdl, bool doe)
127{ eassert (pdl->kind == SPECPDL_BACKTRACE); pdl->v.bt.debug_on_exit = doe; }
128
129/* Helper functions to scan the backtrace. */
130
131LISP_INLINE bool backtrace_p (struct specbinding *pdl)
132{ return pdl >= specpdl; }
133LISP_INLINE struct specbinding *backtrace_top (void)
124{ 134{
125 specpdl_ptr->symbol = symbol; 135 struct specbinding *pdl = specpdl_ptr - 1;
136 while (backtrace_p (pdl) && pdl->kind != SPECPDL_BACKTRACE) \
137 pdl--;
138 return pdl;
126} 139}
127 140LISP_INLINE struct specbinding *backtrace_next (struct specbinding *pdl)
128static void
129set_specpdl_old_value (Lisp_Object oldval)
130{ 141{
131 specpdl_ptr->old_value = oldval; 142 pdl--;
143 while (backtrace_p (pdl) && pdl->kind != SPECPDL_BACKTRACE)
144 pdl--;
145 return pdl;
132} 146}
133 147
148
134void 149void
135init_eval_once (void) 150init_eval_once (void)
136{ 151{
@@ -151,7 +166,6 @@ init_eval (void)
151 specpdl_ptr = specpdl; 166 specpdl_ptr = specpdl;
152 catchlist = 0; 167 catchlist = 0;
153 handlerlist = 0; 168 handlerlist = 0;
154 backtrace_list = 0;
155 Vquit_flag = Qnil; 169 Vquit_flag = Qnil;
156 debug_on_next_call = 0; 170 debug_on_next_call = 0;
157 lisp_eval_depth = 0; 171 lisp_eval_depth = 0;
@@ -234,7 +248,7 @@ static void
234do_debug_on_call (Lisp_Object code) 248do_debug_on_call (Lisp_Object code)
235{ 249{
236 debug_on_next_call = 0; 250 debug_on_next_call = 0;
237 backtrace_list->debug_on_exit = 1; 251 set_backtrace_debug_on_exit (specpdl_ptr - 1, true);
238 call_debugger (Fcons (code, Qnil)); 252 call_debugger (Fcons (code, Qnil));
239} 253}
240 254
@@ -530,9 +544,8 @@ The return value is BASE-VARIABLE. */)
530 struct specbinding *p; 544 struct specbinding *p;
531 545
532 for (p = specpdl_ptr; p > specpdl; ) 546 for (p = specpdl_ptr; p > specpdl; )
533 if ((--p)->func == NULL 547 if ((--p)->kind >= SPECPDL_LET
534 && (EQ (new_alias, 548 && (EQ (new_alias, specpdl_symbol (p))))
535 CONSP (p->symbol) ? XCAR (p->symbol) : p->symbol)))
536 error ("Don't know how to make a let-bound variable an alias"); 549 error ("Don't know how to make a let-bound variable an alias");
537 } 550 }
538 551
@@ -597,8 +610,9 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
597 struct specbinding *pdl = specpdl_ptr; 610 struct specbinding *pdl = specpdl_ptr;
598 while (pdl > specpdl) 611 while (pdl > specpdl)
599 { 612 {
600 if (EQ ((--pdl)->symbol, sym) && !pdl->func 613 if ((--pdl)->kind >= SPECPDL_LET
601 && EQ (pdl->old_value, Qunbound)) 614 && EQ (specpdl_symbol (pdl), sym)
615 && EQ (specpdl_old_value (pdl), Qunbound))
602 { 616 {
603 message_with_string 617 message_with_string
604 ("Warning: defvar ignored because %s is let-bound", 618 ("Warning: defvar ignored because %s is let-bound",
@@ -937,7 +951,7 @@ usage: (catch TAG BODY...) */)
937 951
938/* Set up a catch, then call C function FUNC on argument ARG. 952/* Set up a catch, then call C function FUNC on argument ARG.
939 FUNC should return a Lisp_Object. 953 FUNC should return a Lisp_Object.
940 This is how catches are done from within C code. */ 954 This is how catches are done from within C code. */
941 955
942Lisp_Object 956Lisp_Object
943internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object arg) 957internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object arg)
@@ -949,7 +963,6 @@ internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object
949 c.next = catchlist; 963 c.next = catchlist;
950 c.tag = tag; 964 c.tag = tag;
951 c.val = Qnil; 965 c.val = Qnil;
952 c.backlist = backtrace_list;
953 c.handlerlist = handlerlist; 966 c.handlerlist = handlerlist;
954 c.lisp_eval_depth = lisp_eval_depth; 967 c.lisp_eval_depth = lisp_eval_depth;
955 c.pdlcount = SPECPDL_INDEX (); 968 c.pdlcount = SPECPDL_INDEX ();
@@ -1014,7 +1027,6 @@ unwind_to_catch (struct catchtag *catch, Lisp_Object value)
1014#ifdef DEBUG_GCPRO 1027#ifdef DEBUG_GCPRO
1015 gcpro_level = gcprolist ? gcprolist->level + 1 : 0; 1028 gcpro_level = gcprolist ? gcprolist->level + 1 : 0;
1016#endif 1029#endif
1017 backtrace_list = catch->backlist;
1018 lisp_eval_depth = catch->lisp_eval_depth; 1030 lisp_eval_depth = catch->lisp_eval_depth;
1019 1031
1020 sys_longjmp (catch->jmp, 1); 1032 sys_longjmp (catch->jmp, 1);
@@ -1115,7 +1127,6 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform,
1115 1127
1116 c.tag = Qnil; 1128 c.tag = Qnil;
1117 c.val = Qnil; 1129 c.val = Qnil;
1118 c.backlist = backtrace_list;
1119 c.handlerlist = handlerlist; 1130 c.handlerlist = handlerlist;
1120 c.lisp_eval_depth = lisp_eval_depth; 1131 c.lisp_eval_depth = lisp_eval_depth;
1121 c.pdlcount = SPECPDL_INDEX (); 1132 c.pdlcount = SPECPDL_INDEX ();
@@ -1131,7 +1142,7 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform,
1131 1142
1132 /* Note that this just undoes the binding of h.var; whoever 1143 /* Note that this just undoes the binding of h.var; whoever
1133 longjumped to us unwound the stack to c.pdlcount before 1144 longjumped to us unwound the stack to c.pdlcount before
1134 throwing. */ 1145 throwing. */
1135 unbind_to (c.pdlcount, Qnil); 1146 unbind_to (c.pdlcount, Qnil);
1136 return val; 1147 return val;
1137 } 1148 }
@@ -1170,7 +1181,6 @@ internal_condition_case (Lisp_Object (*bfun) (void), Lisp_Object handlers,
1170 1181
1171 c.tag = Qnil; 1182 c.tag = Qnil;
1172 c.val = Qnil; 1183 c.val = Qnil;
1173 c.backlist = backtrace_list;
1174 c.handlerlist = handlerlist; 1184 c.handlerlist = handlerlist;
1175 c.lisp_eval_depth = lisp_eval_depth; 1185 c.lisp_eval_depth = lisp_eval_depth;
1176 c.pdlcount = SPECPDL_INDEX (); 1186 c.pdlcount = SPECPDL_INDEX ();
@@ -1208,7 +1218,6 @@ internal_condition_case_1 (Lisp_Object (*bfun) (Lisp_Object), Lisp_Object arg,
1208 1218
1209 c.tag = Qnil; 1219 c.tag = Qnil;
1210 c.val = Qnil; 1220 c.val = Qnil;
1211 c.backlist = backtrace_list;
1212 c.handlerlist = handlerlist; 1221 c.handlerlist = handlerlist;
1213 c.lisp_eval_depth = lisp_eval_depth; 1222 c.lisp_eval_depth = lisp_eval_depth;
1214 c.pdlcount = SPECPDL_INDEX (); 1223 c.pdlcount = SPECPDL_INDEX ();
@@ -1250,7 +1259,6 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object),
1250 1259
1251 c.tag = Qnil; 1260 c.tag = Qnil;
1252 c.val = Qnil; 1261 c.val = Qnil;
1253 c.backlist = backtrace_list;
1254 c.handlerlist = handlerlist; 1262 c.handlerlist = handlerlist;
1255 c.lisp_eval_depth = lisp_eval_depth; 1263 c.lisp_eval_depth = lisp_eval_depth;
1256 c.pdlcount = SPECPDL_INDEX (); 1264 c.pdlcount = SPECPDL_INDEX ();
@@ -1294,7 +1302,6 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *),
1294 1302
1295 c.tag = Qnil; 1303 c.tag = Qnil;
1296 c.val = Qnil; 1304 c.val = Qnil;
1297 c.backlist = backtrace_list;
1298 c.handlerlist = handlerlist; 1305 c.handlerlist = handlerlist;
1299 c.lisp_eval_depth = lisp_eval_depth; 1306 c.lisp_eval_depth = lisp_eval_depth;
1300 c.pdlcount = SPECPDL_INDEX (); 1307 c.pdlcount = SPECPDL_INDEX ();
@@ -1362,7 +1369,6 @@ See also the function `condition-case'. */)
1362 = (NILP (error_symbol) ? Fcar (data) : error_symbol); 1369 = (NILP (error_symbol) ? Fcar (data) : error_symbol);
1363 register Lisp_Object clause = Qnil; 1370 register Lisp_Object clause = Qnil;
1364 struct handler *h; 1371 struct handler *h;
1365 struct backtrace *bp;
1366 1372
1367 immediate_quit = 0; 1373 immediate_quit = 0;
1368 abort_on_gc = 0; 1374 abort_on_gc = 0;
@@ -1398,13 +1404,13 @@ See also the function `condition-case'. */)
1398 too. Don't do this when ERROR_SYMBOL is nil, because that 1404 too. Don't do this when ERROR_SYMBOL is nil, because that
1399 is a memory-full error. */ 1405 is a memory-full error. */
1400 Vsignaling_function = Qnil; 1406 Vsignaling_function = Qnil;
1401 if (backtrace_list && !NILP (error_symbol)) 1407 if (!NILP (error_symbol))
1402 { 1408 {
1403 bp = backtrace_list->next; 1409 struct specbinding *pdl = backtrace_next (backtrace_top ());
1404 if (bp && EQ (bp->function, Qerror)) 1410 if (backtrace_p (pdl) && EQ (backtrace_function (pdl), Qerror))
1405 bp = bp->next; 1411 pdl = backtrace_next (pdl);
1406 if (bp) 1412 if (backtrace_p (pdl))
1407 Vsignaling_function = bp->function; 1413 Vsignaling_function = backtrace_function (pdl);
1408 } 1414 }
1409 1415
1410 for (h = handlerlist; h; h = h->next) 1416 for (h = handlerlist; h; h = h->next)
@@ -1901,6 +1907,36 @@ If LEXICAL is t, evaluate using lexical scoping. */)
1901 return unbind_to (count, eval_sub (form)); 1907 return unbind_to (count, eval_sub (form));
1902} 1908}
1903 1909
1910static void
1911grow_specpdl (void)
1912{
1913 register ptrdiff_t count = SPECPDL_INDEX ();
1914 ptrdiff_t max_size = min (max_specpdl_size, PTRDIFF_MAX);
1915 if (max_size <= specpdl_size)
1916 {
1917 if (max_specpdl_size < 400)
1918 max_size = max_specpdl_size = 400;
1919 if (max_size <= specpdl_size)
1920 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil);
1921 }
1922 specpdl = xpalloc (specpdl, &specpdl_size, 1, max_size, sizeof *specpdl);
1923 specpdl_ptr = specpdl + count;
1924}
1925
1926LISP_INLINE void
1927record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs)
1928{
1929 eassert (nargs >= UNEVALLED);
1930 if (specpdl_ptr == specpdl + specpdl_size)
1931 grow_specpdl ();
1932 specpdl_ptr->kind = SPECPDL_BACKTRACE;
1933 specpdl_ptr->v.bt.function = function;
1934 specpdl_ptr->v.bt.args = args;
1935 specpdl_ptr->v.bt.nargs = nargs;
1936 specpdl_ptr->v.bt.debug_on_exit = false;
1937 specpdl_ptr++;
1938}
1939
1904/* Eval a sub-expression of the current expression (i.e. in the same 1940/* Eval a sub-expression of the current expression (i.e. in the same
1905 lexical scope). */ 1941 lexical scope). */
1906Lisp_Object 1942Lisp_Object
@@ -1908,7 +1944,6 @@ eval_sub (Lisp_Object form)
1908{ 1944{
1909 Lisp_Object fun, val, original_fun, original_args; 1945 Lisp_Object fun, val, original_fun, original_args;
1910 Lisp_Object funcar; 1946 Lisp_Object funcar;
1911 struct backtrace backtrace;
1912 struct gcpro gcpro1, gcpro2, gcpro3; 1947 struct gcpro gcpro1, gcpro2, gcpro3;
1913 1948
1914 if (SYMBOLP (form)) 1949 if (SYMBOLP (form))
@@ -1946,12 +1981,8 @@ eval_sub (Lisp_Object form)
1946 original_fun = XCAR (form); 1981 original_fun = XCAR (form);
1947 original_args = XCDR (form); 1982 original_args = XCDR (form);
1948 1983
1949 backtrace.next = backtrace_list; 1984 /* This also protects them from gc. */
1950 backtrace.function = original_fun; /* This also protects them from gc. */ 1985 record_in_backtrace (original_fun, &original_args, UNEVALLED);
1951 backtrace.args = &original_args;
1952 backtrace.nargs = UNEVALLED;
1953 backtrace.debug_on_exit = 0;
1954 backtrace_list = &backtrace;
1955 1986
1956 if (debug_on_next_call) 1987 if (debug_on_next_call)
1957 do_debug_on_call (Qt); 1988 do_debug_on_call (Qt);
@@ -2005,8 +2036,8 @@ eval_sub (Lisp_Object form)
2005 gcpro3.nvars = argnum; 2036 gcpro3.nvars = argnum;
2006 } 2037 }
2007 2038
2008 backtrace.args = vals; 2039 set_backtrace_args (specpdl_ptr - 1, vals);
2009 backtrace.nargs = XINT (numargs); 2040 set_backtrace_nargs (specpdl_ptr - 1, XINT (numargs));
2010 2041
2011 val = (XSUBR (fun)->function.aMANY) (XINT (numargs), vals); 2042 val = (XSUBR (fun)->function.aMANY) (XINT (numargs), vals);
2012 UNGCPRO; 2043 UNGCPRO;
@@ -2027,8 +2058,8 @@ eval_sub (Lisp_Object form)
2027 2058
2028 UNGCPRO; 2059 UNGCPRO;
2029 2060
2030 backtrace.args = argvals; 2061 set_backtrace_args (specpdl_ptr - 1, argvals);
2031 backtrace.nargs = XINT (numargs); 2062 set_backtrace_nargs (specpdl_ptr - 1, XINT (numargs));
2032 2063
2033 switch (i) 2064 switch (i)
2034 { 2065 {
@@ -2118,9 +2149,9 @@ eval_sub (Lisp_Object form)
2118 check_cons_list (); 2149 check_cons_list ();
2119 2150
2120 lisp_eval_depth--; 2151 lisp_eval_depth--;
2121 if (backtrace.debug_on_exit) 2152 if (backtrace_debug_on_exit (specpdl_ptr - 1))
2122 val = call_debugger (Fcons (Qexit, Fcons (val, Qnil))); 2153 val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
2123 backtrace_list = backtrace.next; 2154 specpdl_ptr--;
2124 2155
2125 return val; 2156 return val;
2126} 2157}
@@ -2600,7 +2631,6 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
2600 ptrdiff_t numargs = nargs - 1; 2631 ptrdiff_t numargs = nargs - 1;
2601 Lisp_Object lisp_numargs; 2632 Lisp_Object lisp_numargs;
2602 Lisp_Object val; 2633 Lisp_Object val;
2603 struct backtrace backtrace;
2604 register Lisp_Object *internal_args; 2634 register Lisp_Object *internal_args;
2605 ptrdiff_t i; 2635 ptrdiff_t i;
2606 2636
@@ -2614,12 +2644,8 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
2614 error ("Lisp nesting exceeds `max-lisp-eval-depth'"); 2644 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2615 } 2645 }
2616 2646
2617 backtrace.next = backtrace_list; 2647 /* This also GCPROs them. */
2618 backtrace.function = args[0]; 2648 record_in_backtrace (args[0], &args[1], nargs - 1);
2619 backtrace.args = &args[1]; /* This also GCPROs them. */
2620 backtrace.nargs = nargs - 1;
2621 backtrace.debug_on_exit = 0;
2622 backtrace_list = &backtrace;
2623 2649
2624 /* Call GC after setting up the backtrace, so the latter GCPROs the args. */ 2650 /* Call GC after setting up the backtrace, so the latter GCPROs the args. */
2625 maybe_gc (); 2651 maybe_gc ();
@@ -2744,9 +2770,9 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
2744 } 2770 }
2745 check_cons_list (); 2771 check_cons_list ();
2746 lisp_eval_depth--; 2772 lisp_eval_depth--;
2747 if (backtrace.debug_on_exit) 2773 if (backtrace_debug_on_exit (specpdl_ptr - 1))
2748 val = call_debugger (Fcons (Qexit, Fcons (val, Qnil))); 2774 val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
2749 backtrace_list = backtrace.next; 2775 specpdl_ptr--;
2750 return val; 2776 return val;
2751} 2777}
2752 2778
@@ -2778,15 +2804,17 @@ apply_lambda (Lisp_Object fun, Lisp_Object args)
2778 2804
2779 UNGCPRO; 2805 UNGCPRO;
2780 2806
2781 backtrace_list->args = arg_vector; 2807 set_backtrace_args (specpdl_ptr - 1, arg_vector);
2782 backtrace_list->nargs = i; 2808 set_backtrace_nargs (specpdl_ptr - 1, i);
2783 tem = funcall_lambda (fun, numargs, arg_vector); 2809 tem = funcall_lambda (fun, numargs, arg_vector);
2784 2810
2785 /* Do the debug-on-exit now, while arg_vector still exists. */ 2811 /* Do the debug-on-exit now, while arg_vector still exists. */
2786 if (backtrace_list->debug_on_exit) 2812 if (backtrace_debug_on_exit (specpdl_ptr - 1))
2787 tem = call_debugger (Fcons (Qexit, Fcons (tem, Qnil))); 2813 {
2788 /* Don't do it again when we return to eval. */ 2814 /* Don't do it again when we return to eval. */
2789 backtrace_list->debug_on_exit = 0; 2815 set_backtrace_debug_on_exit (specpdl_ptr - 1, false);
2816 tem = call_debugger (Fcons (Qexit, Fcons (tem, Qnil)));
2817 }
2790 SAFE_FREE (); 2818 SAFE_FREE ();
2791 return tem; 2819 return tem;
2792} 2820}
@@ -2936,20 +2964,38 @@ DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode,
2936 return object; 2964 return object;
2937} 2965}
2938 2966
2939static void 2967/* Return true if SYMBOL currently has a let-binding
2940grow_specpdl (void) 2968 which was made in the buffer that is now current. */
2969
2970bool
2971let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol)
2941{ 2972{
2942 register ptrdiff_t count = SPECPDL_INDEX (); 2973 struct specbinding *p;
2943 ptrdiff_t max_size = min (max_specpdl_size, PTRDIFF_MAX); 2974 Lisp_Object buf = Fcurrent_buffer ();
2944 if (max_size <= specpdl_size) 2975
2945 { 2976 for (p = specpdl_ptr; p > specpdl; )
2946 if (max_specpdl_size < 400) 2977 if ((--p)->kind > SPECPDL_LET)
2947 max_size = max_specpdl_size = 400; 2978 {
2948 if (max_size <= specpdl_size) 2979 struct Lisp_Symbol *let_bound_symbol = XSYMBOL (specpdl_symbol (p));
2949 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil); 2980 eassert (let_bound_symbol->redirect != SYMBOL_VARALIAS);
2950 } 2981 if (symbol == let_bound_symbol
2951 specpdl = xpalloc (specpdl, &specpdl_size, 1, max_size, sizeof *specpdl); 2982 && EQ (specpdl_where (p), buf))
2952 specpdl_ptr = specpdl + count; 2983 return 1;
2984 }
2985
2986 return 0;
2987}
2988
2989bool
2990let_shadows_global_binding_p (Lisp_Object symbol)
2991{
2992 struct specbinding *p;
2993
2994 for (p = specpdl_ptr; p > specpdl; )
2995 if ((--p)->kind >= SPECPDL_LET && EQ (specpdl_symbol (p), symbol))
2996 return 1;
2997
2998 return 0;
2953} 2999}
2954 3000
2955/* `specpdl_ptr->symbol' is a field which describes which variable is 3001/* `specpdl_ptr->symbol' is a field which describes which variable is
@@ -2985,9 +3031,9 @@ specbind (Lisp_Object symbol, Lisp_Object value)
2985 case SYMBOL_PLAINVAL: 3031 case SYMBOL_PLAINVAL:
2986 /* The most common case is that of a non-constant symbol with a 3032 /* The most common case is that of a non-constant symbol with a
2987 trivial value. Make that as fast as we can. */ 3033 trivial value. Make that as fast as we can. */
2988 set_specpdl_symbol (symbol); 3034 specpdl_ptr->kind = SPECPDL_LET;
2989 set_specpdl_old_value (SYMBOL_VAL (sym)); 3035 specpdl_ptr->v.let.symbol = symbol;
2990 specpdl_ptr->func = NULL; 3036 specpdl_ptr->v.let.old_value = SYMBOL_VAL (sym);
2991 ++specpdl_ptr; 3037 ++specpdl_ptr;
2992 if (!sym->constant) 3038 if (!sym->constant)
2993 SET_SYMBOL_VAL (sym, value); 3039 SET_SYMBOL_VAL (sym, value);
@@ -3000,59 +3046,36 @@ specbind (Lisp_Object symbol, Lisp_Object value)
3000 case SYMBOL_FORWARDED: 3046 case SYMBOL_FORWARDED:
3001 { 3047 {
3002 Lisp_Object ovalue = find_symbol_value (symbol); 3048 Lisp_Object ovalue = find_symbol_value (symbol);
3003 specpdl_ptr->func = 0; 3049 specpdl_ptr->kind = SPECPDL_LET_LOCAL;
3004 set_specpdl_old_value (ovalue); 3050 specpdl_ptr->v.let.symbol = symbol;
3051 specpdl_ptr->v.let.old_value = ovalue;
3052 specpdl_ptr->v.let.where = Fcurrent_buffer ();
3005 3053
3006 eassert (sym->redirect != SYMBOL_LOCALIZED 3054 eassert (sym->redirect != SYMBOL_LOCALIZED
3007 || (EQ (SYMBOL_BLV (sym)->where, 3055 || (EQ (SYMBOL_BLV (sym)->where, Fcurrent_buffer ())));
3008 SYMBOL_BLV (sym)->frame_local ?
3009 Fselected_frame () : Fcurrent_buffer ())));
3010 3056
3011 if (sym->redirect == SYMBOL_LOCALIZED 3057 if (sym->redirect == SYMBOL_LOCALIZED)
3012 || BUFFER_OBJFWDP (SYMBOL_FWD (sym))) 3058 {
3059 if (!blv_found (SYMBOL_BLV (sym)))
3060 specpdl_ptr->kind = SPECPDL_LET_DEFAULT;
3061 }
3062 else if (BUFFER_OBJFWDP (SYMBOL_FWD (sym)))
3013 { 3063 {
3014 Lisp_Object where, cur_buf = Fcurrent_buffer ();
3015
3016 /* For a local variable, record both the symbol and which
3017 buffer's or frame's value we are saving. */
3018 if (!NILP (Flocal_variable_p (symbol, Qnil)))
3019 {
3020 eassert (sym->redirect != SYMBOL_LOCALIZED
3021 || (blv_found (SYMBOL_BLV (sym))
3022 && EQ (cur_buf, SYMBOL_BLV (sym)->where)));
3023 where = cur_buf;
3024 }
3025 else if (sym->redirect == SYMBOL_LOCALIZED
3026 && blv_found (SYMBOL_BLV (sym)))
3027 where = SYMBOL_BLV (sym)->where;
3028 else
3029 where = Qnil;
3030
3031 /* We're not using the `unused' slot in the specbinding
3032 structure because this would mean we have to do more
3033 work for simple variables. */
3034 /* FIXME: The third value `current_buffer' is only used in
3035 let_shadows_buffer_binding_p which is itself only used
3036 in set_internal for local_if_set. */
3037 eassert (NILP (where) || EQ (where, cur_buf));
3038 set_specpdl_symbol (Fcons (symbol, Fcons (where, cur_buf)));
3039
3040 /* If SYMBOL is a per-buffer variable which doesn't have a 3064 /* If SYMBOL is a per-buffer variable which doesn't have a
3041 buffer-local value here, make the `let' change the global 3065 buffer-local value here, make the `let' change the global
3042 value by changing the value of SYMBOL in all buffers not 3066 value by changing the value of SYMBOL in all buffers not
3043 having their own value. This is consistent with what 3067 having their own value. This is consistent with what
3044 happens with other buffer-local variables. */ 3068 happens with other buffer-local variables. */
3045 if (NILP (where) 3069 if (NILP (Flocal_variable_p (symbol, Qnil)))
3046 && sym->redirect == SYMBOL_FORWARDED)
3047 { 3070 {
3048 eassert (BUFFER_OBJFWDP (SYMBOL_FWD (sym))); 3071 specpdl_ptr->kind = SPECPDL_LET_DEFAULT;
3049 ++specpdl_ptr; 3072 ++specpdl_ptr;
3050 Fset_default (symbol, value); 3073 Fset_default (symbol, value);
3051 return; 3074 return;
3052 } 3075 }
3053 } 3076 }
3054 else 3077 else
3055 set_specpdl_symbol (symbol); 3078 specpdl_ptr->kind = SPECPDL_LET;
3056 3079
3057 specpdl_ptr++; 3080 specpdl_ptr++;
3058 set_internal (symbol, value, Qnil, 1); 3081 set_internal (symbol, value, Qnil, 1);
@@ -3067,9 +3090,9 @@ record_unwind_protect (Lisp_Object (*function) (Lisp_Object), Lisp_Object arg)
3067{ 3090{
3068 if (specpdl_ptr == specpdl + specpdl_size) 3091 if (specpdl_ptr == specpdl + specpdl_size)
3069 grow_specpdl (); 3092 grow_specpdl ();
3070 specpdl_ptr->func = function; 3093 specpdl_ptr->kind = SPECPDL_UNWIND;
3071 set_specpdl_symbol (Qnil); 3094 specpdl_ptr->v.unwind.func = function;
3072 set_specpdl_old_value (arg); 3095 specpdl_ptr->v.unwind.arg = arg;
3073 specpdl_ptr++; 3096 specpdl_ptr++;
3074} 3097}
3075 3098
@@ -3093,41 +3116,50 @@ unbind_to (ptrdiff_t count, Lisp_Object value)
3093 struct specbinding this_binding; 3116 struct specbinding this_binding;
3094 this_binding = *--specpdl_ptr; 3117 this_binding = *--specpdl_ptr;
3095 3118
3096 if (this_binding.func != 0) 3119 switch (this_binding.kind)
3097 (*this_binding.func) (this_binding.old_value);
3098 /* If the symbol is a list, it is really (SYMBOL WHERE
3099 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3100 frame. If WHERE is a buffer or frame, this indicates we
3101 bound a variable that had a buffer-local or frame-local
3102 binding. WHERE nil means that the variable had the default
3103 value when it was bound. CURRENT-BUFFER is the buffer that
3104 was current when the variable was bound. */
3105 else if (CONSP (this_binding.symbol))
3106 { 3120 {
3107 Lisp_Object symbol, where; 3121 case SPECPDL_UNWIND:
3108 3122 (*specpdl_func (&this_binding)) (specpdl_arg (&this_binding));
3109 symbol = XCAR (this_binding.symbol); 3123 break;
3110 where = XCAR (XCDR (this_binding.symbol)); 3124 case SPECPDL_LET:
3111 3125 /* If variable has a trivial value (no forwarding), we can
3112 if (NILP (where)) 3126 just set it. No need to check for constant symbols here,
3113 Fset_default (symbol, this_binding.old_value); 3127 since that was already done by specbind. */
3114 /* If `where' is non-nil, reset the value in the appropriate 3128 if (XSYMBOL (specpdl_symbol (&this_binding))->redirect
3115 local binding, but only if that binding still exists. */ 3129 == SYMBOL_PLAINVAL)
3116 else if (BUFFERP (where) 3130 SET_SYMBOL_VAL (XSYMBOL (specpdl_symbol (&this_binding)),
3117 ? !NILP (Flocal_variable_p (symbol, where)) 3131 specpdl_old_value (&this_binding));
3118 : !NILP (Fassq (symbol, XFRAME (where)->param_alist))) 3132 else
3119 set_internal (symbol, this_binding.old_value, where, 1); 3133 /* NOTE: we only ever come here if make_local_foo was used for
3134 the first time on this var within this let. */
3135 Fset_default (specpdl_symbol (&this_binding),
3136 specpdl_old_value (&this_binding));
3137 break;
3138 case SPECPDL_BACKTRACE:
3139 break;
3140 case SPECPDL_LET_LOCAL:
3141 case SPECPDL_LET_DEFAULT:
3142 { /* If the symbol is a list, it is really (SYMBOL WHERE
3143 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3144 frame. If WHERE is a buffer or frame, this indicates we
3145 bound a variable that had a buffer-local or frame-local
3146 binding. WHERE nil means that the variable had the default
3147 value when it was bound. CURRENT-BUFFER is the buffer that
3148 was current when the variable was bound. */
3149 Lisp_Object symbol = specpdl_symbol (&this_binding);
3150 Lisp_Object where = specpdl_where (&this_binding);
3151 eassert (BUFFERP (where));
3152
3153 if (this_binding.kind == SPECPDL_LET_DEFAULT)
3154 Fset_default (symbol, specpdl_old_value (&this_binding));
3155 /* If this was a local binding, reset the value in the appropriate
3156 buffer, but only if that buffer's binding still exists. */
3157 else if (!NILP (Flocal_variable_p (symbol, where)))
3158 set_internal (symbol, specpdl_old_value (&this_binding),
3159 where, 1);
3160 }
3161 break;
3120 } 3162 }
3121 /* If variable has a trivial value (no forwarding), we can
3122 just set it. No need to check for constant symbols here,
3123 since that was already done by specbind. */
3124 else if (XSYMBOL (this_binding.symbol)->redirect == SYMBOL_PLAINVAL)
3125 SET_SYMBOL_VAL (XSYMBOL (this_binding.symbol),
3126 this_binding.old_value);
3127 else
3128 /* NOTE: we only ever come here if make_local_foo was used for
3129 the first time on this var within this let. */
3130 Fset_default (this_binding.symbol, this_binding.old_value);
3131 } 3163 }
3132 3164
3133 if (NILP (Vquit_flag) && !NILP (quitf)) 3165 if (NILP (Vquit_flag) && !NILP (quitf))
@@ -3153,18 +3185,16 @@ DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
3153The debugger is entered when that frame exits, if the flag is non-nil. */) 3185The debugger is entered when that frame exits, if the flag is non-nil. */)
3154 (Lisp_Object level, Lisp_Object flag) 3186 (Lisp_Object level, Lisp_Object flag)
3155{ 3187{
3156 register struct backtrace *backlist = backtrace_list; 3188 struct specbinding *pdl = backtrace_top ();
3157 register EMACS_INT i; 3189 register EMACS_INT i;
3158 3190
3159 CHECK_NUMBER (level); 3191 CHECK_NUMBER (level);
3160 3192
3161 for (i = 0; backlist && i < XINT (level); i++) 3193 for (i = 0; backtrace_p (pdl) && i < XINT (level); i++)
3162 { 3194 pdl = backtrace_next (pdl);
3163 backlist = backlist->next;
3164 }
3165 3195
3166 if (backlist) 3196 if (backtrace_p (pdl))
3167 backlist->debug_on_exit = !NILP (flag); 3197 set_backtrace_debug_on_exit (pdl, !NILP (flag));
3168 3198
3169 return flag; 3199 return flag;
3170} 3200}
@@ -3174,58 +3204,41 @@ DEFUN ("backtrace", Fbacktrace, Sbacktrace, 0, 0, "",
3174Output stream used is value of `standard-output'. */) 3204Output stream used is value of `standard-output'. */)
3175 (void) 3205 (void)
3176{ 3206{
3177 register struct backtrace *backlist = backtrace_list; 3207 struct specbinding *pdl = backtrace_top ();
3178 Lisp_Object tail;
3179 Lisp_Object tem; 3208 Lisp_Object tem;
3180 struct gcpro gcpro1;
3181 Lisp_Object old_print_level = Vprint_level; 3209 Lisp_Object old_print_level = Vprint_level;
3182 3210
3183 if (NILP (Vprint_level)) 3211 if (NILP (Vprint_level))
3184 XSETFASTINT (Vprint_level, 8); 3212 XSETFASTINT (Vprint_level, 8);
3185 3213
3186 tail = Qnil; 3214 while (backtrace_p (pdl))
3187 GCPRO1 (tail);
3188
3189 while (backlist)
3190 { 3215 {
3191 write_string (backlist->debug_on_exit ? "* " : " ", 2); 3216 write_string (backtrace_debug_on_exit (pdl) ? "* " : " ", 2);
3192 if (backlist->nargs == UNEVALLED) 3217 if (backtrace_nargs (pdl) == UNEVALLED)
3193 { 3218 {
3194 Fprin1 (Fcons (backlist->function, *backlist->args), Qnil); 3219 Fprin1 (Fcons (backtrace_function (pdl), *backtrace_args (pdl)),
3220 Qnil);
3195 write_string ("\n", -1); 3221 write_string ("\n", -1);
3196 } 3222 }
3197 else 3223 else
3198 { 3224 {
3199 tem = backlist->function; 3225 tem = backtrace_function (pdl);
3200 Fprin1 (tem, Qnil); /* This can QUIT. */ 3226 Fprin1 (tem, Qnil); /* This can QUIT. */
3201 write_string ("(", -1); 3227 write_string ("(", -1);
3202 if (backlist->nargs == MANY) 3228 {
3203 { /* FIXME: Can this happen? */ 3229 ptrdiff_t i;
3204 bool later_arg = 0; 3230 for (i = 0; i < backtrace_nargs (pdl); i++)
3205 for (tail = *backlist->args; !NILP (tail); tail = Fcdr (tail)) 3231 {
3206 { 3232 if (i) write_string (" ", -1);
3207 if (later_arg) 3233 Fprin1 (backtrace_args (pdl)[i], Qnil);
3208 write_string (" ", -1); 3234 }
3209 Fprin1 (Fcar (tail), Qnil); 3235 }
3210 later_arg = 1;
3211 }
3212 }
3213 else
3214 {
3215 ptrdiff_t i;
3216 for (i = 0; i < backlist->nargs; i++)
3217 {
3218 if (i) write_string (" ", -1);
3219 Fprin1 (backlist->args[i], Qnil);
3220 }
3221 }
3222 write_string (")\n", -1); 3236 write_string (")\n", -1);
3223 } 3237 }
3224 backlist = backlist->next; 3238 pdl = backtrace_next (pdl);
3225 } 3239 }
3226 3240
3227 Vprint_level = old_print_level; 3241 Vprint_level = old_print_level;
3228 UNGCPRO;
3229 return Qnil; 3242 return Qnil;
3230} 3243}
3231 3244
@@ -3241,53 +3254,84 @@ or a lambda expression for macro calls.
3241If NFRAMES is more than the number of frames, the value is nil. */) 3254If NFRAMES is more than the number of frames, the value is nil. */)
3242 (Lisp_Object nframes) 3255 (Lisp_Object nframes)
3243{ 3256{
3244 register struct backtrace *backlist = backtrace_list; 3257 struct specbinding *pdl = backtrace_top ();
3245 register EMACS_INT i; 3258 register EMACS_INT i;
3246 Lisp_Object tem;
3247 3259
3248 CHECK_NATNUM (nframes); 3260 CHECK_NATNUM (nframes);
3249 3261
3250 /* Find the frame requested. */ 3262 /* Find the frame requested. */
3251 for (i = 0; backlist && i < XFASTINT (nframes); i++) 3263 for (i = 0; backtrace_p (pdl) && i < XFASTINT (nframes); i++)
3252 backlist = backlist->next; 3264 pdl = backtrace_next (pdl);
3253 3265
3254 if (!backlist) 3266 if (!backtrace_p (pdl))
3255 return Qnil; 3267 return Qnil;
3256 if (backlist->nargs == UNEVALLED) 3268 if (backtrace_nargs (pdl) == UNEVALLED)
3257 return Fcons (Qnil, Fcons (backlist->function, *backlist->args)); 3269 return Fcons (Qnil,
3270 Fcons (backtrace_function (pdl), *backtrace_args (pdl)));
3258 else 3271 else
3259 { 3272 {
3260 if (backlist->nargs == MANY) /* FIXME: Can this happen? */ 3273 Lisp_Object tem = Flist (backtrace_nargs (pdl), backtrace_args (pdl));
3261 tem = *backlist->args;
3262 else
3263 tem = Flist (backlist->nargs, backlist->args);
3264 3274
3265 return Fcons (Qt, Fcons (backlist->function, tem)); 3275 return Fcons (Qt, Fcons (backtrace_function (pdl), tem));
3266 } 3276 }
3267} 3277}
3268 3278
3269 3279
3270#if BYTE_MARK_STACK
3271void 3280void
3272mark_backtrace (void) 3281mark_specpdl (void)
3273{ 3282{
3274 register struct backtrace *backlist; 3283 struct specbinding *pdl;
3275 ptrdiff_t i; 3284 for (pdl = specpdl; pdl != specpdl_ptr; pdl++)
3276
3277 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3278 { 3285 {
3279 mark_object (backlist->function); 3286 switch (pdl->kind)
3287 {
3288 case SPECPDL_UNWIND:
3289 mark_object (specpdl_arg (pdl));
3290 break;
3291 case SPECPDL_BACKTRACE:
3292 {
3293 ptrdiff_t nargs = backtrace_nargs (pdl);
3294 mark_object (backtrace_function (pdl));
3295 if (nargs == UNEVALLED)
3296 nargs = 1;
3297 while (nargs--)
3298 mark_object (backtrace_args (pdl)[nargs]);
3299 }
3300 break;
3301 case SPECPDL_LET_DEFAULT:
3302 case SPECPDL_LET_LOCAL:
3303 mark_object (specpdl_where (pdl));
3304 case SPECPDL_LET:
3305 mark_object (specpdl_symbol (pdl));
3306 mark_object (specpdl_old_value (pdl));
3307 }
3308 }
3309}
3310
3311void
3312get_backtrace (Lisp_Object array)
3313{
3314 struct specbinding *pdl = backtrace_next (backtrace_top ());
3315 ptrdiff_t i = 0, asize = ASIZE (array);
3280 3316
3281 if (backlist->nargs == UNEVALLED 3317 /* Copy the backtrace contents into working memory. */
3282 || backlist->nargs == MANY) /* FIXME: Can this happen? */ 3318 for (; i < asize; i++)
3283 i = 1; 3319 {
3320 if (backtrace_p (pdl))
3321 {
3322 ASET (array, i, backtrace_function (pdl));
3323 pdl = backtrace_next (pdl);
3324 }
3284 else 3325 else
3285 i = backlist->nargs; 3326 ASET (array, i, Qnil);
3286 while (i--)
3287 mark_object (backlist->args[i]);
3288 } 3327 }
3289} 3328}
3290#endif 3329
3330Lisp_Object backtrace_top_function (void)
3331{
3332 struct specbinding *pdl = backtrace_top ();
3333 return (backtrace_p (pdl) ? backtrace_function (pdl) : Qnil);
3334}
3291 3335
3292void 3336void
3293syms_of_eval (void) 3337syms_of_eval (void)
diff --git a/src/lisp.h b/src/lisp.h
index 79d32c90f73..bd2f55f7cf4 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -73,6 +73,7 @@ enum
73 BITS_PER_SHORT = CHAR_BIT * sizeof (short), 73 BITS_PER_SHORT = CHAR_BIT * sizeof (short),
74 BITS_PER_INT = CHAR_BIT * sizeof (int), 74 BITS_PER_INT = CHAR_BIT * sizeof (int),
75 BITS_PER_LONG = CHAR_BIT * sizeof (long int), 75 BITS_PER_LONG = CHAR_BIT * sizeof (long int),
76 BITS_PER_PTRDIFF_T = CHAR_BIT * sizeof (ptrdiff_t),
76 BITS_PER_EMACS_INT = CHAR_BIT * sizeof (EMACS_INT) 77 BITS_PER_EMACS_INT = CHAR_BIT * sizeof (EMACS_INT)
77 }; 78 };
78 79
@@ -2176,12 +2177,24 @@ typedef jmp_buf sys_jmp_buf;
2176#endif 2177#endif
2177 2178
2178 2179
2180/* Elisp uses several stacks:
2181 - the C stack.
2182 - the bytecode stack: used internally by the bytecode interpreter.
2183 Allocated from the C stack.
2184 - The specpdl stack: keeps track of active unwind-protect and
2185 dynamic-let-bindings. Allocated from the `specpdl' array, a manually
2186 managed stack.
2187 - The catch stack: keeps track of active catch tags.
2188 Allocated on the C stack. This is where the setmp data is kept.
2189 - The handler stack: keeps track of active condition-case handlers.
2190 Allocated on the C stack. Every entry there also uses an entry in
2191 the catch stack. */
2192
2179/* Structure for recording Lisp call stack for backtrace purposes. */ 2193/* Structure for recording Lisp call stack for backtrace purposes. */
2180 2194
2181/* The special binding stack holds the outer values of variables while 2195/* The special binding stack holds the outer values of variables while
2182 they are bound by a function application or a let form, stores the 2196 they are bound by a function application or a let form, stores the
2183 code to be executed for Lisp unwind-protect forms, and stores the C 2197 code to be executed for unwind-protect forms.
2184 functions to be called for record_unwind_protect.
2185 2198
2186 If func is non-zero, undoing this binding applies func to old_value; 2199 If func is non-zero, undoing this binding applies func to old_value;
2187 This implements record_unwind_protect. 2200 This implements record_unwind_protect.
@@ -2194,35 +2207,77 @@ typedef jmp_buf sys_jmp_buf;
2194 which means having bound a local value while CURRENT-BUFFER was active. 2207 which means having bound a local value while CURRENT-BUFFER was active.
2195 If WHERE is nil this means we saw the default value when binding SYMBOL. 2208 If WHERE is nil this means we saw the default value when binding SYMBOL.
2196 WHERE being a buffer or frame means we saw a buffer-local or frame-local 2209 WHERE being a buffer or frame means we saw a buffer-local or frame-local
2197 value. Other values of WHERE mean an internal error. */ 2210 value. Other values of WHERE mean an internal error.
2211
2212 NOTE: The specbinding struct is defined here, because SPECPDL_INDEX is
2213 used all over the place, needs to be fast, and needs to know the size of
2214 struct specbinding. But only eval.c should access it. */
2198 2215
2199typedef Lisp_Object (*specbinding_func) (Lisp_Object); 2216typedef Lisp_Object (*specbinding_func) (Lisp_Object);
2200 2217
2218enum specbind_tag {
2219 SPECPDL_UNWIND, /* An unwind_protect function. */
2220 SPECPDL_BACKTRACE, /* An element of the backtrace. */
2221 SPECPDL_LET, /* A plain and simple dynamic let-binding. */
2222 /* Tags greater than SPECPDL_LET must be "subkinds" of LET. */
2223 SPECPDL_LET_LOCAL, /* A buffer-local let-binding. */
2224 SPECPDL_LET_DEFAULT /* A global binding for a localized var. */
2225};
2226
2201struct specbinding 2227struct specbinding
2202 { 2228 {
2203 Lisp_Object symbol, old_value; 2229 enum specbind_tag kind;
2204 specbinding_func func; 2230 union {
2205 Lisp_Object unused; /* Dividing by 16 is faster than by 12. */ 2231 struct {
2232 Lisp_Object arg;
2233 specbinding_func func;
2234 } unwind;
2235 struct {
2236 /* `where' is not used in the case of SPECPDL_LET. */
2237 Lisp_Object symbol, old_value, where;
2238 } let;
2239 struct {
2240 Lisp_Object function;
2241 Lisp_Object *args;
2242 ptrdiff_t nargs : BITS_PER_PTRDIFF_T - 1;
2243 bool debug_on_exit : 1;
2244 } bt;
2245 } v;
2206 }; 2246 };
2207 2247
2248LISP_INLINE Lisp_Object specpdl_symbol (struct specbinding *pdl)
2249{ eassert (pdl->kind >= SPECPDL_LET); return pdl->v.let.symbol; }
2250
2251LISP_INLINE Lisp_Object specpdl_old_value (struct specbinding *pdl)
2252{ eassert (pdl->kind >= SPECPDL_LET); return pdl->v.let.old_value; }
2253
2254LISP_INLINE Lisp_Object specpdl_where (struct specbinding *pdl)
2255{ eassert (pdl->kind > SPECPDL_LET); return pdl->v.let.where; }
2256
2257LISP_INLINE Lisp_Object specpdl_arg (struct specbinding *pdl)
2258{ eassert (pdl->kind == SPECPDL_UNWIND); return pdl->v.unwind.arg; }
2259
2260LISP_INLINE specbinding_func specpdl_func (struct specbinding *pdl)
2261{ eassert (pdl->kind == SPECPDL_UNWIND); return pdl->v.unwind.func; }
2262
2263LISP_INLINE Lisp_Object backtrace_function (struct specbinding *pdl)
2264{ eassert (pdl->kind == SPECPDL_BACKTRACE); return pdl->v.bt.function; }
2265
2266LISP_INLINE ptrdiff_t backtrace_nargs (struct specbinding *pdl)
2267{ eassert (pdl->kind == SPECPDL_BACKTRACE); return pdl->v.bt.nargs; }
2268
2269LISP_INLINE Lisp_Object *backtrace_args (struct specbinding *pdl)
2270{ eassert (pdl->kind == SPECPDL_BACKTRACE); return pdl->v.bt.args; }
2271
2272LISP_INLINE bool backtrace_debug_on_exit (struct specbinding *pdl)
2273{ eassert (pdl->kind == SPECPDL_BACKTRACE); return pdl->v.bt.debug_on_exit; }
2274
2208extern struct specbinding *specpdl; 2275extern struct specbinding *specpdl;
2209extern struct specbinding *specpdl_ptr; 2276extern struct specbinding *specpdl_ptr;
2210extern ptrdiff_t specpdl_size; 2277extern ptrdiff_t specpdl_size;
2211 2278
2212#define SPECPDL_INDEX() (specpdl_ptr - specpdl) 2279#define SPECPDL_INDEX() (specpdl_ptr - specpdl)
2213 2280
2214struct backtrace
2215{
2216 struct backtrace *next;
2217 Lisp_Object function;
2218 Lisp_Object *args; /* Points to vector of args. */
2219 ptrdiff_t nargs; /* Length of vector. */
2220 /* Nonzero means call value of debugger when done with this operation. */
2221 unsigned int debug_on_exit : 1;
2222};
2223
2224extern struct backtrace *backtrace_list;
2225
2226/* Everything needed to describe an active condition case. 2281/* Everything needed to describe an active condition case.
2227 2282
2228 Members are volatile if their values need to survive _longjmp when 2283 Members are volatile if their values need to survive _longjmp when
@@ -2277,9 +2332,10 @@ struct catchtag
2277 Lisp_Object tag; 2332 Lisp_Object tag;
2278 Lisp_Object volatile val; 2333 Lisp_Object volatile val;
2279 struct catchtag *volatile next; 2334 struct catchtag *volatile next;
2335#if 1 /* GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS, but they're defined later. */
2280 struct gcpro *gcpro; 2336 struct gcpro *gcpro;
2337#endif
2281 sys_jmp_buf jmp; 2338 sys_jmp_buf jmp;
2282 struct backtrace *backlist;
2283 struct handler *handlerlist; 2339 struct handler *handlerlist;
2284 EMACS_INT lisp_eval_depth; 2340 EMACS_INT lisp_eval_depth;
2285 ptrdiff_t volatile pdlcount; 2341 ptrdiff_t volatile pdlcount;
@@ -3337,10 +3393,15 @@ extern Lisp_Object safe_call (ptrdiff_t, Lisp_Object, ...);
3337extern Lisp_Object safe_call1 (Lisp_Object, Lisp_Object); 3393extern Lisp_Object safe_call1 (Lisp_Object, Lisp_Object);
3338extern Lisp_Object safe_call2 (Lisp_Object, Lisp_Object, Lisp_Object); 3394extern Lisp_Object safe_call2 (Lisp_Object, Lisp_Object, Lisp_Object);
3339extern void init_eval (void); 3395extern void init_eval (void);
3340#if BYTE_MARK_STACK
3341extern void mark_backtrace (void);
3342#endif
3343extern void syms_of_eval (void); 3396extern void syms_of_eval (void);
3397extern void record_in_backtrace (Lisp_Object function,
3398 Lisp_Object *args, ptrdiff_t nargs);
3399extern void mark_specpdl (void);
3400extern void get_backtrace (Lisp_Object array);
3401Lisp_Object backtrace_top_function (void);
3402extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol);
3403extern bool let_shadows_global_binding_p (Lisp_Object symbol);
3404
3344 3405
3345/* Defined in editfns.c. */ 3406/* Defined in editfns.c. */
3346extern Lisp_Object Qfield; 3407extern Lisp_Object Qfield;
diff --git a/src/profiler.c b/src/profiler.c
index 0a0a4d0bc57..aba81344c68 100644
--- a/src/profiler.c
+++ b/src/profiler.c
@@ -138,10 +138,8 @@ static void evict_lower_half (log_t *log)
138static void 138static void
139record_backtrace (log_t *log, EMACS_INT count) 139record_backtrace (log_t *log, EMACS_INT count)
140{ 140{
141 struct backtrace *backlist = backtrace_list;
142 Lisp_Object backtrace; 141 Lisp_Object backtrace;
143 ptrdiff_t index, i = 0; 142 ptrdiff_t index;
144 ptrdiff_t asize;
145 143
146 if (!INTEGERP (log->next_free)) 144 if (!INTEGERP (log->next_free))
147 /* FIXME: transfer the evicted counts to a special entry rather 145 /* FIXME: transfer the evicted counts to a special entry rather
@@ -151,16 +149,7 @@ record_backtrace (log_t *log, EMACS_INT count)
151 149
152 /* Get a "working memory" vector. */ 150 /* Get a "working memory" vector. */
153 backtrace = HASH_KEY (log, index); 151 backtrace = HASH_KEY (log, index);
154 asize = ASIZE (backtrace); 152 get_backtrace (backtrace);
155
156 /* Copy the backtrace contents into working memory. */
157 for (; i < asize && backlist; i++, backlist = backlist->next)
158 /* FIXME: For closures we should ignore the environment. */
159 ASET (backtrace, i, backlist->function);
160
161 /* Make sure that unused space of working memory is filled with nil. */
162 for (; i < asize; i++)
163 ASET (backtrace, i, Qnil);
164 153
165 { /* We basically do a `gethash+puthash' here, except that we have to be 154 { /* We basically do a `gethash+puthash' here, except that we have to be
166 careful to avoid memory allocation since we're in a signal 155 careful to avoid memory allocation since we're in a signal
@@ -232,7 +221,7 @@ static EMACS_INT current_sampling_interval;
232static void 221static void
233handle_profiler_signal (int signal) 222handle_profiler_signal (int signal)
234{ 223{
235 if (backtrace_list && EQ (backtrace_list->function, Qautomatic_gc)) 224 if (EQ (backtrace_top_function (), Qautomatic_gc))
236 /* Special case the time-count inside GC because the hash-table 225 /* Special case the time-count inside GC because the hash-table
237 code is not prepared to be used while the GC is running. 226 code is not prepared to be used while the GC is running.
238 More specifically it uses ASIZE at many places where it does 227 More specifically it uses ASIZE at many places where it does
diff --git a/src/xdisp.c b/src/xdisp.c
index 9f3be44ecfd..5ae15cbd0b3 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -12846,7 +12846,6 @@ redisplay_internal (void)
12846 struct frame *sf; 12846 struct frame *sf;
12847 int polling_stopped_here = 0; 12847 int polling_stopped_here = 0;
12848 Lisp_Object tail, frame; 12848 Lisp_Object tail, frame;
12849 struct backtrace backtrace;
12850 12849
12851 /* Non-zero means redisplay has to consider all windows on all 12850 /* Non-zero means redisplay has to consider all windows on all
12852 frames. Zero means, only selected_window is considered. */ 12851 frames. Zero means, only selected_window is considered. */
@@ -12890,12 +12889,7 @@ redisplay_internal (void)
12890 specbind (Qinhibit_free_realized_faces, Qnil); 12889 specbind (Qinhibit_free_realized_faces, Qnil);
12891 12890
12892 /* Record this function, so it appears on the profiler's backtraces. */ 12891 /* Record this function, so it appears on the profiler's backtraces. */
12893 backtrace.next = backtrace_list; 12892 record_in_backtrace (Qredisplay_internal, &Qnil, 0);
12894 backtrace.function = Qredisplay_internal;
12895 backtrace.args = &Qnil;
12896 backtrace.nargs = 0;
12897 backtrace.debug_on_exit = 0;
12898 backtrace_list = &backtrace;
12899 12893
12900 FOR_EACH_FRAME (tail, frame) 12894 FOR_EACH_FRAME (tail, frame)
12901 XFRAME (frame)->already_hscrolled_p = 0; 12895 XFRAME (frame)->already_hscrolled_p = 0;
@@ -13532,7 +13526,6 @@ redisplay_internal (void)
13532#endif /* HAVE_WINDOW_SYSTEM */ 13526#endif /* HAVE_WINDOW_SYSTEM */
13533 13527
13534 end_of_redisplay: 13528 end_of_redisplay:
13535 backtrace_list = backtrace.next;
13536 unbind_to (count, Qnil); 13529 unbind_to (count, Qnil);
13537 RESUME_POLLING; 13530 RESUME_POLLING;
13538} 13531}