# Provides the commands:
#
#   perl_backtrace_5_10_0
#   perl_backtrace_5_10_1
#   perl_backtrace_5_12_x
#   perl_backtrace_5_14_x
#
# Example usage:
#
#     gdb -p 7107
#     (gdb) source gdbinit.txt
#     (gdb) perl_backtrace_5_14_x
#     (gdb) detach
#     (gdb) quit

set $DEBUG = 0
set $CXTYPEMASK = 0xf
set $PERL_ITHR_JOINABLE           =  0
set $PERL_ITHR_DETACHED           =  1
set $PERL_ITHR_JOINED             =  2
set $PERL_ITHR_FINISHED           =  4
set $PERL_ITHR_THREAD_EXIT_ONLY   =  8
set $PERL_ITHR_NONVIABLE          = 16
set $PERL_ITHR_DIED               = 32

set $PERL_ITHR_UNCALLABLE  = $PERL_ITHR_DETACHED | $PERL_ITHR_JOINED

define perl_backtrace_an_interp
    set $stackinfo = (PERL_SI*)$interpreter->Icurstackinfo
    while $stackinfo != 0
        set $cxstack = $stackinfo->si_cxstack
        set $cxix = $stackinfo->si_cxix
        set $i = 0
        while $i <= $cxix
            set $context = $cxstack[$i]
            set $type = $context->cx_u.cx_subst.sbu_type & $CXTYPEMASK
            if $type == $CXt_SUB || $type == $CXt_EVAL || $type == $CXt_FORMAT
                set $file = 0
                set $cop = $context->cx_u.cx_blk.blku_oldcop
                set $file = $cop->cop_file
                if $file == 0
                    set $file = "undef"
                end
                set $line = $cop->cop_line
                printf "%s:%d\n", $file, $line
            else
                if $DEBUG
                    printf "%d\t... # (context*){cx_type=%d}\n", $i, $type
                end
            end
            set $i = $i + 1
        end
        set $stackinfo = $stackinfo->si_prev
    end
end
define perl_backtrace_a_thread
    set $tid = $thread->tid
    set $statei = $thread->state
    if $statei == $PERL_ITHR_DETACHED
      set $state = "detached"
    else
      if $statei == $PERL_ITHR_JOINED
        set $state = "joined"
      else
        if $statei = $PERL_ITHR_FINISHED
          set $state = "finished"
        else
          if $statei == $PERL_ITHR_THREAD_EXIT_ONLY
            set $state = "exit()"
          else
            if $statei == $PERL_ITHR_NONVIABLE
              set $state = "thread creation failed"
            else
              if $statei == $PERL_ITHR_DIED
                set $state = "died"
              else
                if $statei == $PERL_ITHR_UNCALLABLE
                  set $state = "uncallable"
                else
                  set $state = "???"
                end
              end
            end
          end
        end
      end
    end
    printf "thread %d %s:\n", $tid, $state
    set $interpreter = $thread->interp
    perl_backtrace_an_interp
end
define perl_backtrace_nothreads
    set $stackinfo = PL_curstackinfo
    while $stackinfo
        set $cxstack = $stackinfo->si_cxstack
        set $cxix = $stackinfo->si_cxix
        set $i = 0
        while $i <= $cxix
            set $context = $cxstack[$i]
            set $type = $context->cx_u.cx_subst.sbu_type & $CXTYPEMASK
            if $type == $CXt_SUB || $type == $CXt_EVAL || $type == $CXt_FORMAT
                set $file = 0
                set $cop = $context->cx_u.cx_blk.blku_oldcop
                set $gv = $cop->cop_filegv
                if $gv
                    set $sv = $gv->sv_u.svu_gp->gp_sv
                    if $sv
                        set $file = $sv->sv_u.svu_pv
                    end
                end
                if ! $file
                    set $file = "undef"
                end
                set $line = $cop->cop_line
                printf "%s:%d\n", $file, $line
            end
            set $i = $i + 1
        end
        set $stackinfo = $stackinfo->si_prev
    end
end

define perl_backtrace_5_8_an_interp
    set $stackinfo = (PERL_SI*)$interpreter->Tcurstackinfo
    while $stackinfo
        set $cxstack = $stackinfo->si_cxstack
        set $cxix = $stackinfo->si_cxix
        set $i = 0
        while $i <= $cxix
            set $context = $cxstack[$i]
            set $type = $context->cx_type & $CXTYPEMASK
            if $type == $CXt_SUB || $type == $CXt_EVAL || $type == $CXt_FORMAT
                set $file = 0
                set $cop = $context->cx_u.cx_blk.blku_oldcop
                set $file = $cop->cop_file
                if ! $file
                    set $file = "undef"
                end
                set $line = $cop->cop_line
                printf "%s:%d\n", $file, $line
            else
                if $DEBUG
                    printf "%d\t... # (context*){cx_type=%d}\n", $i, $type
                end
            end
            set $i = $i + 1
        end
        set $stackinfo = $stackinfo->si_prev
    end
end
define perl_backtrace_5_8_nothreads
    set $stackinfo = PL_curstackinfo
    while $stackinfo
        set $cxstack = $stackinfo->si_cxstack
        set $cxix = $stackinfo->si_cxix
        set $i = 0
        while $i <= $cxix
            set $context = $cxstack[$i]
            set $type = $context->cx_type & $CXTYPEMASK
            if $type == $CXt_SUB || $type == $CXt_EVAL || $type == $CXt_FORMAT
                set $cop = $context->cx_u.cx_blk.blku_oldcop
                set $gv = $cop->cop_filegv
                if $gv
                    set $sv = (((struct xpvgv*)($gv)->sv_any)->xgv_gp)->gp_sv
                    if $sv
                        set $file = ((struct xpv*)  ($sv)->sv_any)->xpv_pv
                    else
                        set $file = "undef"
                    end
                else
                    set $file = "undef"
                end
                set $line = $cop->cop_line
                printf "%s:%d\n", $file, $line
            end
            set $i = $i + 1
        end
        set $stackinfo = $stackinfo->si_prev
    end
end
define perl_backtrace_5_8_a_thread
    if $thread
        set $tid = $thread->tid
        set $statei = $thread->state
        if $statei == $PERL_ITHR_DETACHED
          set $state = "detached"
        else
          if $statei == $PERL_ITHR_JOINED
            set $state = "joined"
          else
            if $statei = $PERL_ITHR_FINISHED
              set $state = "finished"
            else
              if $statei == $PERL_ITHR_THREAD_EXIT_ONLY
                set $state = "exit()"
              else
                if $statei == $PERL_ITHR_NONVIABLE
                  set $state = "thread creation failed"
                else
                  if $statei == $PERL_ITHR_DIED
                    set $state = "died"
                  else
                    if $statei == $PERL_ITHR_UNCALLABLE
                      set $state = "uncallable"
                    else
                      set $state = "???"
                    end
                  end
                end
              end
            end
          end
        end
        printf "thread %d %s:\n", $tid, $state
        set $interpreter = $thread->interp
    else
        set $interpreter = my_perl
    end
    perl_backtrace_5_8_an_interp
end
define perl_backtrace_5_8_threads
    set $main_thread = threads
    set $thread = $main_thread
    perl_backtrace_5_8_a_thread
    if $thread
        set $thread = $thread->next
        while $thread && $thread != $main_thread
            perl_backtrace_5_8_a_thread
            set $thread = $thread->next
        end
    end
end
define perl_backtrace_5_8
    set $CXt_SUB = 1
    set $CXt_EVAL = 2
    set $CXt_FORMAT = 6
    set $interpreter = (PerlInterpreter*)Perl_get_context()
    if $interpreter
        perl_backtrace_5_8_threads
    else
        perl_backtrace_5_8_nothreads
    end
end

define perl_backtrace_5_8_9_an_interp
    set $stackinfo = (PERL_SI*)$interpreter->Icurstackinfo
    while $stackinfo
        set $cxstack = $stackinfo->si_cxstack
        set $cxix = $stackinfo->si_cxix
        set $i = 0
        while $i <= $cxix
            set $context = $cxstack[$i]
            set $type = $context->cx_u.cx_subst.sbu_type & $CXTYPEMASK
            if $type == $CXt_SUB || $type == $CXt_EVAL || $type == $CXt_FORMAT
                set $file = 0
                set $cop = $context->cx_u.cx_blk.blku_oldcop
                set $file = $cop->cop_file
                if ! $file
                    set $file = "undef"
                end
                set $line = $cop->cop_line
                printf "%s:%d\n", $file, $line
            else
                if $DEBUG
                    printf "%d\t... # (context*){cx_type=%d}\n", $i, $type
                end
            end
            set $i = $i + 1
        end
        set $stackinfo = $stackinfo->si_prev
    end
end
define perl_backtrace_5_8_9_nothreads
    perl_backtrace_5_8_nothreads
end
define perl_backtrace_5_8_9_a_thread
    set $tid = $thread->tid
    set $statei = $thread->state
    if $statei == $PERL_ITHR_DETACHED
      set $state = "detached"
    else
      if $statei == $PERL_ITHR_JOINED
        set $state = "joined"
      else
        if $statei = $PERL_ITHR_FINISHED
          set $state = "finished"
        else
          if $statei == $PERL_ITHR_THREAD_EXIT_ONLY
            set $state = "exit()"
          else
            if $statei == $PERL_ITHR_NONVIABLE
              set $state = "thread creation failed"
            else
              if $statei == $PERL_ITHR_DIED
                set $state = "died"
              else
                if $statei == $PERL_ITHR_UNCALLABLE
                  set $state = "uncallable"
                else
                  set $state = "???"
                end
              end
            end
          end
        end
      end
    end
    printf "thread %d %s:\n", $tid, $state
    set $interpreter = $thread->interp
    perl_backtrace_5_8_9_an_interp
end
define perl_backtrace_5_8_9_threads
    set $main_thread = threads
    set $thread = $main_thread
    perl_backtrace_5_8_9_a_thread
    if $thread
        set $thread = $thread->next
        while $thread && $thread != $main_thread
            perl_backtrace_5_8_9_a_thread
            set $thread = $thread->next
        end
    end
end
define perl_backtrace_5_8_9
    set $CXt_SUB = 1
    set $CXt_EVAL = 2
    set $CXt_FORMAT = 6
    set $interpreter = (PerlInterpreter*)Perl_get_context()
    if $interpreter
        set $POOL_KEY = "threads::_pool1.71"
        set $POOL_KEY_LEN = 18
        perl_backtrace_5_8_9_threads
    else
        perl_backtrace_5_8_nothreads
    end
end

define perl_backtrace_5_10_threads
    set $modglobal = $interpreter->Imodglobal
    set $my_pool_svp = Perl_hv_fetch($interpreter, $modglobal, $POOL_KEY, $POOL_KEY_LEN, 0)
    if $my_pool_svp
        set $my_pool_sv = *$my_pool_svp
        set $my_pool_svval = (struct xpvuv*)($my_pool_sv->sv_any)
        set $my_poolp = (my_pool_t*)($my_pool_svval->xuv_u.xuvu_uv)
        set $main_thread = &($my_poolp->main_thread)
        set $thread = $main_thread
        perl_backtrace_a_thread
        set $thread = $main_thread->next
        while $thread != $main_thread
            perl_backtrace_a_thread
            set $thread = $thread->next
        end
    else
        set $interpreter = my_perl
        perl_backtrace_an_interp
    end
end
define perl_backtrace_5_10_0
    set $CXt_SUB = 1
    set $CXt_EVAL = 2
    set $CXt_FORMAT = 6
    set $interpreter = (PerlInterpreter*)Perl_get_context()
    if $interpreter
        set $POOL_KEY = "threads::_pool1.67"
        set $POOL_KEY_LEN = 18
        perl_backtrace_5_10_threads
    else
        perl_backtrace_nothreads
    end
end
define perl_backtrace_5_10_1
    set $CXt_SUB = 1
    set $CXt_EVAL = 2
    set $CXt_FORMAT = 6
    set $interpreter = (PerlInterpreter*)Perl_get_context()
    if $interpreter
        set $POOL_KEY = "threads::_pool1.72"
        set $POOL_KEY_LEN = 18
        perl_backtrace_5_10_threads
    else
        perl_backtrace_nothreads
    end
end

define perl_backtrace_5_12_threads
    set $modglobal = $interpreter->Imodglobal
    set $my_pool_svp = Perl_hv_fetch($interpreter, $modglobal, $POOL_KEY, $POOL_KEY_LEN, 0)
    if $my_pool_svp
        set $my_pool_sv = *$my_pool_svp
        set $my_pool_svval = (struct xpvuv*)($my_pool_sv->sv_any)
        set $my_poolp = (my_pool_t*)($my_pool_svval->xuv_u.xivu_uv)
        set $main_thread = &($my_poolp->main_thread)
        set $thread = $main_thread
        perl_backtrace_a_thread
        set $thread = $main_thread->next
        while $thread != $main_thread
            perl_backtrace_a_thread
            set $thread = $thread->next
        end
    else
        set $interpreter = my_perl
        perl_backtrace_an_interp
    end
end
define perl_backtrace_5_12_x
    set $CXt_SUB = 8
    set $CXt_FORMAT = 9
    set $CXt_EVAL = 10
    set $interpreter = (PerlInterpreter*)Perl_get_context()
    if $interpreter
        set $POOL_KEY = "threads::_pool1.75"
        set $POOL_KEY_LEN = 18
        perl_backtrace_5_12_threads
    else
        perl_backtrace_nothreads
    end
end

define perl_backtrace_5_14_x
    set $CXt_SUB = 8
    set $CXt_FORMAT = 9
    set $CXt_EVAL = 10
    set $interpreter = (PerlInterpreter*)Perl_get_context()
    if $interpreter
        set $POOL_KEY = "threads::_pool1.83"
        set $POOL_KEY_LEN = 18
        perl_backtrace_5_12_threads
    else
        perl_backtrace_nothreads
    end
end

define perl_backtrace_5_38_x
    set $CXt_SUB = 8
    set $CXt_FORMAT = 9
    set $CXt_EVAL = 10
    set $interpreter = (PerlInterpreter*)PL_current_context
    if $interpreter
        set $POOL_KEY = "threads::_pool1.83"
        set $POOL_KEY_LEN = 18
        perl_backtrace_5_12_threads
    else
        perl_backtrace_nothreads
    end
end