// 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
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)
]