slsh/lib/sldbcore.sl

% Copyright (C) 2012-2017,2018 John E. Davis
%
% This file is part of the S-Lang Library and may be distributed under the
% terms of the GNU General Public License.  See the file COPYING for
% more information.
%---------------------------------------------------------------------------
%
% This file implements the core a simple debugger.  It needs to be wrapped
% by routines that implement the Debugger_Methods.
%
% Public functions:
%   sldb_methods()
%   sldb_stop ();
%   sldb_start ();
%   sldb_set_breakpoint ();
%
%
%  Notes:
%
%    If a file was not compiled with bos/eos hooks, then debugging of
%    it may be limited due to the lack of line number information.
%
%
require ("print");

private variable Debugger_Methods = struct
{
   list,          % list (file, linemin, linemax)
   vmessage,      % vmessage (fmt, args...)
   read_input,    % input = read_input (prompt, default)
   pprint,        % pprint(obj) % pprint the value of an object
   quit,          % quit (and kill) the program
   exit		  % exit the debugger but not the program
};

private define output ()
{
   variable args = __pop_args (_NARGS);
   (@Debugger_Methods.vmessage)(__push_args(args));
}

private define quit_method ()
{
   output ("Program exiting\n");
   exit (0);
}
Debugger_Methods.quit = &quit_method;

private define exit_method ()
{
   output ("Leaving the debugger\n");
}
Debugger_Methods.exit = &exit_method;

define sldb_methods ()
{
   return Debugger_Methods;
}
define sldb_initialize ();	       % This should be overridden

define sldb_stop();

private variable Depth = 0;
private variable Stop_Depth	= 0;
private variable Debugger_Step	= 0;
private variable STEP_NEXT	= 1;
private variable STEP_STEP	= 2;
private variable STEP_FINISH	= 3;
private variable STEP_EXIT	= 4;
private variable Breakpoints = NULL;
private variable Breakpoint_Number = 1;
private variable Current_Frame;
private variable Max_Current_Frame;
private variable Last_List_Line = 0;
private variable Last_Cmd_Line = NULL;
private variable Last_Cmd = NULL;
private variable Prompt = "(SLdb) ";
private variable Startup_PID = NULL;

private define new_breakpoints ()
{
   Breakpoints = Assoc_Type[Int_Type, 0];
   Breakpoint_Number = 1;
}

private define check_breakpoints ()
{
   if (Breakpoints == NULL)
     new_breakpoints ();
}

define sldb_set_breakpoint (pos)
{
   variable bp;

   check_breakpoints ();
   bp = Breakpoint_Number;
   Breakpoints[pos] = bp;
   Breakpoint_Number++;

   output ("breakpoint #%d set at %s\n", bp, pos);
   return bp;
}

private define make_breakpoint_name (file, line)
{
   return sprintf ("%S:%d", file, line);
}

private define eval_in_frame (frame, expr, num_on_stack, print_fun)
{
   variable boseos = _boseos_info;
   variable bofeof = _bofeof_info;
   expr = sprintf ("_boseos_info=0; _bofeof_info=0; _use_frame_namespace(%d); %s; _bofeof_info=%d; _boseos_info=%d;",
		   frame, expr, bofeof, boseos);
   variable depth = _stkdepth () - num_on_stack;
   eval (expr);

   variable n = _stkdepth () - depth;
   if (print_fun == NULL)
     return n;

   loop (n)
     {
	variable val = ();
	(@print_fun) (val);
     }
   return n;
}

private define break_cmd (cmd, args, file, line)
{
   variable bp;
   if (strlen (args) == 0)
     bp = make_breakpoint_name (file, line);
   else if (_slang_guess_type (args) == Int_Type)
     bp = make_breakpoint_name (file, integer (args));
   else
     {
	bp = args;
	if (0 == is_substr (args, ":"))
	  {
	  }
     }

   () = sldb_set_breakpoint (bp);
   return 0;
}

private define display_file_and_line (file, linemin, linemax)
{
   if (file == "***string***")
     return;

   if (linemin < 1)
     linemin = 1;
   if (linemax < linemin)
     linemax = linemin;

   (@Debugger_Methods.list)(file, linemin, linemax);
}

private define finish_cmd (cmd, args, file, line)
{
   %variable fun = _get_frame_info (Max_Current_Frame).function;
   variable fun = _get_frame_info (Current_Frame).function;
   if (fun == NULL) fun = "<top-level>";
   output ("Run until exit from %s\n", fun);
   Debugger_Step = STEP_FINISH;
   Stop_Depth = Depth-1;
   return 1;
}

private define next_cmd (cmd, args, file, line)
{
   Debugger_Step = STEP_NEXT;
   Stop_Depth = Depth;
   return 1;
}

private define step_cmd (cmd, args, file, line)
{
   Debugger_Step = STEP_STEP;
   Stop_Depth = Depth + 1;
   return 1;
}

private define delete_cmd (cmd, args, file, line)
{
   variable bp = make_breakpoint_name (file, line);
   variable n = Breakpoints[bp];
   if (n)
     {
	Breakpoints[bp] = 0;
	output ("Deleted breakpoint #%d\n", n);
	return 0;
     }
   if (args == "")
     {
	new_breakpoints ();
	output ("Deleted all breakpoints\n");
	return 0;
     }

   variable keys = assoc_get_keys (Breakpoints);
   variable vals = assoc_get_values (Breakpoints);

   foreach (eval (sprintf ("[%s]", args)))
     {
	bp = ();
	variable i = wherefirst (vals == bp);
	if (i == NULL)
	  continue;
	assoc_delete_key (Breakpoints, keys[i]);
	output ("Deleted breakpoint %d\n", bp);
     }
   return 0;
}

private define continue_cmd (cmd, args, file, line)
{
   Debugger_Step = 0;
   return 1;
}

private define watch_cmd (cmd, args, file, line)
{
   output ("%s is not implemented\n", cmd);
   return 0;
}

private define exit_cmd (cmd, args, file, line)
{
   sldb_stop ();
   (@Debugger_Methods.exit) ();
   return 1;
}

private define quit_cmd (cmd, args, file, line)
{
   variable prompt = "Are you sure you want to quit (and kill) the program? (y/n) ";
   variable y = (@Debugger_Methods.read_input)(prompt, NULL);
   y = strup (y);
   !if (strlen (y))
     return 0;
   if (y[0] != 'Y')
     {
	output ("Try using 'exit' to leave the debugger");
	return 0;
     }
   sldb_stop ();
   (@Debugger_Methods.quit)();
   return 1;
}

private define simple_print (v)
{
   if (length (v) <= 1)
     print (v, &v);
   output ("%S\n", v);
}

private define pretty_print (v)
{
   variable p = Debugger_Methods.pprint;
   if (p == NULL)
     {
	simple_print (v);
	return;
     }
   (@p)(v);
}

private define print_expr (print_fun, expr)
{
   variable info = _get_frame_info (Current_Frame);
   variable localvars = info.locals;

   if (localvars == NULL)
     {
	() = eval_in_frame (Current_Frame, expr, 0, print_fun);
	return;
     }

   % Create a dummy function and call it with the values of the local-vars
   % The idea is that variables that are initialized will be arguments, and
   % others will just be locals
   variable a = Assoc_Type[];
   foreach (localvars)
     {
	variable lvar = ();
	try
	  {
	     a[lvar] = _get_frame_variable (Current_Frame, lvar);
	  }
	catch VariableUninitializedError;
     }
   variable inited_vars = assoc_get_keys (a);
   variable uninited_vars = String_Type[0];
   foreach (localvars)
     {
	lvar = ();
	if (assoc_key_exists (a, lvar))
	  continue;
	uninited_vars = [uninited_vars, lvar];
     }
   if (length (uninited_vars))
     uninited_vars = strcat ("variable ", strjoin (uninited_vars, ","), ";");
   else
     uninited_vars = "";

   variable fmt = "private define %s (%s) { %s %s; }";
   variable dummy = "__debugger_print_function";
   variable fun = sprintf (fmt, dummy, strjoin (inited_vars, ","),
			   uninited_vars, expr);
   () = eval_in_frame (Current_Frame, fun, 0, print_fun);

   % push values to the stack and call the dummy function
   foreach lvar (inited_vars)
     {
	a[lvar];
     }
   () = eval_in_frame (Current_Frame, dummy, length (inited_vars), print_fun);
}

private define print_cmd (cmd, args, file, line)
{
   print_expr (&simple_print, args);
   return 0;
}

private define pprint_cmd (cmd, args, file, line)
{
   print_expr (&pretty_print, args);
   return 0;
}

private define list_cmd (cmd, args, file, line)
{
   variable dline = 5;
   line = int (line);

   if (Last_Cmd == cmd)
     line = Last_List_Line + 1 + dline;

   variable line_min = line - dline;
   variable line_max = line + dline;

   if (strlen (args))
     {
	line_min = integer (args);
	line_max = line_min + 10;
     }

   display_file_and_line (file, line_min, line_max);
   Last_List_Line = line_max;
   return 0;
}

private define print_frame_info (f, print_line)
{
   variable info = _get_frame_info (f);
   variable file = info.file;
   variable function = info.function;
   variable line = info.line;

   if (function == NULL)
     function = "<top-level frame>";

   output("#%d %S:%d:%s\n", Max_Current_Frame-f, file, line, function);
   if (print_line)
     display_file_and_line (file, line, line);
}

private define up_cmd (cmd, args, file, line)
{
   if (Current_Frame == 1)
     {
	output ("Can't go up\n");
	return 0;
     }
   Current_Frame--;
   print_frame_info (Current_Frame, 1);
   return 0;
}

private define down_cmd (cmd, args, file, line)
{
   if (Current_Frame == Max_Current_Frame)
     {
	output ("At inner-most frame\n");
	return 0;
     }
   Current_Frame++;
   print_frame_info (Current_Frame, 1);
   return 0;
}

private define where_cmd (cmd, args, file, line)
{
   variable i = Current_Frame;
   while (i > 0)
     {
	print_frame_info (i, 0);
	i--;
     }
   return 0;
}

#ifexists fpu_clear_except_bits
private variable WatchFPU_Flags = 0;
#endif

private define watchfpu_cmd (cmd, args, file, line)
{
#ifexists fpu_clear_except_bits
   fpu_clear_except_bits ();
   if (args == "")
     {
	WatchFPU_Flags = FE_ALL_EXCEPT;
	output ("Watching all FPU exceptions:\n");
	output (" FE_DIVBYZERO | FE_INEXACT | FE_INVALID | FE_OVERFLOW | FE_UNDERFLOW\n");
	return 0;
     }
   WatchFPU_Flags = eval (args);
   if (WatchFPU_Flags == 0)
     {
	output ("Watching FPU exceptions disabled\n");
     }
   return 0;
#else
   output ("watchfpu is not supported on this OS\n");
   return 0;
#endif
}

private variable Cmd_Table = Assoc_Type [Ref_Type];
Cmd_Table["finish"] = &finish_cmd;
Cmd_Table["next"] = &next_cmd;
Cmd_Table["step"] = &step_cmd;
Cmd_Table["break"] = &break_cmd;
Cmd_Table["delete"] = &delete_cmd;
Cmd_Table["cont"] = &continue_cmd;
Cmd_Table["continue"] = &continue_cmd;
Cmd_Table["watch"] = &watch_cmd;
Cmd_Table["list"] = &list_cmd;
Cmd_Table["pprint"] = &pprint_cmd;
Cmd_Table["print"] = &print_cmd;
Cmd_Table["exit"] = &exit_cmd;
Cmd_Table["quit"] = &quit_cmd;
Cmd_Table["up"] = &up_cmd;
Cmd_Table["down"] = &down_cmd;
Cmd_Table["where"] = &where_cmd;
Cmd_Table["watchfpu"] = &watchfpu_cmd;

% Aliases
define sldb_add_alias (alias, cmd)
{
   if (0 == assoc_key_exists (Cmd_Table, cmd))
     return;
   Cmd_Table[alias] = Cmd_Table[cmd];
}
sldb_add_alias ("b", "break");
sldb_add_alias ("c", "continue");
sldb_add_alias ("d", "delete");
sldb_add_alias ("h", "help");
sldb_add_alias ("l", "list");
sldb_add_alias ("n", "next");
sldb_add_alias ("p", "print");
sldb_add_alias ("pp", "pprint");
sldb_add_alias ("q", "quit");
sldb_add_alias ("s", "step");

private define help_cmd (cmd, args, file, line)
{
   output ("Commands:\n");
   variable cmds = assoc_get_keys (Cmd_Table);
   cmds = cmds[array_sort(cmds)];
   foreach cmd (cmds)
     output (" %s\n", cmd);
   return 0;
}
Cmd_Table["help"] = &help_cmd;

private define sigint_handler (sig)
{
   Debugger_Step = STEP_STEP;
   Stop_Depth = INT_MAX;
   if (Depth == 0)
     throw UserBreakError;
}

private variable Old_Sigint_Handler;
private define deinit_sigint_handler ()
{
#ifexists SIGINT
   signal (SIGINT, Old_Sigint_Handler);
#endif
}

private define init_sigint_handler ()
{
#ifexists SIGINT
   variable old;
   signal (SIGINT, &sigint_handler, &old);
   ifnot (_eqs(old, &sigint_handler))
     Old_Sigint_Handler = old;
#endif
}

private variable Last_Frame = -1;
private variable Last_Function = NULL;

private define debugger_input_loop ()
{
   variable max_frame = Max_Current_Frame;
   %Last_Cmd_Line = NULL;
   %Last_Cmd = NULL;
   forever
     {
	variable e;
	try (e)
	  {
	     %deinit_sigint_handler ();
	     init_sigint_handler ();
	     Debugger_Step = 0;

	     if (Current_Frame > max_frame)
	       {
		  Max_Current_Frame = max_frame;
		  Current_Frame = max_frame;
	       }
	     variable info = _get_frame_info (Current_Frame);
	     variable file = info.file;
	     variable line = info.line;

	     variable cmdline, cmd, cmd_parm;
	     forever
	       {
		  variable prompt = Prompt;
#iffalse
		  prompt = "Depth=${Depth},Stop_Depth=${Stop_Depth} $prompt"$;
#endif
		  cmdline = (@Debugger_Methods.read_input)(prompt, Last_Cmd_Line);
		  if (cmdline == NULL)
		    throw ReadError, "NULL input returned";

		  cmdline = strtrim (cmdline);
		  variable tokens = strtok (cmdline, " \t");
		  if (length (tokens))
		    {
		       cmd = tokens[0];
		       break;
		    }
	       }
	     cmd_parm = substr (cmdline, 1+strlen(cmd), -1);
	     cmd_parm = strtrim (cmd_parm, "\t ");

	     if (0 == assoc_key_exists (Cmd_Table, cmd))
	       {
		  output("%s is unknown.  Try help.\n", cmd);
		  Last_Cmd_Line = NULL;
		  Last_Cmd = NULL;
		  continue;
	       }
	     variable ret = (@Cmd_Table[cmd])(cmd, cmd_parm, file, line);
	     Last_Cmd_Line = cmdline;
	     Last_Cmd = cmd;
	     if (ret) return;
	  }
	catch IOError:
	  {
	     sldb_stop ();
	     vmessage ("Caught IOError exception -- stopping the debugger: %S",e.message);
	     return;
	  }
	catch AnyError:
	  {
	     output("Caught exception:%S:%S:%S:%S\n", e.file, e.line, e.function, e.message);
	  }
     }
}

private define do_debug (file, line, bp_num)
{
   %output ("do_debug: file=%S, line=%S, fun=%S\n", file, line, bp_num);
   Current_Frame = _get_frame_depth ()-2;
   Max_Current_Frame = Current_Frame;
   %vmessage ("Current_Frame=%d\n", Current_Frame);
   % We do not want the debug_hook catching errors here
   variable debug_hook = _set_debug_hook (NULL);
   EXIT_BLOCK
     {
	if (Debugger_Step != STEP_EXIT)
	  {
	     () = _set_debug_hook (debug_hook);
	     init_sigint_handler ();
	  }
     }

   variable info = _get_frame_info (Current_Frame);
   if (file == NULL)
     {
	file = info.file;
	if (file == NULL)
	  file = "???";
     }
   if (line == NULL)
     line = info.line;

   variable fun = info.function;
   if (fun == NULL) fun = "<top-level>";

   if ((file == "<stdin>"))% or (file == "***string***"))
     {
	Last_Frame = Current_Frame;
	Last_Function = fun;
	Debugger_Step = STEP_NEXT;
	Stop_Depth = Depth-1;
	return;
     }
   if (bp_num)
     {
	output ("Breakpoint %d, %s\n    at %s:%d\n", abs(bp_num), fun, file, line);
     }
   else if ((Last_Frame != Current_Frame) or (Last_Function != fun))
     {
	output ("%s at %s:%d\n", fun, file, line);
     }
   display_file_and_line (file, line, line);
   Last_Frame = Current_Frame;
   Last_Function = fun;

   debugger_input_loop ();
}

private define bos_handler (file, line)
{
   %output ("bos: depth=%d, stop_depth=%d, fun=%S\n", Depth,Stop_Depth,_get_frame_info(-1).function);
   variable pos = make_breakpoint_name (file, line);
   variable bp = Breakpoints[pos];

   if (bp)
     {
	if (bp < 0) Breakpoints[pos] = 0;   %  clear temporary breakpoint
	do_debug (file, line, bp);
	return;
     }

   if (Depth > Stop_Depth)
     return;

   if (Debugger_Step == 0)
     return;

#iffalse
   if (Debugger_Step == STEP_FINISH)
     return;

   if (Debugger_Step == STEP_NEXT)
     {
	if (Depth > Stop_Depth)
	  return;
     }
#endif
   do_debug (file, line, bp);
}

% end of statement handler: tracks the recursion depth,
% to be able to step over function calls (using 'Next' Command)
private define eos_handler()
{
#ifexists fpu_clear_except_bits
   if (WatchFPU_Flags)
     {
	variable bits = fpu_test_except_bits (WatchFPU_Flags);
	if (bits)
	  {
	     variable info = _get_frame_info (-1);
	     variable str = String_Type[0];
	     if (bits & FE_DIVBYZERO) str = [str,"FE_DIVBYZERO"];
	     if (bits & FE_INEXACT) str = [str,"FE_INEXACT"];
	     if (bits & FE_INVALID) str = [str,"FE_INVALID"];
	     if (bits & FE_OVERFLOW) str = [str,"FE_OVERFLOW"];
	     if (bits & FE_UNDERFLOW) str = [str,"FE_UNDERFLOW"];
	     output ("*** FPU exception bits set: %s\n", strjoin(str, ","));
	     output ("Entering the debugger.\n");
	     fpu_clear_except_bits ();
	     do_debug (info.file, info.line, 0);
	  }
     }
#endif
   %output ("eos: depth=%d\n", Depth);
}

private define bof_handler (fun, file)
{
   %output ("Entering BOF: %S, %S, %S", fun, file, line);
   Depth++;

   variable bp = Breakpoints[fun];
   if (bp)
     {
	output ("Breakpoint %d, %s\n", abs(bp), fun);
	if (bp < 0) Breakpoints[fun] = 0;   %  clear temporary breakpoint
	Debugger_Step = STEP_NEXT;
	Stop_Depth = Depth;
     }
}

private define eof_handler ()
{
   %output ("Leaving EOF");
   Depth--;
   if (Debugger_Step)
     {
	if (Debugger_Step == STEP_FINISH)
	  {
	     if (Depth == Stop_Depth)
	       {
		  Debugger_Step = 0;
		  %variable info = _get_frame_info (_get_frame_depth ()-2);
		  %do_debug (info.file, info.line, 0);
		  do_debug (NULL, NULL, 0);
	       }
	  }
	if ((Debugger_Step == STEP_NEXT) and (Stop_Depth > Depth))
	  Stop_Depth = Depth;
     }
}

private define debug_hook (file, line)
{
   if (Startup_PID != getpid())
     return;

   %variable file = e.file, line = e.line;
   variable e = __get_exception_info ();
   output ("Received %s error.  Entering the debugger\n", e.descr);
   check_breakpoints ();
   do_debug (file, line, 0);
}

define sldb_enable ()
{
   ()=_set_bos_handler (&bos_handler);
   ()=_set_eos_handler (&eos_handler);
   ()=_set_bof_handler (&bof_handler);
   ()=_set_eof_handler (&eof_handler);
   ()=_set_debug_hook (&debug_hook);

   check_breakpoints ();
   Depth = 0;
   Debugger_Step = STEP_STEP;
   init_sigint_handler ();
   _traceback = 1;
   _bofeof_info = 1;
   _boseos_info = 3;
}

% Usage Forms:
%   sldb ();
%   sldb (file);
%   sldb (file, ns);
% The namespace semantics are the same as that of require.
define sldb ()
{
   Startup_PID = getpid ();
   sldb_initialize ();

   sldb_enable ();
   if (_NARGS == 0)
     {
	Current_Frame = _get_frame_depth ()-1;
	Max_Current_Frame = Current_Frame;
	debugger_input_loop ();
	return;
     }
   variable args = __pop_args (_NARGS);
   require (__push_args (args));
#iffalse
   variable ns = current_namespace ();
   if (_NARGS == 2)

     ns = ();
   variable file = ();

   if (ns == NULL)
     () = evalfile (file);
   else
     () = evalfile (file, ns);
#endif
}

% remove bos and eos handlers.
define sldb_stop ()
{
   ()=_set_bos_handler (NULL);
   ()=_set_eos_handler (NULL);
   ()=_set_bof_handler (NULL);
   ()=_set_eof_handler (NULL);
   ()=_set_debug_hook (NULL);
   deinit_sigint_handler ();
   _bofeof_info = 0;
   _boseos_info = 0;
   Debugger_Step = STEP_EXIT;
}

provide ("sldbcore");