gdb/guile/scm-safe-call.c

   1 /* GDB/Scheme support for safe calls into the Guile interpreter.
   2
   3    Copyright (C) 2014-2022 Free Software Foundation, Inc.
   4
   5    This file is part of GDB.
   6
   7    This program is free software; you can redistribute it and/or modify
   8    it under the terms of the GNU General Public License as published by
   9    the Free Software Foundation; either version 3 of the License, or
  10    (at your option) any later version.
  11
  12    This program is distributed in the hope that it will be useful,
  13    but WITHOUT ANY WARRANTY; without even the implied warranty of
  14    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15    GNU General Public License for more details.
  16
  17    You should have received a copy of the GNU General Public License
  18    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  19
  20 /* See README file in this directory for implementation notes, coding
  21    conventions, et.al.  */
  22
  23 #include "defs.h"
  24 #include "filenames.h"
  25 #include "guile-internal.h"
  26 #include "gdbsupport/pathstuff.h"
  27
  28 /* Struct to marshall args to scscm_safe_call_body.  */
  29
  30 struct c_data
  31 {
  32   const char *(*func) (void *);
  33   void *data;
  34   /* An error message or NULL for success.  */
  35   const char *result;
  36 };
  37
  38 /* Struct to marshall args through gdbscm_with_catch.  */
  39
  40 struct with_catch_data
  41 {
  42   scm_t_catch_body func;
  43   void *data;
  44   scm_t_catch_handler unwind_handler;
  45   scm_t_catch_handler pre_unwind_handler;
  46
  47   /* If EXCP_MATCHER is non-NULL, it is an excp_matcher_func function.
  48      If the exception is recognized by it, the exception is recorded as is,
  49      without wrapping it in gdb:with-stack.  */
  50   excp_matcher_func *excp_matcher;
  51
  52   SCM stack;
  53   SCM catch_result;
  54 };
  55
  56 /* The "body" argument to scm_i_with_continuation_barrier.
  57    Invoke the user-supplied function.  */
  58
  59 static SCM
  60 scscm_safe_call_body (void *d)
  61 {
  62   struct c_data *data = (struct c_data *) d;
  63
  64   data->result = data->func (data->data);
  65
  66   return SCM_UNSPECIFIED;
  67 }
  68
  69 /* A "pre-unwind handler" to scm_c_catch that prints the exception
  70    according to "set guile print-stack".  */
  71
  72 static SCM
  73 scscm_printing_pre_unwind_handler (void *data, SCM key, SCM args)
  74 {
  75   SCM stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2)));
  76
  77   gdbscm_print_exception_with_stack (SCM_BOOL_F, stack, key, args);
  78
  79   return SCM_UNSPECIFIED;
  80 }
  81
  82 /* A no-op unwind handler.  */
  83
  84 static SCM
  85 scscm_nop_unwind_handler (void *data, SCM key, SCM args)
  86 {
  87   return SCM_UNSPECIFIED;
  88 }
  89
  90 /* The "pre-unwind handler" to scm_c_catch that records the exception
  91    for possible later printing.  We do this in the pre-unwind handler because
  92    we want the stack to include point where the exception occurred.
  93
  94    If DATA is non-NULL, it is an excp_matcher_func function.
  95    If the exception is recognized by it, the exception is recorded as is,
  96    without wrapping it in gdb:with-stack.  */
  97
  98 static SCM
  99 scscm_recording_pre_unwind_handler (void *datap, SCM key, SCM args)
 100 {
 101   struct with_catch_data *data = (struct with_catch_data *) datap;
 102   excp_matcher_func *matcher = data->excp_matcher;
 103
 104   if (matcher != NULL && matcher (key))
 105     return SCM_UNSPECIFIED;
 106
 107   /* There's no need to record the whole stack if we're not going to print it.
 108      However, convention is to still print the stack frame in which the
 109      exception occurred, even if we're not going to print a full backtrace.
 110      For now, keep it simple.  */
 111
 112   data->stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2)));
 113
 114   /* IWBN if we could return the <gdb:exception> here and skip the unwind
 115      handler, but it doesn't work that way.  If we want to return a
 116      <gdb:exception> object from the catch it needs to come from the unwind
 117      handler.  So what we do is save the stack for later use by the unwind
 118      handler.  */
 119
 120   return SCM_UNSPECIFIED;
 121 }
 122
 123 /* Part two of the recording unwind handler.
 124    Here we take the stack saved from the pre-unwind handler and create
 125    the <gdb:exception> object.  */
 126
 127 static SCM
 128 scscm_recording_unwind_handler (void *datap, SCM key, SCM args)
 129 {
 130   struct with_catch_data *data = (struct with_catch_data *) datap;
 131
 132   /* We need to record the stack in the exception since we're about to
 133      throw and lose the location that got the exception.  We do this by
 134      wrapping the exception + stack in a new exception.  */
 135
 136   if (gdbscm_is_true (data->stack))
 137     return gdbscm_make_exception_with_stack (key, args, data->stack);
 138
 139   return gdbscm_make_exception (key, args);
 140 }
 141
 142 /* Ugh. :-(
 143    Guile doesn't export scm_i_with_continuation_barrier which is exactly
 144    what we need.  To cope, have our own wrapper around scm_c_catch and
 145    pass this as the "body" argument to scm_c_with_continuation_barrier.
 146    Darn darn darn.  */
 147
 148 static void *
 149 gdbscm_with_catch (void *data)
 150 {
 151   struct with_catch_data *d = (struct with_catch_data *) data;
 152
 153   d->catch_result
 154     = scm_c_catch (SCM_BOOL_T,
 155                    d->func, d->data,
 156                    d->unwind_handler, d,
 157                    d->pre_unwind_handler, d);
 158
 159 #if HAVE_GUILE_MANUAL_FINALIZATION
 160   scm_run_finalizers ();
 161 #endif
 162
 163   return NULL;
 164 }
 165
 166 /* A wrapper around scm_with_guile that prints backtraces and exceptions
 167    according to "set guile print-stack".
 168    The result if NULL if no exception occurred, otherwise it is a statically
 169    allocated error message (caller must *not* free).  */
 170
 171 const char *
 172 gdbscm_with_guile (const char *(*func) (void *), void *data)
 173 {
 174   struct c_data c_data;
 175   struct with_catch_data catch_data;
 176
 177   c_data.func = func;
 178   c_data.data = data;
 179   /* Set this now in case an exception is thrown.  */
 180   c_data.result = _("Error while executing Scheme code.");
 181
 182   catch_data.func = scscm_safe_call_body;
 183   catch_data.data = &c_data;
 184   catch_data.unwind_handler = scscm_nop_unwind_handler;
 185   catch_data.pre_unwind_handler = scscm_printing_pre_unwind_handler;
 186   catch_data.excp_matcher = NULL;
 187   catch_data.stack = SCM_BOOL_F;
 188   catch_data.catch_result = SCM_UNSPECIFIED;
 189
 190   scm_with_guile (gdbscm_with_catch, &catch_data);
 191
 192   return c_data.result;
 193 }
 194
 195 /* Another wrapper of scm_with_guile for use by the safe call/apply routines
 196    in this file, as well as for general purpose calling other functions safely.
 197    For these we want to record the exception, but leave the possible printing
 198    of it to later.  */
 199
 200 SCM
 201 gdbscm_call_guile (SCM (*func) (void *), void *data,
 202                    excp_matcher_func *ok_excps)
 203 {
 204   struct with_catch_data catch_data;
 205
 206   catch_data.func = func;
 207   catch_data.data = data;
 208   catch_data.unwind_handler = scscm_recording_unwind_handler;
 209   catch_data.pre_unwind_handler = scscm_recording_pre_unwind_handler;
 210   catch_data.excp_matcher = ok_excps;
 211   catch_data.stack = SCM_BOOL_F;
 212   catch_data.catch_result = SCM_UNSPECIFIED;
 213
 214 #if 0
 215   scm_c_with_continuation_barrier (gdbscm_with_catch, &catch_data);
 216 #else
 217   scm_with_guile (gdbscm_with_catch, &catch_data);
 218 #endif
 219
 220   return catch_data.catch_result;
 221 }
 222 \f
 223 /* Utilities to safely call Scheme code, catching all exceptions, and
 224    preventing continuation capture.
 225    The result is the result of calling the function, or if an exception occurs
 226    then the result is a <gdb:exception> smob, which can be tested for with
 227    gdbscm_is_exception.  */
 228
 229 /* Helper for gdbscm_safe_call_0.  */
 230
 231 static SCM
 232 scscm_call_0_body (void *argsp)
 233 {
 234   SCM *args = (SCM *) argsp;
 235
 236   return scm_call_0 (args[0]);
 237 }
 238
 239 SCM
 240 gdbscm_safe_call_0 (SCM proc, excp_matcher_func *ok_excps)
 241 {
 242   SCM args[] = { proc };
 243
 244   return gdbscm_call_guile (scscm_call_0_body, args, ok_excps);
 245 }
 246
 247 /* Helper for gdbscm_safe_call_1.  */
 248
 249 static SCM
 250 scscm_call_1_body (void *argsp)
 251 {
 252   SCM *args = (SCM *) argsp;
 253
 254   return scm_call_1 (args[0], args[1]);
 255 }
 256
 257 SCM
 258 gdbscm_safe_call_1 (SCM proc, SCM arg0, excp_matcher_func *ok_excps)
 259 {
 260   SCM args[] = { proc, arg0 };
 261
 262   return gdbscm_call_guile (scscm_call_1_body, args, ok_excps);
 263 }
 264
 265 /* Helper for gdbscm_safe_call_2.  */
 266
 267 static SCM
 268 scscm_call_2_body (void *argsp)
 269 {
 270   SCM *args = (SCM *) argsp;
 271
 272   return scm_call_2 (args[0], args[1], args[2]);
 273 }
 274
 275 SCM
 276 gdbscm_safe_call_2 (SCM proc, SCM arg0, SCM arg1, excp_matcher_func *ok_excps)
 277 {
 278   SCM args[] = { proc, arg0, arg1 };
 279
 280   return gdbscm_call_guile (scscm_call_2_body, args, ok_excps);
 281 }
 282
 283 /* Helper for gdbscm_safe_call_3.  */
 284
 285 static SCM
 286 scscm_call_3_body (void *argsp)
 287 {
 288   SCM *args = (SCM *) argsp;
 289
 290   return scm_call_3 (args[0], args[1], args[2], args[3]);
 291 }
 292
 293 SCM
 294 gdbscm_safe_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3,
 295                     excp_matcher_func *ok_excps)
 296 {
 297   SCM args[] = { proc, arg1, arg2, arg3 };
 298
 299   return gdbscm_call_guile (scscm_call_3_body, args, ok_excps);
 300 }
 301
 302 /* Helper for gdbscm_safe_call_4.  */
 303
 304 static SCM
 305 scscm_call_4_body (void *argsp)
 306 {
 307   SCM *args = (SCM *) argsp;
 308
 309   return scm_call_4 (args[0], args[1], args[2], args[3], args[4]);
 310 }
 311
 312 SCM
 313 gdbscm_safe_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4,
 314                     excp_matcher_func *ok_excps)
 315 {
 316   SCM args[] = { proc, arg1, arg2, arg3, arg4 };
 317
 318   return gdbscm_call_guile (scscm_call_4_body, args, ok_excps);
 319 }
 320
 321 /* Helper for gdbscm_safe_apply_1.  */
 322
 323 static SCM
 324 scscm_apply_1_body (void *argsp)
 325 {
 326   SCM *args = (SCM *) argsp;
 327
 328   return scm_apply_1 (args[0], args[1], args[2]);
 329 }
 330
 331 SCM
 332 gdbscm_safe_apply_1 (SCM proc, SCM arg0, SCM rest, excp_matcher_func *ok_excps)
 333 {
 334   SCM args[] = { proc, arg0, rest };
 335
 336   return gdbscm_call_guile (scscm_apply_1_body, args, ok_excps);
 337 }
 338 \f
 339 /* Utilities to call Scheme code, not catching exceptions, and
 340    not preventing continuation capture.
 341    The result is the result of calling the function.
 342    If an exception occurs then Guile is left to handle the exception,
 343    unwinding the stack as appropriate.
 344
 345    USE THESE WITH CARE.
 346    Typically these are called from functions that implement Scheme procedures,
 347    and we don't want to catch the exception; otherwise it will get printed
 348    twice: once when first caught and once if it ends up being rethrown and the
 349    rethrow reaches the top repl, which will confuse the user.
 350
 351    While these calls just pass the call off to the corresponding Guile
 352    procedure, all such calls are routed through these ones to:
 353    a) provide a place to put hooks or whatnot in if we need to,
 354    b) add "unsafe" to the name to alert the reader.  */
 355
 356 SCM
 357 gdbscm_unsafe_call_1 (SCM proc, SCM arg0)
 358 {
 359   return scm_call_1 (proc, arg0);
 360 }
 361 \f
 362 /* Utilities for safely evaluating a Scheme expression string.  */
 363
 364 struct eval_scheme_string_data
 365 {
 366   const char *string;
 367   int display_result;
 368 };
 369
 370 /* Wrapper to eval a C string in the Guile interpreter.
 371    This is passed to gdbscm_with_guile.  */
 372
 373 static const char *
 374 scscm_eval_scheme_string (void *datap)
 375 {
 376   struct eval_scheme_string_data *data
 377     = (struct eval_scheme_string_data *) datap;
 378   SCM result = scm_c_eval_string (data->string);
 379
 380   if (data->display_result && !scm_is_eq (result, SCM_UNSPECIFIED))
 381     {
 382       SCM port = scm_current_output_port ();
 383
 384       scm_write (result, port);
 385       scm_newline (port);
 386     }
 387
 388   /* If we get here the eval succeeded.  */
 389   return NULL;
 390 }
 391
 392 /* Evaluate EXPR in the Guile interpreter, catching all exceptions
 393    and preventing continuation capture.
 394    The result is NULL if no exception occurred.  Otherwise, the exception is
 395    printed according to "set guile print-stack" and the result is an error
 396    message.  */
 397
 398 gdb::unique_xmalloc_ptr<char>
 399 gdbscm_safe_eval_string (const char *string, int display_result)
 400 {
 401   struct eval_scheme_string_data data = { string, display_result };
 402   const char *result;
 403
 404   result = gdbscm_with_guile (scscm_eval_scheme_string, (void *) &data);
 405
 406   if (result != NULL)
 407     return make_unique_xstrdup (result);
 408   return NULL;
 409 }
 410 \f
 411 /* Utilities for safely loading Scheme scripts.  */
 412
 413 /* Helper function for gdbscm_safe_source_scheme_script.  */
 414
 415 static const char *
 416 scscm_source_scheme_script (void *data)
 417 {
 418   const char *filename = (const char *) data;
 419
 420   /* The Guile docs don't specify what the result is.
 421      Maybe it's SCM_UNSPECIFIED, but the docs should specify that. :-) */
 422   scm_c_primitive_load_path (filename);
 423
 424   /* If we get here the load succeeded.  */
 425   return NULL;
 426 }
 427
 428 /* Try to load a script, catching all exceptions,
 429    and preventing continuation capture.
 430    The result is NULL if the load succeeded.  Otherwise, the exception is
 431    printed according to "set guile print-stack" and the result is an error
 432    message allocated with malloc, caller must free.  */
 433
 434 gdb::unique_xmalloc_ptr<char>
 435 gdbscm_safe_source_script (const char *filename)
 436 {
 437   /* scm_c_primitive_load_path only looks in %load-path for files with
 438      relative paths.  An alternative could be to temporarily add "." to
 439      %load-path, but we don't want %load-path to be searched.  At least not
 440      by default.  This function is invoked by the "source" GDB command which
 441      already has its own path search support.  */
 442   gdb::unique_xmalloc_ptr<char> abs_filename;
 443   const char *result;
 444
 445   if (!IS_ABSOLUTE_PATH (filename))
 446     {
 447       abs_filename = gdb_realpath (filename);
 448       filename = abs_filename.get ();
 449     }
 450
 451   result = gdbscm_with_guile (scscm_source_scheme_script,
 452                               (void *) filename);
 453
 454   if (result != NULL)
 455     return make_unique_xstrdup (result);
 456   return NULL;
 457 }
 458 \f
 459 /* Utility for entering an interactive Guile repl.  */
 460
 461 void
 462 gdbscm_enter_repl (void)
 463 {
 464   /* It's unfortunate to have to resort to something like this, but
 465      scm_shell doesn't return.  :-(  I found this code on guile-user@.  */
 466   gdbscm_safe_call_1 (scm_c_public_ref ("system repl repl", "start-repl"),
 467                       scm_from_latin1_symbol ("scheme"), NULL);
 468 }