From 72a90f9e907dd561ec2d1ca4ec6dc236edf91553 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Wed, 26 Nov 2003 08:51:52 +0000 Subject: [PATCH] Stepper implemented --- src/CHANGELOG | 30 +++++++++ src/c/cinit.d | 2 +- src/c/compiler.d | 35 ++++++++--- src/c/disassembler.d | 5 ++ src/c/eval.d | 4 +- src/c/interpreter.d | 49 +++++++++++++++ src/c/load.d | 2 +- src/c/read.d | 2 +- src/c/symbols_list.h | 8 ++- src/c/tclBasic.d | 2 +- src/h/bytecodes.h | 3 + src/h/external.h | 2 +- src/lsp/top.lsp | 33 ++++++---- src/lsp/trace.lsp | 141 +++++++++++-------------------------------- 14 files changed, 183 insertions(+), 135 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index a61f2e0ca..6da7b9a98 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -1686,6 +1686,36 @@ ECL 0.9d - The actual implementation uses POSIX threads under Linux. Ports to other operating systems are being worked out. +* System design: Debugging + + - The bytecodes interpreter now implements a barebones debugger, in + which the facilities TRACE, STEP are available, and the content of + local variables may be inspected and changed. To use the debugger, + you must have activated the memoization of function definitions, + by using (setf si::*keep-definitions* t). Sample session: + > (defun foo (x) (print x)) (step (foo 2)) + FOO + Top level. + > (FOO 2) -> + (PRINT X) - :v + Block names: FOO. + Local variables: + X: 2 + Broken at FOO. + (PRINT X) - (setf x 3) + 3 + Broken at FOO. + (PRINT X) - :v + Block names: FOO. + Local variables: + X: 3 + Broken at FOO. + (PRINT X) - + 3 + 3 + Top level. + + * Errors fixed: - Bugs in the mechanism for automatically creating packages when diff --git a/src/c/cinit.d b/src/c/cinit.d index 8c2eed6f2..3d511d52e 100644 --- a/src/c/cinit.d +++ b/src/c/cinit.d @@ -35,7 +35,7 @@ static cl_object si_simple_toplevel () sentence = @read(3, Cnil, Cnil, OBJNULL); if (sentence == OBJNULL) @(return); - prin1(si_eval_with_env(sentence, Cnil), Cnil); + prin1(si_eval_with_env(1, sentence), Cnil); #ifdef TK StdinResume(); #endif diff --git a/src/c/compiler.d b/src/c/compiler.d index c8a9b5b68..a2d03b8bb 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -50,11 +50,12 @@ #define FLAG_USEFUL (FLAG_PUSH | FLAG_VALUES | FLAG_REG0) typedef struct cl_compiler_env { - bool coalesce; cl_object variables; cl_object macros; cl_fixnum lexical_level; cl_object constants; + bool coalesce; + bool stepping; }; #define ENV cl_env.c_env @@ -363,6 +364,7 @@ static void c_new_env(struct cl_compiler_env *new_c_env, cl_object env) { ENV = new_c_env; + ENV->stepping = 0; ENV->coalesce = TRUE; ENV->constants = Cnil; ENV->variables = Cnil; @@ -655,8 +657,14 @@ c_call(cl_object args, int flags) { name = pop(&args); nargs = c_arguments(args); - if (SYMBOLP(name) && - ((flags & FLAG_GLOBAL) || Null(c_tag_ref(name, @':function')))) + if (ENV->stepping) { + /* When stepping, we only have one opcode to do function + * calls: OP_STEPFCALL. */ + asm_function(name, (flags & FLAG_GLOBAL) | FLAG_REG0); + asm_op2(OP_STEPCALL, nargs); + flags = FLAG_REG0; + } else if (SYMBOLP(name) && + ((flags & FLAG_GLOBAL) || Null(c_tag_ref(name, @':function')))) { asm_op2(push? OP_PCALLG : OP_CALLG, nargs); asm_c(name); @@ -690,7 +698,12 @@ c_funcall(cl_object args, int flags) { } compile_form(name, FLAG_PUSH); nargs = c_arguments(args); - asm_op2((flags & FLAG_PUSH)? OP_PFCALL : OP_FCALL, nargs); + if (ENV->stepping) { + asm_op2(OP_STEPCALL, nargs); + flags = FLAG_REG0; + } else { + asm_op2((flags & FLAG_PUSH)? OP_PFCALL : OP_FCALL, nargs); + } return flags; } @@ -1957,10 +1970,14 @@ compile_form(cl_object stmt, int flags) { stmt = CAR(stmt); goto QUOTED; } + if (ENV->stepping) + asm_op2c(OP_STEPIN, stmt); for (l = database; l->symbol != OBJNULL; l++) if (l->symbol == function) { ENV->lexical_level += l->lexical_increment; new_flags = (*(l->compiler))(CDR(stmt), flags); + if (ENV->stepping) + asm_op(OP_STEPOUT); goto OUTPUT; } /* @@ -2516,20 +2533,20 @@ si_make_lambda(cl_object name, cl_object rest) @(return lambda) } -cl_object -si_eval_with_env(cl_object form, cl_object env) -{ +@(defun si::eval-with-env (form &optional (env Cnil) (stepping Cnil)) volatile struct cl_compiler_env *old_c_env = ENV; struct cl_compiler_env new_c_env; volatile cl_index handle; struct ihs_frame ihs; cl_object bytecodes; - +@ /* * Compile to bytecodes. */ ENV = &new_c_env; c_new_env(&new_c_env, env); + cl_env.lex_env = env; + ENV->stepping = stepping != Cnil; handle = asm_begin(); CL_UNWIND_PROTECT_BEGIN { compile_form(form, FLAG_VALUES); @@ -2556,4 +2573,4 @@ si_eval_with_env(cl_object form, cl_object env) #endif ihs_pop(); return VALUES(0); -} +@) diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 055286848..c47fa55c7 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -416,6 +416,7 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { have been also deposited in the stack. The output values are left in VALUES(...) */ + case OP_STEPCALL: case OP_FCALL: string = "FCALL\t"; n = GET_OPARG(vector); goto OPARG; @@ -685,6 +686,10 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { goto NOARG; case OP_PUSHNIL: string = "PUSH\t'NIL"; goto NOARG; + case OP_STEPIN: string = "STEP\tIN"; + goto ARG; + case OP_STEPOUT: string = "STEP\tOUT"; + goto NOARG; default: FEerror("Unknown code ~S", 1, MAKE_FIXNUM(*(vector-1))); return vector; diff --git a/src/c/eval.d b/src/c/eval.d index 96a4c0d4d..aaee5096b 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -232,7 +232,7 @@ si_unlink_symbol(cl_object s) cl_object cl_eval(cl_object form) { - return si_eval_with_env(form, Cnil); + return si_eval_with_env(1, form); } cl_object @@ -244,7 +244,7 @@ cl_safe_eval(cl_object form, cl_object env, cl_object err_value) output = err_value; } else { bds_bind(@'si::*ignore-errors*', Ct); - output = si_eval_with_env(form, env); + output = si_eval_with_env(2, form, env); bds_unwind1(); } frs_pop(); diff --git a/src/c/interpreter.d b/src/c/interpreter.d index fb1cefe3e..30a488664 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -1307,6 +1307,55 @@ interpret(cl_object bytecodes, void *pc) { unwind(cl_env.frs_top + n); break; } + case OP_STEPIN: { + cl_object form = GET_DATA(vector, bytecodes); + cl_object a = SYM_VAL(@'si::*step-action*'); + if (a == Ct) { + /* We are stepping in, but must first ask the user + * what to do. */ + ECL_SETQ(@'si::*step-level*', + cl_1P(SYM_VAL(@'si::*step-level*'))); + cl_stack_push(form); + interpret_funcall(1, @'si::stepper'); + } else if (a != Cnil) { + /* The user told us to step over. *step-level* contains + * an integer number that, when it becomes 0, means + * that we have finished stepping over. */ + ECL_SETQ(@'si::*step-action*', cl_1P(a)); + } else { + /* We are not inside a STEP form. This should + * actually never happen. */ + } + break; + } + case OP_STEPCALL: { + /* We are going to call a function. However, we would + * like to step _in_ the function. STEPPER takes care of + * that. */ + cl_fixnum n = GET_OPARG(vector); + if (SYM_VAL(@'si::*step-action*') == Ct) { + cl_stack_push(reg0); + reg0 = interpret_funcall(1, @'si::stepper'); + } + reg0 = interpret_funcall(n, reg0); + } + case OP_STEPOUT: { + cl_object a = SYM_VAL(@'si::*step-action*'); + if (a == Ct) { + /* We exit one stepping level */ + ECL_SETQ(@'si::*step-level*', + cl_1M(SYM_VAL(@'si::*step-level*'))); + } else if (a == MAKE_FIXNUM(0)) { + /* We are back to the level in which the user + * selected to step over. */ + ECL_SETQ(@'si::*step-action*', Ct); + } else if (a != Cnil) { + ECL_SETQ(@'si::*step-action*', cl_1M(a)); + } else { + /* Not stepping, nothing to be done. */ + } + break; + } default: FEerror("Internal error: Unknown code ~S", 1, MAKE_FIXNUM(*(vector-1))); diff --git a/src/c/load.d b/src/c/load.d index c97731328..c1287afcd 100644 --- a/src/c/load.d +++ b/src/c/load.d @@ -186,7 +186,7 @@ si_load_source(cl_object source, cl_object verbose, cl_object print) x = cl_read(3, strm, Cnil, OBJNULL); if (x == OBJNULL) break; - si_eval_with_env(x, Cnil); + si_eval_with_env(1, x); if (print != Cnil) { @write(1, x); @terpri(0); diff --git a/src/c/read.d b/src/c/read.d index a3888d04b..235379ffb 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -876,7 +876,7 @@ sharp_dot_reader(cl_object in, cl_object c, cl_object d) in = read_object(in); if (read_suppress) @(return Cnil) - in = si_eval_with_env(in, Cnil); + in = si_eval_with_env(1, in); @(return in) } diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index d4555c3df..ed81f3606 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1053,7 +1053,7 @@ cl_symbols[] = { {SYS_ "COPY-STREAM", SI_ORDINARY, si_copy_stream, 1, OBJNULL}, {SYS_ "DAYLIGHT-SAVING-TIME-P", SI_ORDINARY, si_daylight_saving_time_p, -1, OBJNULL}, {SYS_ "ELT-SET", SI_ORDINARY, si_elt_set, 3, OBJNULL}, -{SYS_ "EVAL-WITH-ENV", SI_ORDINARY, si_eval_with_env, 2, OBJNULL}, +{SYS_ "EVAL-WITH-ENV", SI_ORDINARY, si_eval_with_env, -1, OBJNULL}, {SYS_ "EXPAND-DEFMACRO", SI_ORDINARY, NULL, -1, OBJNULL}, {SYS_ "FILE-KIND", SI_ORDINARY, si_file_kind, 2, OBJNULL}, {SYS_ "FILL-POINTER-SET", SI_ORDINARY, si_fill_pointer_set, 2, OBJNULL}, @@ -1370,9 +1370,13 @@ cl_symbols[] = { {MP_ "+LOAD-COMPILE-LOCK+", MP_CONSTANT, NULL, -1, OBJNULL}, {MP_ "WITH-LOCK", MP_CONSTANT, NULL, -1, OBJNULL}, {MP_ "WITHOUT-INTERRUPTS", MP_CONSTANT, NULL, -1, OBJNULL}, -{KEY_ "LOCKABLE", KEYWORD, NULL, -1, OBJNULL}, #endif +{KEY_ "LOCKABLE", KEYWORD, NULL, -1, OBJNULL}, +{SYS_ "*STEP-LEVEL*", SI_SPECIAL, OBJNULL, -1, MAKE_FIXNUM(0)}, +{SYS_ "*STEP-ACTION*", SI_SPECIAL, OBJNULL, -1, Cnil}, +{SYS_ "STEPPER", SI_ORDINARY, OBJNULL, -1, OBJNULL}, + /* Tag for end of list */ {NULL, CL_ORDINARY, NULL, -1, OBJNULL}}; diff --git a/src/c/tclBasic.d b/src/c/tclBasic.d index 258ca2c09..fa8bc97b8 100644 --- a/src/c/tclBasic.d +++ b/src/c/tclBasic.d @@ -62,7 +62,7 @@ eval_from_string(char *s) cl_object x; STRING_INPUT_STREAM(s, strm); x = @read(3, (cl_object)&strm, Cnil, OBJNULL); - return (x != OBJNULL) ? si_eval_with_env(x, Cnil) : Cnil; + return (x != OBJNULL) ? si_eval_with_env(1, x) : Cnil; } static cl_object string_stream; diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index c6ac124d5..998565f83 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -180,6 +180,9 @@ enum { OP_NIL, OP_NOT, OP_PUSHNIL, + OP_STEPIN, + OP_STEPCALL, + OP_STEPOUT, OP_MAXOPCODES = 128, OP_OPCODE_SHIFT = 7 }; diff --git a/src/h/external.h b/src/h/external.h index bdb76caeb..c0d3aed1f 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -402,7 +402,7 @@ extern cl_object si_valid_function_name_p(cl_object name); extern cl_object si_process_declarations _ARGS((int narg, cl_object body, ...)); extern cl_object make_lambda(cl_object name, cl_object lambda); -extern cl_object si_eval_with_env(cl_object form, cl_object env); +extern cl_object si_eval_with_env _ARGS((int narg, cl_object form, ...)); /* interpreter.c */ diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp index dc76e84c9..c24ce67bc 100644 --- a/src/lsp/top.lsp +++ b/src/lsp/top.lsp @@ -457,10 +457,11 @@ file. When the saved image is invoked, it will start the redefined top-level." (defun tpl (&key ((:commands *tpl-commands*) tpl-commands) ((:prompt-hook *tpl-prompt-hook*) nil) + (broken-at nil) (quiet nil)) (let* ((*ihs-base* *ihs-top*) - (*ihs-top* (ihs-top 'tpl)) - (*ihs-current* *ihs-top*) + (*ihs-top* (if broken-at (ihs-search t broken-at) (ihs-top 'tpl))) + (*ihs-current* (if broken-at (ihs-prev *ihs-top*) *ihs-top*)) (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) (*frs-top* (frs-top)) (*read-suppress* nil) @@ -468,6 +469,7 @@ file. When the saved image is invoked, it will start the redefined top-level." (*quit-tag* *quit-tags*) ; any unique new value (*tpl-level* (1+ *tpl-level*)) values) + (set-break-env) (set-current-ihs) (unless quiet (break-where)) @@ -478,6 +480,7 @@ file. When the saved image is invoked, it will start the redefined top-level." (when (catch *quit-tag* (tpl-prompt) (setq - (notinline (tpl-read))) + (cos 1.0) (setq values (multiple-value-list (eval-with-env - *break-env*))) @@ -767,18 +770,24 @@ file. When the saved image is invoked, it will start the redefined top-level." (defun set-break-env () (setq *break-env* (if (= *ihs-current* *ihs-top*) nil (ihs-env *ihs-current*)))) -(defun tpl-backward-search (string) - (do ((ihs (si::ihs-prev *ihs-current*) (si::ihs-prev ihs))) +(defun ihs-search (string unrestricted &optional (start (si::ihs-top 'tpl))) + (do ((ihs start (si::ihs-prev ihs))) ((< ihs *ihs-base*) - (format *debug-io* "Search for ~a failed.~%" string)) - (when (and (ihs-visible ihs) - (search string (symbol-name (ihs-fname ihs)) + (return nil)) + (when (and (or unrestricted (ihs-visible ihs)) + (search (string string) (symbol-name (ihs-fname ihs)) :test #'char-equal)) - (setq *ihs-current* ihs) - (set-current-ihs) - (tpl-print-current) - (return))) - (values)) + (return ihs)))) + +(defun tpl-backward-search (string) + (let ((new-ihs (ihs-search string nil *ihs-current*))) + (cond (new-ihs + (setf *ihs-current* new-ihs) + (set-current-ihs) + (tpl-print-current)) + (t + (format *debug-io* "Search for ~a failed.~%" string))) + (values))) (defun tpl-forward-search (string) (do ((ihs (si::ihs-next *ihs-current*) (si::ihs-next ihs))) diff --git a/src/lsp/trace.lsp b/src/lsp/trace.lsp index 5e713b71e..d2a9ee497 100644 --- a/src/lsp/trace.lsp +++ b/src/lsp/trace.lsp @@ -195,15 +195,11 @@ SI::ARGS." (return-from tracing-body t)))))) nil) -#+nil -(progn (defvar *step-level* 0) -(defvar *step-quit* nil) -(defvar *step-function* nil) ; skip stepping until this function -(defvar *step-form*) -(defvar *step-env*) +(defvar *step-action* nil) +(defvar *step-form* nil) (defvar *step-tag* (cons nil nil)) - +(defvar *step-functions* nil) (defconstant step-commands `("Stepper commands" ((:newline) (step-next) :constant @@ -220,12 +216,6 @@ SI::ARGS." stepping after the current form. With numeric argument (n), resume stepping at the n-th level above. With function name, resume when given function is called.~%") - ((:b :back) (tpl-pop-command) :constant - ":b(ack) Step backward" - ":back [Stepper command]~@ - :b [Abbreviation]~@ - ~@ - Go back one step.~%") ((:pr :print) (step-print) :constant ":pr(int) Pretty print current form" ":print [Stepper command]~@ @@ -241,12 +231,6 @@ SI::ARGS." it is printed by the top level in the usual way and saved in~@ the variable *. The main purpose of this command is to allow~@ the current form to be examined further by accessing *.~%") - ((:ret :return) step-return :eval - ":ret(urn) Return without evaluating current form" - ":return &eval &rest values [Stepper command]~@ - :ret &eval &rest values [Abbreviation]~@ - ~@ - Return from current form without evaluating it.~%") ((:x :exit) (step-quit) :constant ":x or :exit Finish evaluation and exit stepper" ":exit [Stepper command]~@ @@ -262,39 +246,29 @@ for Stepper mode commands." `(step* ',form)) (defun step* (form) - (let* ((*step-quit* nil) - (*step-function* nil) - (*step-level* 0)) - (stepper form nil))) + (let* ((*step-action* t) + (*step-level* 0) + (*step-functions* (make-hash-table :size 128 :test 'eq :lockable t))) + (catch *step-tag* + (si:eval-with-env form nil t)))) -(defun stepper (form &optional env) - (when (eq *step-quit* t) - (return-from stepper (evalhook form nil nil env))) - ;; skip the encapsulation of traced functions: - (when (and (consp form) - (symbolp (car form)) - (get-sysprop (car form) 'TRACED) - (tracing-body (car form))) - (do ((args (cdr form) (cdr args)) - (values)) - ((null args) - (return-from stepper - (applyhook (car form) (nreverse values) #'stepper nil env))) - (push (evalhook (car args) #'stepper nil env) values))) - (when (numberp *step-quit*) - (if (>= *step-level* *step-quit*) - (return-from stepper (evalhook form nil nil env)) - (setq *step-quit* nil))) - (when *step-function* - (if (and (consp form) (eq (car form) *step-function*)) - (let ((*step-function* nil)) - (return-from stepper (stepper form env))) - (return-from stepper (evalhook form #'stepper nil env)))) - (let* ((*step-level* (1+ *step-level*)) - (*step-form* form) - (*step-env* env) - values indent prompt) - (setq indent (min (* *tpl-level* 2) 20)) +(defun steppable-function (form) + (let ((*step-action* nil)) + (or (gethash form *step-functions*) + (multiple-value-bind (f env name) + (function-lambda-expression form) + (if (and (not (get-sysprop name 'TRACED)) f) + (setf (gethash form *step-functions*) + (eval-with-env `(function ,f) env t)) + form))))) + +(defun stepper (form) + (when (typep form '(or symbol function)) + (return-from stepper (steppable-function (coerce form 'function)))) + (let* ((*step-form* form) + (*step-action* nil) + (indent (min (* *tpl-level* 2) 20)) + prompt) (setq prompt #'(lambda () (format *debug-io* "~VT" indent) @@ -302,54 +276,20 @@ for Stepper mode commands." :level 2 :length 2) (princ #\space *debug-io*) (princ #\- *debug-io*))) - (if (constantp form) - (progn - (format *debug-io* "~VT" indent) - (write form :stream *debug-io* :pretty nil - :level 2 :length 2) - (princ #\space *debug-io*) - (princ #\= *debug-io*) - (setq values (multiple-value-list (evalhook form nil nil env))) - (dolist (v values) - (princ #\space *debug-io*) - (write v :stream *debug-io* :pretty nil :level 2 :length 2)) - (terpri *debug-io*)) - (progn - (setq values - (catch *step-tag* - (tpl :quiet t - :commands (adjoin step-commands - (adjoin break-commands *tpl-commands*)) - :prompt-hook prompt))) - (if (endp values) - (format *debug-io* "~V@T=~%" indent) - (do ((l values (cdr l)) - (b t nil)) - ((endp l)) - (format *debug-io* "~V@T~C " indent (if b #\= #\&) (car l)) - (write (car l) :stream *debug-io* :pretty nil - :level 2 :length 2) - (terpri *debug-io*))))) - (values-list values))) + (when (catch *step-tag* + (tpl :quiet t + :commands (adjoin step-commands + (adjoin break-commands *tpl-commands*)) + :broken-at 'stepper + :prompt-hook prompt)) + (throw *step-tag* t)))) (defun step-next () - (throw *step-tag* - (multiple-value-list - (locally (declare (notinline evalhook)) - (evalhook *step-form* #'stepper nil *step-env*))))) + (throw *step-tag* nil)) (defun step-skip (&optional (when 0)) - (throw *step-tag* - (multiple-value-list - (locally (declare (notinline evalhook)) - (cond ((symbolp when) - (let ((*step-function* when)) - (evalhook *step-form* #'stepper nil *step-env*))) - ((integerp when) - (setq *step-quit* (- *step-level* when)) - (evalhook *step-form* nil nil *step-env*)) - (t - (error "Skip: argument must be integer or symbol."))))))) + (setf *step-action* 0) + (throw *step-tag* nil)) (defun step-print () (write *step-form* :stream *debug-io* :pretty t :level nil :length nil) @@ -357,13 +297,4 @@ for Stepper mode commands." (values)) (defun step-quit () - (setq *step-quit* t) - (throw *step-tag* - (multiple-value-list - (locally (declare (notinline evalhook)) - (evalhook *step-form* nil nil *step-env*))))) - -(defun step-return (&rest values) - (throw *step-tag* values)) -) -;(provide 'TRACE) + (throw *step-tag* t))