(FILECREATED " 7-May-86 10:31:13" {ERIS}<TAMARIN>WORK>DT>DSA.;14 26553
changes to: (FNS DSA3 DSA3A DSA2.R DSA2.R.OPFNCTS DSA2.R.OPSORT.1 DSA2.R.OPSORT)
(VARS DSACOMS)
previous date: " 1-Apr-86 09:19:44" {ERIS}<TAMARIN>WORK>DT>DSA.;9)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT DSACOMS)
(RPAQQ DSACOMS [(* DSA0 -- D-machine static analysis)
(COMS (GLOBALVARS DSA.ALLFNS)
(INITVARS DSA.ALLFNS)
(FNS DSA.ALLFNS))
(COMS (* * DSA0 -- counts occurrences of opcodes)
(GLOBALVARS DSA0.INFNS DSA0.NTRIED DSA0.NOPS DSA0.OUT)
(INITVARS (DSA0.NTRIED 0)
(DSA0.NOPS 0)
DSA0.INFNS DSA0.OUT)
(FNS DSA0.I DSA0 DSA0.R1 DSA0.R))
(COMS (* * DSA1 -- find what fns certain opcodes occur in)
(GLOBALVARS DSA1.INFNS DSA1.INOPS DSA1.NTRIED)
(INITVARS DSA1.INFNS DSA1.INOPS (DSA1.NTRIED 0))
(VARS DSA1.INOPS0)
(FNS DSA1.RESET DSA1.I DSA1 DSA1.ALPHACOUNT DSA1.R1 DSA1.R DSA1.R.ARGCTS)
(FNS DSA1.SUBOPLIST DSA1.OPLIST))
(COMS (* * DSA2 -- find what contexts NTYPX occurs in)
(GLOBALVARS DSA2.INFNS DSA2.NTRIED DSA2.FNOPCTS)
(INITVARS DSA2.INFNS (DSA2.NTRIED 0)
DSA2.FNOPCTS)
(FNS DSA2.I DSA2 DSA2.R DSA2.R.OPFNCTS DSA2.R.OPSORT DSA2.R.OPSORT.1))
(COMS (* * DSA3X -- type studies)
(FNS DSA3 (* find out what all the ↑D↑CxxxTYPE# atoms' values are))
(FNS DSA3A (* print DTD type table])
(* DSA0 -- D-machine static analysis)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS DSA.ALLFNS)
)
(RPAQ? DSA.ALLFNS NIL)
(DEFINEQ
(DSA.ALLFNS
[LAMBDA (EVENIFTHERE?) (* jmh
"31-Mar-86 17:44")
(* * set up alphabetized list of all atoms that have CCODEP fn def cells)
(if (OR (NOT DSA.ALLFNS)
EVENIFTHERE?)
then (SETQ DSA.ALLFNS NIL)
[MAPATOMS (FUNCTION (LAMBDA (A)
(if (AND (CCODEP (GETD A))
(NEQ A (QUOTE TASMFN)))
then (push DSA.ALLFNS A]
(SETQ DSA.ALLFNS (SORT DSA.ALLFNS)))
(printout T .I0.10 (LENGTH DSA.ALLFNS)
" fns" T])
)
(* * DSA0 -- counts occurrences of opcodes)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS DSA0.INFNS DSA0.NTRIED DSA0.NOPS DSA0.OUT)
)
(RPAQ? DSA0.NTRIED 0)
(RPAQ? DSA0.NOPS 0)
(RPAQ? DSA0.INFNS NIL)
(RPAQ? DSA0.OUT NIL)
(DEFINEQ
(DSA0.I
[LAMBDA NIL (* jmh
"21-Mar-86 18:19")
(* * init for a run of DSA0s)
(DSA.ALLFNS)
(SETQ DSA0.INFNS DSA.ALLFNS)
(SETQ DSA0.NTRIED 0)
(SETQ DSA0.NOPS 0)
(if (HARRAYP DSA0.OUT)
then (CLRHASH DSA0.OUT)
else (SETQ DSA0.OUT (HASHARRAY 512])
(DSA0
[LAMBDA NIL (* jmh
"21-Mar-86 17:16")
(* * do some more fns off DSA0.INFNS until end or STOPkey)
(* * assume DDISASM doesn't fail)
(LET ((DOTSPACING 100)
(FIRSTFN (CAR DSA0.INFNS))
(LOCALCTR 0)
FN LAP X)
(while [AND DSA0.INFNS (NOT (KEYDOWNP (QUOTE STOP]
do (SETQ FN (CAR DSA0.INFNS))
(BLOCK)
(SETQ X (DDISASM FN))
(BLOCK)
(if (NOT (ZEROP (CAR X)))
then (SHOULDN'T "ddisasm reported error"))
(SETQ LAP (CDR X))
(SETQ LAP (CDR (MEMB (QUOTE CODE:)
LAP)))
(for INSTR in LAP when (AND (LISTP INSTR)
(NEQ (CAR INSTR)
(QUOTE *)))
do (SETQ X (OR (GETHASH (CAR INSTR)
DSA0.OUT)
0))
(PUTHASH (CAR INSTR)
(ADD1 X)
DSA0.OUT)
(if (NEQ (CAR INSTR)
(QUOTE -X-))
then (add DSA0.NOPS 1)))
(pop DSA0.INFNS)
(add DSA0.NTRIED 1)
(if (ZEROP (REMAINDER LOCALCTR DOTSPACING))
then (printout T "."))
(add LOCALCTR 1))
(LIST LOCALCTR FIRSTFN FN])
(DSA0.R1
[LAMBDA NIL (* jmh
"21-Mar-86 12:41")
(* * summary report)
(printout T DSA0.NTRIED " fns processed, of " (LENGTH DSA.ALLFNS)
T DSA0.NOPS " opcode-instances" T])
(DSA0.R
[LAMBDA NIL (* jmh
"21-Mar-86 13:52")
(* * full report)
(DSA0.R1)
(LET (L L0 L1 LX)
(* * turn hash array into list -- add non-occurring opcodes to list)
[MAPHASH DSA0.OUT (FUNCTION (LAMBDA (CT OP)
(push L (CONS OP CT]
(for OPCODE in \OPCODES bind OP when (NOT (ASSOC (SETQ OP (fetch (OPCODE OPCODENAME)
of OPCODE))
L)) do (push L (CONS OP 0)))
(SETQ L (SORT L T))
(LET (PCT Q0 Q1 QX FLAG)
(for OPCT in L do (SETQ PCT (FTIMES (FQUOTIENT (CDR OPCT)
DSA0.NOPS)
100.0))
(SETQ FLAG (if (NOT (\FINDOP (CAR OPCT)))
then (push LX OPCT)
"***"
elseif (ZEROP PCT)
then (push L0 OPCT)
"0 "
elseif (GEQ PCT 1.0)
then (push L1 OPCT)
">1%%"
else " "))
(printout T FLAG ,, .F4.1 PCT "%% [" .I4 (CDR OPCT)
"] "
(CAR OPCT)
T])
)
(* * DSA1 -- find what fns certain opcodes occur in)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS DSA1.INFNS DSA1.INOPS DSA1.NTRIED)
)
(RPAQ? DSA1.INFNS NIL)
(RPAQ? DSA1.INOPS NIL)
(RPAQ? DSA1.NTRIED 0)
(RPAQQ DSA1.INOPS0 (ARG0 (ATOMCELL.N)
BLT CONTEXTSWITCH (COPY.N)
CREATECELL DOCOLLECT DRAWLINE ELT ENDCOLLECT EVAL EVALV FMEMB (GETBASEFIXP.N
)
GETHASH GETP HILOC LISTGET LOLOC MAKENUMBER (MISC1)
(MISC2)
(MISC4)
MYALINK MYARGCOUNT NTHCHC PILOTBITBLT (PUTBASEFIXP.N)
RAID RCLK READFLAGS READPRINTERPORT READRP RECLAIMCELL RPLCHARCODE SETA
STKSCAN (STORE.N)
SUBRCALL
(TYPEMASK.N)
(TYPEP)
VAG2 WRITEMAP WRITEPRINTERPORT))
(DEFINEQ
(DSA1.RESET
[LAMBDA NIL (* jmh
"21-Mar-86 19:17")
(* * discard all DSA1 information)
(SETQ DSA1.INFNS NIL)
(for OPCODE in \OPCODES do (REMPROP (fetch (OPCODE OPCODENAME) of OPCODE)
(QUOTE DSA1.FNCTS])
(DSA1.I
[LAMBDA NIL (* jmh
"22-Mar-86 09:07")
(* * run this once to set up for a new sequence of DSA1s)
(DSA.ALLFNS)
(SETQ DSA1.INFNS DSA.ALLFNS)
(SETQ DSA1.NTRIED 0)
NIL])
(DSA1
[LAMBDA NIL (* jmh
"21-Mar-86 20:17")
(* * do some more fns off DSA1.INFNS until end or STOPkey)
(* * assume DDISASM doesn't fail)
(LET ((DOTSPACING 100)
(FIRSTFN (CAR DSA1.INFNS))
(LOCALCTR 0)
FN LAP X)
(while [AND DSA1.INFNS (NOT (KEYDOWNP (QUOTE STOP]
do (SETQ FN (CAR DSA1.INFNS))
(BLOCK)
(SETQ X (DDISASM FN))
(BLOCK)
(if (NOT (ZEROP (CAR X)))
then (SHOULDN'T "ddisasm reported error"))
(SETQ LAP (CDR X))
(SETQ LAP (CDR (MEMB (QUOTE CODE:)
LAP)))
[for OP in DSA1.INOPS do (SETQ X (if (NLISTP OP)
then (for INSTR in LAP when (LISTP INSTR)
count (EQ OP (CAR INSTR)))
else (DSA1.ALPHACOUNT (CAR OP)
LAP)))
(if (AND X (NOT (ZEROP X)))
then (if (NLISTP OP)
then (ADDPROP OP (QUOTE DSA1.FNCTS)
(CONS FN X)
T)
else (ADDPROP (CAR OP)
(QUOTE DSA1.FNCTS)
(CONS FN X)
T]
(pop DSA1.INFNS)
(add DSA1.NTRIED 1)
(if (ZEROP (REMAINDER LOCALCTR DOTSPACING))
then (printout T "."))
(add LOCALCTR 1))
(LIST LOCALCTR FIRSTFN FN])
(DSA1.ALPHACOUNT
[LAMBDA (OP LAP) (* jmh
"21-Mar-86 20:15")
(* * return <<arg1.count>..> for occurrences of OP in LAP)
(LET (OPCTS OPCT)
(for INSTR in LAP when (AND (LISTP INSTR)
(EQ OP (CAR INSTR)))
do (SETQ OPCT (ASSOC (CADR INSTR)
OPCTS))
(if (NOT OPCT)
then (SETQ OPCT (CONS (CADR INSTR)
0))
(push OPCTS OPCT))
(add (CDR OPCT)
1))
(SORT OPCTS T])
(DSA1.R1
[LAMBDA NIL (* jmh
"21-Mar-86 18:50")
(* * summary report)
(printout T DSA1.NTRIED " fns processed, of " (LENGTH DSA.ALLFNS)
T
(LENGTH DSA1.INOPS)
" opcodes" T])
(DSA1.R
[LAMBDA (MAXFNSTOPRINT) (* jmh
"22-Mar-86 09:15")
(* * full report)
(if (NOT (AND (NUMBERP MAXFNSTOPRINT)
(IGEQ MAXFNSTOPRINT 0)))
then (SETQ MAXFNSTOPRINT 20))
(DSA1.R1)
(for OP in DSA1.INOPS
do (if (NLISTP OP)
then (LET [(FNCTS (GETPROP OP (QUOTE DSA1.FNCTS]
(printout T T OP 13 .I3 (LENGTH FNCTS)
" fns [" .I3 (for FNCT in FNCTS sum (CDR FNCT))
" times]")
[if (AND FNCTS (ILEQ (LENGTH FNCTS)
MAXFNSTOPRINT))
then (printout T , (for FNCT in FNCTS collect (CAR FNCT]
(printout T T))
else (LET*((FNARGCTS (GETPROP (CAR OP)
(QUOTE DSA1.FNCTS)))
(ARGCTS (DSA1.R.ARGCTS FNARGCTS)))
(printout T T OP 13 .I3 (LENGTH FNARGCTS)
" fns [" .I3 (for ARGCT in ARGCTS sum (CDR ARGCT))
" times], "
(LENGTH ARGCTS)
" distinct args" T)
(for ARGCT in ARGCTS do (LET [(FNS (for FNARGCT in FNARGCTS
when (ASSOC (CAR ARGCT)
(CDR FNARGCT))
collect (CAR FNARGCT]
(if (NUMBERP (CAR ARGCT))
then (printout T 5 .I3.8 (CAR ARGCT)
"q")
else (printout T 5 (CAR ARGCT)))
(printout T 15 "in " .I3 (LENGTH FNS)
" fns [" .I3 (CDR ARGCT)
" times]")
(if (AND FNS (ILEQ (LENGTH FNS)
MAXFNSTOPRINT))
then (printout T , FNS))
(printout T T])
(DSA1.R.ARGCTS
[LAMBDA (FNARGCTS) (* jmh
"22-Mar-86 09:01")
(* * build a summary <<arg.ct>..> from a <<fn.<arg.ct>..>..>)
(LET (ARGCTS ARGCT)
[for FNARGCT in FNARGCTS do (for FAC.ARGCT in (CDR FNARGCT)
do (SETQ ARGCT (ASSOC (CAR FAC.ARGCT)
ARGCTS))
(if (NOT ARGCT)
then (SETQ ARGCT (CONS (CAR FAC.ARGCT)
0))
(push ARGCTS ARGCT))
(add (CDR ARGCT)
(CDR FAC.ARGCT]
(SORT ARGCTS T])
)
(DEFINEQ
(DSA1.SUBOPLIST
[LAMBDA (OP SUBOP) (* jmh
"31-Mar-86 09:01")
(* * return list of fns using this opcode+subopcode, smallest definitions
1st)
(SORT (for FNCT in (GETPROP OP (QUOTE DSA1.FNCTS)) when (ASSOC SUBOP (CDR FNCT))
collect (CAR FNCT))
(FUNCTION (LAMBDA (A B)
(ILESSP (ARRAYSIZE (GETD A))
(ARRAYSIZE (GETD B])
(DSA1.OPLIST
[LAMBDA (OP) (* jmh
"31-Mar-86 09:49")
(* * return list of fns using this opcode, smallest definitions 1st)
(SORT (for FNCT in (GETPROP OP (QUOTE DSA1.FNCTS)) collect (CAR FNCT))
(FUNCTION (LAMBDA (A B)
(ILESSP (ARRAYSIZE (GETD A))
(ARRAYSIZE (GETD B])
)
(* * DSA2 -- find what contexts NTYPX occurs in)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS DSA2.INFNS DSA2.NTRIED DSA2.FNOPCTS)
)
(RPAQ? DSA2.INFNS NIL)
(RPAQ? DSA2.NTRIED 0)
(RPAQ? DSA2.FNOPCTS NIL)
(DEFINEQ
(DSA2.I
[LAMBDA NIL (* jmh
"31-Mar-86 16:30")
(* * run this once to set up for a new sequence of DSA1s)
(DSA.ALLFNS)
(SETQ DSA2.INFNS DSA.ALLFNS)
(SETQ DSA2.NTRIED 0)
(SETQ DSA2.FNOPCTS NIL)
NIL])
(DSA2
[LAMBDA NIL (* jmh
"31-Mar-86 17:21")
(* * do some more fns off DSA2.INFNS until end or STOPkey)
(* * assume DDISASM doesn't fail)
(LET ((DOTSPACING 100)
(FIRSTFN (CAR DSA2.INFNS))
(LOCALCTR 0)
FN OPCTS OPCT NEXT2 X)
(while [AND DSA2.INFNS (NOT (KEYDOWNP (QUOTE STOP]
do (SETQ FN (CAR DSA2.INFNS))
(BLOCK)
(SETQ X (DDISASM FN))
(BLOCK)
(if (NOT (ZEROP (CAR X)))
then (SHOULDN'T "ddisasm reported error"))
(SETQ LAP (CDR X))
(SETQ LAP (CDR (MEMB (QUOTE CODE:)
LAP)))
(SETQ OPCTS NIL)
(for TAIL on LAP when (EQUAL (CAR TAIL)
(QUOTE (NTYPX)))
do (SETQ NEXT2 (LIST (CADR TAIL)
(CADDR TAIL)))
(if (NULL (SETQ OPCT (SASSOC NEXT2 OPCTS)))
then (SETQ OPCT (CONS NEXT2 0))
(push OPCTS OPCT))
(add (CDR OPCT)
1))
(if OPCTS
then (push DSA2.FNOPCTS (CONS FN OPCTS)))
(pop DSA2.INFNS)
(add DSA2.NTRIED 1)
(if (ZEROP (REMAINDER LOCALCTR DOTSPACING))
then (printout T "."))
(add LOCALCTR 1))
(LIST LOCALCTR FIRSTFN FN])
(DSA2.R
[LAMBDA (MAXFNSTOPRINT) (* jmh " 2-Apr-86 09:43")
(* * full report)
(OR MAXFNSTOPRINT (SETQ MAXFNSTOPRINT 20))
(printout T DSA2.NTRIED " fns processed, of " (LENGTH DSA.ALLFNS)
" -- "
(LENGTH DSA2.FNOPCTS)
" fns found" T)
(LET ((OPFNCTS (DSA2.R.OPFNCTS DSA2.FNOPCTS)))
(printout T (LENGTH OPFNCTS)
" ops--" T)
(for OPFNCT in OPFNCTS do (printout T T .PPV (CAR OPFNCT)
T 5 .I5 (LENGTH (CDR OPFNCT))
" fns, " .I5 (for FNCT in (CDR OPFNCT)
sum (CDR FNCT))
" times ")
[if (ILEQ (LENGTH (CDR OPFNCT))
MAXFNSTOPRINT)
then (printout T (for FNCT in (CDR OPFNCT)
collect (CAR FNCT]
(printout T T])
(DSA2.R.OPFNCTS
[LAMBDA (FNOPCTS) (* jmh " 2-Apr-86 09:43")
(* * build a summary <op.<fn.ct>..> from a <<fn.<op.ct>..>..>)
(LET (OPFNCTS OPFNCT)
[for FNOPCT in FNOPCTS do (for OPCT in (CDR FNOPCT)
do (if (NULL (SETQ OPFNCT (SASSOC (CAR OPCT)
OPFNCTS)))
then (SETQ OPFNCT (CONS (CAR OPCT)
NIL))
(push OPFNCTS OPFNCT))
(push (CDR OPFNCT)
(CONS (CAR FNOPCT)
(CDR OPCT]
(SORT OPFNCTS (QUOTE DSA2.R.OPSORT))
[for OPFNCT in OPFNCTS do (SORT (CDR OPFNCT)
(FUNCTION (LAMBDA (A B)
(ILESSP (ARRAYSIZE (GETD (CAR A)))
(ARRAYSIZE (GETD (CAR B]
OPFNCTS])
(DSA2.R.OPSORT
[LAMBDA (A B) (* jmh " 2-Apr-86 09:23")
(* * sort by CARs, where CAR is a list of 2 instrs <or possibly labels>)
(NEQ (QUOTE >)
(OR (DSA2.R.OPSORT.1 (CAAR A)
(CAAR B))
(DSA2.R.OPSORT.1 (CADAR A)
(CADAR B])
(DSA2.R.OPSORT.1
[LAMBDA (AA BB) (* jmh " 2-Apr-86 09:58")
(* * return (QUOTE <) NI or (QUOTE >) --
each of AA BB is either NIL, an atom, or a list of up to 2 elements)
(if (NULL AA)
then (if (NULL BB)
then NIL
else (QUOTE <))
elseif (NULL BB)
then (QUOTE >)
elseif (NLISTP AA)
then (if (LISTP BB)
then (QUOTE <)
else (SELECTQ (ALPHORDER AA BB)
(LESSP (QUOTE <))
(NIL (QUOTE >))
NIL))
elseif (NLISTP BB)
then (QUOTE >)
else (SELECTQ (ALPHORDER (CAR AA)
(CAR BB))
(LESSP (QUOTE <))
(NIL (QUOTE >))
(SELECTQ (ALPHORDER (CADR AA)
(CADR BB))
(LESSP (QUOTE <))
(NIL (QUOTE >))
NIL])
)
(* * DSA3X -- type studies)
(DEFINEQ
(DSA3
[LAMBDA NIL (* jmh " 9-Apr-86 12:32")
(* * report on what the ↑D↑CxxxTYPE# atoms' values are)
(LET ((PREFIX (CONCAT (CHARACTER 4)
(CHARACTER 3)))
(SUFFIX "TYPE#")
ATOMS)
(DECLARE (SPECVARS PREFIX SUFFIX ATOMS))
[MAPATOMS (FUNCTION (LAMBDA (A)
(if (AND (STREQUAL PREFIX (SUBSTRING A 1 2))
(STREQUAL SUFFIX (SUBSTRING A -5)))
then (push ATOMS A]
(printout T (LENGTH ATOMS)
" ↑D↑CXXXTYPE# atoms" T T)
(printout T "↑D↑CxxxTYPE# atoms & their values, alpha sort" T)
(for A in (SORT ATOMS) do (printout T A 25 (EVALV A)
T))
(printout T T T "↑D↑CxxxTYPE# atoms & their values, numeric sort" T)
(for A in [SORT ATOMS (FUNCTION (LAMBDA (A B)
(ILEQ (EVALV A)
(EVALV B] do (printout T A 25 (EVALV A)
T])
)
(DEFINEQ
(DSA3A
[LAMBDA NIL (* jmh " 9-Apr-86 14:20")
(* * print part of DTD type table)
(LET (PTR NAME SUPERTYPENR TYPEENTRY)
(for TYPENR from 0 to 255
do (printout T .I3 TYPENR " =" .I3.8.T TYPENR)
(SETQ PTR (\GETDTD TYPENR))
(SETQ NAME (fetch (DTD DTDNAME) of PTR))
[if (NOT (ZEROP NAME))
then (SETQ TYPEENTRY (fetch (DTD DTDTYPEENTRY) of PTR))
(printout T , (\INDEXATOMPNAME NAME)
27 "sz " .I3 (fetch (DTD DTDSIZE) of PTR)
" t.e " .I3.8.T (LOGAND 255 (LRSH TYPEENTRY 8))
" / " .I3.8.T (LOGAND 255 TYPEENTRY))
(if [NOT (ZEROP (SETQ SUPERTYPENR (fetch (DTD DTDSUPERTYPE) of PTR]
then (printout T " sup. " .I3.8.T (fetch (DTD DTDSUPERTYPE) of PTR]
(printout T T])
)
(PUTPROPS DSA COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1978 2758 (DSA.ALLFNS 1988 . 2756)) (3007 7570 (DSA0.I 3017 . 3489) (DSA0 3491 . 5231)
(DSA0.R1 5233 . 5598) (DSA0.R 5600 . 7568)) (8610 16568 (DSA1.RESET 8620 . 9067) (DSA1.I 9069 . 9442)
(DSA1 9444 . 11709) (DSA1.ALPHACOUNT 11711 . 12507) (DSA1.R1 12509 . 12897) (DSA1.R 12899 . 15545) (
DSA1.R.ARGCTS 15547 . 16566)) (16569 17700 (DSA1.SUBOPLIST 16579 . 17174) (DSA1.OPLIST 17176 . 17698))
(17927 24068 (DSA2.I 17937 . 18338) (DSA2 18340 . 20116) (DSA2.R 20118 . 21313) (DSA2.R.OPFNCTS 21315
. 22593) (DSA2.R.OPSORT 22595 . 22974) (DSA2.R.OPSORT.1 22976 . 24066)) (24103 25377 (DSA3 24113 .
25375)) (25378 26479 (DSA3A 25388 . 26477)))))
STOP