Stepper implemented

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

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

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);
-}
+@)

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;

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();

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)));

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);

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)
 }
 

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}};
 

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;

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
 };

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 */
 

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)))

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))