implement C_BP macro for throwing a C debugger breakpoint WIP

embed.fnc

@@ -802,6 +802,8 @@ CRTp	|I32	|cast_i32	|NV f
 CRTp	|IV	|cast_iv	|NV f
 CRTp	|U32	|cast_ulong	|NV f
 CRTp	|UV	|cast_uv	|NV f
+FTXdp	|void	|c_bp		|NN const char *file_metadata		\
+				|...
 p	|bool	|check_utf8_print					\
 				|NN const U8 *s 			\
 				|const STRLEN len

embed.h

@@ -917,6 +917,7 @@
 #   define boot_core_builtin()                  Perl_boot_core_builtin(aTHX)
 #   define boot_core_mro()                      Perl_boot_core_mro(aTHX)
 #   define build_infix_plugin(a,b,c)            Perl_build_infix_plugin(aTHX_ a,b,c)
+#   define c_bp                                 Perl_c_bp
 #   define cando(a,b,c)                         Perl_cando(aTHX_ a,b,c)
 #   define check_utf8_print(a,b)                Perl_check_utf8_print(aTHX_ a,b)
 #   define closest_cop(a,b,c,d)                 Perl_closest_cop(aTHX_ a,b,c,d)

ext/XS-APItest/APItest.pm

@@ -4,7 +4,7 @@ use strict;
 use warnings;
 use Carp;
 
-our $VERSION = '1.38';
+our $VERSION = '1.39';
 
 require XSLoader;
 

ext/XS-APItest/APItest.xs

@@ -5,11 +5,19 @@
 
 /* Do *not* define PERL_NO_GET_CONTEXT.  This is the one place where we get
    to test implicit Perl_get_context().  */
+/* for GetErrorMode */
+#ifdef WIN32
+#   define _WIN32_WINNT 0x0601
+#endif
 
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
 
+#ifdef WIN32
+#  include <windows.h>
+#endif
+
 /* PERL_VERSION_xx sanity checks */
 #if !PERL_VERSION_EQ(PERL_VERSION_MAJOR, PERL_VERSION_MINOR, PERL_VERSION_PATCH)
 #  error PERL_VERSION_EQ(major, minor, patch) is false; expected true
@@ -3152,6 +3160,20 @@ my_cxt_setsv(sv)
         my_cxt_setsv_p(sv _aMY_CXT);
         SvREFCNT_inc(sv);
 
+void
+test_C_BP_breakpoint()
+    CODE:
+    {
+#ifdef WIN32
+      UINT em = GetErrorMode();
+      SetErrorMode( SEM_FAILCRITICALERRORS | SEM_NOGPFAULTERRORBOX );
+#endif
+      C_BP;
+#ifdef WIN32
+      SetErrorMode(em);
+#endif
+    }
+
 bool
 sv_setsv_cow_hashkey_core()
 

handy.h

@@ -155,7 +155,9 @@ required, but is kept for backwards compatibility.
 /* Try to figure out __func__ or __FUNCTION__ equivalent, if any.
  * XXX Should really be a Configure probe, with HAS__FUNCTION__
  *     and FUNCTION__ as results.
- * XXX Similarly, a Configure probe for __FILE__ and __LINE__ is needed. */
+ * XXX Similarly, a Configure probe for __FILE__ and __LINE__ is needed.
+ * Remember to also update CBPFUNCTION__ in util.h
+ */
 #if (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || (defined(__SUNPRO_C)) /* C99 or close enough. */
 #  define FUNCTION__ __func__
 #  define SAFE_FUNCTION__ __func__

pod/perldelta.pod

@@ -346,6 +346,18 @@ well.
 
 =over 4
 
+=item * C_BP XS macro added for C debugger breakpoints
+
+A cross platform macro C<C_BP> was added, that triggers a C breakpoint in the
+appropriate OS/platform specific C debugger, if the C debugger is already
+started. If a C debugger is not available, the C<C_BP> will immedialty kill
+the perl process similar to a SEGV. This new macro makes Perl core hacking
+and XS development easier. The macro is never intended to be shipped in stable
+or production code or even alpha beta code, and is strictly development
+helper tool for local use. It is similar to C<assert()> but launches or triggers
+a breakpoint in the C debugger, and you can resume execution use the step
+controls in the C debugger.
+
 =item *
 
 XXX

t/uni/caller.t

@@ -7,10 +7,11 @@ BEGIN {
     set_up_inc('../lib');
 }
 
+use Config;
 use utf8;
 use open qw( :utf8 :std );
 
-plan( tests => 18 );
+plan( tests => 19 );
 
 package ｍａｉｎ;
 
@@ -74,3 +75,32 @@ $^P = 16;
 $^P = $saved_perldb;
 
 ::is( eval 'ｐｂ()', 'ｍａｉｎ::ｐｂ', 'actually return the right function name even if $^P had been on at some point' );
+
+# Skip the OS signal/exception from this faux-SEGV
+# code is from cpan/Test-Harness/t/harness.t
+SKIP: {
+    ::skip "No SIGSEGV on $^O", 1
+        if $^O ne 'MSWin32' && $Config::Config{'sig_name'} !~ m/SEGV/;
+    #line below not in cpan/Test-Harness/t/harness.t
+    ::skip "No SIGTRAP on $^O", 1
+        if $^O ne 'MSWin32' && $Config::Config{'sig_name'} !~ m/TRAP/;
+
+    # some people -Dcc="somecc -fsanitize=..." or -Doptimize="-fsanitize=..."
+    ::skip "ASAN doesn't passthrough SEGV", 1
+      if "$Config{cc} $Config{ccflags} $Config{optimize}" =~ /-fsanitize\b/;
+
+    my $out_str = ::fresh_perl('BEGIN { chdir \'t\' if -d \'t\';'
+    .'require \'./test.pl\';set_up_inc(\'../lib\',\'../../lib\');}'
+    .'use XS::APItest;XS::APItest::test_C_BP_breakpoint();');
+
+    # On machines where 'ulimit -c' does not return '0', a perl.core
+    # file is created here.  We don't need to examine it, and it's
+    # annoying to have it subsequently show up as an untracked file in
+    # `git status`, so simply get rid of it per suggestion by Karen
+    # Etheridge.
+    END { unlink 'perl.core' }
+
+
+    ::like($out_str, qr/panic: C breakpoint hit file/,
+           'C_BP macro and C breakpoint works');
+}

util.c

@@ -2003,6 +2003,168 @@ Perl_croak_popstack(void)
     my_exit(1);
 }
 
+/*
+=for apidoc c_bp
+
+Internal helper for C<C_BP>.  Not to be called directly.
+
+Prints file name, C function name, line number, and CPU the instruction
+pointer.  Instruction pointer intended to be copied to a C debugger tool or
+disassembler or used with core dumps.  It is a faux-function pointer to
+somewhere in the middle of the caller's C function, this address can never
+be casted from I<void *> to a function pointer, then called, a SEGV will
+occur.
+
+=cut
+*/
+
+void
+Perl_c_bp(const char * file_metadata, ...)
+{
+    /* file_metadata is a string in the format of "XS_my_func*XSModule.c*6789"
+       The 3 arguments are catted together by CPP, so in the caller,
+       when using a C debugger, you press "Step One" key 2 times less, when
+       using step by disassembly view. On compilers like GCC where __FUNCTION__
+       is not a string litteral but a const char * global
+       variable/linker symbol, file_metadata is only the
+       function name, and does not have a "*" in it, so then read the 2nd
+       optional argument which const char * string litteral that has
+       the file name and line number catted together with "*";
+
+       C_BP macro should never appear in
+       public Stable/Gold releases of Perl core or any CPAN module. Using
+       C_BP even in a alpha release, is questionable. Smokers/CI greatly
+       dislike SEGVs which someone require human intervention to unfreeze
+       the console or unattended CI tool.
+    */
+
+    /* XXX improvements, identify which .so/.dll on disk this address is from.
+       Ajust value to a 0-indexed value to remove ASLR randomizing between
+       process runs. Better integration with USE_C_BACKTRACE if
+       USE_C_BACKTRACE enabled on a particular platform. */
+#if defined(__has_builtin) && __has_builtin(__builtin_return_address)
+    void * ip = __builtin_return_address(0); /* GCC family */
+#elif _MSC_VER
+    void * ip = _ReturnAddress();
+#else
+    /* last resort, seems to work on all CPU archs, guaranteed to work
+       on all x86/x64 OSes, all CCs, exceptions to last resort, rumor says
+       Solaris SPARC, call/ret instructions pop and push function pointers
+       to an array of function pointers, far far away from the C stack as
+       a security measure so on SPARC this would be the contents of a random
+       C auto var in the caller.
+
+       IA64, with hardware assistence by the IA64, supposedly appropriate
+       portions of the C stack are automatically shifted into kernel space on
+       each function call so no callee can read or write any C auto var in its
+       caller. Only exception is "other_func(&some_var_this_func);" The shift
+       factor now excludes some_var_this_func. So the line below would SEGV.
+
+       If any bug reports come in from these old CPUs, implement the correct
+       platform specific way to get debugging info, or uncomment the fallback */
+    void * ip = *(((void **)&file_metadata)-1);
+    /* fallback
+#  if PTRSIZE == 4
+    void * ip = (void *)0x12345678;
+#  else
+    void * ip = (void *)0x123456789ABCDEF0;
+#  endif
+    */
+#endif
+    char buf [sizeof("panic: C breakpoint hit file \"%.*s\", function \"%.*s\" line %.*s CPU IP 0x%p\n")
+               + (U8_MAX*3) + (PTRSIZE*2) + 1];
+    va_list args;
+    int out_len;
+    U32 f_len;
+    const char * file_metadata_end;
+    const char * p;
+
+    const char * fnc_st;
+    const char * fnc_end;
+    U8 fnc_len;
+
+    const char * fn_st;
+    const char * fn_end;
+    U8 fn_len;
+
+    const char * ln_st;
+    const char * ln_end;
+    U8 ln_len;
+
+    PERL_ARGS_ASSERT_C_BP;
+
+    va_start(args, file_metadata);
+    f_len = (U32)strlen(file_metadata);
+    file_metadata_end = file_metadata + f_len;
+    p = file_metadata;
+
+    fnc_st = p;
+    fnc_end = (const char*)memchr(  (const void *)fnc_st,
+                                    '*', file_metadata_end - fnc_st);
+    if(!fnc_end) {
+        if(f_len) {
+            fnc_end = fnc_st + f_len;
+            file_metadata = va_arg(args, const char *);
+            f_len = strlen(file_metadata);
+            file_metadata_end = file_metadata + f_len;
+            p = file_metadata;
+        }
+        else {
+            fnc_st = "unknown";
+            fnc_end = fnc_st + STRLENs("unknown");
+            p = file_metadata_end;
+        }
+    }
+    else {
+        p = fnc_end + 1;
+    }
+    fnc_len = (U8)(fnc_end - fnc_st);
+
+    fn_st = p;
+    fn_end = (const char*)memchr( (const void *)fn_st,
+                                  '*', file_metadata_end - fn_st);
+    if(!fn_end) {
+        fn_st = "unknown";
+        fn_end = fn_st + STRLENs("unknown");
+        p = file_metadata_end;
+    }
+    else {
+        p = fn_end + 1;
+    }
+    fn_len = (U8)(fn_end-fn_st);
+
+    ln_st = p;
+    ln_end = file_metadata_end;
+    ln_len = (U8)(ln_end - p);
+    if(!ln_len) {
+        ln_st = "unknown";
+        ln_len = STRLENs("unknown");
+    }
+    out_len = my_snprintf((char*)buf, sizeof(buf)-2,
+                          "panic: C breakpoint hit file \"%.*s\", "
+                          "function \"%.*s\" line %.*s CPU IP 0x%p",
+                          (int)fn_len, fn_st, (int)fnc_len, fnc_st,
+                          (int)ln_len, ln_st, ip);
+    if(out_len > 0 && out_len >= (int)(sizeof(buf)-2)) {
+        out_len = (int)(sizeof(buf)-2);
+    }
+    buf[out_len] = '\0'; /* MSVCRT bug don't ask, paranoia */
+
+    STMT_START {
+        dTHX; /* stderr+stdout, force user to see it */
+        Perl_warn(aTHX_ "%s", (char *)buf); /* no "\n" for max diag info */
+        PerlIO_flush(PerlIO_stderr());
+        PerlIO * out = PerlIO_stdout();
+        buf[out_len] = '\n'; /* force shell/terminal to print it, paranoia */
+        out_len++;
+        buf[out_len] = '\0';
+        PerlIO_write(out, (char *)buf, (Size_t)out_len);
+        PerlIO_flush(out); /* force shell/terminal to print it */
+    } STMT_END;
+    va_end(args);
+    return;
+}
+
 /*
 =for apidoc warn_sv