/* =====> STRACE.C */ /* TIPC Scheme '84 Runtime Support - Driver (C) Copyright 1984, 1985, 1987 by Texas Instruments Incorporated. All rights reserved. Author: John C. Jensen Installation: Texas Instruments Incorporated, Dallas, Texas Division: Central Research Laboratories Cost Center: Computer Science Laboratory Project: Computer Architecture Branch Date Written: 12 April 1984 Last Modification: 11 February 1986 - Remainder Divide by Zero fix (see also sinterp.asm) dbs 21 Oct 86 - changed %graphics to seven arguments (see also sinterp.asm) rb 13 Mar 87 - added %xesc */ #include "scheme.h" static char *opcodes[256] = { /* 000 */ "load", "ld-const", "ld-imm", "ld-nil", "ld-local", "ld-lex", "ld-env", "ld-global", /* 008 */ "ld-fluid", "ld-vec-s", "ld-vec-l", "ld-vec-r", "st-local", "st-lex", "st-env", "st-global", /* 016 */ "st-fluid", "st-vec-s", "st-vec-l", "st-vec-r", "set-car!", "set-cdr!", "set-ref!", "swap-ref!", /* 024 */ "pop", "push", "drop", "ld-global-r", "(unused)", "bind-fl", "unbind-fl", "define!", /* 032 */ "jmp-s", "jmp-l", "j-nil-s", "j-nil-l", "jnnil-s", "jnnil-l", "jatom-s", "jatom-l", /* 040 */ "jnatom-s", "jnatom-l", "jeq-s", "jeq-l", "jneq-s", "jneq-l", "deref", "ref", /* 048 */ "call", "call-tr", "call/cc", "call/cc-tr", "call-cl", "call-cl-tr", "call/cc-cl", "call/cc-cl-tr", /* 056 */ "apply-cl", "apply-cl-tr", "execute", "exit", "close", "drop-env", "mk-hash-env", "ld-fluid-r", /* 064 */ "%%car", "%%cdr", "caar", "cadr", "cdar", "cddr", "caaar", "caadr", /* 072 */ "cadar", "caddr", "cdaar", "cdadr", "cddar", "cdddr", "cadddr", "cons", /* 080 */ "add", "add-imm", "sub", "mul", "mul-imm", "div", "div-imm", "quotient", /* 088 */ "remainder", "%car", "%cdr", "random", "<", "<=", "=", ">", /* 096 */ ">=", "!=", "max", "min", "eq?", "eqv?", "equal?", "memq", /* 104 */ "memv", "member", "reverse!", "reverse", "assq", "assv", "assoc", "list", /* 112 */ "append!", "append", "delq!", "delete!", "get-prop", "put-prop", "proplist", "remprop", /* 120 */ "list2", "(unused)", "(unused)", "(unused)", "(unused)", "bitwise-xor", "bitwise-and", "bitwise-or", /* 128 */ "atom?", "closure?", "code?", "continuation?", "even?", "float?", "fluid-bound?", "integer?", /* 136 */ "null?", "number?", "odd?", "pair?", "port?", "proc?", "ref?", "string?", /* 144 */ "symbol?", "vector?", "zero?", "negative?", "positive?", "abs", "float", "minus", /* 152 */ "floor", "ceiling", "truncate", "round", "char?", "env?", "(unused)", "(unused)", /* 160 */ "ascii->char","char->ascii", "(unused)", "(unused)", "(unused)", "length", "last-pair", "substr", /* 168 */ "alloc-vector","vector-size", "vector-fill", "mk-pack-vector", "substr-display","(unused)", "%start-timer", "%stop-timer", /* 176 */ "open-port", "close-port", "prin1", "princ", "print", "newline", "read", "(unused)", /* 184 */ "print-length","(unused)", "read-line", "read-atom", "read-char", "%transcript", "read-char-ready?","fasl", /* 192 */ "char=", "char-equal?", "char<", "char-less?", "char-upcase","char-downcase","string-length","string-ref", /* 200 */ "string-set!","make-string", "string-fill!", "str->sym", "str->un-sym","sym->str", "srch-next", "srch-prev", /* 208 */ "%make-window","%reify-port!","%reify-port", "%clear-window", "%save-window","%restore-window","%str-append","%graphics", /* 216 */ "%reify", "mk-env", "env-parent", "env-lookup", "define-env", "push-env", "drop-env", "ld-env", /* 224 */ "st-env", "set-glob-env!","%reify!", "obj-hash", "obj-unhash", "%reify-stack", "%reify-stack!","set-file-position!", /* 232 */ "%esc1", "%esc2", "%esc3", "%esc4", "%esc5", "%esc6", "%esc7", "%xesc", /* 240 */ "(unused)", "(unused)", "(unused)", "(unused)", "(unused)", "(unused)", "(unused)", "%gc2", /* 248 */ "%halt", "%gc", "ptime", "reset", "scheme-reset","clear-regs", "(escape)", "begin-debug"}; /* Format Codes: */ #define NO_OPERANDS 0 /* no operands */ #define REG 1 /* reg */ #define R_R 2 /* reg,reg */ #define R_R_R 3 /* reg,reg,reg */ #define SB 4 /* short offset (signed) */ #define UB 5 /* short offset (unsigned) */ #define SW 6 /* long offset (signed) */ #define UB_R 7 /* byte (unsigned),reg */ #define R_SB 8 /* reg,short offset (signed) */ #define R_UB 9 /* reg,short offset (unsigned) */ #define R_SW 10 /* reg,long offset (signed) */ #define R_UB_R 11 /* reg,byte (unsigned),reg */ #define R_UW_R 12 /* reg,word (unsigned),reg */ #define R_UB_SB 13 /* reg,byte (unsigned),byte (signed) */ #define R_SW_UB 14 /* reg,word (signed),byte (unsigned) */ #define SW_SB_UB 15 /* word (signed),byte (signed),byte (unsigned) */ #define R_4 16 /* reg,reg,reg,reg */ #define R_5 17 /* reg,reg,reg,reg,reg */ #define R_6 18 /* reg,reg,reg,reg,reg,reg */ #define R_7 19 /* reg,reg,reg,reg,reg,reg,reg */ #define UB_R_VR 20 /* length, reg, zero or more regs */ /* this array is indexed by the format codes just above */ static int n_ops[21] = {0,1,2,3,-1,-1,-1,-1,2,-1,-1,-1,-1,-1,-1,-1,4,5,6,7,-1}; static char format[256] = { /* 000 */ R_R, R_UB, R_SB, REG, R_UB, R_UB_SB, R_UB, R_UB, /* 008 */ R_UB, R_UB, R_SW /*cheat*/, R_R, R_UB, R_UB_SB, R_UB, R_UB, /* 016 */ R_UB, R_UB_R, R_UW_R, R_R_R, R_R, R_R, R_R, R_R, /* 024 */ REG, REG, UB, R_R, NO_OPERANDS, UB_R, UB, R_UB, /* 032 */ SB, SW, R_SB, R_SW, R_SB, R_SW, R_SB, R_SW, /* 040 */ R_SB, R_SW, R_SB, R_SW, R_SB, R_SW, REG, REG, /* 048 */ SW_SB_UB, SW_SB_UB, SW_SB_UB, SW_SB_UB, R_UB, R_UB, REG, REG, /* 056 */ R_R, R_R, REG, NO_OPERANDS, R_SW_UB, UB, REG, R_R, /* 064 */ R_R, R_R, R_R, R_R, R_R, R_R, R_R, R_R, /* 072 */ R_R, R_R, R_R, R_R, R_R, R_R, R_R, R_R_R, /* 080 */ R_R, R_SB, R_R, R_R, R_SB, R_R, R_SB, R_R, /* 088 */ R_R, REG, REG, REG, R_R, R_R, R_R, R_R, /* 096 */ R_R, R_R, R_R, R_R, R_R, R_R, R_R, R_R, /* 104 */ R_R, R_R, REG, REG, R_R, R_R, R_R, REG, /* 112 */ R_R, R_R, R_R, R_R, R_R, R_R_R, REG, R_R, /* 120 */ R_R, NO_OPERANDS, NO_OPERANDS, NO_OPERANDS, NO_OPERANDS, R_R, R_R, R_R, /* 128 */ REG, REG, REG, REG, REG, REG, REG, REG, /* 136 */ REG, REG, REG, REG, REG, REG, REG, REG, /* 144 */ REG, REG, REG, REG, REG, REG, REG, REG, /* 152 */ REG, REG, REG, REG, REG, REG, NO_OPERANDS, NO_OPERANDS, /* 160 */ REG, REG, NO_OPERANDS, NO_OPERANDS, NO_OPERANDS, REG, REG, R_R_R, /* 168 */ REG, REG, R_R, R_R_R, R_5, NO_OPERANDS, REG, REG, /* 176 */ R_R, REG, R_R, R_R, R_R, REG, REG, NO_OPERANDS, /* 184 */ REG, NO_OPERANDS, NO_OPERANDS, REG, REG, REG, REG, REG, /* 192 */ R_R, R_R, R_R, R_R, REG, REG, REG, R_R, /* 200 */ R_R_R, R_R, R_R, REG, REG, REG, R_4, R_4, /* 208 */ REG, R_R_R, R_R, REG, REG, R_R, R_7, R_7, /* 216 */ R_R, REG, REG, R_R, R_R_R, UB, UB, R_UB, /* 224 */ R_UB, REG, R_R_R, REG, REG, REG, R_R, R_R_R, /* 232 */ REG, R_R, R_R_R, R_4, R_5, R_6, R_7, UB_R_VR, /* 240 */ NO_OPERANDS, NO_OPERANDS, NO_OPERANDS, NO_OPERANDS, NO_OPERANDS, NO_OPERANDS, NO_OPERANDS, NO_OPERANDS, /* 248 */ NO_OPERANDS, NO_OPERANDS, REG, NO_OPERANDS, NO_OPERANDS, NO_OPERANDS, NO_OPERANDS, NO_OPERANDS}; static int page,disp,display; t_inst(_page, pc, run, _display) int _page, *pc, run, _display; { int len = 3; /* instruction length (number of bytes) */ int op; int reg1,reg2,reg3; int nregs; /* #regs in a variable-length instruction */ int stat = 0; /* status returned from "interp" */ disp = *pc; page = _page; display = _display; op = get_byte(page, disp); if (display) printf("\t\t\t\t%3x:%04x %12s", page, *pc, opcodes[op]); reg1 = reg2 = reg3 = -1; switch(format[op]) { case NO_OPERANDS: /* no operands */ if (display) printf("\n"); len = 1; break; case REG: /* one register operand */ reg1 = get_reg(1); fmt_regs(1); len = 2; break; case R_R: /* two register operands */ reg1 = get_reg(1); reg2 = get_reg(2); fmt_regs(2); break; case R_R_R: /* three register operands */ reg1 = get_reg(1); reg2 = get_reg(2); reg3 = get_reg(3); fmt_regs(3); len = 4; break; case R_4: /* four register operands */ reg1 = get_reg(1); reg2 = get_reg(2); reg3 = get_reg(3); fmt_regs(4); len = 5; break; case R_5: /* five register operands */ reg1 = get_reg(1); reg2 = get_reg(2); reg3 = get_reg(3); fmt_regs(5); len = 6; break; case R_6: /* six register operands */ reg1 = get_reg(1); reg2 = get_reg(2); reg3 = get_reg(3); fmt_regs(6); len = 7; break; case R_7: /* seven register operands */ reg1 = get_reg(1); reg2 = get_reg(2); reg3 = get_reg(3); fmt_regs(7); len = 8; break; case SB: /* short offset (signed byte) */ if (display) printf(" %d\n", (get_w(1) << 8) >> 8); len = 2; break; case SW: /* long offset (signed word) */ if (display) printf(" %d\n", get_w(1)); break; case UB: /* unsigned short offset (byte) */ if (display) printf(" %d\n", get_b(1)); len = 2; break; case UB_R: /* unsigned short offset (byte) plus register */ reg1 = get_reg(2); if (display) printf(" %d,R%d\n", get_b(1), reg1); break; case R_SB: /* one register plus short offset (signed) */ reg1 = get_reg(1); if (display) printf(" R%d,%d\n", reg1, (get_b(2) << 8) >> 8); break; case R_UB: /* one register plus short offset (unsigned) */ reg1 = get_reg(1); if (display) printf(" R%d,%d\n", reg1, get_b(2)); break; case R_SW: /* one register plus long offset (signed) */ reg1 = get_reg(1); if (display) printf(" R%d,%d\n", reg1, get_w(2)); len = 4; break; case R_UB_R: /* register, short offset (unsigned), register */ reg1 = get_reg(1); reg2 = get_reg(3); if (display) printf(" R%d,%d,R%d\n", reg1, get_b(2), reg2); len = 4; break; case R_UW_R: /* register, long offset (unsigned), register */ reg1 = get_reg(1); reg2 = get_reg(4); if (display) printf(" R%d,%d,R%d\n", reg1, get_w(2), reg2); len = 5; break; case R_UB_SB: /* register, unsigned byte, signed byte */ reg1 = get_reg(1); if (display) printf(" R%d,%d,%d\n", reg1, get_b(2), (get_b(3) << 8) >> 8); len = 4; break; case R_SW_UB: /* register, signed word, unsigned byte */ reg1 = get_reg(1); if (display) printf(" R%d,%d,%d\n", reg1, get_w(2), get_b(4)); len = 5; break; case SW_SB_UB: /* signed word, signed byte, unsigned byte */ if (display) printf(" %d,%d,%d\n", get_w(1), (get_b(3) << 8) >> 8, get_b(4)); len = 5; break; case UB_R_VR: /* unsigned length byte, register, zero or more registers */ len = get_b(1); /* length byte = #bytes in inst - 1) */ nregs = len - 2; /* # optional registers */ reg1 = get_reg(2); if (nregs >= 1) reg2 = get_reg(3); if (nregs >= 2) reg3 = get_reg(4); if (display) { printf(" %d,R%d\n",len,reg1); if (nregs > 0) { printf("\t\t\t\t\t\t "); disp += 2; /* move over opcode, length */ fmt_regs(nregs); /* enough regs will give ugly wraparound */ } /* end if (nregs ...) */ } /* end if (display) */ len = len + 1; break; default: /* ? */ printf("t_inst: invalid instruction format-- op=%02x\n",op); } /* end: switch(format[op]) */ if (run) { if (display) { /* dump the registers prior to execution */ if (reg2 == reg1) reg2 = -1; if (reg3 == reg1 || reg3 == reg2) reg3 = -1; if (reg1 >= 0) prt_reg(reg1); if (reg2 >= 0) prt_reg(reg2); if (reg3 >= 0) prt_reg(reg3); } /* end: if (display) */ /* execute the instruction */ stat = interp(pc, 1); if (display) { /* dump the registers after execution */ if (reg1 >= 0) { printf("After execution:\n"); prt_reg(reg1); if (reg2 >= 0) prt_reg(reg2); if (reg3 >= 0) prt_reg(reg3); } /* end: if (reg1 >= 0) */ } /* end: if (display) */ } /* end: if (run) */ else (*pc) += len; return(stat); } /* end of function: t_inst(page,disp) */ /************************************************************************/ /* Format a Series of Register Operands */ /************************************************************************/ fmt_regs(n) int n; /* the number of register operands */ { int i; /* the usual index variable */ char *comma; /* text used to separate assembly language operands */ if (display) { comma = " "; /* output blanks to separate instruction, first operand */ for (i = 1; i <= n; i++) { printf("%sR%d", comma, get_reg(i)); /* print the next register */ comma = ","; /* subsequent items separated by a comma */ } printf("\n"); /* output a newline character */ } } /* end of function: fmt_regs(n) */ /************************************************************************/ /* Return Register Number */ /************************************************************************/ get_reg(offset) int offset; { return(get_byte(page, disp+offset) >> 2); } /* end of function: get_reg(offset) */ /************************************************************************/ /* Return Word Value */ /************************************************************************/ get_w(offset) int offset; { return(get_word(page, disp+offset)); } /* end of function: get_reg(offset) */ /************************************************************************/ /* Return Byte Value */ /************************************************************************/ get_b(offset) int offset; { return(get_byte(page, disp+offset)); } /* end of function: get_reg(offset) */ /************************************************************************/ /* "Disassemble" a Scheme Instruction for Error Message *IRRITANT* */ /* */ /* Note: This routine works for instructions with only registers for */ /* operands. Immediates, offsets, etc., will cause a list to */ /* be created with only the function name in the first position. */ /* */ /* The "offset" operand is the absolute displacement of the */ /* instruction in the page containing the current code block, */ /* not the displacement relative to the beginning of the code */ /* block. */ /************************************************************************/ disassemble(function,offset) char *function; /* string containing function name */ int offset; /* offset in PAGE containing current code block of the instruction to be disassembled */ { int reg_addr[10]; /* register addresses of the instruction's operands */ int i; /* index variable */ int number_of_operands; /* number of operands for the instruction */ int op; /* opcode for the instruction */ static int fix_reg[2] = {0,SPECFIX*2}; /* special "register" for immediates */ /* determine characteristics of the instruction with which we're dealing */ page = CORRPAGE(CB_pag); op = get_byte(page,offset++); tmp_page = tmp_disp = 0; if ((number_of_operands = n_ops[format[op]]) > 0) { /* compute the register address for each operand */ for (i = 0; i < number_of_operands; i++) reg_addr[i] = get_byte(page,offset++) + (int)(®0); /* if last operand is an immediate operand, phoney up a register for it */ if (format[op] == R_SB) { reg_addr[i-1] = (int) fix_reg; fix_reg[C_DISP] = (get_byte(page,offset-1)<<8)>>8; } /* cons up argument list */ for (i = number_of_operands - 1; i >= 0; i--) cons(tmp_reg, reg_addr[i], tmp_reg); } /* create a symbol for the function name and cons on front of argument list */ intern(tm2_reg, function, strlen(function)); cons(tmp_reg, tm2_reg, tmp_reg); } /* end of function: disassemble(function,offset) */ /************************************************************************/ /* Display Accounting Information */ /************************************************************************/ accounting() { extern int gc_count; /* garbage collector invocation count */ extern long stk_in, stk_out; /* bytes transfered to/from the stack */ ENTER(accounting); printf("\nGarbage collector invoked %d times\n", gc_count); printf("\n%9ld bytes transfered from stack to heap\n%9ld%s", stk_out, stk_in, " bytes transfered from heap to stack\n"); } /* end of function: accounting() */