gdb/guile/scm-safe-call.c

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