// CopyDiskBfs1.bcpl
// Copyright Xerox Corporation 1979, 1980, 1982
// Last modified July 21, 1982  6:55 PM by Boggs

get "AltoDefs.d"
get "CopyDisk.decl"
get "CopyDiskBfs.decl"

external
[
// outgoing procedures
BfsTryDisk; BfsReader; BfsWriter

// incoming procedures form other CopyDisk modules
ReportBfsError; GetBuffer; ReleaseBuffer; FatalError

// incoming procedures from OS and packages
Enqueue; Dequeue; Unqueue; InsertAfter; QueueLength
Zero; MoveBlock; SysErr; Usc; ReturnTo; MultEq
Idle; Noop; Block

// incoming statics
CtxRunning; driveLock; freePageFid
compressFlag; bootFlag
]

//----------------------------------------------------------------------------
let BfsTryDisk(partition, drive, cylinder, sector) = valof
//----------------------------------------------------------------------------
// If cylinder is 0, returns true if disk is on line
// If cylinder is 203, returns true if disk is model 44
[
let kcb = vec lKCB; Zero(kcb, lKCB)
kcb>>KCB.command = seekOnly
kcb>>KCB.command.partition = partition
kcb>>KCB.diskAddress.disk = drive
kcb>>KCB.diskAddress.cylinder = cylinder
kcb>>KCB.diskAddress.sector = sector
until @diskCommand eq 0 loop
@diskCommand = kcb
until kcb>>KCB.status.done loop
resultis (kcb>>KCB.status & DSTgoodStatusMask) eq DSTgoodStatus
]

//---------------------------------------------------------------------------
and BfsInitializeCbStorage(cbz, length, retry, error, cleanup; numargs na) be
//---------------------------------------------------------------------------
[
if na gr 1 then
   [
   Zero(cbz, length)
   cbz>>CBZ.length = length
   cbz>>CBZ.error = error
   cbz>>CBZ.retry = retry
   cbz>>CBZ.cleanup = cleanup
   ]
let cb = lv cbz>>CBZ.CBs
cbz>>CBZ.head = cb
   [
   cbz>>CBZ.tail = cb
   cb>>CB.cbz = cbz
   cb>>CB.status = DSTfreeStatus
   cb = cb + lCB
   if Usc(cb+lCB, cbz+cbz>>CBZ.length) gr 0 then cb = 0
   cbz>>CBZ.tail>>CB.nextCB = cb
   ] repeatuntil cb eq 0
]

//---------------------------------------------------------------------------
and BfsDoDiskCommand(cb, buffer, command) be
//---------------------------------------------------------------------------
[
let ss = CtxRunning>>CDCtx.ss

cb>>CB.headerAddress = lv buffer>>BFSBuffer.header
cb>>CB.labelAddress = lv buffer>>BFSBuffer.label
cb>>CB.dataAddress = lv buffer>>BFSBuffer.data
cb>>CB.diskAddress = ss>>BFSSS.currentDA
cb>>CB.command = command
if command eq seekOnly then
   [
   cb>>CB.diskAddress.restore = 1
   cb>>CB.diskAddress.cylinder = 0
   ]
cb>>CB.command.partition = ss>>BFSSS.partition

let p = @diskCommand
if p ne 0 then
   [
      [
      let np = p>>CB.link
      if np eq 0 break
      p = np
      ] repeat
   p>>CB.link = cb
   ]

// If there are no disk commands queued at the moment, be very careful
// about plopping down a pointer to our cb.  We must be sure that the
// previous cb for this cbz has NOT encountered an error (it's OK
// if it is free or has been transferred already, but not OK if there
// is an error or if it has not been transferred at all)
let cbz = cb>>CB.cbz
if @diskCommand eq 0 then
   [
   // take from head, add to tail => tail newest
   let prevCb = cbz>>CBZ.head? cbz>>CBZ.tail, 0
   let stat = prevCb>>CB.status & DSTgoodStatusMask
   if prevCb eq 0 % (stat ne 0 & (stat & DSTerrorBits) eq 0) then
      @diskCommand = cb
   ]

// Put this CB on the tail of the available queue
cb>>CB.nextCB = 0
test cbz>>CBZ.head eq 0
   ifso cbz>>CBZ.head = cb
   ifnot cbz>>CBZ.tail>>CB.nextCB = cb
cbz>>CBZ.tail = cb
//Enqueue(lv cbz>>CBZ.head, lv cb>>CB.nextCB)
]

//---------------------------------------------------------------------------
and BfsGetCb(cbz) = valof
//---------------------------------------------------------------------------
// Here we wait for a transfer to complete.  If, for some reason, 521
// (diskCommand) has been zeroed, which means that disk has
// gone idle without executing this command, we fake an error
// in this command in order to get the rest of this (BfsGetCb) code
// executed.  The cbz will be rebuilt, and the transfer re-queued.
// This means that several callers of the Bfs active at once
// (i.e., disk commands from several cbzs are queued) should all
// work: if no errors happen during transfer, everything is fine.  If
// errors occur in one cbz, all will stop.  Then, as the control
// blocks become "cleaned up," we will eventually find, in each
// cbz, one that was not executed (and with the disk idle).  So the
// mechanism for "faking" an error (DSTfakeError) will cause
// the proper transfers to be re-queued.
[
let cb = cbz>>CBZ.head; if cb eq 0 then SysErr(cbz, ecBfsQueue)

   [
   if (cb>>CB.status & DSTdoneBits) ne 0 break
   if @diskCommand eq 0 & (cb>>CB.status & DSTdoneBits) eq 0 then
      cb>>CB.status = DSTfakeError
   Idle()  //Let someone else in
   ] repeat

cbz>>CBZ.head = cb>>CB.nextCB
cb>>CB.command.seal = 0

// This block returns true iff the cb corresponds to a completed transfer.
if valof
   [
   let s = cb>>CB.status & DSTgoodStatusMask
   if s eq DSTfreeStatus resultis false
   // Restore commands can only be initiated from within BfsGetCb,
   //  so this is our command, not the client's.  Treat cb as free.
   if cb>>CB.diskAddress.restore eq 1 resultis false
   if s eq DSTgoodStatus test cb>>CB.command.headerAction ne 0
      ifso resultis true 
      ifnot if (cb>>CB.diskAddress & -4) eq (cb>>CB.headerAddress>>DH.diskAddress & -4) resultis true

   until @diskCommand eq 0 do Idle()  // Wait for disk to stop spinning
   let ec = cbz>>CBZ.errorCount
   if cb>>CB.status.dataLate eq 0 then cbz>>CBZ.errorCount = ec +1
   cbz>>CBZ.errorDA = cb>>CB.diskAddress  //we deal entirely in real DAs
   if cbz>>CBZ.errorCount ge CtxRunning>>CDCtx.ss>>BFSSS.retryCount then
      [  // Unrecoverable error
      (cbz>>CBZ.error)(cb, ecUnRecovDiskError)
      resultis true  //treat it as if it completed normally
      ]

   BfsInitializeCbStorage(cbz)
   // If the error count is large enough, initiate a restore.  Note
   // that the command is issued, but we do not wait to be sure
   // it completes.
   if ec gr (CtxRunning>>CDCtx.ss>>BFSSS.retryCount rshift 1) then
      [
      @diskAddress = -1
      BfsDoDiskCommand(BfsGetCb(cbz), nil, seekOnly)
      ]
   ReturnTo(cbz>>CBZ.retry)
   ] then
   [
   cbz>>CBZ.errorCount = 0
   (cbz>>CBZ.cleanup)(cb)
   ]

Zero(cb, lVarCB)
resultis cb
]

//----------------------------------------------------------------------------
and BfsReader(ctx) be  //a context
//----------------------------------------------------------------------------
[
let done = false
let ss = ctx>>CDCtx.ss
let cbz = ss>>BFSSS.cbz
let xp = lv ss>>BFSSS.tp>>CD.xferParams.params
ss>>BFSSS.currentDA = xp>>BFSXferParams.firstDA
ss>>BFSSS.currentDA.disk = ss>>BFSSS.driveNumber
   [
   BfsInitializeCbStorage(cbz, lenCBZ, BfsReadRetry, BfsReadError, BfsReadCleanup)
   Idle() repeatwhile driveLock %
    (QueueLength(ss>>SS.inputQ) ls ss>>SS.maxBuffers &
    ss>>SS.otherSS>>SS.type eq ss>>SS.type)
   driveLock = ctx
   if false then
      [
      BfsReadRetry:
      Idle() repeatuntil driveLock eq 0 % driveLock eq ctx
      driveLock = ctx
      ss>>BFSSS.currentDA = cbz>>CBZ.errorDA
      while (ss>>SS.tempQ)!0 ne 0 do ReleaseBuffer(Dequeue(ss>>SS.tempQ))
      ReportBfsError(EtSoft+EtRead, ss>>BFSSS.currentDA)
      ]
      [
      let cb = BfsGetCb(cbz)
      let buffer = GetBuffer(true); if buffer eq 0 break
      Enqueue(ss>>SS.tempQ, buffer)
      BfsDoDiskCommand(cb, buffer, readHLD)
      done = BfsBumpDA()
      ] repeatuntil done
   driveLock = 0
   while cbz>>CBZ.head ne 0 do BfsGetCb(cbz)
   ] repeatuntil done % ss>>SS.fatalFlag
let buffer = GetBuffer(false)
buffer>>BFSBuffer.type = endOfTransfer
buffer>>BFSBuffer.length = 2
Enqueue(ss>>SS.outputQ, buffer)
ss>>SS.doneFlag = true
Block() repeat
]

//----------------------------------------------------------------------------
and BfsReadCleanup(cb) be
//----------------------------------------------------------------------------
[
let ss = CtxRunning>>CDCtx.ss
let buffer = Dequeue(ss>>SS.tempQ)
if cb>>CB.dataAddress ne lv buffer>>BFSBuffer.data then
   FatalError("*N[BfsReadCleanup] tempQ bad")
buffer>>BFSBuffer.length = lenBFSBuffer-offset Buffer.length/16
buffer>>BFSBuffer.type = hereIsDiskPage
if MultEq(lv buffer>>BFSBuffer.label.fid, table [ -2; -2; -2 ], lFID) then
   MoveBlock(lv buffer>>BFSBuffer.label.fid, freePageFid, lFID)
if MultEq(lv buffer>>BFSBuffer.label.fid, freePageFid, lFID) & compressFlag then
   buffer>>BFSBuffer.length = lenFreePage
Enqueue(ss>>SS.outputQ, buffer)
]

//----------------------------------------------------------------------------
and BfsReadError(cb, errorcode) be
//----------------------------------------------------------------------------
   ReportBfsError(EtHard+EtRead, cb)

//----------------------------------------------------------------------------
and BfsWriter(ctx) be  //a context
//----------------------------------------------------------------------------
[
let done = false
let ss = ctx>>CDCtx.ss
if ss>>BFSSS.driveNumber eq 0 then bootFlag = true
let cbz = ss>>BFSSS.cbz
let xp = lv ss>>BFSSS.tp>>CD.xferParams.params
ss>>BFSSS.currentDA = xp>>BFSXferParams.firstDA
ss>>BFSSS.currentDA.disk = ss>>BFSSS.driveNumber
   [
   BfsInitializeCbStorage(cbz, lenCBZ, BfsWriteRetry, BfsWriteError, BfsWriteCleanup)
   Idle() repeatwhile driveLock % (ss>>SS.inputQ)!0 eq 0
   driveLock = ctx
   if false then
      [
      BfsWriteRetry:
      Idle() repeatuntil driveLock eq 0 % driveLock eq ctx
      driveLock = ctx
      ss>>BFSSS.currentDA = cbz>>CBZ.errorDA
      let p = ss>>SS.inputQ; while (ss>>SS.tempQ)!0 ne 0 do
         [
         InsertAfter(ss>>SS.inputQ, p, Dequeue(ss>>SS.tempQ))
         p = p!0
         ]
      ReportBfsError(EtSoft+EtWrite, ss>>BFSSS.currentDA)
      ]
      [
      let cb = BfsGetCb(cbz)
      let buffer = Dequeue(ss>>SS.inputQ); if buffer eq 0 break
      if buffer>>BFSBuffer.type ne hereIsDiskPage then
         [ ReleaseBuffer(buffer); ss>>SS.fatalFlag = true; break ]
      Enqueue(ss>>SS.tempQ, buffer)
      BfsDoDiskCommand(cb, buffer, writeHLD)
      done = BfsBumpDA()
      ] repeatuntil done
   driveLock = 0
   while cbz>>CBZ.head ne 0 do BfsGetCb(cbz)
   ] repeatuntil done % ss>>SS.fatalFlag
ss>>SS.doneFlag = true
Block() repeat
]

//----------------------------------------------------------------------------
and BfsWriteCleanup(cb) be
//----------------------------------------------------------------------------
[
let buffer = Dequeue(CtxRunning>>CDCtx.ss>>SS.tempQ)
if cb>>CB.dataAddress ne lv buffer>>BFSBuffer.data then
   FatalError("*N[BfsWriteCleanup] tempQ bad")
ReleaseBuffer(buffer)
]

//----------------------------------------------------------------------------
and BfsWriteError(cb, errorcode) be
//----------------------------------------------------------------------------
   ReportBfsError(EtHard+EtWrite, cb)

//----------------------------------------------------------------------------
and BfsBumpDA() = valof
//----------------------------------------------------------------------------
[
let ss = CtxRunning>>CDCtx.ss
let da = lv ss>>BFSSS.currentDA
let dp = lv ss>>SS.dp>>CD.diskParams.params
let tp = lv ss>>SS.tp>>CD.xferParams.params

let currentDA = @da
if dp>>BFSDiskParams.nDisks eq 1 then currentDA<<DA.disk = 0
if currentDA eq tp>>BFSXferParams.lastDA resultis true

da>>DA.sector = da>>DA.sector +1
if da>>DA.sector eq dp>>BFSDiskParams.nSectors then
   [
   da>>DA.sector = 0
   da>>DA.head = da>>DA.head +1
   if da>>DA.head eq 0 then
      [
      da>>DA.head = 0
      da>>DA.cylinder = da>>DA.cylinder +1
      if da>>DA.cylinder eq dp>>BFSDiskParams.nCylinders then
         [
         da>>DA.cylinder = 0
         da>>DA.disk = da>>DA.disk +1
         ]
      ]
   ]
resultis false
]