| /*
* Updates:
*
* September 30th, 1996 by Bob Sampson:
*
* Enhanced traceback output implemented. CMEXEC privilege and read access
* to system executive symbol tables and resident shareable images, are
* required. An attempt is made to interpret each system PC from the
* traceback as an image name plus offset, and as a routine name plus
* offset, in a manner similar to that provided by the output of the SDA
* commands MAP and EVALUATE. When compiled on OpenVMS Alpha V7.0 or
* later, support is provided for the new 64-bit PC traceback line format.
*
* May 16th, 1997 by Bob Sampson, with thanks to an alert user:
*
* Attempted to correct omissions and typos that the user found
* by actually compiling my hand-typed version on an Alpha.
*
* Stay tuned for an upcoming improvement allowing a wider
* variety of global symbols to be correctly interpreted.
*/
#include <builtins.h>
#include <chfdef.h>
#include <descrip.h>
#define __NEW_STARLET 1
#include <eobjrecdef.h>
#include <egsdef.h>
#include <egsydef.h>
#include <egstdef.h>
#undef __NEW_STARLET
#include <fcntl.h>
#include <file.h>
#include <float.h>
#include <fp.h>
#include <fp_class.h>
#include <fscndef.h>
#include <ints.h>
#include <lib$routines.h>
#include <libicb.h>
#include <math.h>
#include <ots$routines.h>
#include <pdscdef.h>
#include <psigdef.h>
#include <rmedef.h>
#include <rms.h>
#include <ssdef.h>
#include <starlet.h>
#include <stdarg.h>
#include <stddef.h>
#include <stdio.h>
#include <str$routines.h>
#include <string.h>
#include <stsdef.h>
#include <unistd.h>
/*
* The following headers are modules in text library SYS$LIBRARY:SYS$LIB_C.TLB.
*/
#include "chfctxdef.h" /* condition handling facility context */
#include "eihddef.h" /* "EVAX" image header */
#include "eihsdef.h" /* "EVAX" image header symbol table and debug info */
#include "fcbdef.h" /* file control block */
#include "imcbdef.h" /* image control block */
#include "kfddef.h" /* known file directory */
#include "kfedef.h" /* known file entry */
#include "kferesdef.h" /* special known file entry for resident image */
#include "ldrimgdef.h" /* loaded system executive image */
#include "psldef.h" /* processor status */
#include "wcbdef.h" /* window control block */
#include "homer.h"
typedef struct {float re; float im;} complex_t;
typedef struct {double re; double im;} dcomplex_t;
typedef union
{
char b[32768];
EOBJRECDEF objrec;
EGSDEF gs;
} objrec_t;
#pragma extern_model save
#pragma extern_model relaxed_refdef shr
extern const IMCB *volatile IAC$GL_IMAGE_LIST;
extern const LDRIMG *volatile LDR$GQ_IMAGE_LIST[2];
#pragma extern_model restore
int32 decc$tprintf(const char *__format, ...);
static const int64 maxi64 = 0x7FFFFFFFFFFFFFFFL;
static const int32 fp_class_valid = 0x330;
static const char *fp_class_name[] = {
"signalling NaN (Not-a-Number)",
"quiet NaN (Not-a-Number)",
"positive infinity",
"negative infinity",
"positive normalized",
"negative normalized",
"positive denormalized",
"negative denormalized",
"positive zero",
"negative zero" };
#define NALIGN 4
static const char *align_name[NALIGN] = {
"byte",
"word",
"longword",
"quadword" };
#if __IEEE_FLOAT
static const char flt_name = 'S';
static const char dbl_name = 'T';
static const uint8 flt_dtype = DSC$K_DTYPE_FS;
static const uint8 dbl_dtype = DSC$K_DTYPE_FT;
#else
static const char flt_name = 'F';
static const uint8 flt_dtype = DSC$K_DTYPE_F;
#if __D_FLOAT
static const char dbl_name = 'D';
static const uint8 dbl_dtype = DSC$K_DTYPE_D;
#else
static const char dbl_name = 'G';
static const uint8 dbl_dtype = DSC$K_DTYPE_G;
#endif
#endif
int32 prober(const void *base_address, int32 *plength, int8 *pmode)
{
return (__PAL_PROBER(base_address, *plength, *pmode) == 0) ? 0 : -1;
}
show_signature_encoding(uint32 sig_enc)
{
switch (sig_enc)
{
case PSIG$K_FR_I64: printf("64 bits in R0 | none | 1st parm mch"); break;
case PSIG$K_FR_D64: printf("R0 lo 32 bits, R1 hi 32 bits signed"); break;
case PSIG$K_FR_I32: printf("32 bits signed in R0"); break;
case PSIG$K_FR_U32: printf("32 bits unsigned in R0"); break;
case PSIG$K_FR_FF: printf("F float in F0"); break;
case PSIG$K_FR_FD: printf("D double in F0"); break;
case PSIG$K_FR_FG: printf("G double in F0"); break;
case PSIG$K_FR_FS: printf("S float in F0"); break;
case PSIG$K_FR_FT: printf("T double in F0"); break;
case PSIG$K_FR_FFC: printf("F float complex in F0 and F1"); break;
case PSIG$K_FR_FDC: printf("D double complex in F0 and F1"); break;
case PSIG$K_FR_FGC: printf("G double complex in F0 and F1"); break;
case PSIG$K_FR_FSC: printf("S float complex in F0 and F1"); break;
case PSIG$K_FR_FTC: printf("T double complex in F0 and F1"); break;
default: printf("other"); break;
}
} /* show_signature_encoding() */
/*
* Provide an F float variant for fp_classf().
*/
#if !__IEEE_FLOAT
int32 ffp_class(float f)
{
register int32 i32 = *((int32*)&f);
register int32 sign_exp = i32 & 0xFF80;
if (sign_exp == 0x8000)
return FP_SNAN;
else
{
register int32 fraction = i32 & ~0xFF80;
if ((sign_exp == 0) && (fraction != 0))
return FP_POS_DENORM;
else
{
if (f == 0E0f)
return FP_POS_ZERO;
else
{
if (f < 0E0f)
return FP_NEG_NORM;
else
return FP_POS_NORM;
}
}
}
}
#define fp_classf ffp_class
#endif
/*
* Provide a D double variant for fp_classf().
*/
#if __D_FLOAT
int32 dfp_class(double d)
{
register int64 i64 = *((int64*)&d);
register int64 sign_exp = i64 & 0xFF80L;
if (sign_exp == 0x8000L)
return FP_SNAN;
else
{
register int64 fraction = i64 & ~0xFF80L;
if ((sign_exp == 0L) && (fraction != 0L))
return FP_POS_DENORM;
else
{
if (d == 0E0)
return FP_POS_ZERO;
else
{
if (d < 0E0)
return FP_NEG_NORM;
else
return FP_POS_NORM;
}
}
}
}
#define fp_class dfp_class
#endif
show_pd(struct pdscdef *ppdsc, struct invo_context_blk *picb)
{
register struct psigdef *ppsig;
register uint8 *pmase;
if (alpha_trace_dscs)
{
printf("\n kind of procedure: %u; ", ppdsc->pdsc$v_kind);
switch (ppdsc->pdsc$v_kind)
{
case PDSC$K_KIND_BOUND: printf("bound"); break;
case PDSC$K_KIND_NULL: printf("null"); break;
case PDSC$K_KIND_FP_STACK: printf("stack frame"); break;
case PDSC$K_KIND_FP_REGISTER: printf("register frame"); break;
default: printf("other"); break;
}
printf("\n");
if (ppdsc->pdsc$v_handler_valid)
printf(" optional handler (stack or register) present & valid\n");
if (ppdsc->pdsc$v_handler_reinvokable)
printf(" exception handler is reinvokable\n");
if (ppdsc->pdsc$v_handler_data_valid)
printf(" optional hander data (stack or register) present & valid\n");
if (ppdsc->pdsc$v_base_reg_is_fp)
printf(" FP is also base register (vs. SP)\n");
if (ppdsc->pdsc$v_rei_return)
printf(" exit from procedure via REI\n");
if (ppdsc->pdsc$v_stack_return_value)
printf(" function value is returned on the stack\n");
if (ppdsc->pdsc$v_base_frame)
printf(" base frame\n");
if (ppdsc->pdsc$v_target_invo)
printf(" unwind target invo handler to be called\n");
if (ppdsc->pdsc$v_native)
printf(" native\n");
if (ppdsc->pdsc$v_no_jacket)
printf(" no jacket\n");
if (ppdsc->pdsc$v_tie_frame)
printf(" tie frame\n");
switch (ppdsc->pdsc$v_kind)
{
case PDSC$K_KIND_FP_STACK:
printf(" stack frame offset to register save area from base: %04X\n",
ppdsc->pdsc$w_rsa_offset);
printf(" stack frame integer register save mask: %08X\n",
ppdsc->pdsc$l_ireg_mask);
printf(" stack frame floating register save mask: %08X\n",
ppdsc->pdsc$l_freg_mask);
break;
case PDSC$K_KIND_FP_REGISTER:
printf(" register frame saved frame pointer in R%u\n",
ppdsc->pdsc$b_save_fp);
printf(" register frame saved return address in R%u\n",
ppdsc->pdsc$b_save_ra);
break;
default:
break;
}
printf(" return address is passed in R%u\n", ppdsc->pdsc$b_entry_ra);
printf(" function value return registers: %u; ",
ppdsc->pdsc$v_func_return);
show_signature_encoding(ppdsc->pdsc$v_func_return);
printf("\n");
printf(" caller's desired exception reporting behavior: %u; ",
ppdsc->pdsc$v_exception_mode);
switch (ppdsc->pdsc$v_exception_mode)
{
case PDSC$K_EXC_MODE_SIGNAL: printf("signal"); break;
case PDSC$K_EXC_MODE_SIGNAL_ALL: printf("signal all"); break;
case PDSC$K_EXC_MODE_SIGNAL_SILENT: printf("signal silent"); break;
case PDSC$K_EXC_MODE_FULL_IEEE: printf("full IEEE"); break;
case PDSC$K_EXC_MODE_CALLER: printf("caller"); break;
default: printf("other"); break;
}
printf("\n");
printf(" entry code address is %08X%08X\n",
ppdsc->pdsc$q_entry[1], ppdsc->pdsc$q_entry[0]);
switch (ppdsc->pdsc$v_kind)
{
case PDSC$K_KIND_FP_STACK:
case PDSC$K_KIND_FP_REGISTER:
printf(" size of fixed portion of stack is %u bytes\n",
ppdsc->pdsc$l_size);
break;
default:
break;
}
printf(" signature block offset: %04X", ppdsc->pdsc$w_signature_offset);
} /* if procedure descriptor trace */
if (ppdsc->pdsc$w_signature_offset == 0)
{
if (alpha_trace_dscs)
printf("; none\n");
}
else if (ppdsc->pdsc$w_signature_offset == 1)
{
if (alpha_trace_dscs)
printf("; standard default used\n");
}
else if (alpha_trace_sigs)
{
register int64 *margs = 0;
register void *parg;
register int32 i, k, fpc, nbytes;
register uint32 argsigenc;
register int32 ialign;
int64 argval;
char *pargval[256];
uint8 nbytes_est[256];
ppsig = (struct psigdef*)(((char*)ppdsc)
+ ppdsc->pdsc$w_signature_offset);
if (alpha_trace_dscs)
{
printf("; %u arguments:\n", ppsig->psig$b_arg_count);
}
else
{
printf("\n entry at PC %08X%08X\n",
ppdsc->pdsc$q_entry[1], ppdsc->pdsc$q_entry[0]);
if (picb)
{
printf(" called from %08X%08X with %u arguments:\n",
picb->libicb$q_program_counter[1],
picb->libicb$q_program_counter[0],
ppsig->psig$b_arg_count);
}
}
if (ppsig->psig$v_su_vlist)
printf(" VAX style argument list expected\n");
printf(" function return signature: %u; ",
ppsig->psig$v_func_return);
show_signature_encoding(ppsig->psig$v_func_return);
printf("\n");
if (ppsig->psig$b_arg_count > 6)
{
printf(" memory arguments 7 thru %u summary is %u; ",
ppsig->psig$b_arg_count, ppsig->psig$v_su_asum);
switch (ppsig->psig$v_su_asum)
{
case 0: printf("all 64 bits, or not used"); break;
case 1: printf("all 32 bits sign extended"); break;
case 2: printf("(reserved)"); break;
case 3: printf("assorted signatures"); break;
}
printf("\n");
} /* if memory arguments summary exists */
if (picb)
{
if (ppdsc->pdsc$v_base_reg_is_fp)
margs = (int64*)picb->libicb$q_ireg[29];
else
margs = (int64*)picb->libicb$q_ireg[30];
margs = (int64*)(((char*)margs) + ppdsc->pdsc$l_size - (6*8));
}
/*
* Try to determine the addresses of all argument values.
*/
for (i = 0; i < ppsig->psig$b_arg_count; i++)
{
pargval[i] = (char*)(margs ? &margs[i] : 0);
nbytes_est[i] = 8; /* initially assume passed by value */
if (i < 6)
{
argsigenc = ((uint32)ppsig->psig$v_reg_arg_info)
>> ((uint32)(4*i));
argsigenc &= RASE$M_SIG_ENC;
if (argsigenc != RASE$K_RA_I32) continue; /* known passed by value */
} /* if register argument */
else
{
pmase = &ppsig->psig$b_arg_count;
pmase++; /* point to first byte of psig$v_memory_arg_info bitfield */
argsigenc = (uint32)(pmase[(i-6)/4]
>> (uint8)(2*((i-6)%4)));
argsigenc &= 3;
if (argsigenc != MASE$K_MA_I32) continue; /* known passed by value */
} /* if memory argument */
if (!__PAL_PROBER(&margs[i],8,0)) continue;
parg = &margs[i];
argval = margs[i];
if (((argval >= 0x00010000L) && (argval < 0x80000000L))
|| ((argval & 0xFFFFFFFF80000000L) == 0xFFFFFFFF80000000L))
{
if (__PAL_PROBER((void*)argval,1,0))
{
parg = (void*)argval;
} /* if reference to user-readable memory */
} /* if possible 32-bit sign-extended P0, P1, S0, S1 address */
if (parg != &margs[i])
{
pargval[i] = parg;
nbytes_est[i] = 16; /* very likely passed by reference */
}
} /* for all arguments i */
/*
* Limit maximum sizes of argument values; check for overlaps.
*/
for (i = 0; i < ppsig->psig$b_arg_count; i++)
{
if (!pargval[i]) continue;
for (k = 0; k < ppsig->psig$b_arg_count; k++)
{
if (k == i) continue;
if (!pargval[k]) continue;
if (pargval[k] <= pargval[i]) continue;
nbytes = pargval[k] - pargval[i];
if (nbytes_est[i] < nbytes) continue;
nbytes_est[i] = nbytes;
} /* for all arguments k */
if (!margs) continue;
if ((char*)margs <= pargval[i]) continue;
nbytes = (char*)margs - pargval[i];
if (nbytes_est[i] < nbytes) continue;
nbytes_est[i] = nbytes;
} /* for all arguments i */
/*
* Display information about each of the arguments.
*/
for (i = 0; i < ppsig->psig$b_arg_count; i++)
{
if (i < 6)
{
argsigenc = ((uint32)ppsig->psig$v_reg_arg_info)
>> ((uint32)(4*i));
argsigenc &= RASE$M_SIG_ENC;
printf(" (register) argument #%d signature: %u; ", 1+i, argsigenc);
switch (argsigenc)
{
case RASE$K_RA_NOARG: printf("not present"); break;
case RASE$K_RA_Q: printf("R%d 64 bits", 16+i); break;
case RASE$K_RA_I32: printf("R%d 32 bits signed", 16+i); break;
case RASE$K_RA_U32: printf("R%d 32 bits unsigned", 16+i); break;
case RASE$K_RA_FF: printf("F%d <-> F float", 16+i); break;
case RASE$K_RA_FD: printf("F%d <-> D double", 16+i); break;
case RASE$K_RA_FG: printf("F%d <-> G double", 16+i); break;
case RASE$K_RA_FS: printf("F%d <-> S float", 16+i); break;
case RASE$K_RA_FT: printf("F%d <-> T double", 16+i); break;
default: printf("reserved for future use"); break;
}
printf("\n");
} /* if register argument */
else
{
pmase = &ppsig->psig$b_arg_count;
pmase++; /* point to first byte of psig$v_memory_arg_info bitfield */
argsigenc = (uint32)(pmase[(i-6)/4]
>> (uint8)(2*((i-6)%4)));
argsigenc &= (uint32)3;
printf(" (memory) argument #%d signature: %u; ", 1+i, argsigenc);
switch (argsigenc)
{
case MASE$K_MA_Q: printf("64 bits"); break;
case MASE$K_MA_I32: printf("32 bits signed"); break;
default: printf("reserved for future use"); break;
}
printf("\n");
} /* if memory argument */
if (__PAL_PROBER(&margs[i],8,0))
{
printf(" %08p", &margs[i]);
if (((i < 6) && (argsigenc == RASE$K_RA_I32))
|| ((i >= 6) && (argsigenc == MASE$K_MA_I32)))
{
register struct dsc$descriptor_s *pascid;
register uint8 *p;
register int32 iaccess;
register uint16 n;
iaccess = 3;
parg = &margs[i];
argval = margs[i];
if (((argval >= 0x00010000L) && (argval < 0x80000000L))
|| ((argval & 0xFFFFFFFF80000000L) == 0xFFFFFFFF80000000L))
{
for (ialign = 0;
(ialign < NALIGN-1) && (((int32)argval & (1 << ialign)) == 0);
ialign++) continue;
if (__PAL_PROBER((void*)argval,1,0))
{
parg = (void*)argval;
printf(": %08p (", parg);
printf("%s", ((int32)parg < 0) ? "S" : "P");
printf("%s", ((int32)parg & 0x40000000) ? "1" : "0");
printf(" pointer?)\n");
printf(" %08p", parg);
if (__PAL_PROBER(parg,8,0)
&& (ialign >= 3) && (nbytes_est[i] >= 8))
iaccess = 3;
else if (__PAL_PROBER(parg,4,0)
&& (ialign >= 2) && (nbytes_est[i] >= 4))
iaccess = 2;
else if (__PAL_PROBER(parg,2,0)
&& (ialign >= 1) && (nbytes_est[i] >= 2))
iaccess = 1;
else
iaccess = 0;
switch (iaccess)
{
case 0:
argval = *((int8*)parg);
break;
case 1:
argval = *((int16*)parg);
break;
case 2:
argval = *((int32*)parg);
break;
case 3:
default:
argval = *((int64*)parg);
break;
} /* switch (iaccess) */
} /* if reference to user-readable memory */
} /* if possible 32-bit sign-extended P0, P1, S0, S1 address */
/*
* Always display the 64-bit hex value first.
*/
printf(": %016LX\n", argval);
/*
* If the argument is passed by reference, it might be a string descriptor
* (.ASCID), or an array of characters terminated by a NUL (zero) byte
* (.ASCIZ). Allow only ASCII printable characters and tabs. If the format
* is very likely .ASCID or .ASCIZ, don't bother with other interpretations.
*/
if (parg != &margs[i])
{
/*
* Try to interpret the argument as a string descriptor.
*/
if (iaccess >= 3)
{
pascid = (struct dsc$descriptor_s*)parg;
if (pascid->dsc$w_length)
{
if ((pascid->dsc$a_pointer >= (char*)0x00010000)
&& ((((int32)parg) < 0) ==
(((int32)pascid->dsc$a_pointer) < 0)))
{
if (__PAL_PROBER
(pascid->dsc$a_pointer,pascid->dsc$w_length,0))
{
for (n = 0, p = (uint8*)pascid->dsc$a_pointer;
n < pascid->dsc$w_length;
n++)
if (((p[n] < ' ') || (p[n] > '~')) && (p[n] != '\t'))
break;
if (n)
{
printf(" = .ASCID \"%.*s\"\n", n, p);
if (n == pascid->dsc$w_length)
continue;
else
printf(" (%hu of %hu characters)\n",
n, pascid->dsc$w_length);
if (pascid->dsc$b_dtype != DSC$K_DTYPE_T)
printf(" (dtype = %02X)\n",
0xFF & pascid->dsc$b_dtype);
if ((pascid->dsc$b_class != DSC$K_CLASS_S)
&& (pascid->dsc$b_class != DSC$K_CLASS_D))
printf(" (class = %02X)\n",
0xFF & pascid->dsc$b_class);
} /* if one or more printable characters is found */
} /* if full string is accessible */
} /* if pointer field is plausible */
} /* if length field is non-zero */
} /* if aligned quadword */
/*
* Try to interpret the argument as a NUL-terminated string.
*/
for (n = 0, p = parg;
(n < 255) && __PAL_PROBER(&p[n],1,0);
n++)
if (((p[n] < ' ') || (p[n] > '~')) && (p[n] != '\t'))
break;
if (n)
{
if ((p[n] == 0) || (n > 8))
{
printf(" = .ASCIZ \"%.*s\"\n", n, p);
if ((p[n] == 0) && (n > 8)) continue;
}
} /* if one or more printable characters is found */
} /* if might be .ASCID or .ASCIZ by reference */
/*
* Interpret value as signed (and unsigned, if different) byte integer.
*/
printf(" = %d as signed %s\n",
*((int8*)parg), align_name[0]);
if (*((int8*)parg) < 0)
printf(" = %u as unsigned %s\n",
0xFF & *((uint8*)parg), align_name[0]);
/*
* Interpret value as signed (and unsigned, if different) word integer.
*/
if ((iaccess >= 1)
&& (*((int16*)parg) != *((int8*)parg)))
{
printf(" %s= %hd as signed %s\n",
((argval & 0xFF00L) == 0x2000L) ?
"(unlikely) " : "",
*((int16*)parg), align_name[1]);
if (*((int16*)parg) < 0)
printf(" %s= %hu as unsigned %s\n",
((argval & 0xFF00L) == 0x2000L) ?
"(unlikely) " : "",
*((uint16*)parg), align_name[1]);
}
/*
* Interpret value as signed (and unsigned, if different) longword integer.
*/
if ((iaccess >= 2)
&& (*((int32*)parg) != *((int16*)parg)))
{
printf(" %s= %d as signed %s\n",
((argval & 0xFFFF0000L) == 0x20200000L) ?
"(unlikely) " : "",
*((int32*)parg), align_name[2]);
if (*((int32*)parg) < 0)
printf(" %s= %u as unsigned %s\n",
((argval & 0xFFFF0000L) == 0x20200000L) ?
"(unlikely) " : "",
*((uint32*)parg), align_name[2]);
}
/*
* Interpret value as signed (and unsigned, if different) quadword integer.
*/
if ((iaccess >= 3)
&& (argval != *((int32*)parg)))
{
printf(" %s= %d as signed %s\n",
((argval & 0xFFFFFFFF00000000L)
== 0x2020202000000000L) ?
"(unlikely) " : "",
argval, align_name[3]);
if (argval < 0)
printf(" %s= %u as unsigned %s\n",
((argval & 0xFFFFFFFF00000000L)
== 0x2020202000000000L) ?
"(unlikely) " : "",
argval, align_name[3]);
}
/*
* Any argument passed by reference, or any memory argument that claims
* to be a signed 32-bit value, might actually be a floating-point value.
*
* Any register argument passed by value that claims to be a signed
* 32-bit value, might actually be (a structure containing) one (or more)
* floating-point value(s). For example, this occurs in the (unusual)
* instance of passing a (complex) pair of floating-point values.
* Usually, though, the data type of a register argument passed by value
* can be correctly identified, if the procedure signature was generated
* by the /TIE compiler option.
*
* The actual data type is not specified, so each likely format should
* be checked. When compiling *all* modules, the *same* /FLOAT compiler
* option (D|G|IEEE) *must* be specified, so that *all* likely formats
* will match float (F|F|S), double (D|G|T), or long double (X|X|X)
* in this module.
*/
/*
* Try to interpret the argument as a float (32 bits).
*/
if (iaccess >= 2)
{
if ((1 << fp_classf(*((float*)parg))) & fp_class_valid)
{
printf(
" %s= %+.*G as %c float\n",
(*((int32*)parg) == 0x20202020) ?
"(unlikely) " : "",
FLT_DIG,
*((float*)parg), flt_name);
/*
* Look for second float (32 bits) as the imaginary part of a complex number.
*/
if (iaccess >=3)
{
if ((1 << fp_classf(*((float*)
(((char*)parg)+sizeof(float))))) & fp_class_valid)
{
printf(
" %s %+.*G as %c float (im)\n",
(*((int32*)(((char*)parg)+sizeof(float)))
== 0x20202020) ? "(unlikely) " : "",
FLT_DIG,
*((float*)(((char*)parg)+sizeof(float))), flt_name);
} /* if valid float (imaginary part of complex?) */
else if (alpha_trace_dnrm)
{
printf(" %s as %c float (im)\n",
fp_class_name[fp_classf(*((float*)
(((char*)parg)+sizeof(float))))], flt_name);
}
} /* if aligned quadword */
} /* if valid float */
else if (alpha_trace_dnrm)
{
printf(" = %s as %c float\n",
fp_class_name[fp_classf(*((float*)parg))], flt_name);
}
} /* if aligned longword */
/*
* Try to interpret the argument as a double (64 bits).
*/
if (iaccess >= 3)
{
if ((1 << fp_class(*((double*)parg))) & fp_class_valid)
{
printf(
" %s= %+.*G as %c double\n",
(*((int32*)(((char*)parg)+sizeof(float)))
== 0x20202020) ? "(unlikely) " : "",
DBL_DIG,
*((double*)parg), dbl_name);
} /* if valid double */
else if (alpha_trace_dnrm)
{
printf(" = %s as %c double\n",
fp_class_name[fp_class(*((double*)parg))], dbl_name);
}
/*
* If the argument is plausible as a distinct octaword...
*/
if ((parg != &margs[i]) /* passed by reference */
&& __PAL_PROBER(parg,16,0) /* accessible octaword */
&& (nbytes_est[i] >= 16)) /* no known overlap */
{
/*
* If the first double is valid, look for second double as imaginary part.
*/
if ((1 << fp_class(*((double*)parg))) & fp_class_valid)
{
if ((1 << fp_class(*((double*)
(((char*)parg)+sizeof(double))))) & fp_class_valid)
{
printf(
" %s %+.*G as %c double (im)\n",
(*((int32*)(((char*)parg)+sizeof(double)+sizeof(float)))
== 0x20202020) ? "(unlikely) " : "",
DBL_DIG,
*((double*)(((char*)parg)+sizeof(double))), dbl_name)
} /* if valid second double (imag. part of double complex?) */
else if (alpha_trace_dnrm)
{
printf(" %s as %c double (im)\n",
fp_class_name[fp_class(*((double*)
(((char*)parg)+sizeof(double))))], dbl_name);
}
} /* if valid first double */
/*
* Try to interpret the argument as a long double (128 bits).
*/
if ((1 << fp_classl(*((long double*)parg))) & fp_class_valid)
{
printf(
" %s= %+.*LG as X long double\n",
(*((int64*)(((char*)parg)+sizeof(double)))
== 0x2020202020202020L) ? "(unlikely) " : "",
LDBL_DIG,
*((long double*)parg));
} /* if valid long double */
else if (alpha_trace_dnrm)
{
printf(" = %s as X long double\n",
fp_class_name[fp_classl(*((long double*)parg))]);
}
/*
* Show the full 128 bits as hex digits.
*/
printf(" %08p: %016LX%016LX\n", parg,
*((int64*)(((char*)parg)+sizeof(int64))), argval);
} /* if argument is plausible as a distinct octaword */
} /* if aligned quadword */
} /* if homed argument claims to be a 32-bit signed value */
else if (i < 6)
{
struct dsc$descriptor_s src;
struct dsc$descriptor_s dst;
double d;
float f;
int32 ndigits;
printf(": %016LX = ", margs[i]);
src.dsc$a_pointer = (char*)&margs[i];
src.dsc$b_class = dst.dsc$b_class = DSC$K_CLASS_S;
switch (argsigenc)
{
case RASE$K_RA_FF:
src.dsc$w_length = sizeof(float);
src.dsc$b_dtype = DSC$K_DTYPE_F;
ndigits = __F_FLT_DIG;
break;
case RASE$K_RA_FS:
src.dsc$w_length = sizeof(float);
src.dsc$b_dtype = DSC$K_DTYPE_FS;
ndigits = __S_FLT_DIG;
break;
case RASE$K_RA_FD:
src.dsc$w_length = sizeof(double);
src.dsc$b_dtype = DSC$K_DTYPE_D;
ndigits = __G_FLT_DIG;
break;
case RASE$K_RA_FG:
src.dsc$w_length = sizeof(double);
src.dsc$b_dtype = DSC$K_DTYPE_G;
ndigits = __G_FLT_DIG;
break;
case RASE$K_RA_FT:
src.dsc$w_length = sizeof(double);
src.dsc$b_dtype = DSC$K_DTYPE_FT;
ndigits = __T_FLT_DIG;
break;
default:
src.dsc$w_length = 0;
src.dsc$b_dtype = DSC$K_DTYPE_Z;
ndigits = 0;
printf("(unknown)");
break;
}
dst.dsc$w_length = src.dsc$w_length;
if (dst.dsc$w_length == sizeof(float))
{
dst.dsc$b_dtype = flt_dtype;
dst.dsc$a_pointer = (char*)&f;
}
else if (dst.dsc$w_length == sizeof(double))
{
dst.dsc$b_dtype = dbl_dtype;
dst.dsc$a_pointer = (char*)&d;
}
else
{
dst.dsc$b_dtype = src.dsc$b_dtype;
dst.dsc$a_pointer = 0;
}
if (lib$cvt_dx_dx(&src, &dst) & 1)
{
if (dst.dsc$w_length == sizeof(float))
printf("%+.*G", ndigits, f);
else if (dst.dsc$w_length == sizeof(double))
printf("%+.*G", ndigits, d);
}
printf("\n");
}
}
} /* for all arguments i */
} /* if signature block trace */
if (alpha_trace_dscs)
{
switch (ppdsc->pdsc$v_kind)
{
case PDSC$K_KIND_FP_STACK:
if (ppdsc->pdsc$v_handler_data_valid)
{
printf(" stack handler data %08X%08X\n",
ppdsc->pdsc$q_stack_handler_data[1],
ppdsc->pdsc$q_stack_handler_data[0]);
}
if (ppdsc->pdsc$v_handler_valid)
{
printf(" stack handler procedure descriptor at %08X%08X:\n",
ppdsc->pdsc$q_stack_handler[1],
ppdsc->pdsc$q_stack_handler[0]);
show_pd((struct pdscdef*)ppdsc->pdsc$q_stack_handler[0], 0);
}
break;
case PDSC$K_KIND_FP_REGISTER:
if (ppdsc->pdsc$v_handler_data_valid)
{
printf(" register handler data %08X%08X\n",
ppdsc->pdsc$q_reg_handler_data[1],
ppdsc->pdsc$q_reg_handler_data[0]);
}
if (ppdsc->pdsc$v_handler_valid)
{
printf(" register handler procedure descriptor at %08X%08X:\n",
ppdsc->pdsc$q_reg_handler[1],
ppdsc->pdsc$q_reg_handler[0]);
show_pd((struct pdscdef*)ppdsc->pdsc$q_reg_handler[0], 0);
}
break;
case PDSC$K_KIND_BOUND:
printf(" bound procedure descriptor value %08X%08X\n",
ppdsc->pdsc$q_proc_value[1],
ppdsc->pdsc$q_proc_value[0]);
printf(" bound procedure descriptor environment %08X%08X\n",
ppdsc->pdsc$q_environment[1],
ppdsc->pdsc$q_environment[0]);
break;
default:
break;
} /* switch (ppdsc->pdsc$v_kind) */
} /* if procedure descriptor trace */
} /* show_pd() */
/*
* This routine must execute in executive access mode.
* Any unhandled exception will result in process deletion.
*/
int32 get_ldrimg_info(LDRIMG *pldrimg)
{
/* Check argument count */
if (__VA_COUNT_BUILTIN() != 1)
return SS$_ACCVIO;
/* Check for user-writeable LDRIMG output */
if (!__PAL_PROBEW(pldrimg, sizeof(*pldrimg), PSL$C_USER))
return SS$_ACCVIO;
/* If forward link is non-negative, initialize it to the first in the queue */
if ((int32)pldrimg->ldrimg$l_flink >= 0)
pldrimg->ldrimg$l_flink = (LDRIMG*)LDR$GQ_IMAGE_LIST[0];
/* If forward link points to the head or is zero, then end of list */
if ((pldrimg->ldrimg$l_flink == (LDRIMG*)LDR$GQ_IMAGE_LIST)
|| (pldrimg->ldrimg$l_flink == 0))
return SS$_NOMOREITEMS;
/* Check for privileged read access to entire next LDRIMG */
if (!__PAL_PROBER(pldrimg->ldrimg$l_flink, sizeof(LDRIMG), PSL$C_EXEC))
return SS$_ACCVIO;
/* Copy the entire next LDRIMG */
ots$move3(sizeof(LDRIMG), (char*)pldrimg->ldrimg$l_flink, (char*)pldrimg);
/* Return success status */
return SS$_NORMAL;
} /* get_ldrimg_info() */
void tbk_find_ldrimg_symbol(
const uint8 imgnamlen,
const char *const imgnam,
const int64 pcrel,
const int32 imgoff,
const int32 imgend)
{
register int64 epoff, epmin;
char *pchar = 0;
EGSYDEF *pgsy = 0;
EGSTDEF *pgst = 0;
objrec_t r;
int32 fd = 0;
int32 lrec;
char stbname[40];
char symname[32];
struct dsc$descriptor_s namedsc;
struct fscndef fscnlist[2];
if (imgnamlen >= sizeof(stbname)) return; /* need room for filename */
if (pcrel < imgoff) return; /* offset must be big enough */
if (pcrel > imgend) return; /* offset must be small enough */
ots$move5(imgnamlen, imgnam, '\0', sizeof(stbname), stbname);
namedsc.dsc$w_length = imgnamlen;
namedsc.dsc$b_dtype = DSC$K_DTYPE_T;
namedsc.dsc$b_class = DSC$K_CLASS_S;
namedsc.dsc$a_pointer = stbname;
fscnlist[0].fscn$w_length = 0;
fscnlist[0].fscn$w_item_code = FSCN$_TYPE;
fscnlist[0].fscn$l_addr = 0;
fscnlist[1].fscn$w_length = 0;
fscnlist[1].fscn$w_item_code = 0;
fscnlist[1].fscn$l_addr = 0;
if (!(sys$filescan(&namedsc, fscnlist, 0, 0, 0) & 1)) return;
if (fscnlist[0].fscn$w_length >= 4)
{
if (strncmp((char*)fscnlist[0].fscn$l_addr, ".EXE", 4) == 0)
{
strncpy((char*)fscnlist[0].fscn$l_addr, ".STB", 4);
}
}
fd = open(stbname, O_RDONLY, 0,
"rop=asy,nlk,rah,rrl", "shr=upi",
"ctx=bin", "ctx=nocvt", "ctx=rec",
"mbc=127", "mbf=2",
"dna=SYS$LOADABLE_IMAGES:.STB;");
if (fd == -1)
{
perror("fopen");
fprintf(stderr, "Failed to open symbol table file \"%s\".\n", stbname);
return;
}
epmin = maxi64;
while ((lrec = read(fd, r.b, sizeof(r.b)-1)) >= 0)
{
if (lrec < 4) break; /* must be large enough */
if (lrec > EOBJ$C_MAXRECSIZ) break; /* must be small enough */
if (lrec != r.objrec.eobj$w_size) break; /* sizes must match */
if (r.objrec.eobj$w_rectyp == EOBJ$C_EEOM) break; /* must not be eom */
if (r.objrec.eobj$w_rectyp != EOBJ$C_EGSD) continue; /* must be GSD rec */
for (pchar = (char*)&r.gs.egsd$w_gsdtyp, pgsy = (EGSYDEF*)pchar;
pchar < (char*)&r + r.objrec.eobj$w_size;
pgsy = (EGSYDEF*)pchar, pchar += pgsy->egsy$w_size)
{
if (pgsy->egsy$w_gsdtyp != EGSD$C_SYMG) continue; /* must be gbl sym */
if (!pgsy->egsy$v_def) continue; /* must be a definition */
if (!pgsy->egsy$v_rel) continue; /* must be relocatable */
if (!pgsy->egsy$v_norm) continue; /* must be a normal procedure */
pgst = (EGSTDEF*)pchar;
epoff = pcrel - pgst->egst$q_lp_1; /* offset from entry point */
if (epoff < 0) continue; /* must be non-negative */
if (epmin < epoff) continue; /* must be smallest so far */
epmin = epoff; /* store smallest offset */
ots$move5( /* store symbol name */
pgst->egst$b_namlng,
pgst->egst$t_name,
'\0',
sizeof(symname),
symname);
} /* for each global symbol entry in this record */
} /* for each record in file */
if (close(fd) != 0)
{
perror("close");
fprintf(stderr, "Failed to close symbol table file \"%s\"\n", stbname);
}
if (epmin == maxi64) return; /* must have found an entry point symbol */
printf("= %s+%05LX\n", symname, epmin); /* display symbol name plus offset */
} /* tbk_find_ldrimg_symbol() */
int32 get_resimg_gst_info(
const EIHD *const peihd,
const KFE *const pkfe,
uint32 *pgst_vbn,
uint32 *pgst_nrecs,
struct namdef *pnam)
{
WCB *pwcb;
FCB *pfcb;
KFD *pkfd;
char *pddtstr;
EIHS *peihs;
/* Check argument count */
if (__VA_COUNT_BUILTIN() < 5)
return SS$_INSFARG;
else if (__VA_COUNT_BUILTIN() > 5)
return SS$_TOO_MANY_ARGS;
/* Check for user write access to NAM argument DVI field */
if (!__PAL_PROBEW(pnam->nam$t_dvi,sizeof(pnam->nam$t_dvi),PSL$C_USER))
return SS$_ACCVIO;
/* Check for user write access to NAM argument FID fields */
if (!__PAL_PROBEW(pnam->nam$w_fid,sizeof(pnam->nam$w_fid),PSL$C_USER))
return SS$_ACCVIO;
/* Initialize these output arguments to zero */
ots$move5(0, 0, '\0', sizeof(pnam->nam$t_dvi), pnam->nam$t_dvi);
pnam->nam$w_fid[0] = pnam->nam$w_fid[1] = pnam->nam$w_fid[2] = 0;
/* Check for user write access to GST VBN argument */
if (!__PAL_PROBEW(pgst_vbn,sizeof(*pgst_vbn),PSL$C_USER))
return SS$_ACCVIO;
/* Check for user write access to GST record count argument */
if (!__PAL_PROBEW(pgst_nrecs,sizeof(*pgst_nrecs),PSL$C_USER))
return SS$_ACCVIO;
/* Initialize these output arguments to zero */
*pgst_vbn = 0;
*pgst_nrecs = 0;
/* Check for privileged read access to KFD pointer in KFE */
if (!__PAL_PROBER(&pkfe->kfe$l_kfd,sizeof(pkfe->kfe$l_kfd),PSL$C_EXEC))
return SS$_ACCVIO;
pkfd = pkfe->kfe$l_kfd;
/* Check for privileged read access to length of device name in KFD */
if (!__PAL_PROBER(&pkfd->kfd$b_devlen,sizeof(pkfd->kfd$b_devlen),PSL$C_EXEC))
return SS$_ACCVIO;
pddtstr = (char*)pkfd + offsetof(KFD,kfd$b_ddtstrlen) + 1;
/* Check for privileged read access to device name in KFD */
if (!__PAL_PROBER(pddtstr,pkfd->kfd$b_devlen,PSL$C_EXEC))
return SS$_ACCVIO;
/* Provide device name (without final colon) as NAM DVI .ASCIC counted string */
if (pkfd->kfd$b_devlen > sizeof(pnam->nam$t_dvi))
pnam->nam$t_dvi[0] = sizeof(pnam->nam$t_dvi) - 1;
else
pnam->nam$t_dvi[0] = pkfd->kfd$b_devlen - 1;
ots$move5(
pkfd->kfd$b_devlen-1,
pddtstr,
'\0',
sizeof(pnam->nam$t_dvi)-1,
&pnam->nam$t_dvi[1]);
/* Check for privileged read access to WCB pointer in KFE */
if (!__PAL_PROBER(&pkfe->kfe$l_wcb,sizeof(pkfe->kfe$l_wcb),0))
return SS$_ACCVIO;
pwcb = pkfe->kfe$l_wcb;
/* Check for privileged read access to FCB pointer in WCB */
if (!__PAL_PROBER(&pwcb->wcb$l_fcb,sizeof(pwcb->wcb$l_fcb),0))
return SS$_ACCVIO;
pfcb = pwcb->wcb$l_fcb;
/* Check for privileged read access to FID fields in FCB */
if (!__PAL_PROBER(pfcb->fcb$w_fid,sizeof(pfcb->fcb$w_fid),0))
return SS$_ACCVIO;
pnam->nam$w_fid[0] = pfcb->fcb$w_fid[0];
pnam->nam$w_fid[1] = pfcb->fcb$w_fid[1];
pnam->nam$w_fid[2] = pfcb->fcb$w_fid[2];
/* Check for privileged read access to EIHS offset field in EIHD */
if (!__PAL_PROBER(&peihd->eihd$l_symdbgoff,sizeof(peihd->eihd$l_symdbgoff),0))
return SS$_ACCVIO;
/* Check for zero offset, indicating no EIHS */
if (peihd->eihd$l_symdbgoff == 0)
return SS$_ACCVIO;
/* Compute EIHS pointer from image header offset */
peihs = (EIHS*)(((char*)peihd) + peihd->eihd$l_symdbgoff);
/* Check for privileged read access to GST VBN field in EIHS */
if (__PAL_PROBER(&peihs->eihs$l_gstvbn,sizeof(peihs->eihs$l_gstvbn),0))
*pgst_vbn = peihs->eihs$l_gstvbn;
/* Check for privileged read access to GST record count field in EIHS */
if (__PAL_PROBER(&peihs->eihs$l_gstsize,sizeof(peihs->eihs$l_gstsize),0))
*pgst_nrecs = peihs->eihs$l_gstsize;
/* Return with success status */
return SS$_NORMAL;
} /* get_resimg_gst_info() */
void tbk_find_resimg_symbol(
const EIHD *const peihd,
const KFE *const pkfe,
const int64 pcrel)
{
uint32 arg_gst[6] = {5, 0, 0, 0, 0, 0};
uint32 gst_nrecs, irec;
struct namdef nam;
struct fabdef fab;
struct rabdef rab;
char ubf[32768];
objrec_t *pobj;
register int64 epoff, epmin;
char *pchar = 0;
EGSYDEF *pgsy = 0;
EGSTDEF *pgst = 0;
char symname[32];
/* Initialize minimum entry point offset to largest possible value */
epmin = maxi64;
/* Initialize NAM */
ots$move5(0, 0, '\0', sizeof(nam), &nam);
nam.nam$b_bid = NAM$C_BID; /* identify RMS structure */
nam.nam$b_bln = NAM$C_BLN; /* specify size in bytes */
/* Initialize RAB */
ots$move5(0, 0, '\0', sizeof(rab), &rab);
rab.rab$b_bid = RAB$C_BID; /* identify RMS structure */
rab.rab$b_bln = RAB$C_BLN; /* specify size in bytes */
rab.rab$l_fab = &fab; /* point to FAB */
rab.rab$b_rac = RAB$C_RFA; /* find first GST record's file address */
rab.rab$b_mbc = 127; /* largest possible buffers */
rab.rab$b_mbf = 2; /* double buffering */
rab.rab$v_loc = 1; /* enable locate mode */
rab.rab$v_rah = 1; /* enable read ahead */
rab.rab$v_nlk = 1; /* no record locking */
rab.rab$v_rrl = 1; /* read records regardless of locks */
rab.rab$l_ubf = ubf; /* user buffer */
rab.rab$w_usz = sizeof(ubf)-1; /* size in bytes of user buffer */
/*
* Determine the starting VBN and record count for the global symbol table
* (if any), device name and file identification for the resident image file.
*/
arg_gst[1] = (uint32)peihd; /* copy image header */
arg_gst[2] = (uint32)pkfe; /* copy known file entry */
arg_gst[3] = (uint32)&rab.rab$l_rfa0; /* fill in GST VBN for find */
arg_gst[4] = (uint32)&gst_nrecs; /* fill in GST record count */
arg_gst[5] = (uint32)&nam; /* fill in DVI and FID fields */
if (!(sys$cmexec(&get_resimg_gst_info, arg_gst) & 1)) return;
if ((rab.rab$l_rfa0 == 0) || (gst_nrecs == 0)) return;
/* Initialize FAB */
ots$move5(0, 0, '\0', sizeof(fab), &fab);
fab.fab$b_bid = FAB$C_BID; /* identify RMS structure */
fab.fab$b_bln = FAB$C_BLN; /* specify size in bytes */
fab.fab$v_get = 1; /* read-only access */
fab.fab$v_nam = 1; /* open by NAM */
fab.fab$l_nam = &nam; /* point to NAM */
fab.fab$b_rtv = 255; /* cathedral retrieval windows */
fab.fab$v_shrget = 1; /* allow other readers */
fab.fab$v_upi = 1; /* no file locking */
/* Open the image file by NAM (DVI and FID fields) */
if (!(sys$open(&fab) & 1)) return;
/* Switch to variable record format for GST, using an undocumented feature */
fab.fab$b_rfm = FAB$C_VAR; /* variable record format */
fab.fab$v_esc = 1; /* escape bit for (non-std) modify funtion */
fab.fab$l_ctx = RME$C_SETRFM; /* specify set record format for modify */
if (!(sys$modify(&fab) & 1)) goto close_file;
/* Connect record stream and find GST VBN */
if (!(sys$connect(&rab) & 1)) goto close_file;
if (!(sys$find(&rab) & 1)) goto close_file;
/* Read the GST records */
rab.rab$b_rac = RAB$C_SEQ; /* switch to sequential record access */
irec = 0;
while ((sys$get(&rab) & 1) && (irec < gst_nrecs))
{
irec++;
if (rab.rab$w_rsz < 4) break; /* large enough */
if (rab.rab$w_rsz > EOBJ$C_MAXRECSIZ) break; /* small enough */
pobj = (objrec_t*)rab.rab$l_rbf; /* get object record pointer */
if (rab.rab$w_rsz != pobj->objrec.eobj$w_size) break; /* right size */
if (pobj->objrec.eobj$w_rectyp != EOBJ$C_EGSD)
continue; /* global symbol directory record */
for (pchar = (char*)&pobj->gs.egsd$w_gsdtyp, pgsy = (EGSYDEF*)pchar;
pchar < (char*)pobj + pobj->objrec.eobj$w_size;
pgsy = (EGSYDEF*)pchar, pchar += pgsy->egsy$w_size)
{
if (pgsy->egsy$w_gsdtyp != EGSD$C_SYMG) continue; /* global symbol */
if (!pgsy->egsy$v_def) continue; /* definition */
if (!pgsy->egsy$v_rel) continue; /* relocatable */
if (!pgsy->egsy$v_norm) continue; /* normal procedure */
pgst = (EGSTDEF*)pchar;
epoff = pcrel - pgst->egst$q_lp_1; /* offset from entry point */
if (epoff < 0) continue; /* non-negative offset */
if (epmin < epoff) continue; /* smallest one so far */
epmin = epoff; /* store new smallest offset */
ots$move5( /* store new symbol name */
pgst->egst$b_namlng,
pgst->egst$t_name,
'\0',
sizeof(symname),
symname);
} /* for each global symbol entry in this record */
} /* for each object record in GST */
close_file:
sys$close(&fab);
if (epmin == maxi64) return; /* entry point found */
printf("= %s+%05LX\n", symname, epmin); /* display symbol name plus offset */
return;
} /* tbk_find_resimg_symbol() */
int32 tbk_find_system_pc(const int64 pcabs)
{
LDRIMG ldrimg;
IMCB *pimcb;
KFERES *pkferes;
KFERES_SECTION *pkferes_section;
struct fscndef fscnlist[2];
int32 arg_ldrimg[2] = {1, 0};
register int64 base, pcrel;
struct dsc$descriptor_s namedsc;
#ifdef LINKTIME
struct dsc$descriptor_s timedsc;
char timebuf[24];
#endif
#if __VMS_VER >= 70000000
static const int64 pcabs_mask = 0xFFFFFFFFFFFFFFFFL;
static const char *tbk_out_fmt = " %s %-39.*s+ %016LX %016LX\n";
#else
static const int64 pcabs_mask = 0xFFFFFFFFL;
static const char *tbk_out_fmt = " %s %-51.*s+ %08LX %08LX\n";
#endif
fscnlist[0].fscn$w_item_code = FSCN$_NAME;
fscnlist[1].fscn$w_length = 0;
fscnlist[1].fscn$w_item_code = 0;
fscnlist[1].fscn$l_addr = 0;
arg_ldrimg[1] = (int32)&ldrimg;
namedsc.dsc$b_dtype = DSC$K_DTYPE_T;
namedsc.dsc$b_class = DSC$K_CLASS_S;
#ifdef LINKTIME
timedsc.dsc$b_dtype = DSC$K_DTYPE_T;
timedsc.dsc$b_class = DSC$K_CLASS_S;
timedsc.dsc$a_pointer = timebuf;
#endif
ldrimg.ldrimg$l_flink = 0;
while (ldrimg.ldrimg$l_flink != (LDRIMG*)LDR$GQ_IMAGE_LIST)
{
if (!(sys$cmexec(&get_ldrimg_info, arg_ldrimg) & 1)) break;
/*
* Try to reduce the image name to the file name component only.
* This should result in an image name of 39 bytes or less,
* which will fit conveniently into the traceback line format.
*/
fscnlist[0].fscn$w_length = 0;
fscnlist[0].fscn$l_addr = 0;
namedsc.dsc$w_length = ldrimg.ldrimg$b_imgnamlen;
namedsc.dsc$a_pointer = ldrimg.ldrimg$t_imgnam;
if (!(sys$filescan(&namedsc, &fscnlist, 0, 0, 0) & 1)) continue;
if (fscnlist[0].fscn$w_length && fscnlist[0].fscn$l_addr)
{
namedsc.dsc$w_length = fscnlist[0].fscn$w_length;
namedsc.dsc$a_pointer = (char*)fscnlist[0].fscn$l_addr;
}
#ifdef LINKTIME
timedsc.dsc$w_length = sizeof(timebuf) - 1;
sys$asctim(&timedsc.dsc$w_length, &timedsc, &ldrimg.ldrimg$q_linktime, 0);
timebuf[timedsc.dsc$w_length] = '\0';
#endif
base = (int64)ldrimg.ldrimg$l_nonpag_r_base;
if ((pcabs >= base) && (pcabs < (base + ldrimg.ldrimg$l_nonpag_r_len)))
{
pcrel = pcabs - base;
pcrel += ldrimg.ldrimg$l_nonpag_r_offset;
printf(tbk_out_fmt,
"n:r",
namedsc.dsc$w_length,
namedsc.dsc$a_pointer,
pcrel, pcabs & pcabs_mask);
#ifdef LINKTIME
printf(" linked %.*s\n", timedsc.dsc$w_length, timedsc.dsc$a_pointer);
#endif
tbk_find_ldrimg_symbol(
ldrimg.ldrimg$b_imgnamlen, ldrimg.ldrimg$t_imgnam, pcrel,
ldrimg.ldrimg$l_nonpag_r_offset, ldrimg.ldrimg$l_nonpag_r_end);
return 1;
}
base = (int64)ldrimg.ldrimg$l_nonpag_w_base;
if ((pcabs >= base) && (pcabs < (base + ldrimg.ldrimg$l_nonpag_w_len)))
{
pcrel = pcabs - base;
pcrel += ldrimg.ldrimg$l_nonpag_w_offset;
printf(tbk_out_fmt,
"n:w",
namedsc.dsc$w_length,
namedsc.dsc$a_pointer,
pcrel, pcabs & pcabs_mask);
#ifdef LINKTIME
printf(" linked %.*s\n", timedsc.dsc$w_length, timedsc.dsc$a_pointer);
#endif
tbk_find_ldrimg_symbol(
ldrimg.ldrimg$b_imgnamlen, ldrimg.ldrimg$t_imgnam, pcrel,
ldrimg.ldrimg$l_nonpag_w_offset, ldrimg.ldrimg$l_nonpag_w_end);
return 1;
}
base = (int64)ldrimg.ldrimg$l_pag_r_base;
if ((pcabs >= base) && (pcabs < (base + ldrimg.ldrimg$l_pag_r_len)))
{
pcrel = pcabs - base;
pcrel += ldrimg.ldrimg$l_pag_r_offset;
printf(tbk_out_fmt,
"p:r",
namedsc.dsc$w_length,
namedsc.dsc$a_pointer,
pcrel, pcabs & pcabs_mask);
#ifdef LINKTIME
printf(" linked %.*s\n", timedsc.dsc$w_length, timedsc.dsc$a_pointer);
#endif
tbk_find_ldrimg_symbol(
ldrimg.ldrimg$b_imgnamlen, ldrimg.ldrimg$t_imgnam, pcrel,
ldrimg.ldrimg$l_pag_r_offset, ldrimg.ldrimg$l_pag_r_end);
return 1;
}
base = (int64)ldrimg.ldrimg$l_pag_w_base;
if ((pcabs >= base) && (pcabs < (base + ldrimg.ldrimg$l_pag_w_len)))
{
pcrel = pcabs - base;
pcrel += ldrimg.ldrimg$l_pag_w_offset;
printf(tbk_out_fmt,
"p:w",
namedsc.dsc$w_length,
namedsc.dsc$a_pointer,
pcrel, pcabs & pcabs_mask);
#ifdef LINKTIME
printf(" linked %.*s\n", timedsc.dsc$w_length, timedsc.dsc$a_pointer);
#endif
tbk_find_ldrimg_symbol(
ldrimg.ldrimg$b_imgnamlen, ldrimg.ldrimg$t_imgnam, pcrel,
ldrimg.ldrimg$l_pag_w_offset, ldrimg.ldrimg$l_pag_w_end);
return 1;
}
base = (int64)ldrimg.ldrimg$l_fixup_base;
if ((pcabs >= base) && (pcabs < (base + ldrimg.ldrimg$l_fixup_len)))
{
pcrel = pcabs - base;
pcrel += ldrimg.ldrimg$l_fixup_offset;
printf(tbk_out_fmt,
"fix",
namedsc.dsc$w_length,
namedsc.dsc$a_pointer,
pcrel, pcabs & pcabs_mask);
#ifdef LINKTIME
printf(" linked %.*s\n", timedsc.dsc$w_length, timedsc.dsc$a_pointer);
#endif
tbk_find_ldrimg_symbol(
ldrimg.ldrimg$b_imgnamlen, ldrimg.ldrimg$t_imgnam, pcrel,
ldrimg.ldrimg$l_fixup_offset, ldrimg.ldrimg$l_fixup_end);
return 1;
}
base = (int64)ldrimg.ldrimg$l_init_base;
if ((pcabs >= base) && (pcabs < (base + ldrimg.ldrimg$l_init_len)))
{
pcrel = pcabs - base;
pcrel += ldrimg.ldrimg$l_init_offset;
printf(tbk_out_fmt,
"ini",
namedsc.dsc$w_length,
namedsc.dsc$a_pointer,
pcrel, pcabs & pcabs_mask);
#ifdef LINKTIME
printf(" linked %.*s\n", timedsc.dsc$w_length, timedsc.dsc$a_pointer);
#endif
tbk_find_ldrimg_symbol(
ldrimg.ldrimg$b_imgnamlen, ldrimg.ldrimg$t_imgnam, pcrel,
ldrimg.ldrimg$l_init_offset, ldrimg.ldrimg$l_init_end);
return 1;
}
} /* while following the ldrimg queue forward links */
for ( pimcb = (IMCB*)IAC$GL_IMAGE_LIST;
pimcb != (IMCB*)&IAC$GL_IMAGE_LIST;
pimcb = pimcb->imcb$l_flink )
{
pkferes = pimcb->imcb$l_kferes_ptr;
if (pkferes)
{
/*
* Note that the system resident code section is *assumed* here
* to be the first section in the list. This may or may not be
* a valid assumption in the future.
*/
pkferes_section =
(KFERES_SECTION*)((char*)pkferes + KFERES$K_FIXED_LENGTH);
if (pkferes_section->kferes$l_section_type == KFERES$K_CODE)
{
base = (int64)pkferes_section->kferes$l_va;
if ((pcabs >= base)
&& (pcabs < (base + pkferes_section->kferes$l_length)))
{
pcrel = pcabs - base;
pcrel += (int64)pkferes_section->kferes$l_image_offset;
printf(tbk_out_fmt,
"res",
(uint32)pimcb->imcb$t_image_name[0],
&pimcb->imcb$t_image_name[1],
pcrel, pcabs & pcabs_mask);
tbk_find_resimg_symbol(pimcb->imcb$l_ihd, pimcb->imcb$l_kfe, pcrel);
return 1;
} /* if the absolute PC is within the section limits */
} /* if this is a system resident code section */
} /* if this is a resident image */
} /* for each image control block in the current process image list */
return 0;
} /* tbk_find_system_pc() */
int32 tbk_analyze_line(struct dsc$descriptor_s *plinedsc)
{
struct dsc$descriptor_s subsdsc;
int64 pcrel, pcabs;
static const int64 GL = 0xFFFFFFFF80000000L;
#if __VMS_VER >= 70000000
static const $DESCRIPTOR(nonadsc,
" 0 ");
#else
static const $DESCRIPTOR(nonadsc,
" 0 ");
#endif
/*
* The traceback line should have the required minimum length.
*/
#if __VMS_VER >= 70000000
if (plinedsc->dsc$w_length < 79) return 0;
#else
if (plinedsc->dsc$w_length < 78) return 0;
#endif
/*
* The traceback line should not have image, module, or routine names,
* and should have line number zero.
*/
subsdsc = *plinedsc;
subsdsc.dsc$w_length = nonadsc.dsc$w_length;
if (str$compare_eql(&subsdsc, &nonadsc) != 0) return 0;
/*
* Read the hexadecimal relative and absolute PC values.
*/
#if __VMS_VER >= 70000000
if (sscanf(&plinedsc->dsc$a_pointer[nonadsc.dsc$w_length],
"%16LX %16LX", &pcrel, &pcabs) != 2) return 0;
#else
if (sscanf(&plinedsc->dsc$a_pointer[nonadsc.dsc$w_length],
"%8LX %8LX", &pcrel, &pcabs) != 2) return 0;
if (pcrel & 0x80000000L) pcrel |= 0xFFFFFFFF00000000L;
if (pcabs & 0x80000000L) pcabs |= 0xFFFFFFFF00000000L;
#endif
/*
* Relative and absolute PC should be the same.
*/
if (pcrel != pcabs) return 0;
/*
* PC value should be a 32-bit system address (S0 or S1) only.
*/
if (pcabs < GL) return 0;
if (pcabs >= 0L) return 0;
/*
* Look for a loaded system executive iamge or resident shareable image,
* with address range matching the PC value.
*/
return tbk_find_system_pc(pcabs);
} /* tbk_analyze_line() */
tbk_action(struct dsc$descriptor_s *plinedsc, int32 *puser_arg)
{
if (!tbk_analyze_line(plinedsc))
printf("%.*s\n", plinedsc->dsc$w_length, plinedsc->dsc$a_pointer);
} /* tbk_action() */
alpha_trace()
{
register uint32 i, nctx, isav, fsav;
register struct pdscdef *ppdsc;
struct chfdef1 *psigargs;
struct chfdef2 *pmchargs;
struct invo_context_blk invctx;
extern void tbk$show_traceback(
int32 faulting_fp,
int32 faulting_sp,
int32 faulting_pc,
int32 detail_level,
void *user_action_procedure,
int32 user_arg);
nctx = 0;
memset(&invctx, 0, sizeof(invctx));
lib$get_curr_invo_context(&invctx);
if (&tbk$show_traceback)
{
printf("\n[alpha_trace] tbk$show_traceback for curr invo context:\n");
tbk$show_traceback(
invctx.libicb$q_ireg[29],
invctx.libicb$q_ireg[30],
invctx.libicb$q_program_counter[0],
0, (void*)&tbk_action, 999);
}
else
{
printf("\n[alpha_trace] attempting lib$signal traceback\n");
lib$signal(SS$_RESIGNAL_64);
}
do
{
ppdsc = (struct pdscdef*)invctx.libicb$ph_procedure_descriptor;
if (alpha_trace_icbs)
{
/* register chfctx_t *pchfctx = 0; */
printf("\nInvo Context #%d; version %u/%u; %u/%u/%u bytes.\n",
++nctx,
invctx.libicb$b_block_version,
LIBICB$K_INVO_CONTEXT_VERSION,
invctx.libicb$l_context_length,
sizeof(invctx),
LIBICB$K_INVO_CONTEXT_BLK_SIZE);
if (invctx.libicb$v_exception_frame)
printf(" exception frame\n");
if (invctx.libicb$v_ast_frame)
printf(" AST frame\n");
if (invctx.libicb$v_bottom_of_stack)
printf(" bottom of stack\n");
if (invctx.libicb$v_base_frame)
printf(" base frame\n");
printf(" program counter at %08X%08X\n",
invctx.libicb$q_program_counter[1],
invctx.libicb$q_program_counter[0]);
printf(" processor status is %08X%08X\n",
invctx.libicb$q_processor_status[1],
invctx.libicb$q_processor_status[0]);
printf(" saved scalar and/or floating-point registers:\n");
for (i=0; i<31; i++)
{
isav = (ppdsc->pdsc$l_ireg_mask & ((uint32)1 << i));
fsav = (ppdsc->pdsc$l_freg_mask & ((uint32)1 << i));
if (isav || fsav)
{
if (isav)
printf(" R%02d = %016LX", i, invctx.libicb$q_ireg[i]);
else
printf(" ");
if (fsav) /* always saved in IEEE T format */
decc$tprintf(" | F%02d = %016LX = %+.*G\n",
i, invctx.libicb$q_freg[i],
__T_FLT_DIG, invctx.libicb$q_freg[i]);
else
printf("\n");
}
}
/*
pchfctx = (chfctx_t*)invctx.libicb$ph_chfctx_addr;
if (pchfctx && __PAL_PROBER(pchfctx,sizeof(chfctx_t),0))
{
printf(" condition handling facility context at %016p:\n",
invctx.libicb$ph_chfctx_addr);
printf(" byte count is %u.\n", pchfctx->bytecnt);
printf(" signal argument count is %u.\n", pchfctx->sig_args);
printf(" message pointer is %08p\n", pchfctx->msgptr);
printf(" flags are %08X:\n", pchfctx->flags);
if (pchfctx->flags & CHFCTX$M_SIGNAL)
printf(" signal\n");
if (pchfctx->flags & CHFCTX$M_STOP)
printf(" stop\n");
if (pchfctx->flags & CHFCTX$M_FPREGS_VALID)
printf(" fpregs_valid\n");
if (pchfctx->flags & CHFCTX$M_UNWIND_AST)
printf(" unwind_AST\n");
if (pchfctx->flags & CHFCTX$M_REINVOKABLE)
printf(" reinvokable\n");
if (pchfctx->flags & CHFCTX$M_FPREGS_READY)
printf(" fpregs_ready\n");
if (pchfctx->flags & CHFCTX$M_SYS_UNWIND)
printf(" sys_unwind\n");
if (pchfctx->flags & CHFCTX$M_GOTO_UNWIND)
printf(" goto_unwind\n");
if (pchfctx->flags & CHFCTX$M_EXIT_UNWIND)
printf(" exit_unwind\n");
if (pchfctx->flags & CHFCTX$M_RECALL_TARGET)
printf(" recall_target\n");
if (pchfctx->flags & CHFCTX$M_REENABLE_ASTS)
printf(" reenable_ASTs\n");
if (pchfctx->flags & CHFCTX$M_CALL_CLRAST)
printf(" call_clrAST\n");
printf(" linkage pointer at %016p\n", pchfctx->linkage_ptr);
printf(" exception address at %016p\n", pchfctx->expt_addr);
printf(" exception frame at %016p\n", pchfctx->expt_fp);
printf(" unwind stack pointer at %016p\n", pchfctx->unwind_sp);
printf(" reinvokable frame at %016p\n", pchfctx->reinvokable_fp);
printf(" unwind target at %016p\n", pchfctx->unwind_target);
printf(" signal arguments at %016p:\n", pchfctx->sigarglst);
psigargs = (struct chfdef1*)pchfctx->sigarglst;
if (__PAL_PROBER(psigargs,sizeof(psigargs->chf$is_sig_args),0))
{
if (__PAL_PROBER
(psigargs,sizeof(int32)*(1+psigargs->chf$is_sig_args),0))
{
register int32 *psig = (int32*)psigargs;
register uint32 isig;
for (isig = 0; isig <= psigargs->chf$is_sig_args; isig++)
printf(" #%02u: %08X\n", isig, psig[isig]);
}
}
printf(" mechanism arguments at %016p:\n", pchfctx->mcharglst);
pmchargs = (struct chfdef2*)pchfctx->mcharglst;
if (__PAL_PROBER(pmchargs,sizeof(pmchargs->chf$is_mch_args),0))
{
if (__PAL_PROBER
(pmchargs,sizeof(int64)*(1+pmchargs->chf$is_mch_args),0))
{
register int64 *pmch = (int64*)pmchargs;
register uint32 imch;
for (imch = 0; imch <= pmchargs->chf$is_mch_args; imch++)
printf(" #%02u: %016LX\n", imch, pmch[imch]);
}
}
}
*/
/* if condition handling facility context exists */
printf(" procedure descriptor at %016p:\n",
invctx.libicb$ph_procedure_descriptor);
} /* if invo context block trace */
show_pd(ppdsc, &invctx);
if (alpha_trace_icbs) printf("\n");
}
while (lib$get_prev_invo_context(&invctx));
} /* alpha_trace() */
uint32 trace_handl(
struct chfdef1 *psigargs,
struct chfdef2 *pmchargs)
{
uint32 depth = 1;
if (psigargs->chf$is_sig_name == SS$_UNWIND)
return 0;
if ($VMS_STATUS_SEVERITY(psigargs->chf$is_sig_name) != STS$K_SEVERE)
return SS$_RESIGNAL_64;
alpha_trace();
pmchargs->chf$q_mch_savr0 = psigargs->chf$is_sig_name;
if (alpha_trace_args)
printf("\n[trace_handl] %u sigargs, %u mchargs.\n",
psigargs->chf$is_sig_args, pmchargs->chf$is_mch_args);
HOMER(psigargs)
if (sys$unwind(&depth, 0) & 1) return 0;
return SS$_RESIGNAL_64;
} /* trace_handl() */
int32 bad_boy(const dcomplex_t D)
{
register double d;
register int64 n;
for (n = 0, d = D.im;; n++, d *= D.re)
printf("%Lu: %+.*G\n", n, DBL_DIG, d);
if (alpha_trace_args)
{
printf("\n[bad_boy] D.re: %+.*G; D.im: %+.*G\n",
DBL_DIG, D.re, DBL_DIG, D.im);
}
HOMER(D)
return SS$_NORMAL;
} /* bad_boy() */
ast_one(const dcomplex_t *pD)
{
printf("\n[ast_one] bad_boy returned %d.\n", bad_boy(*pD));
if (alpha_trace_args)
{
printf("\n[ast_one] pD->re: %+.*G; pD->im: %+.*G\n",
DBL_DIG, pD->re, DBL_DIG, pD->im);
}
HOMER(pD)
} /* ast_one() */
proc_dos(
char *a01,
double a02,
int32 a03,
int64 a04,
float a05,
uint64 a06,
char *a07,
double a08,
int32 a09,
char *a10,
float a11,
int32 a12,
char *a13,
double a14,
int32 a15,
char *a16,
float a17,
int32 a18,
char *a19,
double a20,
int32 a21)
{
int64 Q = 123456789012345;
int32 L = -1234567890;
int16 W = -32768;
int8 B = -128;
$DESCRIPTOR (A,"Argument #5");
float S = -6.6f;
double T = 77.77;
long double X = -88.88L;
complex_t C = {+99.99f, -99.99f};
dcomplex_t D = {-99.99, +99.99};
extern long double alfalfa(
int64 *pQ,
int32 *pL,
int16 *pW,
int8 *pB,
struct dsc$descriptor_s *pA,
float *pS,
double *pT,
long double *pX,
complex_t *pC,
dcomplex_t *pD);
printf("\n[proc_dos] alfalfa returned %+.*LG\n", LDBL_DIG,
alfalfa(&Q,&L,&W,&B,&A,&S,&T,&X,&C,&D));
if (alpha_trace_args)
{
printf("\n[proc_dos] a01: %s; a02: %f; a03: %d;\n", a01, a02, a03);
printf(" a04: %d; a05: %f; a06: %Lu;\n", a04, a05, a06);
printf(" a07: %s; a08: %f; a09: %d;\n", a07, a08, a09);
printf(" a10: %s; a11: %f; a12: %d;\n", a10, a11, a12);
printf(" a13: %s; a14: %f; a15: %d;\n", a13, a14, a15);
printf(" a16: %s; a17: %f; a18: %d;\n", a16, a17, a18);
printf(" a19: %s; a20: %f; a21: %d\n", a19, a20, a21);
}
HOMER(a01)
} /* proc_dos() */
proc_uno(int32 a01, double a02, char *a03)
{
proc_dos(
"argument #01", 2.2, 3,
-4, 123.45, 99999123456,
"argument #07", 8.8, 9,
"argument #10", 11.11, 12,
"argument #13", 14.14, 15,
"argument #16", 17.17, 18,
"argument #19", 20.20L, 21);
if (alpha_trace_args)
{
printf("\n[proc_uno] a01: %d; a02: %f; a03: %s\n", a01, a02, a03);
}
HOMER(a01)
} /* proc_uno() */
main(int32 argc, char *argv[])
{
int32 iarg;
vaxc$establish(&trace_handl);
proc_uno(1, 12.5, "argument #3");
if (alpha_trace_args)
{
printf("\n[main] argc: %d;\n", argc);
for (iarg = 0; iarg < argc; iarg++)
printf(" argv[%d]: \"%s\"\n", iarg, argv[iarg]);
}
HOMER(argc)
} /* main() */
|
| /*
* ALPHA_TRACE does two things:
*
* 1) Provides an enhanced traceback using image global symbols.
*
* 2) Interprets call frames, including procedure descriptors,
* procedure signatures, and homed arguments.
*
* Updates:
*
* September 30th, 1996 by Bob Sampson:
*
* Implemented enhanced traceback. Read access to symbol tables and
* images is required. CMEXEC privilege is required to access data
* structures related to loadable and resident images. An attempt
* is made to interpret each system PC from the traceback as an
* image name plus offset, and as a routine name plus offset, in a
* manner similar to that provided by the output of the SDA commands
* MAP and EVALUATE. When compiled on OpenVMS Alpha V7.0 or later,
* support is provided for the new 64-bit PC traceback line format.
*
* June 1st, 1997 by Bob Sampson:
*
* Corrected numerous "typos" and other mistakes.
*
* Enhanced traceback has been extended to correctly interpret
* SYMG, SYMM, and SYMV global symbols from loadable, resident,
* shareable, and executable images. Image offsets should now
* be properly calculated to match SDA MAP results in all cases.
*
* Enhanced traceback is intended to complement the information
* presented in a standard traceback. The TBK$SHOW_TRACEBACK
* routine (provided by OpenVMS TRACE.EXE) already does a fine
* job of interpreting the DMT (debug module/psect table) and
* DST (debug symbol table), for shareable and executable images
* that have them.
*
* For loadable and resident images, as well as for other images
* that may lack this DMT/DST information, enhanced traceback
* displays a replacement line, with image name, image slice type
* (in place of line number "0"; e.g. "n:r" denotes a read-only
* image slice loaded in non-paged pool), image offset as "rel PC",
* and the original "abs PC". Tracebacks on OpenVMS Alpha normally
* show "rel PC" as a module offset, unless the DMT is unavailable.
* Then the same value is shown for both "rel PC" and "abs PC".
*
* Enhanced traceback then searches the image GST (global
* symbol table), if any. Most images have at least a few
* global symbols. All symbols exactly matching "abs PC"
* are shown. If no exact match is found, the first symbol
* in the GST with the smallest positive non-zero offset
* from "abs PC" (if any) is shown.
*
* OpenVMS Alpha V7.2 (Raven) will provide a documented API
* for writing SDA extensions. Re-implementing enhanced
* traceback using these calls may prove to be a good idea.
*/
#include <atrdef.h> /* file attributes */
#include <builtins.h> /* Alpha built-ins */
#include <chfdef.h> /* condition handling facility */
#include <descrip.h> /* (string) descriptors */
#include <eobjrecdef.h> /* EOBJ object records */
#include <egsdef.h> /* EGSD global symbol definition record */
#include <egsydef.h> /* EGSY global symbol entry */
#include <egstdef.h> /* EGST universal symbol definition */
#include <esdfmdef.h> /* ESDFM version mask symbol definition */
#include <esdfvdef.h> /* ESDFV vectored symbol definition */
#include <egpsdef.h> /* EGPS program section definition */
#include <fcntl.h> /* file control information */
#include <fibdef.h> /* file information block */
#include <fiddef.h> /* file identification */
#include <file.h> /* BSD open() constants */
#include <float.h> /* characteristics of floating types */
#include <fp.h> /* ANSI C floating support */
#include <fp_class.h> /* IEEE classification func ret vals */
#include <fscndef.h> /* sys$filescan() definitions */
#include <ints.h> /* integer types */
#include <iodef.h> /* I/O function codes and modifiers */
#include <lib$routines.h> /* RTL LIB$ routines */
#include <libicb.h> /* invocation context block */
#include <math.h> /* math routines */
#include <ots$routines.h> /* RTL OTS$ routines */
#include <pdscdef.h> /* procedure descriptor */
#include <psigdef.h> /* procedure signature */
#include <rmedef.h> /* RMS extensions (undocumented) */
#include <rms.h> /* RMS definitions (documented) */
#include <ssdef.h> /* system service message codes */
#include <starlet.h> /* system service function prototypes */
#include <stdarg.h> /* standard arguments */
#include <stddef.h> /* standard definitions */
#include <stdio.h> /* standard input/output */
#include <str$routines.h> /* RTL STR$ routines */
#include <string.h> /* string routines */
#include <stsdef.h> /* message code format */
#include <unistd.h> /* POSIX standard routines */
/*
* The following headers are modules in text library SYS$LIBRARY:SYS$LIB_C.TLB.
*/
#include "chfctxdef.h" /* condition handling facility context */
#include "eihddef.h" /* EIHD image header */
#include "eihsdef.h" /* EIHS symbol table and debug section */
#include "fcbdef.h" /* file control block */
#include "imcbdef.h" /* image control block */
#include "kfddef.h" /* known file directory */
#include "kfedef.h" /* known file entry */
#include "kferesdef.h" /* special KFE for resident image */
#include "ldrimgdef.h" /* loaded system executive image */
#include "psldef.h" /* processor status */
#include "wcbdef.h" /* window control block */
#include "homer.h" /* from ALPHA_TRACE source directory */
typedef struct {float re; float im;} complex_t;
typedef struct {double re; double im;} dcomplex_t;
typedef union
{
char b[32768];
EOBJRECDEF objrec;
EGSDEF gs;
} objrec_t;
#pragma extern_model save
#pragma extern_model relaxed_refdef shr
extern const IMCB *volatile IAC$GL_IMAGE_LIST;
extern const LDRIMG *volatile LDR$GQ_IMAGE_LIST[2];
extern const int32 EXE$GL_SYS_SYMVEC;
extern const int32 EXE$GL_SYS_SYMVEC_END;
extern const int32 EXE$GL_PUBLIC_VECTOR_SYMVEC;
extern const int32 EXE$GL_PUBLIC_VECTOR_SYMVEC_END;
#pragma extern_model restore
int32 decc$tprintf(const char *__format, ...);
static const int64 maxi64 = 0x7FFFFFFFFFFFFFFFL;
static const int64 GL = 0xFFFFFFFF80000000L;
static const int32 fp_class_valid = 0x330;
static const char *fp_class_name[] = {
"signalling NaN (Not-a-Number)",
"quiet NaN (Not-a-Number)",
"positive infinity",
"negative infinity",
"positive normalized",
"negative normalized",
"positive denormalized",
"negative denormalized",
"positive zero",
"negative zero" };
#define NALIGN 4
static const char *align_name[NALIGN] = {
"byte",
"word",
"longword",
"quadword" };
#if __IEEE_FLOAT
static const char flt_name = 'S';
static const char dbl_name = 'T';
static const uint8 flt_dtype = DSC$K_DTYPE_FS;
static const uint8 dbl_dtype = DSC$K_DTYPE_FT;
#else
static const char flt_name = 'F';
static const uint8 flt_dtype = DSC$K_DTYPE_F;
#if __D_FLOAT
static const char dbl_name = 'D';
static const uint8 dbl_dtype = DSC$K_DTYPE_D;
#else
static const char dbl_name = 'G';
static const uint8 dbl_dtype = DSC$K_DTYPE_G;
#endif
#endif
int32 prober(const void *base_address, int32 *plength, int8 *pmode)
{
return (__PAL_PROBER(base_address, *plength, *pmode) == 0) ? 0 : -1;
}
show_signature_encoding(uint32 sig_enc)
{
switch (sig_enc)
{
case PSIG$K_FR_I64: printf("64 bits in R0 | none | 1st parm mch"); break;
case PSIG$K_FR_D64: printf("R0 lo 32 bits, R1 hi 32 bits signed"); break;
case PSIG$K_FR_I32: printf("32 bits signed in R0"); break;
case PSIG$K_FR_U32: printf("32 bits unsigned in R0"); break;
case PSIG$K_FR_FF: printf("F float in F0"); break;
case PSIG$K_FR_FD: printf("D double in F0"); break;
case PSIG$K_FR_FG: printf("G double in F0"); break;
case PSIG$K_FR_FS: printf("S float in F0"); break;
case PSIG$K_FR_FT: printf("T double in F0"); break;
case PSIG$K_FR_FFC: printf("F float complex in F0 and F1"); break;
case PSIG$K_FR_FDC: printf("D double complex in F0 and F1"); break;
case PSIG$K_FR_FGC: printf("G double complex in F0 and F1"); break;
case PSIG$K_FR_FSC: printf("S float complex in F0 and F1"); break;
case PSIG$K_FR_FTC: printf("T double complex in F0 and F1"); break;
default: printf("other"); break;
}
} /* show_signature_encoding() */
/*
* Provide F float variant for fp_classf().
*/
#if !__IEEE_FLOAT
int32 ffp_class(float f)
{
register int32 i32 = *((int32*)&f);
register int32 sign_exp = i32 & 0xFF80;
if (sign_exp == 0x8000)
return FP_SNAN;
else
{
register int32 fraction = i32 & ~0xFF80;
if ((sign_exp == 0) && (fraction != 0))
return FP_POS_DENORM;
else
{
if (f == 0E0f)
return FP_POS_ZERO;
else
{
if (f < 0E0f)
return FP_NEG_NORM;
else
return FP_POS_NORM;
}
}
}
}
#define fp_classf ffp_class
#endif
/*
* Provide D double variant for fp_classf().
*/
#if __D_FLOAT
int32 dfp_class(double d)
{
register int64 i64 = *((int64*)&d);
register int64 sign_exp = i64 & 0xFF80L;
if (sign_exp == 0x8000L)
return FP_SNAN;
else
{
register int64 fraction = i64 & ~0xFF80L;
if ((sign_exp == 0L) && (fraction != 0L))
return FP_POS_DENORM;
else
{
if (d == 0E0)
return FP_POS_ZERO;
else
{
if (d < 0E0)
return FP_NEG_NORM;
else
return FP_POS_NORM;
}
}
}
}
#define fp_class dfp_class
#endif
show_pd(struct pdscdef *ppdsc, struct invo_context_blk *picb)
{
register struct psigdef *ppsig;
register uint8 *pmase;
int32 tbk_symbolize_address(const int64 pcabs, const int32 replacement);
if (alpha_trace_dscs)
{
printf("\n kind of procedure: %u; ", ppdsc->pdsc$v_kind);
switch (ppdsc->pdsc$v_kind)
{
case PDSC$K_KIND_BOUND: printf("bound"); break;
case PDSC$K_KIND_NULL: printf("null"); break;
case PDSC$K_KIND_FP_STACK: printf("stack frame"); break;
case PDSC$K_KIND_FP_REGISTER: printf("register frame"); break;
default: printf("other"); break;
}
printf("\n");
if (ppdsc->pdsc$v_handler_valid)
printf(" optional handler (stack or register) present & valid\n");
if (ppdsc->pdsc$v_handler_reinvokable)
printf(" exception handler is reinvokable\n");
if (ppdsc->pdsc$v_handler_data_valid)
printf(" optional hander data (stack or register) present & valid\n");
if (ppdsc->pdsc$v_base_reg_is_fp)
printf(" FP is also base register (vs. SP)\n");
if (ppdsc->pdsc$v_rei_return)
printf(" exit from procedure via REI\n");
if (ppdsc->pdsc$v_stack_return_value)
printf(" function value is returned on the stack\n");
if (ppdsc->pdsc$v_base_frame)
printf(" base frame\n");
if (ppdsc->pdsc$v_target_invo)
printf(" unwind target invo handler to be called\n");
if (ppdsc->pdsc$v_native)
printf(" native\n");
if (ppdsc->pdsc$v_no_jacket)
printf(" no jacket\n");
if (ppdsc->pdsc$v_tie_frame)
printf(" tie frame\n");
switch (ppdsc->pdsc$v_kind)
{
case PDSC$K_KIND_FP_STACK:
printf(" stack frame offset to register save area from base: %04X\n",
ppdsc->pdsc$w_rsa_offset);
printf(" stack frame integer register save mask: %08X\n",
ppdsc->pdsc$l_ireg_mask);
printf(" stack frame floating register save mask: %08X\n",
ppdsc->pdsc$l_freg_mask);
break;
case PDSC$K_KIND_FP_REGISTER:
printf(" register frame saved frame pointer in R%u\n",
ppdsc->pdsc$b_save_fp);
printf(" register frame saved return address in R%u\n",
ppdsc->pdsc$b_save_ra);
break;
default:
break;
}
printf(" return address is passed in R%u\n", ppdsc->pdsc$b_entry_ra);
printf(" function value return registers: %u; ",
ppdsc->pdsc$v_func_return);
show_signature_encoding(ppdsc->pdsc$v_func_return);
printf("\n");
printf(" caller's desired exception reporting behavior: %u; ",
ppdsc->pdsc$v_exception_mode);
switch (ppdsc->pdsc$v_exception_mode)
{
case PDSC$K_EXC_MODE_SIGNAL: printf("signal"); break;
case PDSC$K_EXC_MODE_SIGNAL_ALL: printf("signal all"); break;
case PDSC$K_EXC_MODE_SIGNAL_SILENT: printf("signal silent"); break;
case PDSC$K_EXC_MODE_FULL_IEEE: printf("full IEEE"); break;
case PDSC$K_EXC_MODE_CALLER: printf("caller"); break;
default: printf("other"); break;
}
printf("\n");
printf(" entry code address is %08X%08X\n",
ppdsc->pdsc$q_entry[1], ppdsc->pdsc$q_entry[0]);
tbk_symbolize_address(*((int64*)ppdsc->pdsc$q_entry), 1);
switch (ppdsc->pdsc$v_kind)
{
case PDSC$K_KIND_FP_STACK:
case PDSC$K_KIND_FP_REGISTER:
printf(" size of fixed portion of stack is %u bytes\n",
ppdsc->pdsc$l_size);
break;
default:
break;
} /* switch (ppdsc->pdsc$v_kind) */
printf(" signature block offset: %04X", ppdsc->pdsc$w_signature_offset);
} /* if (alpha_trace_dscs) */
if (ppdsc->pdsc$w_signature_offset == 0)
{
if (alpha_trace_dscs)
printf("; none\n");
}
else if (ppdsc->pdsc$w_signature_offset == 1)
{
if (alpha_trace_dscs)
printf("; standard default used\n");
}
else if (alpha_trace_sigs)
{
register int64 *margs = 0;
register void *parg;
register int32 i, k, fpc, nbytes;
register uint32 argsigenc;
register int32 ialign;
int64 argval, extval, extmsk;
char *pargval[256];
uint8 nbytes_est[256];
ppsig = (struct psigdef*)(((char*)ppdsc)
+ ppdsc->pdsc$w_signature_offset);
if (alpha_trace_dscs)
{
printf("; %u arguments:\n", ppsig->psig$b_arg_count);
}
else
{
printf("\n caller's entry PC %08X%08X\n",
ppdsc->pdsc$q_entry[1], ppdsc->pdsc$q_entry[0]);
tbk_symbolize_address(*((int64*)ppdsc->pdsc$q_entry), 1);
if (picb)
{
printf(" caller's return PC %08X%08X with %u arguments:\n",
picb->libicb$q_program_counter[1],
picb->libicb$q_program_counter[0],
ppsig->psig$b_arg_count);
tbk_symbolize_address(*((int64*)picb->libicb$q_program_counter), 1);
}
}
if (ppsig->psig$v_su_vlist)
printf(" VAX style argument list expected\n");
printf(" function return signature: %u; ",
ppsig->psig$v_func_return);
show_signature_encoding(ppsig->psig$v_func_return);
printf("\n");
if (ppsig->psig$b_arg_count > 6)
{
printf(" memory arguments 7 thru %u summary is %u; ",
ppsig->psig$b_arg_count, ppsig->psig$v_su_asum);
switch (ppsig->psig$v_su_asum)
{
case 0: printf("all 64 bits, or not used"); break;
case 1: printf("all 32 bits sign extended"); break;
case 2: printf("(reserved)"); break;
case 3: printf("assorted signatures"); break;
}
printf("\n");
} /* if memory arguments summary exists */
if (picb)
{
if (ppdsc->pdsc$v_base_reg_is_fp)
margs = (int64*)picb->libicb$q_ireg[29];
else
margs = (int64*)picb->libicb$q_ireg[30];
margs = (int64*)(((char*)margs) + ppdsc->pdsc$l_size - (6*8));
}
/*
* Try to determine the addresses of all argument values.
*/
for (i = 0; i < ppsig->psig$b_arg_count; i++)
{
pargval[i] = (char*)(margs ? &margs[i] : 0);
nbytes_est[i] = 8; /* initially assume passed by value */
if (i < 6)
{
argsigenc = ((uint32)ppsig->psig$v_reg_arg_info)
>> ((uint32)(4*i));
argsigenc &= RASE$M_SIG_ENC;
if (argsigenc != RASE$K_RA_I32) continue; /* known passed by value */
} /* if register argument */
else
{
pmase = &ppsig->psig$b_arg_count;
pmase++; /* point to first byte of psig$v_memory_arg_info bitfield */
argsigenc = (uint32)(pmase[(i-6)/4]
>> (uint8)(2*((i-6)%4)));
argsigenc &= (uint32)3;
if (argsigenc != MASE$K_MA_I32) continue; /* known passed by value */
} /* if memory argument */
if (!__PAL_PROBER(&margs[i], 8, 0)) continue;
parg = &margs[i];
argval = margs[i];
if (((argval >= 0x00010000L) && (argval < 0x80000000L))
|| ((argval & 0xFFFFFFFF80000000L) == 0xFFFFFFFF80000000L))
{
if (__PAL_PROBER((void*)argval, 1, 0))
{
parg = (void*)argval;
} /* if reference to user-readable memory */
} /* if possible 32-bit sign-extended P0, P1, S0, S1 address */
if (parg != &margs[i])
{
pargval[i] = parg;
nbytes_est[i] = 16; /* very likely passed by reference */
}
} /* for all arguments i */
/*
* Estimate the sizes of all argument values; check for overlaps.
*/
for (i = 0; i < ppsig->psig$b_arg_count; i++)
{
if (!pargval[i]) continue;
for (k = 0; k < ppsig->psig$b_arg_count; k++)
{
if (k == i) continue;
if (!pargval[k]) continue;
if (pargval[k] <= pargval[i]) continue;
nbytes = pargval[k] - pargval[i];
if (nbytes_est[i] < nbytes) continue;
nbytes_est[i] = nbytes;
} /* for all arguments k */
if (!margs) continue;
if ((char*)margs <= pargval[i]) continue;
nbytes = (char*)margs - pargval[i];
if (nbytes_est[i] < nbytes) continue;
nbytes_est[i] = nbytes;
} /* for all arguments i */
/*
* Display information about each of the arguments.
*/
for (i = 0; i < ppsig->psig$b_arg_count; i++)
{
if (i < 6)
{
argsigenc = ((uint32)ppsig->psig$v_reg_arg_info)
>> ((uint32)(4*i));
argsigenc &= RASE$M_SIG_ENC;
printf(" (register) argument #%d signature: %u; ", 1+i, argsigenc);
switch (argsigenc)
{
case RASE$K_RA_NOARG: printf("not present"); break;
case RASE$K_RA_Q: printf("R%d 64 bits", 16+i); break;
case RASE$K_RA_I32: printf("R%d 32 bits signed", 16+i); break;
case RASE$K_RA_U32: printf("R%d 32 bits unsigned", 16+i); break;
case RASE$K_RA_FF: printf("F%d <-> F float", 16+i); break;
case RASE$K_RA_FD: printf("F%d <-> D double", 16+i); break;
case RASE$K_RA_FG: printf("F%d <-> G double", 16+i); break;
case RASE$K_RA_FS: printf("F%d <-> S float", 16+i); break;
case RASE$K_RA_FT: printf("F%d <-> T double", 16+i); break;
default: printf("reserved for future use"); break;
}
printf("\n");
} /* if register argument */
else
{
pmase = &ppsig->psig$b_arg_count;
pmase++; /* point to first byte of psig$v_memory_arg_info bitfield */
argsigenc = (uint32)(pmase[(i-6)/4]
>> (uint8)(2*((i-6)%4)));
argsigenc &= (uint32)3;
printf(" (memory) argument #%d signature: %u; ", 1+i, argsigenc);
switch (argsigenc)
{
case MASE$K_MA_Q: printf("64 bits"); break;
case MASE$K_MA_I32: printf("32 bits signed"); break;
default: printf("(reserved)"); break;
}
printf("\n");
} /* if memory argument */
if (__PAL_PROBER(&margs[i], 8, 0))
{
printf(" %08X", &margs[i]);
if (((i < 6) && (argsigenc == RASE$K_RA_I32))
|| ((i >= 6) && (argsigenc == MASE$K_MA_I32)))
{
register struct dsc$descriptor_s *pascid;
register uint8 *p;
register int32 iaccess;
register uint16 n;
iaccess = 3;
parg = &margs[i];
argval = margs[i];
if (((argval >= 0x00010000L) && (argval < 0x80000000L))
|| ((argval & 0xFFFFFFFF80000000L) == 0xFFFFFFFF80000000L))
{
for (ialign = 0;
(ialign < NALIGN-1) && (((int32)argval & (1 << ialign)) == 0);
ialign++) continue;
if (__PAL_PROBER((void*)argval, 1, 0))
{
parg = (void*)argval;
printf(": %08X (", parg);
printf("%s", ((int32)parg < 0) ? "S" : "P");
printf("%s", ((int32)parg & 0x40000000) ? "1" : "0");
printf(" pointer?)\n");
printf(" %08X", parg);
if (__PAL_PROBER(parg, 8, 0)
&& (ialign >= 3) && (nbytes_est[i] >= 8))
iaccess = 3;
else if (__PAL_PROBER(parg, 4, 0)
&& (ialign >= 2) && (nbytes_est[i] >= 4))
iaccess = 2;
else if (__PAL_PROBER(parg, 2, 0)
&& (ialign >= 1) && (nbytes_est[i] >= 2))
iaccess = 1;
else
iaccess = 0;
switch (iaccess)
{
case 0:
argval = *((int8*)parg);
break;
case 1:
argval = *((int16*)parg);
break;
case 2:
argval = *((int32*)parg);
break;
case 3:
default:
argval = *((int64*)parg);
break;
} /* switch (iaccess) */
} /* if reference to user-readable memory */
} /* if possible 32-bit sign-extended P0, P1, S0, S1 address */
/*
* Always display the 64-bit hex value first.
*/
printf(": %016LX\n", argval);
/*
* If the argument is passed by reference, it might be a string descriptor
* (.ASCID), or an array of characters terminated by a NUL (zero) byte
* (.ASCIZ). Allow only ASCII printable characters and tabs. If the format
* is very likely .ASCID or .ASCIZ, don't bother with other interpretations.
*/
if (parg != &margs[i])
{
/*
* Try to interpret the argument as a string descriptor.
*/
if (iaccess >= 3)
{
pascid = (struct dsc$descriptor_s*)parg;
if (pascid->dsc$w_length)
{
if ((pascid->dsc$a_pointer >= (char*)0x00010000)
&& ((((int32)parg) < 0) ==
(((int32)pascid->dsc$a_pointer) < 0)))
{
if (__PAL_PROBER
(pascid->dsc$a_pointer, pascid->dsc$w_length, 0))
{
for (n = 0, p = (uint8*)pascid->dsc$a_pointer;
n < pascid->dsc$w_length;
n++)
if (((p[n] < ' ') || (p[n] > '~')) && (p[n] != '\t'))
break;
if (n)
{
printf(" = .ASCID \"%.*s\"\n", n, p);
if (n == pascid->dsc$w_length)
continue;
else
printf(" (%hu of %hu characters)\n",
n, pascid->dsc$w_length);
if (pascid->dsc$b_dtype != DSC$K_DTYPE_T)
printf(" (dtype = %02X)\n",
0xFF & pascid->dsc$b_dtype);
if ((pascid->dsc$b_class != DSC$K_CLASS_S)
&& (pascid->dsc$b_class != DSC$K_CLASS_D))
printf(" (class = %02X)\n",
0xFF & pascid->dsc$b_class);
} /* if one or more printable characters is found */
} /* if full string is accessible */
} /* if pointer field is plausible */
} /* if length field is non-zero */
} /* if aligned quadword */
/*
* Try to interpret the argument as a NUL-terminated string.
*/
for (n = 0, p = parg;
(n < 255) && __PAL_PROBER(&p[n], 1, 0);
n++)
if (((p[n] < ' ') || (p[n] > '~')) && (p[n] != '\t'))
break;
if (n)
{
if ((p[n] == 0) || (n > 8))
{
printf(" = .ASCIZ \"%.*s\"\n", n, p);
if ((p[n] == 0) && (n > 8)) continue;
}
} /* if one or more printable characters is found */
} /* if might be .ASCID or .ASCIZ by reference */
/*
* Interpret value as signed (and unsigned, if different) byte integer.
*/
extmsk = 0xFFFFFFFFFFFFFF80L;
if (parg == &margs[i])
{
extval = argval & extmsk;
if (!extval) extval = extmsk;
}
else
extval = extmsk;
if (extval == extmsk)
{
printf(" = %+d", *((int8*)parg));
if (*((int8*)parg) < 0)
printf(" = %uu", 0xFF & *((uint8*)parg));
printf(" %s\n", align_name[0]);
}
/*
* Interpret value as signed (and unsigned, if different) word integer.
*/
extmsk = 0xFFFFFFFFFFFF8000L;
if (parg == &margs[i])
{
extval = argval & extmsk;
if (!extval) extval = extmsk;
}
else
extval = extmsk;
if ((iaccess >= 1)
&& (*((int16*)parg) != *((int8*)parg))
&& (extval == extmsk))
{
printf(" = %+hd", *((int16*)parg));
if (*((int16*)parg) < 0)
printf(" = %huu", *((uint16*)parg));
printf(" %s\n", align_name[1]);
} /* if not just a sign-extended byte */
/*
* Interpret value as signed (and unsigned, if different) longword integer.
*/
extmsk = 0xFFFFFFFF80000000L;
if (parg == &margs[i])
{
extval = argval & extmsk;
if (!extval) extval = extmsk;
}
else
extval = extmsk;
if ((iaccess >= 2)
&& (*((int32*)parg) != *((int16*)parg))
&& (extval == extmsk))
{
printf(" = %+d", *((int32*)parg));
if (*((int32*)parg) < 0)
printf(" = %uu", *((uint32*)parg));
printf(" %s\n", align_name[2]);
} /* if not just a sign-extended word */
/*
* Interpret value as signed (and unsigned, if different) quadword integer.
*/
if ((iaccess >= 3)
&& (argval != *((int32*)parg)))
{
printf(" = %+Ld", argval);
if (argval < 0)
printf(" = %Luu", argval);
printf(" %s\n", align_name[3]);
} /* if not just a sign-extended longword */
/*
* Any argument passed by reference, or any memory argument that claims
* to be a signed 32-bit value, might actually be a floating-point value.
*
* Similarly, any register argument passed by value that claims to be a
* signed 32-bit value, might actually be (or be a structure containing)
* floating-point value(s). For example, this occurs in the (unusual)
* case of passing a complex datum (paired floats or doubles) by value.
* Usually, though, the data type of a register argument passed by value
* can be correctly identified when the procedure signature is generated
* by the /TIE compiler option.
*
* The actual data type is not specified, so all possibilities should
* be checked. The same /FLOAT compiler option (D|G|IEEE) should be
* specified when compiling this module and all others, to make all
* likely floating-point formats compatible with float (F|F|S), double
* (D|G|T), and long double (X|X|X) in this module.
*/
/*
* Try to interpret the argument as a float (32 bits).
*/
if (iaccess >= 2)
{
if ((1 << fp_classf(*((float*)parg))) & fp_class_valid)
{
printf(
" %s= %+.*G %c float\n",
(*((int32*)parg) == 0x20202020) ?
"(unlikely) " : "",
FLT_DIG,
*((float*)parg), flt_name);
/*
* Look for second float (32 bits) as the imaginary part of a complex number.
*/
if (iaccess >=3)
{
if ((1 << fp_classf(*((float*)
(((char*)parg)+sizeof(float))))) & fp_class_valid)
{
printf(
" %s %+.*G %c float (im)\n",
(*((int32*)(((char*)parg)+sizeof(float)))
== 0x20202020) ? "(unlikely) " : "",
FLT_DIG,
*((float*)(((char*)parg)+sizeof(float))), flt_name);
} /* if valid float (imaginary part of complex?) */
else if (alpha_trace_dnrm)
{
printf(" %s %c float (im)\n",
fp_class_name[fp_classf(*((float*)
(((char*)parg)+sizeof(float))))], flt_name);
}
} /* if aligned quadword */
} /* if valid float */
else if (alpha_trace_dnrm)
{
printf(" = %s %c float\n",
fp_class_name[fp_classf(*((float*)parg))], flt_name);
}
} /* if aligned longword */
/*
* Try to interpret the argument as a double (64 bits).
*/
if (iaccess >= 3)
{
if ((1 << fp_class(*((double*)parg))) & fp_class_valid)
{
printf(
" %s= %+.*G %c double\n",
(*((int32*)(((char*)parg)+sizeof(float)))
== 0x20202020) ? "(unlikely) " : "",
DBL_DIG,
*((double*)parg), dbl_name);
} /* if valid double */
else if (alpha_trace_dnrm)
{
printf(" = %s %c double\n",
fp_class_name[fp_class(*((double*)parg))], dbl_name);
}
/*
* If the argument is plausible as a distinct octaword...
*/
if ((parg != &margs[i]) /* passed by reference */
&& __PAL_PROBER(parg, 16, 0) /* accessible octaword */
&& (nbytes_est[i] >= 16)) /* no known overlap */
{
/*
* If the first double is valid, look for second double as imaginary part.
*/
if ((1 << fp_class(*((double*)parg))) & fp_class_valid)
{
if ((1 << fp_class(*((double*)
(((char*)parg)+sizeof(double))))) & fp_class_valid)
{
printf(
" %s %+.*G %c double (im)\n",
(*((int32*)(((char*)parg)+sizeof(double)+sizeof(float)))
== 0x20202020) ? "(unlikely) " : "",
DBL_DIG,
*((double*)(((char*)parg)+sizeof(double))), dbl_name)
} /* if valid second double (imag. part of double complex?) */
else if (alpha_trace_dnrm)
{
printf(" %s %c double (im)\n",
fp_class_name[fp_class(*((double*)
(((char*)parg)+sizeof(double))))], dbl_name);
}
} /* if valid first double */
/*
* Try to interpret the argument as a long double (128 bits).
*/
if ((1 << fp_classl(*((long double*)parg))) & fp_class_valid)
{
printf(
" %s= %+.*LG X long double\n",
(*((int64*)(((char*)parg)+sizeof(double)))
== 0x2020202020202020L) ? "(unlikely) " : "",
LDBL_DIG,
*((long double*)parg));
} /* if valid long double */
else if (alpha_trace_dnrm)
{
printf(" = %s X long double\n",
fp_class_name[fp_classl(*((long double*)parg))]);
}
/*
* Show the full 128 bits as hex digits.
*/
printf(" %08X: %016LX%016LX\n", parg,
*((int64*)(((char*)parg)+sizeof(int64))), argval);
} /* if argument is plausible as a distinct octaword */
} /* if aligned quadword */
} /* if homed argument claims to be a 32-bit signed value */
else if (i < 6)
{
struct dsc$descriptor_s src;
struct dsc$descriptor_s dst;
double d;
float f;
int32 ndigits;
printf(": %016LX = ", margs[i]);
src.dsc$a_pointer = (char*)&margs[i];
src.dsc$b_class = dst.dsc$b_class = DSC$K_CLASS_S;
switch (argsigenc)
{
case RASE$K_RA_FF:
src.dsc$w_length = sizeof(float);
src.dsc$b_dtype = DSC$K_DTYPE_F;
ndigits = __F_FLT_DIG;
break;
case RASE$K_RA_FS:
src.dsc$w_length = sizeof(float);
src.dsc$b_dtype = DSC$K_DTYPE_FS;
ndigits = __S_FLT_DIG;
break;
case RASE$K_RA_FD:
src.dsc$w_length = sizeof(double);
src.dsc$b_dtype = DSC$K_DTYPE_D;
ndigits = __G_FLT_DIG;
break;
case RASE$K_RA_FG:
src.dsc$w_length = sizeof(double);
src.dsc$b_dtype = DSC$K_DTYPE_G;
ndigits = __G_FLT_DIG;
break;
case RASE$K_RA_FT:
src.dsc$w_length = sizeof(double);
src.dsc$b_dtype = DSC$K_DTYPE_FT;
ndigits = __T_FLT_DIG;
break;
default:
src.dsc$w_length = 0;
src.dsc$b_dtype = DSC$K_DTYPE_Z;
ndigits = 0;
printf("(unknown)");
break;
}
dst.dsc$w_length = src.dsc$w_length;
if (dst.dsc$w_length == sizeof(float))
{
dst.dsc$b_dtype = flt_dtype;
dst.dsc$a_pointer = (char*)&f;
}
else if (dst.dsc$w_length == sizeof(double))
{
dst.dsc$b_dtype = dbl_dtype;
dst.dsc$a_pointer = (char*)&d;
}
else
{
dst.dsc$b_dtype = src.dsc$b_dtype;
dst.dsc$a_pointer = 0;
}
if (lib$cvt_dx_dx(&src, &dst) & 1)
{
if (dst.dsc$w_length == sizeof(float))
printf("%+.*G", ndigits, f);
else if (dst.dsc$w_length == sizeof(double))
printf("%+.*G", ndigits, d);
}
printf("\n");
}
}
} /* for all arguments i */
} /* if signature block trace */
if (alpha_trace_dscs)
{
switch (ppdsc->pdsc$v_kind)
{
case PDSC$K_KIND_FP_STACK:
if (ppdsc->pdsc$v_handler_data_valid)
{
printf(" stack handler data %08X%08X\n",
ppdsc->pdsc$q_stack_handler_data[1],
ppdsc->pdsc$q_stack_handler_data[0]);
}
if (ppdsc->pdsc$v_handler_valid)
{
printf(" stack handler procedure descriptor at %08X%08X:\n",
ppdsc->pdsc$q_stack_handler[1],
ppdsc->pdsc$q_stack_handler[0]);
tbk_symbolize_address(*((int64*)ppdsc->pdsc$q_stack_handler), 1);
show_pd((struct pdscdef*)ppdsc->pdsc$q_stack_handler[0], 0);
}
break;
case PDSC$K_KIND_FP_REGISTER:
if (ppdsc->pdsc$v_handler_data_valid)
{
printf(" register handler data %08X%08X\n",
ppdsc->pdsc$q_reg_handler_data[1],
ppdsc->pdsc$q_reg_handler_data[0]);
}
if (ppdsc->pdsc$v_handler_valid)
{
printf(" register handler procedure descriptor at %08X%08X:\n",
ppdsc->pdsc$q_reg_handler[1],
ppdsc->pdsc$q_reg_handler[0]);
tbk_symbolize_address(*((int64*)ppdsc->pdsc$q_reg_handler), 1);
show_pd((struct pdscdef*)ppdsc->pdsc$q_reg_handler[0], 0);
}
break;
case PDSC$K_KIND_BOUND:
printf(" bound procedure descriptor value %08X%08X\n",
ppdsc->pdsc$q_proc_value[1],
ppdsc->pdsc$q_proc_value[0]);
tbk_symbolize_address(*((int64*)ppdsc->pdsc$q_proc_value), 1);
printf(" bound procedure descriptor environment %08X%08X\n",
ppdsc->pdsc$q_environment[1],
ppdsc->pdsc$q_environment[0]);
tbk_symbolize_address(*((int64*)ppdsc->pdsc$q_environment), 1);
break;
default:
break;
} /* switch (ppdsc->pdsc$v_kind) */
} /* if procedure descriptor trace */
} /* show_pd() */
/*
* Look for symbol table file (.STB) first; if missing, look for image file
* (.EXE). For a process-activated image, a non-null pnam argument points
* to an RMS NAM block that supplies the device and file ID; any accompanying
* symbol table must have the same full file specification, except type and
* version. Find and search the global symbol table (GST). Display any
* symbols that exactly match pcabs. Otherwise, display the first single
* symbol that was found at the minimum offset.
*/
void tbk_search_gst(
const uint8 imgnamlen,
char *const imgnam,
struct namdef *const pnam,
const int64 pcabs,
const int32 imgoff,
const int64 bslice,
const int64 lslice,
const int64 symvva,
const int32 read_only)
{
struct egsydef *pgsy = 0;
struct egstdef *pgst = 0;
struct esdfmdef *psdfm = 0;
struct esdfvdef *psdfv = 0;
struct egpsdef *pgps = 0;
objrec_t *pobj;
struct fabdef fab;
struct rabdef rab;
char ubf[32768];
char expand[NAM$C_MAXRSS+1];
char result[NAM$C_MAXRSS+1];
struct
{
uint16 nbytes;
char string[ATR$S_FILE_SPEC-sizeof(uint16)];
} file_spec;
char symnammin[64];
char *pchar = 0;
EIHD *peihd = 0;
EIHS *peihs = 0;
int64 vecptr, symslice, pcslice;
int64 epoff, epoff1, epoff2, epmin;
int32 ipsect, base_image_psect, public_vectors_psect;
int32 psect_symvva, psect_symvva_end;
static const $DESCRIPTOR(base_image_pname, ".$$SYS$BASE_IMAGE$$.");
static const $DESCRIPTOR(public_vectors_pname,".$$SYS$PUBLIC_VECTORS$$.");
uint32 status;
uint32 gst_nrecs, gst_vbn;
uint32 irec, ient;
uint32 irecmin, ientmin;
uint32 lpv, lpvmin, normmin, vermskmin, countmin;
uint32 symnamminlen;
uint16 gsdtypmin;
/* determine the slice offset of pcabs */
pcslice = pcabs - bslice;
/* make sure it is within the slice */
if (pcslice >= lslice) return;
/* initialize FAB */
ots$move5(0, 0, '\0', sizeof(fab), &fab);
fab.fab$b_bid = FAB$C_BID; /* identify RMS structure */
fab.fab$b_bln = FAB$C_BLN; /* specify size in bytes */
fab.fab$v_get = 1; /* read-only access */
fab.fab$b_rtv = 255; /* cathedral retrieval windows */
fab.fab$v_shrget = 1; /* allow other readers */
fab.fab$v_upi = 1; /* no file locking */
/* initialize RAB */
ots$move5(0, 0, '\0', sizeof(rab), &rab);
rab.rab$b_bid = RAB$C_BID; /* identify RMS structure */
rab.rab$b_bln = RAB$C_BLN; /* specify size in bytes */
rab.rab$l_fab = &fab; /* point to FAB */
rab.rab$b_rac = RAB$C_SEQ; /* sequential record access */
rab.rab$b_mbc = 127; /* largest possible buffers */
rab.rab$b_mbf = 2; /* double buffering */
rab.rab$v_loc = 1; /* enable locate mode */
rab.rab$v_rah = 1; /* enable read ahead */
rab.rab$v_nlk = 1; /* no record locking */
rab.rab$v_rrl = 1; /* read records regardless of locks */
rab.rab$l_ubf = ubf; /* user buffer */
rab.rab$w_usz = sizeof(ubf)-1; /* size in bytes of user buffer */
/*
* Always try to open a symbol table file first. If opened successfully,
* give gst_nrecs a large non-zero value to indicate a symbol table.
* Otherwise, try to open an image file.
*/
gst_nrecs = 0;
gst_vbn = 0;
epmin = maxi64;
/*
* If a non-zero pnam was specified, then the image file is
* specified by the device name and file ID in the NAM block.
*/
if (pnam)
{
struct fibdef fib;
struct dsc$descriptor_s fibdsc, devdsc;
struct atrdef atr[2];
uint16 iosb[4];
uint16 chan;
/* set up the file information block (fib) */
ots$move5(0, (char*)NULL, '\0', FIB$C_LENGTH, (char*)&fib);
fib.fab$w_fid[0] = pnam->nam$w_fid[0];
fib.fab$w_fid[1] = pnam->nam$w_fid[1];
fib.fab$w_fid[2] = pnam->nam$w_fid[2];
/* set up a descriptor for the fib */
fibdsc.dsc$w_length = sizeof(fib);
fibdsc.dsc$b_dtype = DSC$K_DTYPE_T;
fibdsc.dsc$b)class = DSC$K_CLASS_S;
fibdsc.dsc$a_pointer = (char*)&fib;
/* set up the attribute list (single item then termination) */
atr[0].atr$w_type = ATR$C_FILE_SPEC;
atr[0].atr$w_size = ATR$S_FILE_SPEC;
atr[0].atr$l_addr = &file_spec;
atr[1].atr$w_type = 0;
atr[1].atr$w_size = 0;
atr[1].atr$l_addr = 0;
/* set up a descriptor for the device name */
devdsc.dsc$w_length = (uint8)pnam->nam$t_dvi[0];
devdsc.dsc$b_dtype = DSC$K_DTYPE_T;
devdsc.dsc$b_class = DSC$K_CLASS_S;
devdsc.dsc$a_pointer = &pnam->nam$t_dvi[1];
/* assign a channel to the device */
if (!(sys$assign(&devdsc, &chan, 0, 0, 0) & 1)) return;
/* read file attribute(s) */
status = sys$qiow(0, chan, IO$_ACCESS, iosb, 0, 0,
&fibdsc, 0, 0, 0, atr, 0);
/* deassign the channel */
sys$dassgn(chan);
/* check queueing and completion status */
if (status & 1) status = iosb[0];
if (!(status & 1)) return;
/* ensure that the provided NAM block has an expanded string */
if ((!pnam->nam$l_esa) || (!pnam->nam$b_ess))
{
pnam->nam$l_esa = expand;
pnam->nam$b_ess = NAM$C_MAXRSS;
}
/* ensure that the provided NAM block has a resultant string */
if ((!pnam->nam$l_rsa) || (!pnam->nam$b_rss))
{
pnam->nam$l_rsa = result;
pnam->nam$b_rss = NAM$C_MAXRSS;
}
/* ignore any conceal attribute; fully translate logical names */
pnam->nam$v_noconceal = 1;
/* specify NAM block */
fab.fab$l_nam = pnam;
/* specify provided file spec */
fab.fab$l_fna = file_spec.string;
fab.fab$b_fns = file_spec.nbytes;
/* parse the file spec */
if (!(sys$parse(&fab) & 1)) return;
/* change leading .EXE in file type (if any) to .STB */
if (pnam->nam$b_type >= 4)
if (strncmp(pnam->nam$l_type, ".EXE", 4) == 0)
strncpy(pnam->nam$l_type, ".STB", 4);
/* use parsed (and hopefully modified) expanded file spec */
fab.fab$l_fna = pnam->nam$l_esa;
fab.fab$b_fns = pnam->nam$b_esl;
/* remove version from this file spec */
fab.fab$b_fns -= pnam->nam$b_ver;
/* try to open symbol table file */
if (sys$open(&fab) & 1)
{
gst_nrecs = 0xFFFFFFFFu;
}
/* if that fails, try to open image file */
else
{
fab.fab$l_fna = file_spec.string;
fab.fab$b_fns = file_spec.nbytes;
if (!(sys$open(&fab) & 1)) return;
}
result[pnam->nam$b_rsl] = '\0';
}
/*
* If pnam is zero, then the image file
* is specified by imgnamlen and imgnam.
*/
else
{
static const $DESCRIPTOR(stb_default,"SYS$LOADABLE_IMAGES:.STB;");
static const $DESCRIPTOR(exe_default,"SYS$LOADABLE_IMAGES:.EXE;");
struct namdef nam;
struct dsc$descriptor_s namedsc;
struct fscndef fscnlist[2];
/* make a local copy of the image name */
file_spec.nbytes = imgnamlen;
ots$move5(imgnamlen, imgnam, '\0',
sizeof(file_spec.string), file_spec.string);
/* find the file type (if any) */
namedsc.dsc$w_length = file_spec.nbytes;
namedsc.dsc$b_dtype = DSC$K_DTYPE_T;
namedsc.dsc$b_class = DSC$K_CLASS_S;
namedsc.dsc$a_pointer = file_spec.string;
fscnlist[0].fscn$w_length = 0;
fscnlist[0].fscn$w_item_code = FSCN$_TYPE;
fscnlist[0].fscn$l_addr = 0;
fscnlist[1].fscn$w_length = 0;
fscnlist[1].fscn$w_item_code = 0;
fscnlist[1].fscn$l_addr = 0;
if (!(sys$filescan(&namedsc, &fscnlist, 0, 0, 0) & 1)) return;
/* change leading .EXE in file type (if any) to .STB */
if (fscnlist[0].fscn$w_length >= 4)
if (strncmp((char*)fscnlist[0].fscn$l_addr, ".EXE", 4) == 0)
strncpy((char*)fscnlist[0].fscn$l_addr, ".STB", 4);
/* initialize NAM */
ots$move5(0, 0, '\0', sizeof(nam), &nam);
nam.nam$b_bid = NAM$C_BID; /* identify RMS structure */
nam.nam$b_bln = NAM$C_BLN; /* specify size in bytes */
nam.nam$l_esa = expand; /* expanded string address */
nam.nam$b_ess = NAM$C_MAXRSS; /* expanded string size */
nam.nam$l_rsa = result; /* resultant string address */
nam.nam$b_rss = NAM$C_MAXRSS; /* resultant string size */
nam.nam$v_noconceal = 1; /* fully translate logical names */
/* specify NAM block */
fab.fab$l_nam = &nam;
/* specify (possibly modified) file spec */
fab.fab$l_fna = file_spec.string;
fab.fab$b_fns = file_spec.nbytes;
/* specify default name */
fab.fab$l_dna = stb_default.dsc$a_pointer;
fab.fab$b_dns = stb_default.dsc$w_length;
/* try to open symbol table file */
if (sys$open(&fab) & 1)
{
gst_nrecs = 0xFFFFFFFFu;
}
/* if that fails, try to open image file */
else
{
if (fscnlist[0].fscn$w_length >= 4)
if (strncmp((char*)fscnlist[0].fscn$l_addr, ".STB", 4) == 0)
strncpy((char*)fscnlist[0].fscn$l_addr, ".EXE", 4);
/* specify original file spec */
fab.fab$l_fna = imgnam;
fab.fab$b_fns = imgnamlen;
/* specify default name */
fab.fab$l_dna = exe_default.dsc$a_pointer;
fab.fab$b_dns = exe_default.dsc$w_length;
if (!(sys$open(&fab) & 1)) return;
}
result[nam.nam$b_rsl] = '\0';
fab.fab$l_nam = 0;
}
/*
* If gst_nrecs is non-zero, then a symbol table file is open,
* and a record stream just needs to be connected.
*/
if (gst_nrecs)
{
if (!(sys$connect(&rab) & 1)) goto close_file;
}
/*
* If gst_nrecs is zero, then an image file was opened, and the image header
* should be read to obtain gst_vbn and gst_nrecs. Connect the record stream,
* then read the first block (image header). Determine the starting VBN and
* record count for the global symbol table. Disconnect the record stream,
* but only after extracting the information from the header; RMS locate mode
* does not necessarily preserve the record buffer.
*/
else
{
if (!(sys$connect(&rab) & 1)) goto close_file;
if (!(sys$get(&rab) & 1)) goto close_file;
peihd = (EIHD*)rab.rab$l_rbf;
if (peihd->eihd$l_symdbgoff == 0) goto close_file;
peihs = (EIHS*)(((char*)peihd) + peihd->eihd$l_symdbgoff);
gst_vbn = peihs->eihs$l_gstvbn;
gst_nrecs = peihs->eihs$l_gstsize;
if (!(sys$disconnect(&rab) & 1)) goto close_file;
if ((gst_vbn == 0) || (gst_nrecs == 0)) goto close_file;
/*
* Select variable record format, by making use of an undocumented RMS
* feature (sys$modify). Connect a new record stream, and position to GST.
*/
fab.fab$b_rfm = FAB$C_VAR; /* variable record format */
fab.fab$v_esc = 1; /* escape bit for modify function */
fab.fab$l_ctx = RME$C_SETRFM; /* specify set record format */
if (!(sys$modify(&fab) & 1)) goto close_file;
if (!(sys$connect(&rab) & 1)) goto close_file;
rab.rab$b_rac = RAB$C_RFA; /* find by record's file address */
rab.rab$l_rfa0 = gst_vbn; /* specify start VBN of GST */
rab.rab$w_rfa4 = 0; /* specify start of block */
if (!(sys$find(&rab) & 1)) goto close_file;
rab.rab$b_rac = RAB$C_SEQ; /* back to sequential record access */
}
ipsect = 0;
base_image_psect = public_vectors_psect = -1;
countmin = 0;
irec = 0;
while ((sys$get(&rab) & 1) && (irec < gst_nrecs))
{
irec++;
if (rab.rab$w_rsz < 4) break; /* record must be big enough */
if (rab.rab$w_rsz > EOBJ$C_MAXRECSIZ) break; /* and small enough */
pobj = (objrec_t*)rab.rab$l_rbf; /* object record pointer */
if (rab.rab$w_rsz != pobj->objrec.eobj$w_size) break; /* sizes must match */
if (pobj->objrec.eobj$w_rectyp == EOBJ$C_EEOM) break; /* last record? */
if (pobj->objrec.eobj$w_rectyp != EOBJ$C_EGSD) continue; /* GSD record? */
ient = 0;
for (pchar = (char*)&pobj->gs.egsd$w_gsdtyp;
pchar < (rab.rab$l_rbf + rab.rab$w_rsz);
pchar += pgsy->egsy$w_size)
{
ient++;
pgsy = (struct egsydef*)pchar;
if (!pgsy->egsy$v_def) continue; /* definition entry? */
epoff1 = epoff2 = maxi64;
switch (pgsy->egsy$w_gsdtyp)
{
case EGSD$C_SYMG:
if (!pgsy->egsy$v_rel) continue; /* relocatable entry? */
pgst = (struct egstdef*)pchar;
vecptr = *((int64*)pgst->egst$q_value); /* get symvec offset */
symslice = *((int64*)pgst->egst$q_lp_1); /* image offset of code */
if (symvva && vecptr && !symslice)
{
vecptr += symvva; /* compute address of symbol vector entry */
symslice = *((int64*)vecptr); /* fetch code address */
if (symslice >= bslice) /* valid address within image slice */
{
symslice -= bslice; /* slice offset */
if (symslice <= pcslice) epoff1 = pcslice - symslice;
}
}
else if (symslice >= imgoff)
{
symslice -= imgoff; /* slice offset of code */
if (symslice <= pcslice) epoff1 = pcslice - symslice;
}
symslice = *((int64*)pgst->egst$q_lp_2); /* image offset of data */
if (symslice >= imgoff)
{
symslice -= imgoff; /* slice offset of data */
if (symslice <= pcslice) epoff2 = pcslice - symslice;
}
break;
case EGSD$C_SYMM:
if (!pgsy->egsy$v_rel) continue; /* relocatable entry? */
if (!symvva) continue; /* symbol vector exists for this image? */
psdfm = (struct esdfmdef*)pchar;
vecptr = *((int64*)psdfm->esdfm$q_value); /* get symvec offset */
vecptr += symvva; /* compute address of symbol vector entry */
symslice = *((int64*)vecptr); /* fetch code address */
if (symslice >= bslice) /* valid address within image slice */
{
symslice -= bslice; /* slice offset */
if (symslice <= pcslice) epoff1 = pcslice - symslice;
}
symslice = *((int64*)(vecptr + 8)); /* fetch data address */
if (symslice >= bslice) /* valid address within image slice */
{
symslice -= bslice; /* slice offset */
if (symslice <= pcslice) epoff2 = pcslice - symslice;
}
break;
case EGSD$C_SYMV:
if (!pgsy->egsy$v_rel) continue; /* relocatable entry? */
psdfv = (struct esdfvdef*)pchar;
psect_symvva = 0;
if (psdfv->esdfv$l_psindx == base_image_psect)
{
psect_symvva = EXE$GL_SYS_SYMVEC;
psect_symvva_end = EXE$GL_SYS_SYMVEC_END;
}
else if (psdfv->esdfv$l_psindx == public_vectors_psect)
{
psect_symvva = EXE$GL_PUBLIC_VECTOR_SYMVEC;
psect_symvva_end = EXE$GL_PUBLIC_VECTOR_SYMVEC_END;
}
if (psect_symvva)
{
vecptr = psdfv->esdfv$l_vector; /* symvec offset */
vecptr += psect_symvva; /* add symvec address */
if (vecptr < psect_symvva_end) /* must be within symvec */
{
symslice = *((int64*)vecptr); /* fetch code address */
if (symslice >= bslice) /* valid address within image slice */
{
symslice -= bslice; /* slice offset */
if (symslice <= pcslice) epoff1 = pcslice - symslice;
}
}
}
symslice = *((int64*)psdfv->esdfv$q_value); /* get image value */
if (symslice >= imgoff)
{
symslice -= imgoff; /* slice offset of data */
if (symslice <= pcslice) epoff2 = pcslice - symslice;
}
break;
case EGSD$C_PSC:
pgps = (struct egpsdef*)pchar;
if (pgps->egps$b_namlng == base_image_pname.dsc$w_length)
if (!strncmp(pgps->egps$t_name,
base_image_pname.dsc$a_pointer,
base_image_pname.dsc$w_length))
base_image_psect = ipsect;
if (pgps->egps$b_namlng == public_vectors_pname.dsc$w_length)
if (!strncmp(pgps->egps$t_name,
public_vectors_pname.dsc$a_pointer,
public_vectors_pname.dsc$w_length))
public_vectors_psect = ipsect;
ipsect++;
continue;
default:
continue;
}
if ((epoff1 == maxi64) && (epoff2 == maxi64)) continue;
if (epoff1 <= epoff2)
{
epoff = epoff1;
lpv = 1;
}
else
{
epoff = epoff2;
lpv = 2;
}
if (epoff == epmin) countmin++;
if (!epoff) /* display any exact-match symbol info */
{
if (epmin) countmin = 1;
epmin = 0;
switch (pgsy->egsy$w_gsdtyp)
{
case EGSD$C_SYMG:
printf("= %.*s", pgst->egst$b_namlng, pgst->egst$t_name);
break;
case EGSD$C_SYMM:
printf("= %.*s", psdfm->esdfm$b_namlng, psdfm->esdfm$t_name);
break;
case EGSD$C_SYMV:
printf("= %.*s", psdfv->esdfv$b_namlng, psdfv->esdfv$t_name);
break;
default:
break;
}
printf(" (%s)",
((lpv == 1) ? "entry" :
(pgsy->egsy$v_norm ? "PDsc" :
(read_only ? "label" : "cell"))));
if (alpha_trace_gsti)
{
switch (pgsy->egsy$w_gsdtyp)
{
case EGSD$C_SYMG: printf("; SYMG"); break;
case EGSD$C_SYMM: printf("; SYMM %08X",
psdfm->esdfm$l_version_mask); break;
case EGSD$C_SYMV: printf("; SYMV"); break;
default: break;
}
printf(" entry %u of GST record %u;", ient, irec);
}
printf("\n");
}
else if (epoff < epmin) /* save new closest symbol info */
{
countmin = 1;
epmin = epoff;
irecmin = irec;
ientmin = ient;
gsdtypmin = pgsy->egsy$w_gsdtyp;
lpvmin = lpv;
normmin = pgsy->egsy$v_norm;
switch (gsdtypmin)
{
case EGSD$C_SYMG:
symnamminlen = pgst->egst$b_namlng;
ots$move5(pgst->egst$b_namlng, pgst->egst$t_name, '\0',
sizeof(symnammin), symnammin);
break;
case EGSD$C_SYMM:
vermskmin = psdfm->esdfm$l_version_mask;
symnamminlen = psdfm->esdfm$b_namlng;
ots$move5(psdfm->esdfm$b_namlng, psdfm->esdfm$t_name, '\0',
sizeof(symnammin), symnammin);
break;
case EGSD$C_SYMV:
symnamminlen = psdfv->esdfv$b_namlng;
ots$move5(psdfv->esdfv$b_namlng, psdfv->esdfv$t_name, '\0',
sizeof(symnammin), symnammin);
break;
default:
break;
}
}
} /* for each global symbol entry in this record */
} /* for each object record in GST */
close_file:
sys$close(&fab);
if (epmin && (epmin != maxi64))
{
printf("= %.*s+%05LX (%s", symnamminlen, symnammin, epmin,
((lpvmin == 1) ? "entry" :
(normmin ? "PDsc" :
(read_only ? "label" : "cell"))));
if ((lpvmin == 1) || (read_only && !normmin))
printf(" + %Ld inst)", epmin / 4L);
else
printf(" + %Ld byte%s)", epmin, ((epmin == 1) ? "" : "s"));
if (alpha_trace_gsti)
{
switch (gsdtypmin)
{
case EGSD$C_SYMG: printf("; SYMG"); break;
case EGSD$C_SYMM: printf("; SYMM %08X", vermskmin); break;
case EGSD$C_SYMV: printf("; SYMV"); break;
default: break;
}
printf(" entry %u of GST record %u;", ientmin, irecmin);
if (countmin != 1)
printf("\n first of %u equivalent symbols found;", countmin);
}
printf("\n");
}
if (alpha_trace_gsti) printf(" %s\n", result);
return;
} /* tbk_search_gst() */
/*
* This routine must execute in executive access mode.
* Any unhandled exception will result in process deletion.
*/
int32 get_ldrimg_info(LDRIMG *pldrimg)
{
/* Check argument count */
if (__VA_COUNT_BUILTIN() != 1)
return SS$_ACCVIO;
/* Check for user-writeable LDRIMG output */
if (!__PAL_PROBEW(pldrimg, sizeof(*pldrimg), PSL$C_USER))
return SS$_ACCVIO;
/* If forward link is non-negative, initialize it to the first in the queue */
if ((int32)pldrimg->ldrimg$l_flink >= 0)
pldrimg->ldrimg$l_flink = (LDRIMG*)LDR$GQ_IMAGE_LIST[0];
/* If forward link points to the head or is zero, then end of list */
if ((pldrimg->ldrimg$l_flink == (LDRIMG*)LDR$GQ_IMAGE_LIST)
|| (pldrimg->ldrimg$l_flink == 0))
return SS$_NOMOREITEMS;
/* Check for privileged read access to entire next LDRIMG */
if (!__PAL_PROBER(pldrimg->ldrimg$l_flink, sizeof(LDRIMG), 0))
return SS$_ACCVIO;
/* Copy the entire next LDRIMG */
ots$move3(sizeof(LDRIMG), (char*)pldrimg->ldrimg$l_flink, (char*)pldrimg);
/* Return success status */
return SS$_NORMAL;
} /* get_ldrimg_info() */
void tbk_find_ldrimg_symbol(
const uint8 imgnamlen,
const char *const imgnam,
const int64 pcabs,
const int32 imgoff,
const int64 bslice,
const int64 lslice,
const int32 symvva,
const int32 read_only)
{
tbk_search_gst(
imgnamlen,
imgnam,
0,
pcabs,
imgoff,
bslice,
lslice,
symvva,
read_only);
return;
} /* tbk_find_ldrimg_symbol() */
int32 get_resimg_info(
const KFE *const pkfe,
struct namdef *pnam)
{
KFD *pkfd;
WCB *pwcb;
FCB *pfcb;
char *pddtstr;
/* Check argument count */
if (__VA_COUNT_BUILTIN() != 2)
return SS$_ACCVIO;
/* Check for user write access to NAM argument DVI field */
if (!__PAL_PROBEW(pnam->nam$t_dvi, sizeof(pnam->nam$t_dvi), PSL$C_USER))
return SS$_ACCVIO;
/* Check for user write access to NAM argument FID fields */
if (!__PAL_PROBEW(pnam->nam$w_fid, sizeof(pnam->nam$w_fid), PSL$C_USER))
return SS$_ACCVIO;
/* Initialize these output arguments to zero */
ots$move5(0, 0, '\0', sizeof(pnam->nam$t_dvi), pnam->nam$t_dvi);
pnam->nam$w_fid[0] = pnam->nam$w_fid[1] = pnam->nam$w_fid[2] = 0;
/* Check for privileged read access to KFD pointer in KFE */
if (!__PAL_PROBER(&pkfe->kfe$l_kfd, sizeof(pkfe->kfe$l_kfd), 0))
return SS$_ACCVIO;
pkfd = pkfe->kfe$l_kfd;
/* Check for privileged read access to length of device name in KFD */
if (!__PAL_PROBER(&pkfd->kfd$b_devlen, sizeof(pkfd->kfd$b_devlen), 0))
return SS$_ACCVIO;
pddtstr = (char*)pkfd + offsetof(KFD,kfd$b_ddtstrlen) + 1;
/* Check for privileged read access to device name in KFD */
if (!__PAL_PROBER(pddtstr, pkfd->kfd$b_devlen, 0))
return SS$_ACCVIO;
/* Provide device name (without final colon) as .ASCIC counted string in NAM */
if (pkfd->kfd$b_devlen > sizeof(pnam->nam$t_dvi))
pnam->nam$t_dvi[0] = sizeof(pnam->nam$t_dvi) - 1;
else
pnam->nam$t_dvi[0] = pkfd->kfd$b_devlen - 1;
ots$move5(
pkfd->kfd$b_devlen-1,
pddtstr,
'\0',
sizeof(pnam->nam$t_dvi)-1,
&pnam->nam$t_dvi[1]);
/* Check for privileged read access to WCB pointer in KFE */
if (!__PAL_PROBER(&pkfe->kfe$l_wcb, sizeof(pkfe->kfe$l_wcb), 0))
return SS$_ACCVIO;
pwcb = pkfe->kfe$l_wcb;
/* Check for privileged read access to FCB pointer in WCB */
if (!__PAL_PROBER(&pwcb->wcb$l_fcb, sizeof(pwcb->wcb$l_fcb), 0))
return SS$_ACCVIO;
pfcb = pwcb->wcb$l_fcb;
/* Check for privileged read access to FID fields in FCB */
if (!__PAL_PROBER(pfcb->fcb$w_fid, sizeof(pfcb->fcb$w_fid), 0))
return SS$_ACCVIO;
pnam->nam$w_fid[0] = pfcb->fcb$w_fid[0];
pnam->nam$w_fid[1] = pfcb->fcb$w_fid[1];
pnam->nam$w_fid[2] = pfcb->fcb$w_fid[2];
/* Return with success status */
return SS$_NORMAL;
} /* get_resimg_info() */
void tbk_find_shrimg_symbol(
const KFE *const pkfe,
const int64 pcabs,
const int32 imgoff,
const int64 bslice,
const int64 lslice,
const int64 symvva,
const int32 read_only)
{
struct namdef nam;
uint32 arg_gri[3] = {2, 0, 0};
/* initialize NAM */
ots$move5(0, 0, '\0', sizeof(nam), &nam);
nam.nam$b_bid = NAM$C_BID; /* identify RMS structure */
nam.nam$b_bln = NAM$C_BLN; /* specify size in bytes */
/*
* Determine the device name and file ID for the image file.
*/
arg_gri[1] = (uint32)pkfe; /* known file entry pointer */
arg_gri[2] = (uint32)&nam; /* fill in DVI and FID fields */
if (!(sys$cmexec(&get_resimg_info, arg_gri) & 1)) return;
tbk_search_gst(
0,
0,
&nam,
pcabs,
imgoff,
bslice,
lslice,
symvva,
read_only);
return;
} /* tbk_find_shrimg_symbol() */
void tbk_find_exeimg_symbol(
const IMCB *const pimcb,
const int64 pcabs,
const int32 imgoff,
const int64 bslice,
const int64 lslice,
const int32 read_only)
{
struct namdef nam;
/* initialize NAM */
ots$move5(0, 0, '\0', sizeof(nam), &nam);
nam.nam$b_bid = NAM$C_BID; /* identify RMS structure */
nam.nam$b_bln = NAM$C_BLN; /* specify size in bytes */
/* determine the device name and file ID for the image file */
if ((uint8)pimcb->imcb$t_dvi[0] >= sizeof(nam.nam$t_dvi))
nam.nam$t_dvi[0] = sizeof(nam.nam$t_dvi) - 1;
else
nam.nam$t_dvi[0] = pimcb->imcb$t_dvi[0];
ots$move5((uint8)pimcb->imcb$t_dvi[0], &pimcb->imcb$t_dvi[1], '\0',
sizeof(nam.nam$t_dvi)-1, &nam.nam$t_dvi[1]);
nam.nam$w_fid[0] = pimcb->imcb$w_fid[0];
nam.nam$w_fid[1] = pimcb->imcb$w_fid[1];
nam.nam$w_fid[2] = pimcb->imcb$w_fid[2];
tbk_search_gst(
0,
0,
&nam,
pcabs,
imgoff,
bslice,
lslice,
0,
read_only);
return;
} /* tbk_find_exeimg_symbol() */
/*
* For the specified PC, search the lists of loadable and activated images,
* until a match is found. This generates output similar to "SDA> MAP <PC>".
* Then search the appropriate GST. This implements a utility similar to:
*
* SDA> READ/EXECUTIVE
* SDA> READ/IMAGE <symbol-table>
* SDA> READ/IMAGE <image-file>
*
* ...while generating output similar to:
*
* SDA> EVALUATE/SYMBOL <PC>
*/
int32 tbk_symbolize_address(const int64 pcabs, const int32 replacement)
{
LDRIMG ldrimg;
IMCB *pimcb;
KFERES *pkferes;
KFERES_SECTION *pkferes_section;
struct fscndef fscnlist[2];
int64 bslice, lslice, pcrel;
struct dsc$descriptor_s namedsc;
int32 arg_ldrimg[2] = {1, 0};
int32 imgoff;
uint32 nimcb;
#if __VMS_VER >= 70000000
static const char tbk_out_fmt[] = " %-40.*s %s %016LX %016LX\n";
static const int64 pcabs_mask = 0xFFFFFFFFFFFFFFFFL;
#else
static const char tbk_out_fmt[] = " %-52.*s %s %08LX %08LX\n";
static const int64 pcabs_mask = 0xFFFFFFFFL;
#endif
if ((pcabs < GL) || (pcabs >= 0L)) goto skip_ldrimg;
arg_ldrimg[1] = (int32)&ldrimg;
namedsc.dsc$b_dtype = DSC$K_DTYPE_T;
namedsc.dsc$b_class = DSC$K_CLASS_S;
fscnlist[0].fscn$w_item_code = FSCN$_NAME;
fscnlist[1].fscn$w_length = 0;
fscnlist[1].fscn$w_item_code = 0;
fscnlist[1].fscn$l_addr = 0;
ldrimg.ldrimg$l_flink = 0;
while (ldrimg.ldrimg$l_flink != (LDRIMG*)LDR$GQ_IMAGE_LIST)
{
if (!(sys$cmexec(&get_ldrimg_info, arg_ldrimg) & 1)) break;
/*
* Try to reduce the image name to the file name component only.
* This should result in an image name of 39 bytes or less,
* which will fit conveniently into the traceback line format.
*/
fscnlist[0].fscn$w_length = 0;
fscnlist[0].fscn$l_addr = 0;
namedsc.dsc$w_length = ldrimg.ldrimg$b_imgnamlen;
namedsc.dsc$a_pointer = ldrimg.ldrimg$t_imgnam;
if (!(sys$filescan(&namedsc, &fscnlist, 0, 0, 0) & 1)) continue;
if (fscnlist[0].fscn$w_length && fscnlist[0].fscn$l_addr)
{
namedsc.dsc$w_length = fscnlist[0].fscn$w_length;
namedsc.dsc$a_pointer = (char*)fscnlist[0].fscn$l_addr;
}
bslice = (int64)ldrimg.ldrimg$l_nonpag_r_base;
lslice = (int64)ldrimg.ldrimg$l_nonpag_r_len;
imgoff = ldrimg.ldrimg$l_nonpag_r_offset;
if ((pcabs >= bslice) && (pcabs < (bslice + lslice)))
{
pcrel = pcabs - bslice + imgoff;
if (replacement)
printf(tbk_out_fmt,
namedsc.dsc$w_length,
namedsc.dsc$a_pointer,
"n:r",
pcrel, pcabs & pcabs_mask);
tbk_find_ldrimg_symbol(ldrimg.ldrimg$b_imgnamlen,
ldrimg.ldrimg$t_imgnam, pcabs, imgoff,
bslice, lslice, (int32)ldrimg.ldrimg$l_symvva, 1);
return 1;
}
bslice = (int64)ldrimg.ldrimg$l_nonpag_w_base;
lslice = (int64)ldrimg.ldrimg$l_nonpag_w_len;
imgoff = ldrimg.ldrimg$l_nonpag_w_offset;
if ((pcabs >= bslice) && (pcabs < (bslice + lslice)))
{
pcrel = pcabs - bslice + imgoff;
if (replacement)
printf(tbk_out_fmt,
namedsc.dsc$w_length,
namedsc.dsc$a_pointer,
"n:w",
pcrel, pcabs & pcabs_mask);
tbk_find_ldrimg_symbol(ldrimg.ldrimg$b_imgnamlen,
ldrimg.ldrimg$t_imgnam, pcabs, imgoff,
bslice, lslice, (int32)ldrimg.ldrimg$l_symvva, 1);
return 1;
}
bslice = (int64)ldrimg.ldrimg$l_pag_r_base;
lslice = (int64)ldrimg.ldrimg$l_pag_r_len;
imgoff = ldrimg.ldrimg$l_pag_r_offset;
if ((pcabs >= bslice) && (pcabs < (bslice + lslice)))
{
pcrel = pcabs - bslice + imgoff;
if (replacement)
printf(tbk_out_fmt,
namedsc.dsc$w_length,
namedsc.dsc$a_pointer,
"p:r",
pcrel, pcabs & pcabs_mask);
tbk_find_ldrimg_symbol(ldrimg.ldrimg$b_imgnamlen,
ldrimg.ldrimg$t_imgnam, pcabs, imgoff,
bslice, lslice, (int32)ldrimg.ldrimg$l_symvva, 1);
return 1;
}
bslice = (int64)ldrimg.ldrimg$l_pag_w_base;
lslice = (int64)ldrimg.ldrimg$l_pag_w_len;
imgoff = ldrimg.ldrimg$l_pag_w_offset;
if ((pcabs >= bslice) && (pcabs < (bslice + lslice)))
{
pcrel = pcabs - bslice + imgoff;
if (replacement)
printf(tbk_out_fmt,
namedsc.dsc$w_length,
namedsc.dsc$a_pointer,
"p:w",
pcrel, pcabs & pcabs_mask);
tbk_find_ldrimg_symbol(ldrimg.ldrimg$b_imgnamlen,
ldrimg.ldrimg$t_imgnam, pcabs, imgoff,
bslice, lslice, (int32)ldrimg.ldrimg$l_symvva, 1);
return 1;
}
bslice = (int64)ldrimg.ldrimg$l_fixup_base;
lslice = (int64)ldrimg.ldrimg$l_fixup_len;
imgoff = ldrimg.ldrimg$l_fixup_offset;
if ((pcabs >= bslice) && (pcabs < (bslice + lslice)))
{
pcrel = pcabs - bslice + imgoff;
if (replacement)
printf(tbk_out_fmt,
namedsc.dsc$w_length,
namedsc.dsc$a_pointer,
"fix",
pcrel, pcabs & pcabs_mask);
tbk_find_ldrimg_symbol(ldrimg.ldrimg$b_imgnamlen,
ldrimg.ldrimg$t_imgnam, pcabs, imgoff,
bslice, lslice, (int32)ldrimg.ldrimg$l_symvva, 1);
return 1;
}
bslice = (int64)ldrimg.ldrimg$l_init_base;
lslice = (int64)ldrimg.ldrimg$l_init_len;
imgoff = ldrimg.ldrimg$l_init_offset;
if ((pcabs >= bslice) && (pcabs < (bslice + lslice)))
{
pcrel = pcabs - bslice + imgoff;
if (replacement)
printf(tbk_out_fmt,
namedsc.dsc$w_length,
namedsc.dsc$a_pointer,
"ini",
pcrel, pcabs & pcabs_mask);
tbk_find_ldrimg_symbol(ldrimg.ldrimg$b_imgnamlen,
ldrimg.ldrimg$t_imgnam, pcabs, imgoff,
bslice, lslice, (int32)ldrimg.ldrimg$l_symvva, 1);
return 1;
}
} /* while following the ldrimg queue forward links */
skip_ldrimg:
nimcb = 0;
for ( pimcb = (IMCB*)IAC$GL_IMAGE_LIST;
pimcb != (IMCB*)&IAC$GL_IMAGE_LIST;
pimcb = pimcb->imcb$l_flink )
{
pkferes = pimcb->imcb$l_kferes_ptr;
if (pkferes)
{
pkferes_section =
(KFERES_SECTION*)((char*)pkferes + KFERES$K_FIXED_LENGTH);
if (pkferes_section->kferes$l_section_type != KFERES$K_CODE)
printf("Expected resident code section (type %u), found type %u.\n",
KFERES$K_CODE, pkferes_section->kferes$l_section_type);
bslice = (int64)pkferes_section->kferes$l_va;
lslice = (int64)pkferes_section->kferes$l_length;
imgoff = (int32)pkferes_section->kferes$l_image_offset;
if ((pcabs >= bslice) && (pcabs < (bslice + lslice)))
{
pcrel = pcabs - bslice + imgoff;
if (replacement)
printf(tbk_out_fmt,
(uint32)pimcb->imcb$t_image_name[0],
&pimcb->imcb$t_image_name[1],
"res",
pcrel, pcabs & pcabs_mask);
tbk_find_shrimg_symbol(pimcb->imcb$l_kfe, pcabs,
imgoff, bslice, lslice,
pimcb->imcb$r_fill_12.imcb$q_symbol_vector_address, 1);
return 1;
} /* if the absolute PC is within the section limits */
} /* if this is a resident image */
else /* this is an executable or non-resident shareable image */
{
if (nimcb)
bslice = (int64)pimcb->imcb$l_base_address;
else
bslice = 0L;
lslice = (int64)pimcb->imcb$l_end_address;
lslice -= bslice;
lslice++;
imgoff = 0;
if ((pcabs >= bslice) && (pcabs < (bslice + lslice)))
{
int32 read_only = !__PAL_PROBEW((void*)pcabs, 4, 0);
pcrel = pcabs - bslice + imgoff;
if (replacement)
printf(tbk_out_fmt,
(uint32)pimcb->imcb$t_image_name[0],
&pimcb->imcb$t_image_name[1],
(pimcb->imcb$v_shareable) ?
(read_only ? "s:r" : "s:w") :
(read_only ? "e:r" : "e:w"),
pcrel, pcabs & pcabs_mask);
if (pimcb->imcb$l_kfe)
tbk_find_shrimg_symbol(pimcb->imcb$l_kfe, pcabs,
imgoff, bslice, lslice,
pimcb->imcb$r_fill_12.imcb$q_symbol_vector_address, read_only);
else
tbk_find_exeimg_symbol
(pimcb, pcabs, imgoff, bslice, lslice, read_only);
return 1;
}
} /* this is an executable or non-resident shareable image */
nimcb++;
} /* for each image control block in the current process image list */
return 0;
} /* tbk_symbolize_address() */
int32 tbk_analyze_line(struct dsc$descriptor_s *plinedsc)
{
struct dsc$descriptor_s subsdsc;
int64 pcrel, pcabs;
/*
* The traceback line should have the required minimum length.
*/
#if __VMS_VER >= 70000000
if (plinedsc->dsc$w_length < 79) return 0;
#else
if (plinedsc->dsc$w_length < 78) return 0;
#endif
/*
* Read the hexadecimal relative and absolute PC values.
*/
#if __VMS_VER >= 70000000
if (sscanf(&plinedsc->dsc$a_pointer[46],
"%16LX %16LX", &pcrel, &pcabs) != 2) return 0;
#else
if (sscanf(&plinedsc->dsc$a_pointer[58],
"%8LX %8LX", &pcrel, &pcabs) != 2) return 0;
if (pcrel & 0x80000000L) pcrel |= 0xFFFFFFFF00000000L;
if (pcabs & 0x80000000L) pcabs |= 0xFFFFFFFF00000000L;
#endif
/*
* If relative PC is the same as absolute PC, then the image does not
* have any module information (DMT). A replacement line should be
* displayed, the image offset as the relative PC. Only if no matching
* image is found should the original traceback line be displayed.
*/
if (pcrel == pcabs)
{
return tbk_symbolize_address(pcabs, 1);
}
/*
* Otherwise, the original traceback line should be displayed first.
* The relative PC is a module offset. In addition to the image name,
* there may be a module name, routine name, and/or line number as well,
* from the debug symbol table (DST) of the image (if any).
*/
else
{
printf("%.*s\n", plinedsc->dsc$w_length, plinedsc->dsc$a_pointer);
tbk_symbolize_address(pcabs, 0);
return 1;
}
} /* tbk_analyze_line() */
tbk_action(struct dsc$descriptor_s *plinedsc, int32 *puser_arg)
{
if (!tbk_analyze_line(plinedsc))
printf("%.*s\n", plinedsc->dsc$w_length, plinedsc->dsc$a_pointer);
} /* tbk_action() */
alpha_trace()
{
register uint32 i, nctx, isav, fsav;
register struct pdscdef *ppdsc;
struct chfdef1 *psigargs;
struct chfdef2 *pmchargs;
struct invo_context_blk curctx;
extern void tbk$show_traceback(
int32 faulting_fp,
int32 faulting_sp,
int32 faulting_pc,
int32 detail_level,
void *user_action_procedure,
int32 user_arg);
nctx = 0;
memset(&curctx, 0, sizeof(curctx));
lib$get_curr_invo_context(&curctx);
if (alpha_trace_etbk)
{
if (&tbk$show_traceback)
{
printf("\n[alpha_trace] tbk$show_traceback for curr invo context:\n");
tbk$show_traceback(
curctx.libicb$q_ireg[29],
curctx.libicb$q_ireg[30],
curctx.libicb$q_program_counter[0],
0, (void*)&tbk_action, 999);
}
else
{
printf("\n[alpha_trace] attempting lib$signal traceback\n");
lib$signal(SS$_RESIGNAL);
}
}
do
{
ppdsc = (struct pdscdef*)curctx.libicb$ph_procedure_descriptor;
if (alpha_trace_icbs)
{
register CHFCTX *pchfctx = 0;
printf("\nInvo Context #%d; version %u/%u; %u/%u/%u bytes.\n",
++nctx,
curctx.libicb$b_block_version,
LIBICB$K_INVO_CONTEXT_VERSION,
curctx.libicb$l_context_length,
sizeof(curctx),
LIBICB$K_INVO_CONTEXT_BLK_SIZE);
if (curctx.libicb$v_exception_frame)
printf(" exception frame\n");
if (curctx.libicb$v_ast_frame)
printf(" AST frame\n");
if (curctx.libicb$v_bottom_of_stack)
printf(" bottom of stack\n");
if (curctx.libicb$v_base_frame)
printf(" base frame\n");
printf(" program counter at %016LX\n",
*((int64*)curctx.libicb$q_program_counter));
tbk_symbolize_address(*((int64*)curctx.libicb$q_program_counter), 1);
printf(" processor status is %016LX\n",
*((int64*)curctx.libicb$q_processor_status));
printf(" saved scalar and/or floating-point registers:\n");
for (i=0; i<31; i++)
{
isav = (ppdsc->pdsc$l_ireg_mask & ((uint32)1 << i));
fsav = (ppdsc->pdsc$l_freg_mask & ((uint32)1 << i));
if (isav || fsav)
{
if (isav)
printf(" R%02d = %016LX", i, curctx.libicb$q_ireg[i]);
else
printf(" ");
if (fsav) /* always saved in IEEE T format */
decc$tprintf(" | F%02d = %016LX = %+.*G\n",
i, curctx.libicb$q_freg[i],
__T_FLT_DIG, curctx.libicb$q_freg[i]);
else
printf("\n");
}
}
pchfctx = (CHFCTX*)curctx.libicb$ph_chfctx_addr;
if (pchfctx && __PAL_PROBER(pchfctx, sizeof(CHFCTX), 0))
{
printf(" condition handling facility context at %016LX:\n",
curctx.libicb$ph_chfctx_addr);
printf(" linkage pointer at %016LX\n",
pchfctx->chfctx$q_linkage_ptr);
tbk_symbolize_address(pchfctx->chfctx$q_linkage_ptr, 1);
printf(" signal arguments at %016LX\n",
pchfctx->chfctx$q_sigarglst);
psigargs = (struct chfdef1*)pchfctx->chfctx$q_sigarglst;
if (__PAL_PROBER(psigargs, sizeof(psigargs->chf$is_sig_args), 0))
{
if (__PAL_PROBER
(psigargs, sizeof(int32)*(1+psigargs->chf$is_sig_args), 0))
{
register int32 *psig = (int32*)psigargs;
register uint32 isig;
for (isig = 0; isig <= psigargs->chf$is_sig_args; isig++)
printf(" #%02u: %08X\n", isig, psig[isig]);
}
}
printf(" mechanism arguments at %016LX:\n",
pchfctx->chfctx$q_mcharglst);
pmchargs = (struct chfdef2*)pchfctx->chfctx$q_mcharglst;
if (__PAL_PROBER(pmchargs, sizeof(pmchargs->chf$is_mch_args), 0))
{
#if __VMS_VER >= 70000000
register uint32 nmchargs = pmchargs->chf$is_mch_args;
#else
register uint32 nmchargs = *((uint32*)&pmchargs->chf$q_mch_args);
#endif
if (__PAL_PROBER(pmchargs, sizeof(int64)*(1+nmchargs), 0))
{
register int64 *pmch = (int64*)pmchargs;
register uint32 imch;
for (imch = 0; imch <= nmchargs; imch++)
printf(" #%02u: %016LX\n", imch, pmch[imch]);
}
}
printf(" exception address at %016LX\n",
pchfctx->chfctx$q_expt_addr);
printf(" exception frame at %016LX\n",
pchfctx->chfctx$q_expt_fp);
printf(" unwind stack pointer at %016LX\n",
pchfctx->chfctx$q_unwind_sp);
printf(" reinvokable frame at %016LX\n",
pchfctx->chfctx$q_reinvokable_fp);
printf(" unwind target at %016LX\n",
pchfctx->chfctx$q_unwind_target);
tbk_symbolize_address(pchfctx->chfctx$q_unwind_target, 1);
printf(" byte count is %u.\n",
pchfctx->chfctx$l_bytecnt);
printf(" signal argument count is %u.\n",
pchfctx->chfctx$l_sig_args);
printf(" flags are %08X:\n", pchfctx->chfctx$l_flags);
if (pchfctx->chfctx$v_signal)
printf(" signal\n");
if (pchfctx->chfctx$v_stop)
printf(" stop\n");
if (pchfctx->chfctx$v_fpregs_valid)
printf(" floating-point registers valid\n");
if (pchfctx->chfctx$v_unwind_ast)
printf(" unwinding from AST\n");
if (pchfctx->chfctx$v_reinvokable)
printf(" reinvokable algorithm in progress\n");
if (pchfctx->chfctx$v_fpregs_ready)
printf(" floating-point registers ready\n");
if (pchfctx->chfctx$v_sys_unwind)
printf(" unwind by depth\n");
if (pchfctx->chfctx$v_goto_unwind)
printf(" GOTO unwind in progress\n");
if (pchfctx->chfctx$v_exit_unwind)
printf(" exit unwind in progress\n");
if (pchfctx->chfctx$v_recall_target)
printf(" recall target invo handler\n");
#if __VMS_VER >= 70000000
if (pchfctx->chfctx$v_reenable_asts)
printf(" reenable ASTs (after unwind)\n");
if (pchfctx->chfctx$v_call_clrast)
printf(" call CLRAST in CHF_RESTORE_REGS\n");
#endif
#ifdef CHFCTX$M_SIG64
if (pchfctx->chfctx$v_sig64)
printf(" this is a 64-bit signal\n");
#endif
printf(" message pointer is %08X\n",
pchfctx->chfctx$l_msgptr);
}
printf(" procedure descriptor at %016LX:\n",
curctx.libicb$ph_procedure_descriptor);
tbk_symbolize_address(pchfctx->chfctx$q_expt_addr, 1);
} /* if invo context block trace */
show_pd(ppdsc, &curctx);
if (alpha_trace_icbs) printf("\n");
}
while (lib$get_prev_invo_context(&curctx));
} /* alpha_trace() */
uint32 trace_handl(
struct chfdef1 *psigargs,
struct chfdef2 *pmchargs)
{
uint32 depth = 1;
if (psigargs->chf$is_sig_name == SS$_UNWIND)
return 0;
if ($VMS_STATUS_SEVERITY(psigargs->chf$is_sig_name) != STS$K_SEVERE)
return SS$_RESIGNAL_64;
alpha_trace();
pmchargs->chf$q_mch_savr0 = psigargs->chf$is_sig_name;
if (alpha_trace_args)
printf("\n[trace_handl] %u sigargs, %u mchargs.\n",
psigargs->chf$is_sig_args, pmchargs->chf$is_mch_args);
HOMER(psigargs)
if (sys$unwind(&depth, 0) & 1) return 0;
return SS$_RESIGNAL_64;
} /* trace_handl() */
int32 bad_boy(const dcomplex_t D)
{
register double d;
register int64 n;
for (n = 0, d = D.im;; n++, d *= D.re)
printf("%Lu: %+.*G\n", n, DBL_DIG, d);
if (alpha_trace_args)
{
printf("\n[bad_boy] D.re: %+.*G; D.im: %+.*G\n",
DBL_DIG, D.re, DBL_DIG, D.im);
}
HOMER(D)
return SS$_NORMAL;
} /* bad_boy() */
ast_one(const dcomplex_t *pD)
{
printf("\n[ast_one] bad_boy returned %d.\n", bad_boy(*pD));
if (alpha_trace_args)
{
printf("\n[ast_one] pD->re: %+.*G; pD->im: %+.*G\n",
DBL_DIG, pD->re, DBL_DIG, pD->im);
}
HOMER(pD)
} /* ast_one() */
proc_dos(
char *a01,
double a02,
int32 a03,
int64 a04,
float a05,
uint64 a06,
char *a07,
double a08,
int32 a09,
char *a10,
float a11,
int32 a12,
char *a13,
double a14,
int32 a15,
char *a16,
float a17,
int32 a18,
char *a19,
double a20,
int32 a21)
{
int64 Q = 123456789012345;
int32 L = -1234567890;
int16 W = -32768;
int8 B = -128;
$DESCRIPTOR (A,"Argument #5");
float S = -6.6f;
double T = 77.77;
long double X = -88.88L;
complex_t C = {+99.99f, -99.99f};
dcomplex_t D = {-99.99, +99.99};
extern long double alfalfa(
int64 *pQ,
int32 *pL,
int16 *pW,
int8 *pB,
struct dsc$descriptor_s *pA,
float *pS,
double *pT,
long double *pX,
complex_t *pC,
dcomplex_t *pD);
printf("\n[proc_dos] alfalfa returned %+.*LG\n", LDBL_DIG,
alfalfa(&Q,&L,&W,&B,&A,&S,&T,&X,&C,&D));
if (alpha_trace_args)
{
printf("\n[proc_dos] a01: %s; a02: %f; a03: %d;\n", a01, a02, a03);
printf(" a04: %d; a05: %f; a06: %Lu;\n", a04, a05, a06);
printf(" a07: %s; a08: %f; a09: %d;\n", a07, a08, a09);
printf(" a10: %s; a11: %f; a12: %d;\n", a10, a11, a12);
printf(" a13: %s; a14: %f; a15: %d;\n", a13, a14, a15);
printf(" a16: %s; a17: %f; a18: %d;\n", a16, a17, a18);
printf(" a19: %s; a20: %f; a21: %d\n", a19, a20, a21);
}
HOMER(a01)
} /* proc_dos() */
proc_uno(int32 a01, double a02, char *a03)
{
proc_dos(
"argument #01", 2.2, 3,
-4, 123.45, 99999123456,
"argument #07", 8.8, 9,
"argument #10", 11.11, 12,
"argument #13", 14.14, 15,
"argument #16", 17.17, 18,
"argument #19", 20.20L, 21);
if (alpha_trace_args)
{
printf("\n[proc_uno] a01: %d; a02: %f; a03: %s\n", a01, a02, a03);
}
HOMER(a01)
} /* proc_uno() */
main(int32 argc, char *argv[])
{
int32 iarg;
vaxc$establish(&trace_handl);
proc_uno(1, 12.5, "argument #3");
if (alpha_trace_args)
{
printf("\n[main] argc: %d;\n", argc);
for (iarg = 0; iarg < argc; iarg++)
printf(" argv[%d]: \"%s\"\n", iarg, argv[iarg]);
}
HOMER(argc)
} /* main() */
|