(FILECREATED "13-Oct-86 23:38:09" {ERIS}<LISPCORE>SOURCES>ACODE.;28 51122
changes to: (MACROS PRINTCODEHEADERDECODE)
(FNS PRINTCODE PRINTCODENT)
previous date: " 3-Oct-86 17:24:14" {ERIS}<LISPCORE>SOURCES>ACODE.;27)
(* "
Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT ACODECOMS)
(RPAQQ ACODECOMS ((COMS (* ; "Printing compiled code")
(FNS PRINTCODE PRINTCODENT)
(DECLARE: DONTCOPY (MACROS PCVAR PRINJUMP NEXTBYTE PRINTCODEHEADERDECODE)
(GLOBALVARS \INITSUBRS \PRINTCODE.LEVEL \PRINTCODE.STKSTATE)))
(COMS (* ; "Analyzing compiled code")
(FNS CALLSCCODE RUNION WHOCALLS WHOCALLS1)
(FNS CHANGECCODE CCCSUBFN? \SUBFNDEF CCCSCAN)
(FNS \MAP-CODE-POINTERS \MAP-CODE-LITERALS)
(BLOCKS (CALLSCCODE CALLSCCODE RUNION)
(CHANGECCODE CHANGECCODE CCCSUBFN? CCCSCAN))
(DECLARE: DONTCOPY (RECORDS REFMAP)
(MACROS CODEBASELT CODEBASELT2 CODEBASESETA CODEBASESETA2))
(ADDVARS (IGNOREFNS)))
(COMS (* ; "Low-level break")
(FNS LLBREAK BROKENDEF))
[COMS (* ; "for TELERAID")
(DECLARE: DONTCOPY (ADDVARS (RDCOMS (FNS PRINTCODE PRINTCODENT BROKENDEF))
(EXPANDMACROFNS NEXTBYTE PCVAR PRINJUMP CODEBASELT
CODEBASELT2 CODEBASESETA CODEBASESETA2
PRINTCODEHEADERDECODE]
(COMS (* ; "reference to opcodes symbolically")
(FNS PRINTOPCODES)
(GLOBALVARS \OPCODES))
(DECLARE: EVAL@COMPILE DONTCOPY (LOCALVARS . T))))
(* ; "Printing compiled code")
(DEFINEQ
(PRINTCODE
[LAMBDA (FN LVFLG RADIX OUTF FIRSTBYTE PC FN.IS.CODEBASE) (* bvm: "13-Oct-86 23:37")
(* ;;; "WARNING: this code must run `renamed' for TeleRaid Printcode to work. However, it is pretty tricky to get it to run renamed because some of the constructs run in local space (e.g., the CARs and CADRs of the code list) and many run in remote space (e.g., the bytes of the code).
It seems that frequently when modifying any part of PRINTCODE the renamed version stops working, so *BEWARE* and make sure you test any edits by doing a (DORENAME 'R) and checking TeleRaid's CodePrint command, as well as in normal PRINTCODE mode.")
(* ;;; "All the CODEARRAY accesses are equivalent to FNHEADER accesses indirected thru the CCODEP object. The reason it is done this awful crufty way, instead of fetching the code base, is so this works in Interlisp-10 as well. Might want to punt that now.")
(DECLARE (SPECVARS OUTF))
(OR RADIX (SETQ RADIX 8))
(LET
([CODEBASE (COND
(FN.IS.CODEBASE FN)
(T (OR (\GET-COMPILED-CODE-BASE FN)
[AND (LITATOM FN)
(\GET-COMPILED-CODE-BASE (GET FN (QUOTE CODE]
(ERROR FN "not compiled code"]
(I4 (NUMFORMATCODE (LIST (QUOTE FIX)
4 RADIX)))
(I6 (NUMFORMATCODE (LIST (QUOTE FIX)
6 RADIX)))
NTSIZE STARTPC TAG TEMP OP# PVARS FVARS IVARS)
(DECLARE (SPECVARS CODEBASE IVARS PVARS FVARS I4 I6)) (* ; "Used by PRINTCODENT")
(LET ((*PRINT-BASE* RADIX))
(for I from 0 by BYTESPERWORD while (ILESSP I (UNFOLD (fetch (FNHEADER OVERHEADWORDS)
of T)
BYTESPERWORD))
do (PRINTNUM I4 I OUTF)
(PRIN1 ": " OUTF)
(PRINTNUM I6 (CODEBASELT2 CODEBASE I)
OUTF)
(PRINTCODEHEADERDECODE CODEBASE I OUTF) (* ; "Interpret header word")
(TERPRI OUTF)))
(SETQ NTSIZE (fetch (FNHEADER NTSIZE) of CODEBASE))
(PRINTCODENT "name table: " (UNFOLD (fetch (FNHEADER OVERHEADWORDS) of T)
BYTESPERWORD)
(UNFOLD NTSIZE BYTESPERWORD))
(SETQ STARTPC (fetch (FNHEADER STARTPC) of CODEBASE))
(COND
((GREATERP [SETQ NTSIZE (IDIFFERENCE STARTPC (SETQ TEMP
(IPLUS (UNFOLD (fetch (FNHEADER OVERHEADWORDS)
of T)
BYTESPERWORD)
(COND
((EQ NTSIZE 0)
(* ;
"No nametable, but there's a quad of zeros there anyway")
BYTESPERQUAD)
(T (UNFOLD NTSIZE (ITIMES 2
BYTESPERWORD
]
BYTESPERCELL)
(PRINTCODENT "Local args: " TEMP (FOLDLO NTSIZE 2)))
((EQ NTSIZE BYTESPERCELL) (* ; "Debugging info")
(printout OUTF T "Info: " .P2 (\GETBASEPTR CODEBASE (FOLDLO TEMP BYTESPERWORD))
T)))
(printout OUTF T "----" T)
(PROG ((CODELOC STARTPC)
(LEVEL (AND LVFLG 0))
B B1 B2 B3 FN LEN LEVADJ STK)
[ALLOCAL (COND
(LEVEL (SETUPHASHARRAY (QUOTE \PRINTCODE.LEVEL))
(SETUPHASHARRAY (QUOTE \PRINTCODE.STKSTATE))
(CLRHASH \PRINTCODE.LEVEL)
(CLRHASH \PRINTCODE.STKSTATE]
LP (COND
((AND PC (IGEQ CODELOC PC)) (* ; "Caller asked to highlight this spot")
(COND
((NOT (IEQP CODELOC PC))
(PRINTOUT OUTF "(PC ")
(PRINTNUM I4 PC OUTF)
(PRINTOUT OUTF " not found)")))
(printout OUTF "------------------------------" T)
(SETQ PC)))
(COND
((OR (NULL FIRSTBYTE)
(IGEQ CODELOC FIRSTBYTE))
(PRINTNUM I4 CODELOC OUTF)
(PRIN1 ": " OUTF)
[COND
(LVFLG (SETQ TEMP (GETHASH CODELOC \PRINTCODE.LEVEL))
[COND
[LEVEL (COND
([AND TEMP (OR (NEQ LEVEL TEMP)
(NOT (EQUAL STK (GETHASH CODELOC
\PRINTCODE.STKSTATE]
(PRIN1 "*" OUTF]
(T (SETQ LEVEL TEMP)
(SETQ STK (GETHASH CODELOC \PRINTCODE.STKSTATE]
(COND
(LEVEL (TAB 7 NIL OUTF)
(PRINTNUM I4 LEVEL OUTF]
(TAB 12 NIL OUTF))
(T (* ;
"Don't print code, but quietly process LEVEL etc")
(SETQ TAG (\FINDOP (NEXTBYTE)))
(SELECTQ (ALLOCAL (OR (fetch OPPRINT of TAG)
(fetch OPCODENAME of TAG)))
(-X- (TERPRI OUTF)
(RETURN))
(BIND [ALLOCAL (COND
(LEVEL (push STK (SETQ LEVEL
(ADD1 (IDIFFERENCE LEVEL
(LOGAND (CODEBASELT CODEBASE
CODELOC)
15])
(UNBIND [ALLOCAL (AND LEVEL (SETQ LEVEL (pop STK])
(DUNBIND [ALLOCAL (AND LEVEL (SETQ LEVEL (SUB1 (pop STK])
(RETURN (SETQ LEVEL))
(SUBRCALL [AND LEVEL (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL (CODEBASELT
CODEBASE
(ADD1 CODELOC])
NIL)
[COND
([AND LEVEL (ALLOCAL (SETQ LEVADJ (fetch LEVADJ of TAG]
[ALLOCAL (COND
((LISTP LEVADJ)
(SETQ LEVADJ (CAR LEVADJ]
(SELECTQ LEVADJ
(FNX (add LEVEL (IDIFFERENCE 1 (CODEBASELT CODEBASE CODELOC))))
(POP.N (SETQ LEVEL (IDIFFERENCE LEVEL (CODEBASELT CODEBASE CODELOC))))
((JUMP UNWIND)
(SETQ LEVEL))
((CJUMP NCJUMP)
(add LEVEL -1))
(COND
((NUMBERP LEVADJ)
(add LEVEL LEVADJ]
(ALLOCAL (add CODELOC (fetch OPNARGS of TAG)))
(GO LP)))
[SETQ LEN (LOCAL (fetch OPNARGS of (SETQ TAG (\FINDOP (SETQ B (NEXTBYTE]
(PRINTNUM I4 B OUTF)
(COND
((IGREATERP LEN 0)
(PRINTNUM I4 (SETQ B1 (NEXTBYTE))
OUTF)))
(COND
((IGREATERP LEN 1)
(PRINTNUM I4 (SETQ B2 (NEXTBYTE))
OUTF)))
(AND (IGREATERP LEN 2)
(PRINTNUM I4 (SETQ B3 (NEXTBYTE))
OUTF))
[ALLOCAL (PROGN (printout OUTF 30 (fetch OPCODENAME of TAG))
(SETQ OP# (fetch OP# of TAG))
(SETQ LEVADJ (fetch LEVADJ of TAG]
[ALLOCAL (COND
((LISTP OP#)
(SETQ OP# (CAR OP#]
[SELECTQ [SETQ TAG (ALLOCAL (OR (fetch OPPRINT of TAG)
(fetch OPCODENAME of TAG]
(-X- (TERPRI OUTF)
(RETURN))
(IVAR (TAB 40 NIL OUTF)
(PCVAR (SELECTQ LEN
(0 (IDIFFERENCE B OP#))
(LRSH B1 1))
IVARS
(QUOTE ivar)))
(PVAR (TAB 40 NIL OUTF)
(PCVAR (SELECTQ LEN
(0 (IDIFFERENCE B OP#))
(LRSH B1 1))
PVARS
(QUOTE pvar)))
(FVAR (TAB 40 NIL OUTF)
(PCVAR (SELECTQ LEN
(0 (IDIFFERENCE B OP#))
(LRSH B1 1))
FVARS
(QUOTE fvar)))
(JUMP (PRINJUMP (IPLUS (IDIFFERENCE B OP#)
2)))
(SIC (printout OUTF 40 .P2 B1))
(SNIC (printout OUTF 40 .P2 (IDIFFERENCE B1 256)))
(SICX (printout OUTF 40 .P2 (IPLUS (LLSH B1 8)
B2)))
(JUMPX (PRINJUMP (COND
((IGEQ B1 128)
(IDIFFERENCE B1 256))
(T B1))))
(FN (SETQ B (IPLUS (LLSH B1 8)
B2))
(printout OUTF 40 .P2 (\INDEXATOMDEF B)))
(BIND (TAB 40 NIL OUTF)
[ALLOCAL (PROG ((NNILS (LRSH B1 4))
(NVALS (LOGAND B1 15)))
(for I from (ADD1 (IDIFFERENCE B2 (IPLUS NNILS NVALS)))
to (IDIFFERENCE B2 NNILS) do (SPACES 1 OUTF)
(PCVAR I PVARS (QUOTE pvar)))
(PRIN1 (QUOTE ;)
OUTF)
(for I from (ADD1 (IDIFFERENCE B2 NNILS)) to B2
do (SPACES 1 OUTF)
(PCVAR I PVARS (QUOTE pvar)))
(COND
(LEVEL (push STK (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL NVALS])
(JUMPXX [PRINJUMP (IPLUS (LLSH B1 8)
B2
(COND
((IGREATERP B1 127)
-65536)
(T 0])
(ATOM (printout OUTF 40 .P2 (\INDEXATOMPNAME (IPLUS (LLSH B1 8)
B2))))
(GCONST [printout OUTF 40 .P2 (1ST (\VAG2 B1 (IPLUS (LLSH B2 8)
B3])
(FNX (printout OUTF "(" B1 ")" 40 .P2 (\INDEXATOMDEF (IPLUS (LLSH B2 8)
B3))))
(TYPEP (printout OUTF "(" .P2 (OR (\TYPENAMEFROMNUMBER B1)
(QUOTE ?))
")"))
(UNBIND [ALLOCAL (AND LEVEL (SETQ LEVEL (pop STK])
(DUNBIND [ALLOCAL (AND LEVEL (SETQ LEVEL (SUB1 (pop STK])
(RETURN (SETQ LEVEL))
(SUBRCALL [ALLOCAL (printout OUTF 40 .P2 (CAR (NTH \INITSUBRS (ADD1 B1]
[AND LEVEL (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL B2])
(ALLOCAL (COND
((LISTP TAG)
(printout OUTF 40 (CAR (NTH TAG (ADD1 B1]
(TERPRI OUTF)
[COND
((AND LEVEL LEVADJ)
(SELECTQ LEVADJ
(FNX (add LEVEL (IDIFFERENCE 1 B1)))
(POP.N (SETQ LEVEL (IDIFFERENCE LEVEL B1)))
((JUMP UNWIND)
(SETQ LEVEL))
((CJUMP NCJUMP)
(add LEVEL -1))
(COND
((NUMBERP LEVADJ)
(add LEVEL LEVADJ]
(GO LP])
(PRINTCODENT
[LAMBDA (STR START1 START2)
(DECLARE (USEDFREE CODEBASE IVARS PVARS FVARS I4 I6 OUTF))
(* bvm: "13-Oct-86 23:34")
(* ;; "Prints the name table identified with title STR that starts with names at START1 and codes at START2")
(LET (NAME TAG)
(COND
((ILESSP START1 (SETQ START2 (IPLUS START2 START1)))
(printout OUTF STR T)
(for NT1 from START1 by BYTESPERWORD while (ILESSP NT1 START2) as NT2 from START2
by BYTESPERWORD do (PRINTNUM I4 NT1 OUTF)
(PRIN1 ": " OUTF)
(PRINTNUM I6 (CODEBASELT2 CODEBASE NT1)
OUTF)
(SPACES 3 OUTF)
(PRINTNUM I4 NT2 OUTF)
(PRIN1 ": " OUTF)
(PRINTNUM I6 (CODEBASELT2 CODEBASE NT2)
OUTF)
(COND
((SETQ NAME (\INDEXATOMVAL (CODEBASELT2 CODEBASE NT1)))
(SETQ TAG (CODEBASELT CODEBASE (ADD1 NT2)))
(printout OUTF .SP 5
(SELECTC (CODEBASELT CODEBASE NT2)
((LRSH IVARCODE 8)
(ALLOCAL (push IVARS (LIST TAG NAME)))
(QUOTE IVAR))
((LRSH PVARCODE 8)
(ALLOCAL (push PVARS (LIST TAG NAME)))
(QUOTE PVAR))
(PROGN (ALLOCAL (push FVARS (LIST TAG NAME)))
(QUOTE FVAR)))
" " TAG ": " .P2 NAME)))
(TERPRI OUTF])
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTPROPS PCVAR MACRO ((IND LST NAME)
(* lmm "11-AUG-81 22:27")
(ALLOCAL (PROG NIL (PRIN2 [CADR (OR (ASSOC IND LST)
(RETURN (printout OUTF "[" NAME IND "]"]
OUTF]
[PUTPROPS PRINJUMP MACRO (LAMBDA (N)
(PRIN1 "->" OUTF)
(PRINTNUM I4 [SETQ N (IPLUS N (IDIFFERENCE CODELOC (ADD1 LEN]
OUTF)
(COND (LEVEL (PUTHASH N (SELECTQ LEVADJ ((NCJUMP JUMP)
LEVEL)
(SUB1 LEVEL))
\PRINTCODE.LEVEL)
(PUTHASH N STK \PRINTCODE.STKSTATE]
[PUTPROPS NEXTBYTE MACRO (NIL (CODEBASELT CODEBASE (PROG1 CODELOC (add CODELOC 1]
[PUTPROPS
PRINTCODEHEADERDECODE DMACRO
(DEFMACRO (CODEBASE INDEX OUTF) (LET
(INDICES I THERE)
(for NAME in (CDR (RECORDFIELDNAMES (QUOTE FNHEADER)
T))
when
(AND NAME (SYMBOLP NAME))
do
(SETQ I (EVAL (BQUOTE (INDEXF (fetch (FNHEADER (\, NAME)))))))
(COND ((EQ NAME (QUOTE #FRAMENAME))
(* ;
"Kludge to get frame name printed next to second word of its cell"
)
(add I 1)))
(COND ((SETQ THERE (ASSOC I INDICES))
(push (CDR THERE)
NAME))
(T (push INDICES (LIST I NAME)))))
(BQUOTE
(SELECTQ
(\, INDEX)
(\,@
(for
PAIR in INDICES collect
(CONS
(UNFOLD (CAR PAIR)
BYTESPERWORD)
(COND
((CDDR PAIR)
(* ; "Several things, need to identify and label")
(for NAME in (CDR PAIR)
collect
(SELECTQ
NAME
(CLOSUREP (* ; "Print as flag")
(BQUOTE (AND (fetch (FNHEADER CLOSUREP)
of
(\, CODEBASE))
(PRIN1 " ClosureP " (\, OUTF)))))
(BQUOTE (printout (\, OUTF)
(\, (CONCAT " " (L-CASE (MKSTRING
NAME))
": "))
(fetch (FNHEADER (\, NAME))
of
(\, CODEBASE)))))))
((EQ (CADR PAIR)
(QUOTE #FRAMENAME))
(BQUOTE ((printout (\, OUTF)
" frame name: " .P2
(1ST (fetch (FNHEADER #FRAMENAME)
of
(\, CODEBASE)))))))
(T (* ; "Just one thing here, so label it")
(BQUOTE ((PRIN1 (\, (CONCAT " " (L-CASE
(MKSTRING (CADR PAIR)))))
(\, OUTF)))))))))
NIL))) )
]
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \INITSUBRS \PRINTCODE.LEVEL \PRINTCODE.STKSTATE)
)
)
(* ; "Analyzing compiled code")
(DEFINEQ
(CALLSCCODE
[LAMBDA (DEF OPTION FNAPPLY) (* DECLARATIONS: (RECORD RESULT
(LNCALLED CALLED BOUND USEDFREE
GLOBALS)))
(* bvm: "23-Jul-86 11:47")
(* * "Analyze DEF for function calls and variable references. Action depends on OPTION as follows:
OPTION = NIL means return value of CALLSCCODE as described in IRM;
OPTION = T means return list of free variable references;
OPTION = APPLY, FNAPPLY, or VARAPPLY means call FNAPPLY on various references and return nothing. FNAPPLY takes two arguments: a symbol and a keyword indicating the type of reference, one of BOUND, USEDFREE, GLOBALS, or CALLED. If OPTION is FNAPPLY, only function references are noticed; if VARAPPLY, only variable bindings and references; otherwise all.
For OPTION = NIL or T, CALLSCCODE descends into subfunctions.")
(PROG ((CODEBASE (OR (\GET-COMPILED-CODE-BASE DEF)
(ERROR DEF "not compiled code")))
USEDFREE BOUND GLOBALS CALLED LNCALLED NTSIZE NAME TYPE TAG)
[COND
((NEQ OPTION (QUOTE FNAPPLY)) (* "Get variables out of name table")
(SETQ NTSIZE (fetch (FNHEADER NTSIZE) of CODEBASE))
(for NT1 from (UNFOLD (fetch (FNHEADER OVERHEADWORDS) of T)
BYTESPERWORD) by BYTESPERWORD as NT2
from (UNFOLD (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T)
NTSIZE)
BYTESPERWORD) by BYTESPERWORD
until [NULL (SETQ NAME (\INDEXATOMVAL (CODEBASELT2 CODEBASE NT1]
do (SETQ TYPE (SELECTQ (CODEBASELT CODEBASE NT2)
((0 128)
(QUOTE BOUND))
(QUOTE USEDFREE))) (*
"Top two bits of the entry indicate kind of name: 00 = IVAR, 10 = PVAR, 11 = FVAR")
(SELECTQ OPTION
((VARAPPLY APPLY)
(FUNCALL FNAPPLY NAME TYPE))
(SELECTQ TYPE
(BOUND (pushnew BOUND NAME))
(pushnew USEDFREE NAME]
(PROG ((CODELOC (fetch (FNHEADER STARTPC) of CODEBASE))
B B1 B2 B3 FN LEN)
LP (SETQ B (NEXTBYTE))
(SETQ B1 (AND [ILESSP 0 (SETQ LEN (fetch OPNARGS of (SETQ TAG (\FINDOP B]
(NEXTBYTE)))
(SETQ B2 (AND (ILESSP 1 LEN)
(NEXTBYTE)))
(SETQ B3 (AND (ILESSP 2 LEN)
(NEXTBYTE)))
(SELECTQ (fetch OPCODENAME of TAG)
(-X- (RETURN))
((FN0 FN1 FN2 FN3 FN4)
(SETQ NAME (\INDEXATOMDEF (IPLUS (LLSH B1 8)
B2)))
(GO FN))
(FNX (SETQ NAME (\INDEXATOMDEF (IPLUS (LLSH B2 8)
B3)))
(GO FN))
((GVAR GVAR←)
[SELECTQ OPTION
(FNAPPLY)
((VARAPPLY APPLY)
(FUNCALL FNAPPLY (\INDEXATOMVAL (IPLUS (LLSH B1 8)
B2))
(QUOTE GLOBALS)))
(pushnew GLOBALS (\INDEXATOMVAL (IPLUS (LLSH B1 8)
B2])
NIL)
(GO LP)
FN [SELECTQ OPTION
((FNAPPLY APPLY)
(FUNCALL FNAPPLY NAME (QUOTE CALLED)))
(VARAPPLY)
(COND
((FMEMB NAME IGNOREFNS) (* "Don't show calls to these")
)
[(SETQ B (\SUBFNDEF NAME)) (*
"Compiled subfunction, recursively analyze it")
(COND
((SETQ B (CALLSCCODE B OPTION))
(COND
((EQ OPTION T) (* "Just got free variables back")
(SETQ USEDFREE (RUNION B USEDFREE)))
(T (SETQ LNCALLED (RUNION (fetch LNCALLED of B)
LNCALLED))
(SETQ BOUND (RUNION (fetch BOUND of B)
BOUND))
(SETQ USEDFREE (RUNION (fetch USEDFREE of B)
USEDFREE))
(SETQ GLOBALS (RUNION (fetch GLOBALS of B)
GLOBALS))
(SETQ CALLED (RUNION (fetch CALLED of B)
CALLED]
((EQ OPTION T) (* "Only look at vars")
)
(T (pushnew CALLED NAME]
(GO LP))
(RETURN (SELECTQ OPTION
((FNAPPLY VARAPPLY APPLY)
NIL)
(T (* "All free var references")
(RUNION USEDFREE GLOBALS))
(create RESULT
LNCALLED ← (REVERSE LNCALLED)
CALLED ← (REVERSE CALLED)
BOUND ← (REVERSE BOUND)
USEDFREE ← (REVERSE USEDFREE)
GLOBALS ← (REVERSE GLOBALS])
(RUNION
[LAMBDA (L1 L2) (* bvm: "14-Mar-86 14:27")
(* * Fast UNION using EQ)
(for X in L1 unless (FMEMB X L2) do (push L2 X))
L2])
(WHOCALLS
[LAMBDA (CALLEE USAGE)
(DECLARE (SPECVARS CALLEE USAGE CALLTYPE VAL)) (* bvm: " 1-Oct-86 14:05")
(PROG ([CALLTYPE (if (LISTP USAGE)
then (* ; "some subset of (BOUND USEDFREE GLOBALS)")
[SETQ USAGE (for TYPE in USAGE
collect (OR (MISSPELLED? TYPE 70 (QUOTE (BOUND USEDFREE
GLOBALS))
)
(\ILLEGAL.ARG TYPE]
(QUOTE VARAPPLY)
else (SELECTQ USAGE
((USES VAR VARS BOUND USEDFREE GLOBALS)
(SETQ USAGE (QUOTE USES))
(QUOTE VARAPPLY))
((BOUND USEDFREE GLOBALS)
(SETQ USAGE (LIST USAGE))
(QUOTE VARAPPLY))
((NIL CALLS)
(QUOTE FNAPPLY))
(\ILLEGAL.ARG USAGE]
VAL)
(MAPATOMS (FUNCTION WHOCALLS1))
(RETURN VAL])
(WHOCALLS1
[LAMBDA (FN)
(DECLARE (USEDFREE CALLEE USAGE CALLTYPE VAL)) (* bvm: " 1-Oct-86 14:05")
(* ;; "If FN uses CALLEE in the CALLTYPE manner, add FN to the list VAL. This is separate fn because of the RETFROM.")
(COND
((CCODEP FN)
[CALLSCCODE FN CALLTYPE (FUNCTION (LAMBDA (CALLED FLG)
(COND
([AND (OR (NLISTP USAGE)
(MEMB FLG USAGE))
(COND
((LISTP CALLEE)
(MEMB CALLED CALLEE))
(T (EQ CALLED CALLEE]
(printout T FN ", ")
(push VAL FN)
(RETFROM (QUOTE WHOCALLS1]
(BLOCK])
)
(DEFINEQ
(CHANGECCODE
[LAMBDA (NEWREF OLDREF FN) (* bvm: " 8-Jul-86 17:02")
(* * "A reference map is a list (`refmap' E1 ... EN), where each element E has the form (CODEARRAY NAMELOCS CONSTLOCS DEFLOCS PTRLOCS). The first element is for the main function, and further elements are for compiler-generated subfunctions. Each LOCS list is a list of byte locations in the code to be fixed up in the indicated way (i.e. VALINDEX, LOLOC, DEFINDEX, and full 24-bit pointer in GCONST format respectively).")
(PROG ((SEAL (QUOTE "refmap"))
DEF MAP)
(SETQ DEF (OR (\GET-COMPILED-CODE-BASE FN)
(RETURN)))
[COND
[(NEQ (CAR (LISTP OLDREF))
SEAL) (*
"Construct a reference map for OLDREF in DEF")
(COND
((EQ [PROG1 OLDREF (SETQ OLDREF (CONS SEAL (CCCSCAN DEF OLDREF]
NEWREF) (*
"No change, just return reference map")
(RETURN OLDREF]
((NEQ (fetch (REFMAP CODEARRAY) of (CADR OLDREF))
DEF)
(ERROR (QUOTE "Inconsistent reference map")
(CONS OLDREF FN] (*
"Change all references in the map OLDREF to refer to NEWREF")
[for MAP in (CDR OLDREF) do (SETQ DEF (fetch CODEARRAY of MAP))
[COND
((OR (fetch NAMELOCS of MAP)
(fetch CONSTLOCS of MAP)
(fetch DEFLOCS of MAP))
(OR (LITATOM NEWREF)
(ERROR
"Can't changename a symbol to a non-symbol in compiled code"
NEWREF]
(for LC in (fetch NAMELOCS of MAP)
do (CODEBASESETA2 DEF LC (\ATOMVALINDEX NEWREF)))
(for LC in (fetch CONSTLOCS of MAP)
do (CODEBASESETA2 DEF LC (\ATOMPNAMEINDEX NEWREF)))
(for LC in (fetch DEFLOCS of MAP)
do (CODEBASESETA2 DEF LC (\ATOMDEFINDEX NEWREF)))
(for LC in (fetch PTRLOCS of MAP)
do (UNINTERRUPTABLY
(* "should do (\DELREF (\VAG2 (CODELT DEF LC) (CODELT2 DEF (ADD1 LC)))) but can't because references aren't incremented by MOVD")
(\ADDREF NEWREF)
(CODEBASESETA DEF LC (\HILOC NEWREF))
(CODEBASESETA2 DEF (ADD1 LC)
(\LOLOC NEWREF)))]
(RETURN OLDREF])
(CCCSUBFN?
[LAMBDA (X) (* bvm: "11-Jul-86 16:47")
(* Tests if X is fnA0nnn or (fnA0nnn), the latter being a possible ERRORSET
form. If so, and X is a compiled function, adds X's analysis to SUBMAPS)
(COND
((SETQ X (\SUBFNDEF X))
(SETQ X (\GET-COMPILED-CODE-BASE X))
(OR (find Y in SUBMAPS suchthat (EQ (fetch (REFMAP CODEARRAY) of Y)
X))
(SETQ SUBMAPS (NCONC SUBMAPS (CCCSCAN X OLDREF])
(\SUBFNDEF
[LAMBDA (X) (* bvm: " 7-Jul-86 16:31")
(AND (LITATOM X)
(EQ (NTHCHARCODE X -5)
(CHARCODE A))
[NOT (find I C from -4 to -1 suchthat (OR (ILESSP (SETQ C (NTHCHARCODE X I))
(CHARCODE 0))
(IGREATERP C (CHARCODE 9]
(\GET-COMPILED-DEFINITION X])
(CCCSCAN
[LAMBDA (DEF OLDREF)
(DECLARE (SPECVARS SUBMAPS OLDREF)) (* bvm: " 8-Jul-86 17:04")
(PROG ((CA DEF)
CONSTLOCS DEFLOCS PTRLOCS SUBMAPS NAMELOCS TAG B NAME CODELOC)
(SETQ CODELOC (fetch (FNHEADER STARTPC) of CA))
[COND
((LITATOM OLDREF)
(for NT1 from (UNFOLD (fetch (FNHEADER OVERHEADWORDS) of T)
BYTESPERWORD) by BYTESPERWORD
do (OR (SETQ NAME (\INDEXATOMVAL (CODEBASELT2 CA NT1)))
(RETURN))
(AND (EQ NAME OLDREF)
(push NAMELOCS NT1]
LP (SETQ B (CODEBASELT CA CODELOC))
(SETQ TAG (\FINDOP B))
(add CODELOC (fetch OPNARGS of TAG)
1)
(SELECTQ (OR (fetch OPPRINT of TAG)
(fetch OPCODENAME of TAG))
(-X- (RETURN (CONS (create REFMAP
CODEARRAY ← CA
NAMELOCS ← NAMELOCS
CONSTLOCS ← CONSTLOCS
DEFLOCS ← DEFLOCS
PTRLOCS ← PTRLOCS)
SUBMAPS)))
((FN FNX)
(SETQ NAME (CODEBASELT2 CA (IDIFFERENCE CODELOC 2)))
[COND
((AND (LITATOM OLDREF)
(EQ NAME (\ATOMDEFINDEX OLDREF)))
(push DEFLOCS (IDIFFERENCE CODELOC 2]
(CCCSUBFN? (\INDEXATOMDEF NAME)))
(ATOM [COND
((AND (LITATOM OLDREF)
(EQ (CODEBASELT2 CA (IDIFFERENCE CODELOC 2))
(\ATOMPNAMEINDEX OLDREF)))
(push CONSTLOCS (IDIFFERENCE CODELOC 2])
(GCONST [COND
((EQ [SETQ NAME (\VAG2 (CODEBASELT CA (IDIFFERENCE CODELOC 3))
(CODEBASELT2 CA (IDIFFERENCE CODELOC 2]
OLDREF)
(push PTRLOCS (IDIFFERENCE CODELOC 3])
NIL)
(GO LP])
)
(DEFINEQ
(\MAP-CODE-POINTERS
[LAMBDA (CODEBLOCK MAPFN) (* bvm: " 3-Oct-86 12:09")
(* ;; "CODEBLOCK is pointer to base of compiled code block. We walk thru the code and apply MAPFN to each pointer we find (i.e., GCONST). MAPFN is called with three args: the pointer, CODEBLOCK, and the byte offset in CODEBLOCK where the pointer lives.")
(if (NEQ [LET ((TYPENO (NTYPX CODEBLOCK)))
(COND
[(EQ TYPENO 0)
(fetch (ARRAYBLOCK GCTYPE) of (\ADDBASE CODEBLOCK (IMINUS
\ArrayBlockHeaderWords
]
(T (fetch DTDGCTYPE of (\GETDTD TYPENO]
CODEBLOCK.GCT)
then (ERROR "ARG NOT Compiled Code Block" CODEBLOCK)
else (PROG ((CODELOC (fetch (FNHEADER STARTPC) of CODEBLOCK))
TAG)
LP (SETQ TAG (\FINDOP (CODEBASELT CODEBLOCK CODELOC)))
(add CODELOC 1)
(SELECTQ (fetch OPCODENAME of TAG)
(-X- (RETURN))
(GCONST (FUNCALL MAPFN (\VAG2 (CODEBASELT CODEBLOCK CODELOC)
(CODEBASELT2 CODEBLOCK (ADD1 CODELOC)))
CODEBLOCK CODELOC))
NIL)
(add CODELOC (fetch OPNARGS of TAG))
(GO LP])
(\MAP-CODE-LITERALS
[LAMBDA (CODEBLOCK MAPFN) (* bvm: " 3-Oct-86 17:22")
(* ;; "CODEBLOCK is pointer to base of compiled code block. We walk thru the code and apply MAPFN to each literal we find (i.e., GCONST). MAPFN is called with four args: the literal, CODEBLOCK, the byte offset in CODEBLOCK where the literal lives, and the type of literal, one of ATOM, FN or POINTER. If you're only interested in pointers, the speedier \MAP-CODE-POINTERS is more appropriate.")
(if (NEQ [LET ((TYPENO (NTYPX CODEBLOCK)))
(COND
[(EQ TYPENO 0)
(fetch (ARRAYBLOCK GCTYPE) of (\ADDBASE CODEBLOCK (IMINUS
\ArrayBlockHeaderWords
]
(T (fetch DTDGCTYPE of (\GETDTD TYPENO]
CODEBLOCK.GCT)
then (ERROR "ARG NOT Compiled Code Block" CODEBLOCK)
else (PROG ((CODELOC (fetch (FNHEADER STARTPC) of CODEBLOCK))
TAG)
(for NT1 from (UNFOLD (fetch (FNHEADER OVERHEADWORDS) of T)
BYTESPERWORD) by BYTESPERWORD
do (FUNCALL MAPFN (OR (\INDEXATOMVAL (CODEBASELT2 CODEBLOCK NT1))
(RETURN))
CODEBLOCK NT1 (QUOTE ATOM)))
LP (SETQ TAG (\FINDOP (CODEBASELT CODEBLOCK CODELOC)))
(add CODELOC (fetch OPNARGS of TAG)
1)
(SELECTQ (OR (fetch OPPRINT of TAG)
(fetch OPCODENAME of TAG))
(-X- (RETURN))
((FN FNX)
(FUNCALL MAPFN (\INDEXATOMDEF (CODEBASELT2 CODEBLOCK (IDIFFERENCE CODELOC 2
)))
CODEBLOCK
(IDIFFERENCE CODELOC 2)
(QUOTE FN)))
(ATOM (FUNCALL MAPFN (\INDEXATOMPNAME (CODEBASELT2 CODEBLOCK (IDIFFERENCE
CODELOC 2)))
CODEBLOCK
(IDIFFERENCE CODELOC 2)
(QUOTE ATOM)))
(GCONST (FUNCALL MAPFN (\VAG2 (CODEBASELT CODEBLOCK (IDIFFERENCE CODELOC 3))
(CODEBASELT2 CODEBLOCK (IDIFFERENCE CODELOC 2)))
CODEBLOCK
(IDIFFERENCE CODELOC 3)
(QUOTE POINTER)))
NIL)
(GO LP])
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: CALLSCCODE CALLSCCODE RUNION)
(BLOCK: CHANGECCODE CHANGECCODE CCCSUBFN? CCCSCAN)
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(RECORD REFMAP (CODEARRAY NAMELOCS CONSTLOCS DEFLOCS PTRLOCS))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS CODEBASELT MACRO (= . \GETBASEBYTE))
[PUTPROPS CODEBASELT2 MACRO (OPENLAMBDA (DEF LC)
(LOGOR (LLSH (CODEBASELT DEF LC)
BITSPERBYTE)
(CODEBASELT DEF (ADD1 LC]
(PUTPROPS CODEBASESETA MACRO (= . \PUTBASEBYTE))
[PUTPROPS CODEBASESETA2 MACRO (OPENLAMBDA (DEF LC VALUE)
(CODEBASESETA DEF LC (LRSH VALUE BITSPERBYTE))
(CODEBASESETA DEF (ADD1 LC)
(IMOD VALUE (CONSTANT (LLSH 1 BITSPERBYTE]
)
)
(ADDTOVAR IGNOREFNS )
(* ; "Low-level break")
(DEFINEQ
(LLBREAK
[LAMBDA (FN WHEN)
(DECLARE (GLOBALVARS BROKENFNS)) (* bvm: " 8-Jul-86 17:11")
(PROG (NUFN DEF)
[COND
((GETPROP FN (QUOTE BROKEN))
(RESTORE FN (QUOTE BROKEN]
(OR (SETQ DEF (\GET-COMPILED-DEFINITION FN))
(ERROR FN "is not compiled code"))
(/SETATOMVAL (QUOTE BROKENFNS)
(CONS FN BROKENFNS))
(/PUTD [SETQ NUFN (PACK* FN (GENSYM (QUOTE L]
DEF T)
(/PUTPROP FN (QUOTE BROKEN)
NUFN)
(/PUTD FN (create COMPILED-CLOSURE using DEF FNHEADER ← (BROKENDEF DEF WHEN)))
(RETURN FN])
(BROKENDEF
[LAMBDA (DEF CA WHEN) (* bvm: "11-Jul-86 17:15")
(PROG ((CA (\GET-COMPILED-CODE-BASE DEF))
BEFORE AFTER SIZE FIRSTBYTE NEWCA)
(SETQ FIRSTBYTE (fetch (FNHEADER STARTPC) of CA))
(UNLESSRDSYS NIL (PROGN (* For Teleraid, can't create new code
blocks, so can only make break AFTER)
(SETQ NEWCA CA)
(SETQ BEFORE)
(SETQ AFTER T)
(GO DOSCAN)))
(SELECTQ WHEN
(BEFORE (SETQ BEFORE T))
(AFTER (SETQ AFTER T))
((NIL BOTH)
(SETQ BEFORE T)
(SETQ AFTER T))
(LISPERROR "ILLEGAL ARG" WHEN))
(SETQ SIZE (UNFOLD (\#BLOCKDATACELLS CA)
BYTESPERCELL))
(SETQ NEWCA (\ALLOC.CODE.BLOCK (IPLUS (COND
(BEFORE 3)
(T 0))
SIZE)
(CEIL (ADD1 (FOLDHI FIRSTBYTE BYTESPERCELL))
CELLSPERQUAD)))
(COND
(BEFORE (* Need to insert preamble code)
(\MOVEBYTES CA 0 NEWCA 0 FIRSTBYTE) (* Copy header)
[PROGN (* insert call to RAID followed by a
POP)
[CODEBASESETA NEWCA FIRSTBYTE (CAR (\FINDOP (QUOTE 'NIL]
[CODEBASESETA NEWCA (ADD1 FIRSTBYTE)
(CAR (\FINDOP (QUOTE RAID]
(CODEBASESETA NEWCA (IPLUS FIRSTBYTE 2)
(CAR (\FINDOP (QUOTE POP]
(\MOVEBYTES CA FIRSTBYTE NEWCA (IPLUS FIRSTBYTE 3)
(IDIFFERENCE SIZE FIRSTBYTE))
(add FIRSTBYTE 3))
(T (* Just copy verbatim)
(\MOVEBYTES CA 0 NEWCA 0 SIZE)))
(* * NOTE: Need to addref framename if we ever gc code blocks)
DOSCAN
[COND
(AFTER (* Change all RETURNs to \RETURN)
(bind OP do (SELECTQ [fetch (OPCODE OPCODENAME) of (SETQ OP
(\FINDOP (CODEBASELT NEWCA
FIRSTBYTE]
(-X- (RETURN))
(RETURN [CODEBASESETA NEWCA FIRSTBYTE (CAR (\FINDOP (QUOTE
\RETURN
])
NIL)
(add FIRSTBYTE 1 (fetch (OPCODE OPNARGS) of OP]
(RETURN NEWCA])
)
(* ; "for TELERAID")
(DECLARE: DONTCOPY
(ADDTOVAR RDCOMS (FNS PRINTCODE PRINTCODENT BROKENDEF))
(ADDTOVAR EXPANDMACROFNS NEXTBYTE PCVAR PRINJUMP CODEBASELT CODEBASELT2 CODEBASESETA CODEBASESETA2
PRINTCODEHEADERDECODE)
)
(* ; "reference to opcodes symbolically")
(DEFINEQ
(PRINTOPCODES
[LAMBDA (SINGLE) (* lmm "22-Mar-85 10:34")
(printout NIL " #" 9 "name" 24 "len-1" 34 "format" 43 "stk effect" 55 "UFN table entry" T T)
(for X in (COND
(SINGLE (LIST (\FINDOP SINGLE)))
(T \OPCODES)) do [LET ((OP (fetch OP# of X)))
(COND
((LISTP OP)
(printout NIL .I3.8 (CAR OP)
"-"
(CADR OP)))
(T (printout NIL .I3.8 OP]
(TAB 9)
(PRIN1 (fetch OPCODENAME of X))
[COND
((NEQ (fetch OPCODENAME of X)
(QUOTE unused))
(printout NIL 26 (OR (fetch OPNARGS of X)
(QUOTE ?))
35
(OR (fetch OPPRINT of X)
(QUOTE ?))
44
(OR (fetch LEVADJ of X)
(QUOTE ?))
55
(OR (fetch UFNFN of X)
""]
(TERPRI])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \OPCODES)
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(PUTPROPS ACODE COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2069 17770 (PRINTCODE 2079 . 15482) (PRINTCODENT 15484 . 17768)) (22940 32119 (
CALLSCCODE 22950 . 29343) (RUNION 29345 . 29586) (WHOCALLS 29588 . 30999) (WHOCALLS1 31001 . 32117)) (
32120 39017 (CHANGECCODE 32130 . 35598) (CCCSUBFN? 35600 . 36199) (\SUBFNDEF 36201 . 36681) (CCCSCAN
36683 . 39015)) (39018 43702 (\MAP-CODE-POINTERS 39028 . 40659) (\MAP-CODE-LITERALS 40661 . 43700)) (
44679 48786 (LLBREAK 44689 . 45389) (BROKENDEF 45391 . 48784)) (49108 50879 (PRINTOPCODES 49118 .
50877)))))
STOP