// RaidProcs.bcpl. Supplementary procedures for RAID
// Last modified March 20, 1985  10:42 AM by Bill van Melle
// Changed atom hash January 30, 1985  11:49 AM by Bill van Melle
// Last modified January 21, 1985  12:16 PM by Bill van Melle
// Flushed VMDisplay December 13, 1984  12:05 PM by Bill van Melle
// Flushed TeleRaid July 20, 1983  2:49 PM by Bill van Melle
// Last modified March 30, 1983  11:31 AM by Bill van Melle
// Last modified December 16, 1982  10:15 PM by Bill van Melle
// Last modified July 21, 1982  9:32 PM by Bill van Melle
// Last modified September 19, 1981  2:01 PM by Bill van Melle
// Last modified August 4, 1981  12:47 PM by Beau Sheil

	get "AltoDefs.d"
	get "Raid.decl"
	get "Stats.decl"
	get "Vmem.decl"
	get "Streams.d"

external [	// procedures defined here
	ReadNum; ReadAtom; ShowRealCore; AtomNum
	DoYankDef; DoSetTopVal; FetchAtomComponent 
	]

external [	// procedures used
	CRLF; Ws; Wo; Wc; Bytes2
	RaidReset; RAIDCode; ReadStrng; PrintAddrs; Confirm
	@BGetBase; @BGetBasePtr; @BGetBase32; @BPutBase32
	@XSetReadBR; @RRead; @RWrite
	BP; ReadFlags; EmAddr; MkSmallPos; IGetBase
	EqNIL; Lprint

		// OS procs used
	Zero; MoveBlock

		// statics used
	EmulatorSpace; LastRealPageNo; @lvVPtr; @lvNIL
	dsp; @DisplayAddrHi
	]

manifest [
	emptySegment = EMPTY rshift 8	// EMPTY<<VP.segment
	emptyPage = EMPTY & #377	// EMPTY<<VP.page
				// grumble must be constants
	]

static [
	firstChar; reprobe; nReprobes; hash
	]

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


let AtomNum(S) = valof
// Finds atom number for BCPL string. pn char format is that of bcpl strings
 [ 
   let pnLength = S>>String.length
   let lastWord = pnLength rshift 1	// offset of last word in pname
   firstChar = S>>String.char^1
   reprobe = 0
   nReprobes = 0

// Compute the hash code for the name. Mimic the behavior of LISP.
// This code looks simpler than Lisp's because we automatically do
// 16-bit arithmetic, while Lisp has to struggle.

   hash = firstChar lshift 8
   for i = 2 to pnLength do
     [ hash = ((hash & #7777) lshift 2) + hash
       hash = (hash lshift 8) + hash + S>>String.char^i
     ]

   [

   let P = BGetBase(AHTspace, hash)	// P is contents of hash table entry 
   if P eq 0 then RaidReset("No such atom")

// since P was non zero, it is the virtual address of an atom+1
   P = P-1

// fetch atom and check its pname. Check its characters (word-by-word)
// with those in pname. Count is first byte, and pad byte (if any) is 0.

   XSetReadBR(FetchAtomComponent(PNPspace, P))
   for i = 0 to lastWord do if RRead(i) ne S!i goto doReprobe

   resultis P		// pnames are the same; return virtual address

doReprobe:
   if reprobe eq 0
      then reprobe = ((firstChar xor hash) % 1) & #77
   hash = hash+reprobe
   nReprobes = nReprobes+1
   ] repeat			// comparison failed so reprobe
 ]

and FetchAtomComponent (space, atom) = 
  BGetBasePtr (space+(atom rshift 15), atom lshift 1)

and ReadAtom() = valof			// obtains atom number from typein
  [ let s = vec 50
    unless ReadStrng(s) do RaidReset(" XXX")
    let num=0
    for i=1 to s>>String.length do
        [ let c = (s>>String.char^i)-$0
          test (c ge 0) & (c le 7)
            ifso  num=num*8+c
            ifnot resultis AtomNum(s)
        ]
    resultis num
  ]

and ReadNum(radix) = valof	// read number in given radix
  [
   let s = vec 50
   unless ReadStrng(s) do RaidReset(" XXX")
   let num=0
   for i=1 to s>>String.length do
        [ let c = (s>>String.char^i)-$0
          test (c ge 0) & (c ls radix)
            ifso  num=num*radix+c
            ifnot RaidReset(" XXX")
        ]
   resultis num
  ]

and ShowRealCore() be		// Displays a segment page usage map
 [
   CRLF()
   Ws (" State of virtual memory file: ")
   Ws (IGetBase(IFPKey) eq IFPValidKey? "C", "Inc")
   Ws ("onsistent")
   CRLF(); CRLF()
   let base = vec LastVMSegment+2; Zero(base, LastVMSegment+3)
   let ndirty, nlocked, nempty, nunavail = 0, 0, 0, 0
   let bp = BP(0)
   for i = 2 to BptSize do
     [	bp = bp+3		// next one.  Skips the dummy header
	let vp = BGetBase(BptSegment, bp+1)	// bp>>BPT.VP
	let bucket = vp<<VP.segment
	test (bucket ne emptySegment) % (vp<<VP.page ls emptyPage)
	   ifso	[
		if BGetBase(BptSegment, bp) ls 0	// bp>>BPT.LOCK
		   then nlocked = nlocked+1
		if (ReadFlags(vp) & DIRTYbit) ne 0
		   then ndirty = ndirty+1
		base!bucket = base!bucket + 1
		]
	  ifnot test vp eq EMPTY
	   ifso nempty = nempty+1
	  ifnot nunavail = nunavail+1
     ]
   base!EmulatorSpace = PagesPerSegment		// Emulator done specially
   Ws(" Segment   Pages Contents*N")
   let total = 0
   for i = 0 to LastVMSegment do unless base!i eq 0
       do [ Ws("  "); Wo(i); Ws("  "); Wo(base!i)
            // The following is not a SELECT as the choices are not exclusive
            if i eq PNPspace then Ws(" PName pointers")
            if i eq DEFspace then Ws(" Definitions")
            if i eq TOPVALspace then Ws(" TopVals")
            if i eq PLISTspace then Ws(" Property lists")
            if i eq AHTspace then Ws(" Atom Hash Table")
            if i eq PMTspace then Ws(" Primary Page Map (PMT)")
            if i eq PAGEMAPspace then Ws(" Secondary Page Map")
            if i eq INTERFACEspace then Ws(" Interface page")
            if i eq MDSTYPEspace then Ws(" MDS type table")
            if i eq STACKspace then Ws(" Stack")
            if i eq EmulatorSpace then Ws(" Alto emulator")
            if i eq DisplayAddrHi & DisplayAddrHi ne 0
               then Ws(" Lisp display bitmap")
            if i ge ArrayLo & i le ArrayHi then Ws(" Lisp data")
            if i eq GCMainspace then Ws(" GC main table")
            if i eq GCCollspace then Ws(" GC collision table")
            CRLF()
            total = total + base!i ]
   Ws("   Total  "); Wo(total); Ws(" pages in use"); CRLF() 
   let sp = "          "
   Ws(sp); Wo(nempty); Ws(" Empty"); CRLF()
   Ws(sp); Wo(LastRealPageNo-nunavail); Ws(" Total available pages"); CRLF()
   Ws(sp); Wo(nlocked); Ws(" pages locked"); CRLF()
   Ws(sp); Wo(ndirty); Ws(" pages dirty"); CRLF()
  ]

and DoYankDef() be
  [
  Ws(" from atom ")
  let a = ReadAtom()
  FetchAtomComponent(DEFspace, a)
  test EqNIL(lvVPtr)
    ifso Ws ("[no definition")
    ifnot [ Wc($[); PrintAddrs(DEFspace+(a rshift 15), (a lshift 1), 2) ]
  Ws("] and smash it into definition cell of atom ")
  let b = ReadAtom()
  Ws("[was ")
  PrintAddrs(DEFspace+(b rshift 15), (b lshift 1), 2)
  Wc($])
  if Confirm()
    then [	// since lvVPtr has been smashed by now...
	BGetBase32(DEFspace+(a rshift 15), (a lshift 1))
	BPutBase32(DEFspace+(b rshift 15), (b lshift 1), lvVPtr)
	]
  ]

and DoSetTopVal() be
  [
  let a = ReadAtom()
  Ws (" currently ")
  Lprint (FetchAtomComponent(TOPVALspace, a))
  Ws (" to be (atom or small octal value): ")
  let s = vec 50
  MoveBlock (s, "NIL", 2)
  unless ReadStrng(s, 99, true) & (s>>String.length gr 0) do RaidReset(" XXX")
  lvVPtr>>VA.vahi = SMALLPOSspace
  let num=0
  for i=1 to s>>String.length
     do  [
	let c = (s>>String.char^i)-$0
	test (c ge 0) & (c le 7)
           ifso num=num*8+c
          ifnot [	// not numeric
  		num = AtomNum(s)
  		lvVPtr>>VA.vahi = ATOMspace
  		break
  		]
         ]
  lvVPtr>>VA.valo = num
  BPutBase32(TOPVALspace+(a rshift 15), a lshift 1, lvVPtr)
  ]
(1792)