(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(filecreated " 8-Oct-87 14:32:37" {erinyes}<lispusers>lyric>spy2.\;8 33820
|changes| |to:| (variables spy.mergeinfo)
(records spydata fx)
(fns spy.tree spy.find.tree spy.graph.editor spy.makegraphnodes spy.max
spy.merge spy.merge1 spy.mergetree spy.next.tree spy.sum spy.title
spy.make.tree spy.delete spy.dump.buffer spy.original spy.merge.callees
spy.print \\spy.interrupt spy.mergeinfo)
(vars spy2coms spy2objcoms spy.mergeinfo spy.nomergefns)
(props (spy2 makefile-environment))
|previous| |date:| "16-Sep-87 14:51:00" {erinyes}<lispusers>lyric>spy2.\;1)
; Copyright (c) 1987 by Xerox Corporation. All rights reserved.
(prettycomprint spy2coms)
(rpaqq spy2coms
((vars spy.borders spy.buffer.size spy.fragments (spy.hash)
(spy.graph.menu)
spy.show.percentages spy.smallghosts spy.icon)
(variables spy.mergeinfo)
(fns spy.mergeinfo)
(initvars (spy.next 0)
(spy.buffer)
(spy.showcounts t)
(spy.show.threshold 1)
(spy.maxlines 10)
(spy.frequency 10)
(spy.font '(gacha 8))
(spy.tree))
(coms * spy2objcoms)
(fns spy.find.tree spy.toggle spy.tree spy.legend spy.graph.editor spy.end spy.makegraphnodes
spy.max spy.merge spy.merge1 spy.mergetree spy.next.tree spy.sum spy.title spy.make.tree
spy.delete spy.drawbox spy.buffer.entry spy.button spy.end.entry spy.start spy.init
\\spy.interrupt spy.dump.buffer spy.start.entry spy.add.entry spy.original spy.overflow
spy.merge.callees spy.print)
(coms (initvars (spy.button))
(vars spy.open spy.closed))
(variables spy.pointers)
(globalvars spy.overflowed \\periodic.interrupt spy.tree spy.buffer.size spy.next
spy.buffer.threshold spy.buffer spy.frequency spy.show.threshold spy.maxlines spy.font
)
(macros with-spy with.spy)
(declare\: dontcopy (records spyrecord spydata))
(initrecords spyrecord)
(files grapher readnumber imageobj)
(prop makefile-environment spy2)
(declare\: donteval@load doeval@compile dontcopy (files (loadcomp)
llparams llbasic llstk))))
(rpaqq spy.borders ((normal "Normal" 2 -1)
(ghost "Shown elsewhere" 2 8840)
(recursiveghost "End of recursive chain" 2 0 -1)
(merged "Includes other branches" 4 42405)
(selfrecursive "Includes self-recursive calls" 2 61375)
(recursive "Head of recursive chain" 4 28086)
(endofline "exceeded depth limit" 6 64510)))
(rpaqq spy.buffer.size 5120)
(rpaqq spy.fragments t)
(rpaqq spy.hash nil)
(rpaqq spy.graph.menu nil)
(rpaqq spy.show.percentages t)
(rpaqq spy.smallghosts t)
(rpaqq spy.icon #*(56 28)OOOOOOOOOOOOOO@@OOOOOOOOOOOOOO@@L@@@@@@@@@@@@C@@L@@@@@@@@@@@@C@@L@@@@@@@@@@@@C@@L@@@@@@@@COONC@@L@@@@@@@@B@@BC@@L@@@@@@@@B@@BC@@L@GOOOO@@N@@BC@@L@D@@@A@CB@@BC@@L@ENODE@LB@@BC@@L@E@IBIC@COONC@@L@ENOAAL@@@@@C@@L@DBHAAF@COONC@@L@ENHAAAHB@@BC@@L@D@@@A@FB@@BC@@L@GOOOO@AJ@@BC@@L@@@@@@@@F@@BC@@L@@@@@@@@B@@BC@@L@@@@@@@@B@@BC@@L@@@@@@@@B@@BC@@L@@@@@@@@B@@BC@@L@@@@@@@@B@@BC@@L@@@@@@@@COONC@@L@@@@@@@@@@@@C@@L@@@@@@@@@@@@C@@OOOOOOOOOOOOOO@@OOOOOOOOOOOOOO@@
)
(cl:defparameter spy.mergeinfo
(* |;;| "A list of function names and how spy is supposed to handle it. ")
(* |;;| "The CDR is a list of nodes that this function can merge with.")
(* |;;| "CADR is what to do if the parent node isn't any of the others")
(* |;;|
"keywords are used as the name of generic classes of functions which shouldn't be shown otherwise")
'((exec :exec)
(ttyin :exec)
(exec-read-line :exec)
(exec-read :exec)
(xcl-user::lex-do-event :exec)
(do-event :exec)
(eval-input :exec)
(si::*unwind-protect* :any)
(t :top)
(\\make.process0 :top)
(\\proc.repeatedlyevalqt :top)
(\\evalform :eval :top)
(progn :eval :top)
(prog1 :eval)
(arg :eval)
(setarg :eval)
(ersetq :eval)
(nlsetq :eval)
(prog :eval nil)
(resetlst :eval)
(savesetq :eval)
(cl:eval :eval)
(\\eval-progn :eval)
(\\interpret-arguments :eval)
(\\interpreter :eval)
(\\interpreter1 :eval)
(\\eval :eval)
(\\evalform :eval)
(apply :eval)
(\\progv :any)
(eval :eval)
(errorset :any)
(ttyin1 :exec)
(ttbin :exec)
(ttwaitforinput :exec)
(\\progv :any)
(\\gc.handleoverflow :gc)
(\\htfind :gc)))
(defineq
(spy.mergeinfo
(lambda (name parent-name mergeinfo) (* \; "Edited 8-Oct-87 13:56 by Masinter") (cl:block info (cl:macrolet ((ret (x) (bquote (cl:return-from info (\\\, x)))) (lk nil (bquote (cl:when (eq (car x) name) (cl:unless found (setq found x)) (cl:when (eq (cadr x) (quote :none)) (ret (cdr x))) (cl:when (fmemb parent-name (cdr x)) (ret (cdr x))))))) (prog (found) (cl:when (and (cl:symbolp name) (cl:symbolp parent-name) (gensym? name) (or (cl:keywordp parent-name) (strpos parent-name name 1 nil t))) (ret (list parent-name))) (* |;;| "would have used FLET but the bytecompiler can't handle it and the pavcompiler can't handle \\MYALINK and friends ") (cl:dolist (x mergeinfo) (lk)) (cl:dolist (x spy.mergeinfo) (lk)) (cl:when found (ret (cdr found))) (cl:when (strpos "\\interpret-" name) (ret (quote (:eval))))))))
)
)
(rpaq? spy.next 0)
(rpaq? spy.buffer )
(rpaq? spy.showcounts t)
(rpaq? spy.show.threshold 1)
(rpaq? spy.maxlines 10)
(rpaq? spy.frequency 10)
(rpaq? spy.font '(gacha 8))
(rpaq? spy.tree )
(rpaqq spy2objcoms ((fns spyobj spyobj.button spyobj.save spyobj.copy spyobj.get spyobj.imagebox
spyobj.display spyobj.label spyobj.height spyobj.copyin spy.copybutton)
(vars (spyobj.imagefns (imagefnscreate (function spyobj.display)
(function spyobj.imagebox)
(function spyobj.save)
(function spyobj.get)
(function spyobj.copy)
(function spyobj.button)
(function spyobj.copyin)
nil nil nil nil nil nil 'spynode)))
(records spyobjdata)))
(defineq
(spyobj
(lambda (name percent status) (* \; "Edited 9-Sep-87 17:56 by Masinter") (imageobjcreate (|create| spyobjdata label ← name percent ← percent cachedlabel ← (let ((*print-pretty* nil) (*print-level* 1) (*print-length* 1)) (cl:format nil "~D ~S" percent label))) spyobj.imagefns))
)
(spyobj.button
(lambda (obj windowstream sel relx rely window text button) (* |lmm| " 9-Jun-85 00:40") nil))
(spyobj.save
(lambda (obj stream) (* |edited:| "11-Jun-85 05:03") (prin2 (|fetch| objectdatum obj) stream filerdtbl))
)
(spyobj.copy
(lambda (obj) (* |lmm| " 9-Jun-85 00:43") obj))
(spyobj.get
(lambda (stream textstream) (* |lmm| " 9-Jun-85 00:44") (imageobjcreate (read stream filerdtbl) spyobj.imagefns))
)
(spyobj.imagebox
(lambda (obj fontsource) (* |lmm| " 9-Jun-85 01:12") (or fontsource (setq fontsource spy.font)) (let ((data (|fetch| objectdatum obj))) (let ((height (spyobj.height obj fontsource))) (|create| imagebox xsize ← (stringwidth (spyobj.label obj) fontsource) ysize ← height ydesc ← (quotient height 2) xkern ← 0))))
)
(spyobj.display
(lambda (obj stream) (* |lmm| " 9-Jun-85 01:13") (dspfont spy.font stream) (let ((data (|fetch| objectdatum obj))) (let ((height (spyobj.height obj stream))) (relmoveto 0 (quotient (difference height (quotient (fontheight stream) 2)) 2) stream) (prin3 (spyobj.label obj) stream))))
)
(spyobj.label
(lambda (obj) (* |lmm| " 9-Jun-85 01:24") (let ((datum (|fetch| objectdatum obj))) (|with| spyobjdata datum cachedlabel)))
)
(spyobj.height
(lambda (obj stream) (* |lmm| " 9-Jun-85 00:51") (let ((datum (|fetch| objectdatum obj)) (fh (fontheight stream))) (|with| spyobjdata datum (max fh (quotient (times percent spy.maxlines fh) 100)))))
)
(spyobj.copyin
(lambda (a b c) (help)))
(spy.copybutton
(lambda (window) (* |lmm| " 9-Jun-85 01:55") (spy.graph.editor window t)))
)
(rpaq spyobj.imagefns (imagefnscreate (function spyobj.display)
(function spyobj.imagebox)
(function spyobj.save)
(function spyobj.get)
(function spyobj.copy)
(function spyobj.button)
(function spyobj.copyin)
nil nil nil nil nil nil 'spynode))
(declare\: eval@compile
(record spyobjdata (cachedlabel percent label))
)
(defineq
(spy.find.tree
(lambda (fn) (* \; "Edited 8-Oct-87 14:08 by Masinter") (or (|find| x |in| spy.tree |suchthat| (eq (|fetch| (spyrecord name) |of| x) fn)) (car (|push| spy.tree (|create| spyrecord name ← fn count ← 0)))))
)
(spy.toggle
(lambda nil (* |lmm| "24-Oct-84 22:49") (|if| (eq \\periodic.interrupt (quote \\spy.interrupt)) |then| (spy.end) (resetform (cursor waitingcursor) (spy.tree 10)) |else| (spy.start)))
)
(spy.tree
(lambda (threshold individualp mergetype depthlimit) (* \; "Edited 8-Oct-87 14:23 by Masinter")
(cond
((null spy.tree)
"no spy samples have been gathered")
(t (prog ((spydata (|create| spydata
package ← *package*
readtable ← *readtable*
print-case ← *print-case*
cumulative ← (not individualp)
threshold ← (or threshold spy.show.threshold)
mergetype ← (or mergetype (cond
(individualp 'all)
(t t)))
depth ← depthlimit)))
(spy.make.tree (spy.merge spy.tree spydata)
spydata))))))
(spy.legend
(lambda nil (* |lmm| "28-Sep-84 21:27") (showgraph (layoutgraph (|for| x |in| spy.borders |collect| (|create| graphnode nodeid ← x nodelabel ← (cadr x) tonodes ← nil nodefont ← spy.font nodeborder ← (cddr x) nodelabelshade ← (caddr (cddr x)))) (reverse spy.borders) nil spy.font nil 10) "SPY border interpretation" (quote nill) (quote nill)))
)
(spy.graph.editor
(lambda (w copy) (* \; "Edited 8-Oct-87 14:11 by Masinter") (prog* ((trees (windowprop w (quote trees))) new-trees (topcount (windowprop w (quote topcount))) (window w) node lastnode action (spydata (windowprop w (quote spydata))) pending (multiple (mousestate middle)) (*readtable* (|fetch| (spydata readtable) |of| spydata)) (*package* (|fetch| (spydata package) |of| spydata)) (*print-case* (|fetch| (spydata print-case) |of| spydata))) (totopw w) (|do| (setq node (or (nodelst/as/menu (|fetch| (graph graphnodes) |of| (windowprop w (quote graph))) (cons (lastmousex w) (lastmousey w))) copy)) (|if| (neq node lastnode) |then| (cond (lastnode (|if| (eq lastnode t) |then| (invertw w) |else| (flipnode lastnode w)))) (cond (node (|if| (eq node t) |then| (invertw w) |else| (flipnode node w)))) (setq lastnode node)) |repeatwhile| (mousestate (or middle left))) (|if| copy |then| (return (|if| (eq node t) |then| (invertw w) (graphercopybuttoneventfn w) |else| (flipnode node w) (copyinsert (|fetch| (spyrecord name) |of| (|fetch| (graphnode nodeid) |of| node)))))) (|if| node |then| (let ((name (|fetch| (spyrecord name) |of| (|fetch| nodeid |of| node)))) (selectq (setq action (menu (constant (|create| menu items ← (quote (|NewSubTree| |SubTree| |Delete| |Merge| |Don'tMerge| |Edit| |InspectCode|)))))) (nil (flipnode node w) (* \; "no tree action ")) (|Edit| (flipnode node w) (ed name (quote (functions fns :dontwait :display)))) (|InspectCode| (flipnode node w) (inspectcode name)) (|Delete| (* \; "remove this node. Leave still marked") (|push| (|fetch| (spydata deleted) |of| spydata) name) (setq pending "delete")) (|Don'tMerge| (|for| x |in| (|fetch| (spyrecord treefrom) |of| (|fetch| nodeid |of| node)) |do| (|push| (|fetch| (spydata mergeinfo) |of| spydata) (list (|fetch| (spyrecord name) |of| x) (quote :none)))) (setq pending "merge")) (|Merge| (|if| (|fetch| fromnodes |of| node) |then| (|push| (|fetch| (spydata mergeinfo) |of| spydata) (list name (|fetch| (spyrecord name) |of| (car (|fetch| fromnodes |of| node)))))) (setq pending "merge")) (|NewSubTree| (flipnode node w) (spy.make.tree (spy.merge (spy.original (list (|fetch| nodeid |of| node))) spydata) (|create| spydata |using| spydata pending ← nil deleted ← nil))) ((|SubTree|) (setq new-trees (spy.merge (spy.original (list (|fetch| nodeid |of| node))) spydata))) (|printout| promptwindow t "SORRY, FEATURE NOT IMPLEMENTED YET"))) |elseif| (inside? (windowprop w (quote region)) lastmousex lastmousey) |then| (selectq (menu (|create| menu items ← (bquote (|Inspect| |SetThreshold| (\\\, (cond ((|fetch| (spydata cumulative) |of| spydata) (quote |Individual|)) (t (quote |Cumulative|)))) (\\\,@ (selectq (|fetch| (spydata mergetype) |of| spydata) (all (quote (|MergeDefault| |MergeNone|))) (t (quote (|MergeNone| |MergeAll|))) ((nil none) (quote (|MergeDefault| |MergeAll|))) (shouldnt))))))) (nil) (|Inspect| (inspect/plist spydata)) (|SetThreshold| (* \; "no need to remerge") (|replace| (spydata threshold) |of| spydata |with| (rnumber "Threshold (percent)" nil defaultfont defaultfont)) (setq pending "threshold")) (|MergeAll| (|replace| (spydata mergetype) |of| spydata |with| (quote all)) (setq pending "merge-type")) (|MergeNone| (|replace| (spydata mergetype) |of| spydata |with| (quote none)) (setq pending "merge-type")) (|MergeDefault| (|replace| (spydata mergetype) |of| spydata |with| t) (setq pending "merge-type")) ((|Cumulative| |Individual|) (|replace| (spydata mergetype) |of| spydata |with| (cond ((|change| (|fetch| (spydata cumulative) |of| spydata) (not datum)) t) (t (quote all)))) (setq pending "merge-type")) (shouldnt))) doit (|if| (and (not new-trees) multiple) |then| (* \; "multiple action while shift down") (|if| pending |then| (|if| (not (strpos pending (windowprop w (quote title)))) |then| (windowprop w (quote title) (concat pending "/" (windowprop w (quote title))))) (|replace| (spydata pending) |of| spydata |with| t)) |elseif| (or new-trees pending (|fetch| (spydata pending) |of| spydata)) |then| (spy.make.tree (or new-trees (spy.merge (spy.original trees) spydata)) (|create| spydata |using| spydata pending ← nil deleted ← nil) window))))
)
(spy.end
(lambda nil (* \; "Edited 9-Sep-87 17:51 by Masinter") (|if| (eq \\periodic.interrupt (quote \\spy.interrupt)) |then| (setq \\periodic.interrupt) (spy.dump.buffer) (|if| (openwp spy.button) |then| (bitblt spy.closed nil nil spy.button))))
)
(spy.makegraphnodes
(lambda (tree threshold spydata) (* \; "Edited 8-Oct-87 14:11 by Masinter") (* returns node id for tree) (prog ((label (|fetch| (spyrecord name) |of| tree)) (count (cond ((|fetch| (spydata cumulative) spydata) (|fetch| (spyrecord sum) |of| tree)) (t (|fetch| (spyrecord count) |of| tree)))) (status (|fetch| (spyrecord status) |of| tree)) height border width nodebitmap toosmall) (setq border (cddr (or (assoc status spy.borders) (shouldnt)))) (|push| spy.nodes (|create| graphnode nodeid ← tree nodelabel ← (spyobj label (quotient (times count 100) topcount) status) tonodes ← (|for| x |in| (|fetch| (spyrecord callees) |of| tree) |when| (or (zerop threshold) (igeq (spy.max (list x) (not (|fetch| (spydata cumulative) spydata))) threshold)) |bind| val |do| (|push| val (spy.makegraphnodes x threshold spydata)) |finally| (return val)) nodeborder ← border nodefont ← spy.font))) tree)
)
(spy.max
(lambda (trees countp max) (* \; "Edited 8-Oct-87 14:08 by Masinter") (|for| x |in| trees |do| (setq max (spy.max (|fetch| (spyrecord callees) |of| x) countp (imax (or max (imax)) (|if| countp |then| (|fetch| (spyrecord count) |of| x) |else| (|fetch| (spyrecord sum) |of| x)))))) max)
)
(spy.merge
(lambda (trees spydata) (* \; "Edited 8-Oct-87 14:11 by Masinter") (cond (spy.hash (clrhash spy.hash)) (t (setq spy.hash (hasharray 100)))) (|if| (|fetch| (spydata deleted) |of| spydata) |then| (setq trees (spy.delete (|fetch| (spydata deleted) |of| spydata) trees))) (|for| x |in| trees |do| (spy.sum x)) (|for| newnode |in| trees |bind| val z |do| (|for| oldnode |in| val |when| (eq (|fetch| (spyrecord name) |of| oldnode) (|fetch| (spyrecord name) |of| newnode)) |do| (return (spy.mergetree newnode oldnode spydata nil (|fetch| (spydata depth) spydata))) |finally| (and (setq z (spy.merge1 newnode spydata nil nil (|fetch| (spydata depth) spydata))) (setq val (nconc1 val z)))) |finally| (clrhash spy.hash) (return val)))
)
(spy.merge1
(lambda (neworiginal spydata parents caller depth) (* \; "Edited 8-Oct-87 14:11 by Masinter") (* \; "return the 'merged' tree for TREE, a copy of the original") (prog* ((name (|fetch| (spyrecord name) |of| neworiginal)) (parent-name (and parents (|fetch| (spyrecord name) |of| (car parents)))) (new-name name) merge-list cross-mergep oldcopy newcopy) (selectq (|fetch| (spydata mergetype) |of| spydata) ((nil none)) (progn (|if| (setq merge-list (spy.mergeinfo new-name parent-name (|fetch| (spydata mergeinfo) |of| spydata))) |then| (|if| (eq (car merge-list) (quote :any)) |then| (|if| parents |then| (setq new-name parent-name)) |elseif| (eq (car merge-list) (quote :none)) |then| (setq cross-mergep nil) (go no-merge) |elseif| (or (null parents) (not (fmemb parent-name merge-list))) |then| (setq new-name (car merge-list)) |else| (setq new-name parent-name))) (selectq (|fetch| (spydata mergetype) |of| spydata) ((recursive-only) nil) (t (* |;;| "ok to merge non-symbols because merging is done by EQ") (setq cross-mergep (or (not (cl:symbolp new-name)) (not merge-list)))) (all (setq cross-mergep t)) (shouldnt)))) (cond ((or (and cross-mergep (setq oldcopy (gethash new-name spy.hash))) (selectq (|fetch| (spydata mergetype) |of| spydata) ((nil none) nil) (and parents (eq new-name (|fetch| (spyrecord name) |of| (setq oldcopy (car parents))))))) (* \; "mergeable, and we found one to merge into") (spy.mergetree neworiginal oldcopy spydata parents depth) (cond ((or (|fetch| (spydata noghosts) |of| spydata) (eq oldcopy (car parents))) (return nil)) ((and caller (setq newcopy (|find| x |in| (|fetch| (spyrecord callees) |of| caller) |suchthat| (eq (|fetch| (spyrecord name) |of| x) new-name)))) (selectq (|fetch| (spyrecord status) |of| newcopy) (ghost (and (fmemb oldcopy parents) (|replace| (spyrecord status) |of| newcopy |with| (quote recursiveghost)))) ((recursiveghost endofline)) (help "spy: never seen this case before")) (return nil)) (t (setq newcopy (|create| spyrecord |using| neworiginal callees ← nil status ← (quote ghost) treefrom ← neworiginal)) (and caller (|push| (|fetch| (spyrecord callees) |of| caller) newcopy)) (return newcopy))))) no-merge (setq newcopy (|create| spyrecord |using| neworiginal callees ← nil treefrom ← neworiginal name ← new-name)) (* \; "create the copy") (and cross-mergep (puthash new-name newcopy spy.hash)) (* \; "remember it if it is mergable") (and caller (|push| (|fetch| (spyrecord callees) |of| caller) newcopy)) (spy.merge.callees neworiginal newcopy spydata parents depth) (* \; "") (return newcopy)))
)
(spy.mergetree
(lambda (neworiginal oldcopy spydata parents depth) (* \; "Edited 8-Oct-87 14:09 by Masinter") (* \; "insert call tree from NEWORIGINAL into node starting with OLDCOPY") (* \; "this function is only called once we've decided to merge something after all") (prog ((recursive (fmemb oldcopy parents))) (cond ((not recursive) (|add| (|fetch| (spyrecord sum) |of| oldcopy) (|fetch| (spyrecord sum) |of| neworiginal)))) (|add| (|fetch| (spyrecord count) |of| oldcopy) (|fetch| (spyrecord count) |of| neworiginal)) (|if| recursive |then| (selectq (|fetch| (spyrecord status) |of| oldcopy) ((normal selfrecursive) (|replace| (spyrecord treefrom) |of| oldcopy |with| (list (|fetch| (spyrecord treefrom) |of| oldcopy) neworiginal)) (* \; "must be a list") (|replace| (spyrecord status) |of| oldcopy |with| (quote recursive))) (recursive) (merged (|replace| (spyrecord status) |of| oldcopy |with| (quote recursive))) (shouldnt)) |else| (* \; "add to TREEFROM") (|replace| (spyrecord treefrom) |of| oldcopy |with| (cons neworiginal (selectq (|fetch| (spyrecord status) |of| oldcopy) ((normal selfrecursive) (|replace| (spyrecord status) |of| oldcopy |with| (quote merged)) (list (|fetch| (spyrecord treefrom) |of| oldcopy))) ((merged recursive endofline) (|fetch| (spyrecord treefrom) |of| oldcopy)) (shouldnt))))) (spy.merge.callees neworiginal oldcopy spydata parents depth) (return t)))
)
(spy.next.tree
(lambda (tree fn) (* \; "Edited 8-Oct-87 14:08 by Masinter") (|for| x |in| (|fetch| (spyrecord callees) |of| tree) |do| (cond ((eq (|fetch| (spyrecord name) |of| x) fn) (return x))) |finally| (|push| (|fetch| (spyrecord callees) |of| tree) (setq x (|create| spyrecord name ← fn count ← 0))) (return x)))
)
(spy.sum
(lambda (tree) (* \; "Edited 8-Oct-87 14:09 by Masinter") (|replace| (spyrecord sum) |of| tree |with| (plus (|fetch| (spyrecord count) |of| tree) (prog1 (|for| x |in| (|fetch| (spyrecord callees) |of| tree) |sum| (spy.sum x)) (sort (|fetch| (spyrecord callees) |of| tree) (function (lambda (x y) (igreaterp (|fetch| (spyrecord sum) |of| x) (|fetch| (spyrecord sum) |of| y)))))))))
)
(spy.title
(lambda (x topcount spydata) (* \; "Edited 8-Oct-87 14:08 by Masinter") (concat "SPY " (|fetch| (spyrecord name) |of| x) ", " topcount " samples"))
)
(spy.make.tree
(lambda (trees spydata window) (* \; "Edited 8-Oct-87 14:11 by Masinter") (prog (graph ids w h thrsh topcount (*package* (|fetch| (spydata package) |of| spydata)) (*readtable* (|fetch| (spydata readtable) |of| spydata)) (*print-case* (|fetch| (spydata print-case) |of| spydata))) (or (fontp spy.font) (setq spy.font (fontcreate spy.font))) (setq topcount (|for| x |in| trees |sum| (|fetch| (spyrecord sum) |of| x))) (setq thrsh (quotient (times topcount (|fetch| (spydata threshold) |of| spydata)) 100)) (setq spy.nodes) (setq spy.topnodes (|for| x |in| trees |collect| (spy.makegraphnodes x thrsh spydata))) (setq title (spy.title (car spy.topnodes) topcount spydata)) (setq spy.window (showgraph (layoutgraph (reverse spy.nodes) spy.topnodes nil spy.font) (cond ((windowp window) (windowprop window (quote title) title) window) (t title)) nil nil nil nil (function spy.copybutton))) (windowprop spy.window (quote icon) spy.icon) (windowprop spy.window (quote buttoneventfn) (function spy.graph.editor)) (windowprop spy.window (quote rightbuttonfn) nil) (windowprop spy.window (quote spydata) spydata) (windowprop spy.window (quote trees) trees) (windowprop spy.window (quote topcount) topcount)))
)
(spy.delete
(lambda (names trees) (* \; "Edited 8-Oct-87 14:08 by Masinter") (|for| x |in| trees |when| (not (eqmemb (|fetch| (spyrecord name) |of| x) names)) |collect| (|create| spyrecord |using| x callees ← (spy.delete names (|fetch| (spyrecord callees) |of| x)))))
)
(spy.drawbox
(lambda (width height borderwidth bitmap texture) (* \; "Edited 9-Sep-87 17:54 by Masinter") (bitblt nil nil nil bitmap 0 0 borderwidth height (quote texture) (quote paint) texture) (bitblt nil nil nil bitmap 0 0 width borderwidth (quote texture) (quote paint) texture) (bitblt nil nil nil bitmap 0 (difference height borderwidth) width borderwidth (quote texture) (quote paint) texture) (bitblt nil nil nil bitmap (difference width borderwidth) 0 borderwidth height (quote texture) (quote paint) texture))
)
(spy.buffer.entry
(lambda (n) (* \; "Edited 9-Sep-87 18:27 by Masinter") (cond (spy.pointers (and (ileq (setq n (llsh n 1)) spy.buffer.size) (\\getbaseptr spy.buffer n))) ((ileq n spy.buffer.size) (\\vag2 0 (\\getbase spy.buffer n)))))
)
(spy.button
(lambda (pos) (* |gbn| " 2-Jun-85 13:12") (prog ((reg (|if| pos |then| (createregion (|fetch| xcoord |of| pos) (|fetch| ycoord |of| pos) (widthifwindow (bitmapwidth spy.closed)) (heightifwindow (bitmapheight spy.closed))) |else| (getboxregion (widthifwindow (bitmapwidth spy.closed)) (heightifwindow (bitmapheight spy.closed)) nil nil nil "Specify region for window \"Spy Control\"")))) (bitblt spy.closed nil nil (setq spy.button (createw reg nil nil t))) (windowprop spy.button (quote buttoneventfn) (function (lambda (w) (and (lastmousestate up) (spy.toggle)))))))
)
(spy.end.entry
(lambda nil (* |ejs:| "27-APR-84 11:37") (spy.add.entry nil)))
(spy.start
(lambda (file) (* |lmm| "24-Oct-84 22:49") (|if| (openwp spy.button) |then| (bitblt spy.open nil nil spy.button)) (* |ejs:| "27-APR-84 11:37") (spy.init file) (setq \\periodic.interrupt.frequency (quotient 60 spy.frequency)) (setq \\periodic.interrupt (quote \\spy.interrupt)))
)
(spy.init
(lambda nil (* \; "Edited 9-Sep-87 23:47 by Masinter") (or spy.buffer (setq spy.buffer (\\allocblock (cl:* spy.buffer.size 2)))) (setq spy.buffer.threshold (quotient spy.buffer.size 2)) (setq spy.next 0) (setq spy.tree))
)
(\\spy.interrupt
(lambda nil (* \; "Edited 8-Oct-87 14:00 by Masinter") (setq \\periodic.interrupt nil) (* \; "turn off sampling while gathering sample") (prog ((frame (|fetch| (fx clink) (\\myalink)))) (cond ((igeq (|if| spy.pointers |then| (llsh spy.next 1) |else| spy.next) spy.buffer.threshold) (cond (\\interruptable (spy.dump.buffer)) (t (* \; "this sample might overflow; just don't do it") (return))))) (spy.start.entry) sampleloop (spy.add.entry (|fetch| (fx framename) frame)) (cond ((not (|fetch| (fx invalidp) (setq frame (|fetch| (fx clink) frame)))) (go sampleloop)) (t (spy.end.entry)))) (setq \\periodic.interrupt (quote \\spy.interrupt)))
)
(spy.dump.buffer
(lambda nil (* \; "Edited 8-Oct-87 14:09 by Masinter") (|bind| (i ← 0) nexti |while| (ilessp i spy.next) |do| (|bind| (j ← (setq nexti (|for| k |from| i |by| 1 |while| (spy.buffer.entry k) |finally| (return k)))) tree (name ← "NO SUCH NAME") |first| (setq tree (spy.find.tree (spy.buffer.entry (|add| j -1)))) |while| (igreaterp j i) |do| (cond ((neq name (setq name (spy.buffer.entry (|add| j -1)))) (setq tree (spy.next.tree tree name))) (t (|replace| (spyrecord status) |of| tree |with| (quote selfrecursive)))) |finally| (|add| (|fetch| (spyrecord count) |of| tree) 1)) (setq i (add1 nexti))) (setq spy.next 0))
)
(spy.start.entry
(lambda nil (* |ejs:| "27-APR-84 11:37") (* |do| |nothing| |at| |the| |start| |of| |the| |entry,| |do| |this| |at| |the| |end|) nil)
)
(spy.add.entry
(lambda (name) (* \; "Edited 9-Sep-87 18:29 by Masinter") (cond (spy.pointers (\\putbaseptr spy.buffer (llsh spy.next 1) name) (cond ((igeq (llsh (|add| spy.next 1) 1) spy.buffer.size) (spy.overflow)))) (t (or (litatom name) (setq name (quote *form*))) (\\putbase spy.buffer spy.next (\\loloc name)) (cond ((igeq (|add| spy.next 1) spy.buffer.size) (spy.overflow))))))
)
(spy.original
(lambda (trees) (* \; "Edited 8-Oct-87 14:08 by Masinter") (|for| x |in| trees |join| (selectq (|fetch| (spyrecord status) |of| x) ((recursive) (list (car (or (listp (|fetch| (spyrecord treefrom) |of| x)) (shouldnt))))) ((merged endofline) (append (or (listp (|fetch| (spyrecord treefrom) |of| x)) (shouldnt)))) ((normal ghost recursiveghost selfrecursive) (list (or (|fetch| (spyrecord treefrom) |of| x) x))) (shouldnt))))
)
(spy.overflow
(lambda nil (* |ejs:| "27-APR-84 11:37") (|add| spy.next -1) (setq spy.overflowed t)))
(spy.merge.callees
(lambda (neworiginal oldcopy spydata parents depth) (* \; "Edited 8-Oct-87 14:08 by Masinter") (* \; "insert copies of the CALLEEs of NEWORIGINAL into OLDTREE's CALLEEs") (|for| origcallee |in| (|fetch| (spyrecord callees) |of| neworiginal) |do| (|for| copycallee |in| (|fetch| (spyrecord callees) |of| oldcopy) |when| (eq (|fetch| (spyrecord name) |of| copycallee) (|fetch| (spyrecord name) |of| origcallee)) |do| (* \; "found a 'callee' that can merge this one with") (return (|if| (eq (|fetch| (spyrecord status) |of| copycallee) (quote endofline)) |then| (|push| (|fetch| (spyrecord treefrom) |of| copycallee) origcallee) |else| (spy.mergetree origcallee (selectq (|fetch| (spyrecord status) |of| copycallee) ((normal recursive selfrecursive merged) copycallee) ((ghost recursiveghost) (or (gethash (|fetch| (spyrecord name) |of| origcallee) spy.hash) (shouldnt))) (shouldnt)) spydata (cons oldcopy parents) (and depth (sub1 depth))))) |finally| (* \; "no old node of same name found") (|if| (and depth (ileq depth 0)) |then| (|push| (|fetch| (spyrecord callees) |of| oldcopy) (|create| spyrecord |using| origcallee callees ← nil status ← (quote endofline) treefrom ← (list neworiginal))) |else| (spy.merge1 origcallee spydata (cons oldcopy parents) oldcopy (and depth (sub1 depth)))))))
)
(spy.print
(lambda (x file rdtbl) (* \; "Edited 8-Oct-87 14:08 by Masinter") (list (concat "spy:" (|if| (listp (|fetch| (spyrecord name) |of| x)) |then| "*form*" |else| (|fetch| (spyrecord name) |of| x)))))
)
)
(rpaq? spy.button )
(rpaqq spy.open #*(56 59)@@@@@@@@@@@@@@@@GLOLLC@@@@@@@@@@LFLFLC@@@@@@@@@@LFLFFF@@@@@@@@@@O@LFFF@@GLOL@@@@GLLFCL@@LFLF@@@@ANOLAH@@LFLF@@@@LFL@AH@@LFLF@@@@LFL@AH@@LFLF@@@@LFL@AH@@LFLF@@@@GLL@AH@@GLLF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@IEGOOJ@@@@J@@HJ@@BOONHH@@BA@@@@HKOOOFNJHA@D@@HHBGOKNOEB@@@B@@@EDOMMBIGNJH@I@@@HBONJMEEKE@HA@@ECONMJB@KOOJCE@@@KOOJJHEAONHDJ@@KONJD@@@@AONIE@@GOMJH@@@BMOJEB@@FOB@@D@B@@AOEM@@GODDHA@@@AENMG@@KLH@@D@@@@BONM@@GM@HB@@@@BEFKG@@JJDBH@@@@@@INM@@ODA@DDD@@@BEOG@@@KJOMKB@@@AEEK@@JJEBNLIB@@DEOG@@DKNOKONHDDABFI@@BBKFOOMD@AAEFM@@IEIABEEOD@@@JJ@@EFLJKKGEB@EFEB@@J@@BOOHNHD@AEE@@EEEDONKEJ@EEBJ@@H@IOOOOOIEB@HD@@MDDOOOOMDHIEBJ@@BAOKOOOGONNJ@A@@HBKGOOOOOJKHBE@@DHLKMGMGOONJ@I@@@EMBOOJOOOKHBD@@BKDEOOJAOONJ@B@@BKIBOOHEOOOH@D@@HNDAONJBOJDDAA@@BO@DMGDEGOEB@A@@A@DBFJ@BL@@@@D@@@E@ICMAEOJDH@A@@B@@D@ADI@@@@BD@@HDA@JDBEFHH@@A@@@@@H@IDID@@B@D@@AA@A@@@B@A@@AA@@@@@D@@B@J@@A@A@@@@@H@@@D@@@@@J@@@A@@@D@AB@@@BA@@@@@@@@E@@@@@@D@@HH@@@B@@@@@@@B@@
)
(rpaqq spy.closed #*(56 59)@@@@@@@@@@@@@@@@GLOLLC@@@@CHND@@LFLFLC@@@@FAHA@@LFLFFF@@@@FAH@@@O@LFFF@@GLOKNA@@GLLFCL@@LFFAH@@@ANOLAH@@LFFAHA@@LFL@AH@@LFFAH@@@LFL@AH@@LFFAHJ@@LFL@AH@@LFFAH@@@GLL@AH@@GLFAHB@@@@@@@@@@@@@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@@@@IEGOOJ@@@@J@@HJ@@BOONHH@@BA@@@@HKOOOFNJHA@D@@HHBGOKNOEB@@@B@@@EDOMMBIGNJH@I@@@HBONJMEEKE@HA@@ECONMJB@KOOBCE@@@KOOJJHEAOOHDJ@@KONJD@@@@AONIE@@GOMJH@@@BMOJEB@@FOB@@D@B@@AOEM@@GODDHA@@@AENMG@@KLH@@D@@@@BONM@@GM@HB@@@@BEFKG@@JJDBH@@@@@@INM@@ODA@DDD@@@BEOG@@@KJOMKB@@@AEEK@@JJEBNLIB@@DEOG@@DKNOKONHDDABFI@@BBKFOOOD@AAEFM@@IEIABEGND@@@JJ@@EFLLDGGGB@EFEB@@J@@@@@IOHD@AEE@@EEAAEA@FI@EEBJ@@H@HDL@EAME@@HD@@MDEB@NHDJHDABJ@@BAB@@ABICF@J@A@@HB@KDDI@BLI@BE@@DID@A@@JHKDJ@I@@@D@DDDE@EBKEBD@@BAD@@@@A@OED@B@@BHAAAAA@CGNH@D@@H@D@@@@@MOE@AA@@BK@DDDDDGOJJ@A@@B@DA@B@CODFBBD@@EE@HBIAENK@@@A@@BLHBDDDON@@@BD@@KGDHJJIGJHB@@A@@BOBBECGOLB@B@D@@AAMLMKGOH@@@AA@@@GGONNON@H@A@A@@@IKKKKOLJ@@@@J@@@DFOKOO@D@@@BA@@@AEGMMD@A@@@@D@@HHBJMBLA@@@@@B@@
)
(defglobalvar spy.pointers t)
(declare\: doeval@compile dontcopy
(globalvars spy.overflowed \\periodic.interrupt spy.tree spy.buffer.size spy.next
spy.buffer.threshold spy.buffer spy.frequency spy.show.threshold spy.maxlines spy.font)
)
(declare\: eval@compile
(putprops with-spy macro ((form)
(progn (spy.start)
(prog1 form (spy.end)))))
(putprops with.spy macro ((form)
(progn (spy.start)
(prog1 form (spy.end)))))
)
(declare\: dontcopy
(declare\: eval@compile
(datatype spyrecord (name count sum callees status treefrom)
status ← 'normal (init (defprint 'spyrecord 'spy.print)))
(proprecord spydata (* \; "properties of a spy tree")
(deleted cumulative mergetype threshold spymenu depth noghosts package readtable
print-case mergeinfo pending)
cumulative ← t)
)
(/declaredatatype 'spyrecord '(pointer pointer pointer pointer pointer pointer)
'((spyrecord 0 pointer)
(spyrecord 2 pointer)
(spyrecord 4 pointer)
(spyrecord 6 pointer)
(spyrecord 8 pointer)
(spyrecord 10 pointer))
'12)
(defprint 'spyrecord 'spy.print)
)
(/declaredatatype 'spyrecord '(pointer pointer pointer pointer pointer pointer)
'((spyrecord 0 pointer)
(spyrecord 2 pointer)
(spyrecord 4 pointer)
(spyrecord 6 pointer)
(spyrecord 8 pointer)
(spyrecord 10 pointer))
'12)
(defprint 'spyrecord 'spy.print)
(filesload grapher readnumber imageobj)
(putprops spy2 makefile-environment (:readtable "XCL" :package "INTERLISP"))
(declare\: donteval@load doeval@compile dontcopy
(filesload (loadcomp)
llparams llbasic llstk)
)
(putprops spy2 copyright ("Xerox Corporation" 1987))
(declare\: dontcopy
(filemap (nil (5073 5917 (spy.mergeinfo 5083 . 5915)) (7005 8893 (spyobj 7015 . 7307) (spyobj.button
7309 . 7421) (spyobj.save 7423 . 7546) (spyobj.copy 7548 . 7612) (spyobj.get 7614 . 7745) (
spyobj.imagebox 7747 . 8080) (spyobj.display 8082 . 8385) (spyobj.label 8387 . 8529) (spyobj.height
8531 . 8750) (spyobj.copyin 8752 . 8795) (spy.copybutton 8797 . 8891)) (9425 29864 (spy.find.tree 9435
. 9661) (spy.toggle 9663 . 9863) (spy.tree 9865 . 10803) (spy.legend 10805 . 11165) (spy.graph.editor
11167 . 15351) (spy.end 15353 . 15607) (spy.makegraphnodes 15609 . 16521) (spy.max 16523 . 16823) (
spy.merge 16825 . 17567) (spy.merge1 17569 . 20152) (spy.mergetree 20154 . 21554) (spy.next.tree 21556
. 21881) (spy.sum 21883 . 22279) (spy.title 22281 . 22446) (spy.make.tree 22448 . 23668) (spy.delete
23670 . 23944) (spy.drawbox 23946 . 24472) (spy.buffer.entry 24474 . 24716) (spy.button 24718 . 25303)
(spy.end.entry 25305 . 25386) (spy.start 25388 . 25682) (spy.init 25684 . 25921) (\\spy.interrupt
25923 . 26586) (spy.dump.buffer 26588 . 27227) (spy.start.entry 27229 . 27384) (spy.add.entry 27386 .
27776) (spy.original 27778 . 28222) (spy.overflow 28224 . 28328) (spy.merge.callees 28330 . 29647) (
spy.print 29649 . 29862)))))
stop