//
// File search pattern compiler
// last edited September 18, 1980 5:31 PM
//
// Copyright Xerox Corporation 1979, 1980
get "findpkgdefs.d"
get "findintdefs.d"
external // entry point
[ FindCompile // (pat, chartab[, wildchar, fuzz, outs, storeproc, rregs, lvTables, zone]) -> error/0
]
external
[ // O.S.
Allocate
DefaultArgs; Dvec
MoveBlock; MyFrame
Puts
ReturnFrom
SetBlock
sysZone
Usc
Wss
Zero
// rwreg
WriteInsReg
WriteReg
// Template
PutTemplate
// FindCompMu
fRamImage
// FindNext
findJumpRam
findWriteReg
]
structure BS: // Bcpl string
[ length byte
char↑1,255 byte
]
structure MIF: // Microinstruction field value
[ w0 word // add this to word 0
w1 word // add this to word 1
oproc word // output procedure (or 0=Wss)
name word 0 // name starts here
]
manifest [
ramsize = 2000b
consize = 400b
charsetsize = 200b
regsize = 100b
maxpatsize = regsize
fixedram = 40b // space occupied by common microcode
START = 20b // entry to Nova emulator
workarea = 10b // 2-instruction work area for RWREG
]
static [ // other statics
FCoutStream // trace stream for symbolic output, or 0
FCstoreProc // if true, store instructions in RAM
topframe // return frame in case of error
allocbits // bit table for allocating RAM
reglist // list of R registers
constloc // constant locations
constval // constant values
]
let error(s) be ReturnFrom(topframe, s)
let toolong() be error("Pattern too long")
let FindCompile(pat, chartab, wildchar, fuzz, outs, storeproc, rregs, lvTables, zone; numargs na) = valof
[ let dummy = nil // default for lvTables
let sproc = storeproc // To avoid defaulting explicitly supplied value of false
DefaultArgs(lv na, -2, -1, 0, 0, true, table[ 1; 0; 77777b; 177776b ], lv dummy, sysZone)
if na ge 6 then storeproc = sproc
FCoutStream, FCstoreProc = outs, storeproc
@lvTables = 0
// Validate and unpack pattern
for c = 0 to charsetsize-1 do
if (chartab!c ge 0) & (chartab!(chartab!c) ne classOther) then
error("Invalid chartab")
let patlen = pat>>BS.length
if patlen eq 0 then error("Null pattern not allowed")
let nphase = patlen+(patlen&1) // always even
let xpat = patlen+1
Dvec(FindCompile, lv xpat)
xpat!0 = patlen
SetBlock(xpat+1, -1, patlen)
let count = vec charsetsize
Zero(count, charsetsize)
let xchar = charsetsize-1
for i = 1 to patlen do // allocate B dispatch
[ let c = pat>>BS.char↑i
if c eq wildchar then
[ fuzz = fuzz+1
loop
]
if chartab!c ge 0 then c = chartab!c
if chartab!c eq classExit then xchar = c
xpat!i = c
count!c = count!c+1
]
if fuzz ge patlen then error("Too fuzzy")
// Set up values for FindNext
fNegK = -patlen+1+fuzz
fNphase = nphase
fExitChar = (xchar lshift 8) + xchar
// First try compiling to microcode, then to assembly code
let err = FindCompileRam(pat, chartab, nphase, xpat, count, rregs)
if err eq 0 resultis 0
resultis FindCompileSoft(pat, chartab, nphase, xpat, count, lvTables, zone)
]
//
// The version of the compiler that produces microcode
//
and FindCompileRam(pat, chartab, nphase, xpat, count, rregs) = valof
[ topframe = MyFrame()
// Miscellaneous subroutines
// Initialize microinstruction field values
manifest q = 400b
let aluPLUS1 = table[ 5*200b; 0; 0; 2*q+$+; $1*q ]
let aluMINUS1 = table[ 6*200b; 0; 0; 2*q+$-; $1*q ]
let bsLOADR = table[ 1*20b; 0; 0; 2*q+$←; $L*q ]
let f1TASK = table[ 2*1b; 0; -2; 4*q+$T; $A*q+$S; $K*q ]
let f1const = table[ 7*1b; -7*10000b; -1 ]
let f2BUSEQ0 = table[ 0; 1*10000b; -2; 5*q+$B; $U*q+$S; $=*q+$0 ]
let f2BUS = table[ 0; 4*10000b; -2; 3*q+$B; $U*q+$S ]
let f2IDISP = table[ 0; 15b*10000b; -2; 5*q+$I; $D*q+$I; $S*q+$P ]
let LOADL = table[ 0; -1*2000b; -2; 2*q+$L; $←*q ]
let rAC0 = table[ 3 lshift 11; 0; 0; 3*q+$A; $C*q+$0 ]
let rPhase = table[ Rphase lshift 11; 0; 0; 5*q+$p; $h*q+$a; $s*q+$e ]
let rNegK1 = table[ RnegK1 lshift 11; 0; 0; 4*q+$-; $K*q+$+; $1*q ]
// Initialize RAM
let RamImage = fRamImage(workarea, (FCstoreProc eq true? fixedram, -1), error) // Get code from FindCompMu
// Routine to produce microinstructions
let comment(s) be
if FCoutStream ne 0 then PutTemplate(FCoutStream, "; ******************** $S*N", s)
let ctrsel(n) = valof
[ static [ ctrw0; ctrw1 = 0; ctrproc; ctrnum ]
let wctrn(st, p) be PutTemplate(st, "s$O", @p)
let reg = reglist!n
ctrw0 = reg lshift 11 + (reg ge 40b? 3*20b, 0*20b)
ctrproc, ctrnum = wctrn, n
resultis lv ctrw0
]
let consel(n) = valof
[ static [ conw0; conw1 = 7*10000b; conproc; connum ]
let wconn(st, p) be PutTemplate(st, "=$O", constval!(@p))
let loc = constloc!n
conw0 = (loc&370b) lshift 8 + (loc&7) lshift 4
conproc, connum = wconn, n
resultis lv conw0
]
let instr(loc, nil, nil, nil, nil, nil, nil, nil, nil, nil; numargs na) = valof
[ let w0, w1 = 10b, 102000b // no-op
for j = 1 to na-2 do
[ let f = (lv loc)!j
w0 = w0 + f>>MIF.w0
w1 = w1 + f>>MIF.w1
]
let next = (lv loc)!(na-1)
w1 = w1+next
if FCoutStream ne 0 then
[ PutTemplate(FCoutStream, "$4O: $6UO $6UO | $4O: ", loc, w0, w1, loc)
for j = 1 to na-2 do
[ let f = (lv loc)!j
let proc = f>>MIF.oproc
if proc eq -1 loop
test proc eq -2
ifso
[ if j gr 1 then Wss(FCoutStream, ", ")
Wss(FCoutStream, lv f>>MIF.name)
]
ifnot
(proc eq 0? Wss, proc)(FCoutStream, lv f>>MIF.name)
]
PutTemplate(FCoutStream, (na eq 2? ":$O;*N", ", :$O;*N"), next)
]
if FCstoreProc ne 0 then (FCstoreProc eq true? WriteInsReg, FCstoreProc)(loc, lv w0)
resultis next
]
// Bit table routines
let getbit(tab, i) =
tab!(i rshift 4) & (100000b rshift (i&17b))
let setbit(tab, i) be // invert bit
[ let p = tab + i rshift 4
@p = @p xor (100000b rshift (i&17b))
]
let allocins() = valof
[ let j = ramsize/16-1
while allocbits!j eq 0 do
[ if j eq 0 then error("RAM full")
j = j-1
]
let i = j*16+15
while getbit(allocbits, i) eq 0 do i = i-1
setbit(allocbits, i)
resultis i
]
let prealloc(loc, delta, n, trying; numargs na) = valof
[ if na ls 4 then trying = false
for m = 0 to n-1 do
[ let lc = loc+m*delta
if getbit(allocbits, lc) eq 0 resultis -1
unless trying do setbit(allocbits, lc)
]
resultis loc
]
let findalloc(loc, delta, n, inc) = valof
[ let lc, lim = loc, ramsize-delta*n
while lc le lim do
[ if prealloc(lc, delta, n, true) ne -1 then
[ prealloc(lc, delta, n)
resultis lc
]
lc = lc+inc
]
error("Can't preallocate")
]
// Main routines
let nextmask(n) = valof
[ let m = 1
while m le n do m = m lshift 1
resultis m-1
]
// Unpack R register list
let regv = vec regsize
let patmax = 0
for i = 0 to regsize-1 do
if getbit(rregs, i) ne 0 then
[ regv!patmax = i
patmax = patmax+1
]
reglist = regv
patmax = patmax & -2
// Unpack pattern
comment("Pattern is:")
comment(pat)
if nphase gr patmax then toolong()
let npmask = nextmask((nphase-1)*2)+1
let patlen = xpat!0
// Scan constant memory
manifest [ nxcon = 3 ]
manifest [ nconst = maxpatsize+nxcon ]
let cloc, cval = vec nconst, vec nconst
cloc, cval = cloc+nxcon, cval+nxcon
for j = -nxcon to nphase-1 do
[ let val = selecton j into
[ case -3: 1777b // for resetting phase
case -2: 6000b // ditto
case -1: -1 // for signalling match
default: j
]
for i = 0 to consize-1 do
if RamImage!i eq val then
[ cloc!j, cval!j = i, val; goto found ]
error("Inadequate constant memory")
found:
]
constloc, constval = cloc, cval
// Allocate dispatches
let albits = vec (ramsize/16)
allocbits = albits
SetBlock(allocbits, -1, ramsize/16)
let abase = ramsize-charsetsize
prealloc(abase, 1, charsetsize) // allocate A dispatch
let loc = (npmask ls fixedram? fixedram, npmask)
prealloc(0, 1, loc) // skip bottom loc.s
let endloc = vec (maxpatsize)
let idloc = count
for c = 0 to charsetsize-1 do // allocate B dispatch
test idloc!c ne 0 // occurs in pattern
ifso
[ loc = findalloc(loc, 1, nphase, npmask)
idloc!c = loc
]
ifnot idloc!c = -1
let clrbase = findalloc(0, 1, nphase, npmask)
let clrnext = allocins()
comment("Last test")
let next = 2
for ctr = 0 to nphase-1 do
[ endloc!ctr = allocins()
next = findalloc(next, 1, 2, 2)
instr(endloc!ctr, ctrsel(ctr), bsLOADR, next)
instr(next, rPhase, f2BUS, clrnext)
instr(next+1, LOADL, consel(ctr), Match)
]
// Compile test sequences
[ let tlocs = vec maxpatsize
for c = 0 to charsetsize-1 do
if idloc!c ne -1 then
[ let cs = "Code for ' '"
cs>>BS.char↑11 = c
comment(cs)
let nl = -1
for i = 1 to patlen do
if xpat!i eq c then
[ nl = nl+1; tlocs!nl = i ]
for h = 0 to nphase-1 do
[ if nl ne 0 then comment("New phase")
let loc = idloc!c+h
for j = 0 to nl do
[ let ctr = (h-tlocs!j+1+nphase) rem nphase
let n1 = (j eq nl? endloc!ctr, allocins())
instr(loc, LOADL, ctrsel(ctr), aluPLUS1, f2BUSEQ0, n1) // *** should have TASK
if j ne nl then
[ next = findalloc(next, 1, 2, 2)
instr(n1, ctrsel(ctr), bsLOADR, next)
instr(next+1, LOADL, consel(ctr), Match)
loc = next
]
]
]
]
]
// Store C (counter-clearing) code
[ comment("Clearing counters")
instr(clrnext, LOADL, rNegK1, f2IDISP, clrbase)
for h = 0 to nphase-1 do
[ let loc, fetch = clrbase+h, ((h&1) eq 0? FetchOdd, FetchEven)
let nh = (h+1) rem nphase
test nh eq 0
ifso // also reset phase
[ next = findalloc(next, 1, 2, 2)
instr(loc, ctrsel(nh), bsLOADR, next)
let n1 = allocins()
instr(next, LOADL, consel(-3), f1const, f2IDISP, n1)
instr(next+1, LOADL, consel(-2), f1const, aluMINUS1, f2IDISP, n1)
instr(n1, rPhase, bsLOADR, fetch)
]
ifnot
[ instr(loc, ctrsel(nh), bsLOADR, fetch)
]
]
]
// Compile reset sequence
[ comment ("Reset all counters")
let n1 = allocins()
instr(Reset, LOADL, rNegK1, n1)
for i = 0 to nphase-1 do
[ let n2 = allocins()
instr(n1, ctrsel(i), bsLOADR, n2)
n1 = n2
]
let n2 = allocins()
instr(n1, LOADL, rAC0, f1TASK, n2)
instr(n2, rPhase, bsLOADR, START)
]
// Fill in character (A) dispatch
let xchar = charsetsize-1
[ comment("A dispatch")
let outt = FCoutStream
for c = 0 to charsetsize-1 do
if (chartab!c eq classOther) & (idloc!c ne -1) then
[ let l1 = allocins()
instr(l1, idloc!c)
idloc!c = l1
]
for c = 0 to charsetsize-1 do
[ FCoutStream = outt
let c1 = chartab!c
switchon c1 into
[ case classSkip:
instr(abase+c, Skip)
endcase
case classRecord:
instr(abase+c, LOADL, rPhase, Record)
endcase
case classExit:
instr(abase+c, LOADL, consel(-1), Match)
endcase
case classOther:
c1 = c // falls through
default:
switchon idloc!c1 into
[ case -1:
FCoutStream = 0
instr(abase+c, rPhase, f2BUS, clrnext)
endcase
default:
instr(abase+c, rPhase, f2BUS, idloc!c1) // *** should have TASK
]
]
]
FCoutStream = outt
]
// Set up values for FindNext
findJumpRam = 0 // FindInit sets it up
findWriteReg = WriteReg
resultis 0
]
//
// An alternative compiler that doesn't use microcode
//
and FindCompileSoft(pat, chartab, nphase, xpat, count, lvTables, zone) = valof
[
external
[ // fpsoftasm
@flvlvlvCtrs; @fnNctrs; @flvDisp
fJumpRam; fWriteReg
fClear; fSkip; fExit; @fCount
]
topframe = MyFrame()
// Miscellaneous subroutines
let outblk(addr, len) be
[ for i = 0 to len-1 do
[ if (i rem 6) eq 0 then PutTemplate(FCoutStream, "*N$6UO", addr+i)
PutTemplate(FCoutStream, "$8UO", addr!i)
]
Puts(FCoutStream, $*N)
]
// Allocate state vector
let nchars, nlit = 0, 0
for i = 0 to charsetsize-1 do
if count!i ne 0 then nchars, nlit = nchars+1, nlit+count!i
if nphase gr 376b then toolong() // >64K of tables needed!
let state = Allocate(zone,
nphase+ // counters
charsetsize+ // A dispatch
2*nchars+nlit+ // B dispatches
nphase+2+ // First level of counter addresses
nphase*(nphase+1), // Second level
-1)
if state eq 0 then toolong() // Can't allocate tables
@lvTables = state
let ctrbase = state
let adisp = ctrbase+nphase
SetBlock(adisp, fClear, charsetsize)
let bdisp = adisp+charsetsize
let ppcbase = bdisp+2*nchars+nlit+1
let pcbase = ppcbase+nphase+1
// Produce B dispatch tables
[ let bptr = bdisp
for c = 0 to charsetsize-1 do
if count!c ne 0 then
[ adisp!c = bptr
@bptr = 6000b+lv fCount // jsr @
bptr = bptr+1
for i = 1 to xpat!0 do
if xpat!i eq c then
[ @bptr = i-1; bptr = bptr+1 ]
@bptr = -1
bptr = bptr+1
]
]
// Fill in character (A) dispatch
[ for c = 0 to charsetsize-1 do
[ let c1 = chartab!c
let d = nil
switchon c1 into
[ case classSkip:
adisp!c = fSkip
endcase
case classRecord:
adisp!c = fExit
endcase
case classExit:
adisp!c = fExit
endcase
case classOther:
endcase // already done
default:
if count!c1 eq 0 loop
adisp!c = adisp!c1
]
]
]
// Set up pointer tables
[ ppcbase!-1 = -1
let p = pcbase
for i = 0 to nphase-1 do
[ p = p+1
ppcbase!i = p
for j = 0 to nphase-1 do
p!j = ctrbase+((i-j+nphase) rem nphase)
p!-1 = p!(nphase-1)
p = p+nphase
]
ppcbase!nphase = 0
]
// Write listing
if FCoutStream ne 0 then
[ outblk(adisp, charsetsize)
outblk(bdisp, ppcbase-bdisp)
outblk(ppcbase-1, nphase+2)
outblk(pcbase, nphase*(nphase+1))
]
// Set up values for FindNext
findJumpRam = fJumpRam
findWriteReg = fWriteReg
// Set up data for assembly code
flvDisp = adisp
fnNctrs = -nphase
flvlvlvCtrs = ppcbase
resultis 0
]