// Package for analyzing micro-PC histograms
// last edited December 19, 1980  2:21 PM


external	// defined here
[	ReadLispPCHist	// (instrm, hist) -> 0/string
	ScanMBForPCHist	// (mbstrm[, zone]) -> 0/string
	PrintPCHist	// (outstrm, hist)
]


external
[		// OS
	Allocate
	DoubleAdd; Dvec
	Endofs
	GetFixed; Gets
	MoveBlock
	Noop
	oneBits
	Puts
	ReadBlock
	SetBlock
	Usc
	WriteBlock; Ws; Wss
	Zero
		// ReadMB
	ReadMB
		// Template
	PutTemplate
		// DPDivide
	DPDIVIDE
]


manifest
[	lvMultiply = 343b	// Bcpl Multiply subroutine
	lHist = 10000b		// length of histogram
	lHE = 2			// length of histogram entry
	lLine = 96		// line width (assumes Gacha8 on display,
				// Gacha6 on printer)
	lLabel0 = 32		// width of label for Dolphin
	lLabel1 = 27		// width of label for Dorado
	starFactor = 2000	// proportion of total for one *
	upcEventType = 214b	// "event type" in Lisp-format log file
	upcBlockSize = 64	// entries per block
]

structure BS: [ length byte; char^1,255 byte ]

structure Event: [ type byte; arg byte ]

structure MI0:	// Dolphin microinstruction -- as output by MicroD
[	w0 word =
	[ meminst bit 1
	  rmod bit 1
	  = df2 bit 1
	  rselhi4 bit 4
	  aluf bit 4
	  = type bit 4
	  [ bsel bit 2
	    f1 bit 4
	  ] = srcdesthi6 bit 6
	]
	w1 word =
	[ [ lr bit 1
	    lt bit 1
	  ] = srcdestlo2 bit 2
	  f2 bit 4
	  jc bit 3
	  jalo6 bit 6
	  parity bit 1
	]
	w2 word =
	[ rsello2 bit 2
	  jahi2 bit 2
	  blank bit 12
	]
]

manifest
[	f1LoadPage0 = 5
	jcCall0 = 5
	jcReturn0 = 6
]

structure MI1:	// Dorado microinstruction -- as output by MicroD
[	w0 word =
	[ rstk bit 4
	  aluf bit 4
	  bsel bit 3
	  lc bit 3
	  aselx2 bit 2
	]
	w1 word =
	[ asello1 bit 1
	  block bit 1
	  ff bit 8
	  jcn bit 6
	  = [ jclocal bit 2; jnlocalx4 bit 4 ]
	  = [ jcglobal bit 2; jnglobalx4 bit 4 ]
	  = [ jclong bit 4; jnlongx4 bit 2 ]
	  = [ jcfast bit 1; jnfastx8 bit 2; jnfastx2 bit 2; jcondx4 bit 1 ]
	]
	w2 word =
	[ jnlo bit 2
	  = jcondlo bit 2
	  brkp bit 2
	  blank bit 12
	]
]

manifest
[	jcLocal1 = 2
	jcGlobal1 = 3
	jcLong1 = 0
	jcFast1 = 0
]

manifest [ lMI = 3 ]		// width of microinstruction

structure IFUM:	// Dorado IFU memory -- as output by MicroD
[	iw0 word =
	[ PA bit 6	// only uses low bit
	  notIFADr2 bit 10	// not (address rshift 2)
	]
	iw1 word =
	[ Sign bit 1
	  IPar bit 3
	  notLength bit 2
	  notRBaseB bit 1
	  MemB bit 3
	  notTPause bit 1
	  notTJump bit 1
	  N bit 4
	]
]

manifest [ IFADr2mask = 1777b ]	// complement notIFADr2 wrt this


static
[	imx = -1	// memory index of IM
	rimap	// real to imaginary address map
	irmap	// imaginary to real address map
	isymap	// imaginary address to symbol map
	idata	// contents of IM
	ifue	// flags for IFU entries
	machine = -1	// 0 for Dolphin, 1 for Dorado
	mbzone	// zone for allocating symbols
	special	// procedure for machine-dependent output
	lLabel	// machine-dependent label width
	nCalls	// count # of call instructions
]


let ReadLispPCHist(in, hist) = valof
[	Zero(hist, lHist*lHE)
	until Endofs(in) do
	[ let event = Gets(in)
	  let type = event<<Event.type
	  test type eq upcEventType
	   ifso
	  [ let block = Gets(in)
	    if (event<<Event.arg ne upcBlockSize*lHE) % (Usc(block, lHist/upcBlockSize) ge 0) then
	      resultis "Illegal data file"
	    ReadBlock(in, hist+block*upcBlockSize*lHE, upcBlockSize*lHE)
	  ]
	   ifnot
	  switchon type rshift 6 into
	  [ case 2: for i = 0 to event<<Event.arg do Gets(in); endcase
	    case 3: Gets(in); Gets(in)
	    case 1: Gets(in)
	    case 0:
	  ]
	]
	resultis 0
]

and ScanMBForPCHist(mbin, zone; numargs na) = valof
[	let allocfixed(zone, n) = GetFixed(n)
	if na ls 2 then zone = lv allocfixed
	mbzone = zone
	imx, machine = -1, -1
	rimap = Allocate(zone, lHist)	// Real to imaginary address map
	SetBlock(rimap, -1, lHist)
	irmap = Allocate(zone, lHist)	// Imaginary to real address map
	SetBlock(irmap, -1, lHist)
	isymap = Allocate(zone, lHist)	// Imaginary to symbolic address map
	Zero(isymap, lHist)
	isymap!0 = ""
	idata = Allocate(zone, lHist*lMI)	// contents of IM
	ifue = Allocate(zone, lHist/64)	// IFU entry flags, only every 4th instruction
	Zero(ifue, lHist/64)
	resultis ReadMB(mbin, 20, pmemproc, psymproc)
]

and PrintPCHist(out, hist) be
[	switchon machine into
	[ case 0: special, lLabel = special0, lLabel0; endcase
	  case 1: special, lLabel = special1, lLabel1; endcase
	]
	mainprint(out, hist)
	if machine eq 1 then callprint(out, hist)
]

and mainprint(out, hist) be
[	let total = vec 2
	total!0, total!1 = 0, 0
	let nonzero = 0
	let entry = vec 2
	for i = 0 to lHist-1 do
	[ let hp = hist+i*lHE
	  entry!0, entry!1 = hp!1, hp!0
	  if (entry!0 ne 0) % (entry!1 ne 0) then
	  [ nonzero = nonzero+1
	    DoubleAdd(total, entry)
	  ]
	]
	let q, r = vec 2, vec 2
	let perStar = vec 2
	DPDIVIDE(total, table[ 0; starFactor], perStar, r)
	if (perStar!0 eq 0) & (perStar!1 eq 0) then perStar!1 = 1
	let maxStars = lLine-10-lLabel
	PutTemplate(out, "Total of $ED counts, $D nonzero entries; each ** = $ED counts*N*N", total, nonzero, perStar)
	let lastSym = 0
	let cum = vec 2
	cum!0, cum!1 = 0, 0
	let count = vec 2
	nCalls = 0
	for imag = 0 to lHist-1 do
	[ let i = irmap!imag
	  if i eq -1 loop
	  let hp = hist+i*lHE
	  if (hp!0 eq 0) & (hp!1 eq 0) loop
	  let imsym = findsym(imag)
	  let sym = isymap!imsym
	  test sym eq lastSym
	   ifso
	  [ Wss(out, "         ")
	    printstars(out, count, perStar, maxStars)
	  ]
	   ifnot	// print cumulative percent for old symbol
	  [ if lastSym ne 0 then
	    [ printpercent(out, cum, total)
	      printstars(out, count, perStar, maxStars)
	    ]
	  ]
	  Puts(out, $*N)
	  count!0, count!1 = hp!1, hp!0
	  printleft(out, imag, imsym, sym eq lastSym, count)
	  lastSym = sym
	  DoubleAdd(cum, count)
	]
	printpercent(out, cum, total)
	printstars(out, count, perStar, maxStars)
	Puts(out, $*N)
]

and findsym(imag) = valof
[	let imsym = imag
	while isymap!imsym eq 0 do imsym = imsym-1
	resultis imsym
]

and callprint(out, hist) be
[	Wss(out, "*014Call instructions:*N")	// ^L, new page
	special = special1c
	let cfrom, cto = nCalls, nCalls
	Dvec(callprint, lv cfrom, lv cto)
	let ncalls = 0
	for imag = 0 to lHist-1 do
	[ let real = irmap!imag
	  if real eq -1 loop
	  let hp = hist+real*lHE
	  if (hp!0 eq 0) & (hp!1 eq 0) loop
	  let rdest = nia1(imag)
	  let idest = rimap!rdest
	  unless (idest ge 0) & isentry1(idest) loop
	  let ptr = ncalls
	  until ptr eq 0 do
	  [ let nptr = ptr-1
	    if cto!nptr le idest break
	    cfrom!ptr, cto!ptr = cfrom!nptr, cto!nptr
	    ptr = nptr
	  ]
	  cfrom!ptr, cto!ptr = imag, idest
	  ncalls = ncalls+1
	]
	let count = vec 2
	let lastto = -1
	for j = 0 to ncalls-1 do
	[ if cto!j ne lastto then
	  [ lastto = cto!j
	    let hp = hist+irmap!lastto*lHE
	    count!0, count!1 = hp!1, hp!0
	    PutTemplate(out, "<$S> $ED*N", isymap!lastto, count)
	  ]
	  let imag = cfrom!j
	  let hp = hist+irmap!imag*lHE
	  count!0, count!1 = hp!1, hp!0
	  Wss(out, "  ")
	  printleft(out, imag, findsym(imag), false, count)
	  Puts(out, $*N)
	]
]

and printleft(out, imag, imsym, space, count) be
// Print the symbol (or blanks if space), +offset, special stuff, count
[	let sym = isymap!imsym
	test space
	 ifso for i = 1 to sym>>BS.length do Puts(out, $*S)
	 ifnot Wss(out, sym)
	let d = imag-imsym
	if d ne 0 then PutTemplate(out, "+$D", d)
	let width = sym>>BS.length+(d eq 0? 0, d ls 10? 2, d ls 100? 3, d ls 1000? 4, 5)
	width = width+special(out, imag, irmap!imag)	// Do machine-dependent stuff
	let nd = ndigits(count)
	if width+nd+2 gr lLabel then [ Puts(out, $*N); width = 0 ]
	for j = width to lLabel-nd-2 do Puts(out, $*S)
	PutTemplate(out, "$ED ", count)
]


and ndigits(v) = valof
// Return the number of digits in the decimal representation of v
[	if v!0 ne 0 then
	[ let w, r = vec 2, vec 2
	  DPDIVIDE(v, table[ 0; 10000], w, r)
	  resultis ndigits(w)+4
	]
	let n = v!1
	resultis (n ls 0? 5, n ls 10? 1, n ls 100? 2, n ls 1000? 3, n ls 10000? 4, 5)
]

and printstars(out, count, perStar, max) = valof
// Returns # of characters printed
[	let c, d = vec 2, vec 2
	c!0, c!1 = count!0, count!1
	d!0, d!1 = perStar!0 rshift 1, (perStar!0 lshift 15) + (perStar!1 rshift 1)
	DoubleAdd(c, d)	// round numerator
	let q, r = vec 2, vec 2
	DPDIVIDE(c, perStar, q, r)
	let stars = q!1; if stars eq 0 then stars = 1
	let nchars = stars
	if stars gr max then
	[ PutTemplate(out, "($3D)", stars)
	  stars, nchars = max-5, max
	]
	for j = 1 to stars do Puts(out, $**)
	resultis nchars
]

and printpercent(out, cum, total) be
[	let per = per10000(cum, total)
	PutTemplate(out, "($3D.$2F0D) ", per/100, per rem 100)
]

and per10000(num, denom) = valof
// Very carefully compute num*10000/denom
// Know both are positive and num le denom
[	let r1 = vec 2
	let q1 = per100(num, denom, r1)
	let r2 = vec 2
	let q2 = per100(r1, denom, r2)
	resultis q1*100+q2
]

and per100(num, denom, remn) = valof
// Return the quotient of num*100/denom, leave the remainder in remn
// Know both num and denom are positive, and num le denom
[	let n, d = vec 2, vec 2
	n!0, n!1 = num!0, num!1
	d!0, d!1 = denom!0, denom!1
	while n!0 gr 327 do	// make sure 100* will fit
	[ n!1 = (n!0 lshift 15) + (n!1 rshift 1)
	  d!1 = (d!0 lshift 15) + (d!1 rshift 1)
	  n!0, d!0 = n!0 rshift 1, d!0 rshift 1
	]
	let n100 = vec 2
	mul100(n, n100)
	let p = vec 2
	DPDIVIDE(n100, d, p, remn)
	resultis p!1
]

and mul100(v, w) be
// Multiply a double-precision number by 100
// Know the result will fit
[	let Multiply = table[
	  175400b	// inc 3 3 // skip arg count word
	    2343b	// jmp @343b // Bcpl runtime, leaves AC0 = hi part
	 ]
	w!0 = v!0*100 + Multiply(v!1, 100)	// What a kludge!
	w!1 = v!1*100	// discards hi part
]


and special0(out, imag, real) = valof
// Special stuff for Dolphin (opcode entries, calls)
[	let width = 0
	if (real&6003b) eq 2001b then	// opcode entry
	[ PutTemplate(out, " [$3F0O]", (real rshift 2) & 377b)
	  width = width+6
	]
// If the instruction preceding imag is a Call,
// return the imaginary address being called, otherwise -1
	let idest = valof
[	let ip = idata+(imag-1)*lMI
	if ip>>MI0.jc ne jcCall0 resultis -1
	let ja = nia0(imag-1)
	let page = irmap!(imag-1) rshift 8
	ip = ip-lMI
	if (ip>>MI0.meminst eq 0) & (ip>>MI0.f1 eq f1LoadPage0) then page = ip>>MI0.f2
	resultis rimap!((page lshift 8) + ja)
]
	if (idest ne -1) & (isymap!idest ne 0) then	// note the call
	[ let dsym = isymap!idest
	  PutTemplate(out, " <$S>", dsym)
	  width = width+dsym>>BS.length+3
	]
	resultis width
]

and nia0(imag) = valof
[	let ip = idata+imag*lMI
	resultis (ip>>MI0.jahi2 lshift 6) + ip>>MI0.jalo6
]

and special1(out, imag, real) = valof
// Special stuff for Dorado (flag subroutine entries)
[	let w = 0
	let rdest = nia1(imag)
	let idest = rimap!rdest
	if (idest ge 0) & isentry1(idest) then
	[ let s = isymap!idest	// must be exact
	  PutTemplate(out, " <$S>", s)
	  w = w + s>>BS.length + 3
	  nCalls = nCalls+1
	]
	resultis special1c(out, imag, real) + w
]

and special1c(out, imag, real) = valof
// Replaces special1 during listing of calls
[	if isentry1(imag) then
	[ let s = ((real&77b) eq 0? " (****)", " (**)")
	  Wss(out, s)
	  resultis s>>BS.length
	]
	resultis 0
]

and isentry1(imag) = valof
// Return true if imag is a subroutine entry
[	let real = irmap!imag
	if (real&17b) ne 0 resultis false	// not an entry
	if isymap!imag eq 0 resultis false	// no label, almost certainly not an entry
	if nia1(imag-1) eq real resultis false	// previous instruction falls through to here, almost certainly not an entry
	if (ifue!(real rshift 6) & oneBits!((real rshift 2)&17b)) ne 0 resultis false	// an IFU entry
	resultis true
]

and nia1(imag) = valof
// Return the target address from JCN
[	let jfrom = irmap!imag
	let ip = idata+imag*lMI
	let jnlo = ip>>MI1.jnlo
	if ip>>MI1.jclong eq jcLong1 then	// must test long before fast
	  resultis (ip>>MI1.ff lshift 4) + (ip>>MI1.jnlongx4 lshift 2) + jnlo
	if ip>>MI1.jclocal eq jcLocal1 then
	  resultis (jfrom & 7700b) + (ip>>MI1.jnlocalx4 lshift 2) + jnlo
	if ip>>MI1.jcglobal eq jcGlobal1 then
	  resultis ((ip>>MI1.jnglobalx4 lshift 2) + jnlo) lshift 6
//	if ip>>MI1.jcfast eq jcFast1 then
	if (ip>>MI1.jcondx4 lshift 2 + ip>>MI1.jcondlo) ne 7 then
	  resultis (jfrom & 7700b) + (ip>>MI1.jnfastx8 lshift 3) + (ip>>MI1.jnfastx2 lshift 1)
	resultis (jfrom & 7700b) + ((jfrom+1) & 77b)	// a Return or other exception
]


and pmemproc(memx, width, name) = valof
[	test (name!0 eq 1000b+$I) & (name!1 eq $M*400b)
	 ifso [ imx = memx; resultis pimproc ]
	 ifnot
	test (name!0 eq 2000b+$I) & (name!1 eq $F*400b+$U) & (name!2 eq $M*400b)
	 ifso [ machine = 1; resultis pifumproc ]
	 ifnot resultis Noop
]

and pimproc(imag, data) be
[	let real = data!3 & 7777b
	rimap!real = imag
	irmap!imag = real
	MoveBlock(idata+imag*lMI, data, lMI)
]

and pifumproc(addr, data) be
[	let real = IFADr2mask-data>>IFUM.notIFADr2
	let ifup = ifue+(real rshift 4)
	@ifup = oneBits!(real&17b) % @ifup	// mark entry
]

and psymproc(memx, value, name) be
// Save symbolic address
if memx eq imx then
[	let nw = name>>BS.length/2+1
	let sym = Allocate(mbzone, nw)
	MoveBlock(sym, name, nw)
	isymap!value = sym
]