// IFSResUtilb.bcpl - RESIDENT utility stuff
// Copyright Xerox Corporation 1979, 1980, 1981, 1982
// Last modified September 17, 1982  1:20 PM by Taft

get "AltoDefs.d"
get "Ifs.decl"
get logVMPageLength from "IfsVMem.decl"
get "AltoFileSys.d"
get "Disks.d"
get "Tfs.d"

external
[
// outgoing procedures
Lock; Unlock; IFSAllocate; IFSFree; IFSAddToZone; ReturnRetainedFreePages
SysAllocateZero; FreePointer; IFSIdle; IFSError; SysErr

// incoming procedures
Block; SnarfBuffers; UnsnarfBuffers; MulDiv; Zero; Max
Enqueue; Dequeue; Unqueue; QueueLength
Allocate; Free; SysFree; InitializeZone; AddToZone; SysAllocate
Puts; Gets; Endofs; NoBufsProc

// outgoing statics
snarfTable; bigZone; smallZone; oPageQ; chunkQ; freePageQ; dontSnarf
smallZoneOverflows; bigZoneOverflows; numOverflowPages; maxOverflowPages
netAllocBlocks; maxRetainedFreePages

// incoming statics
CtxRunning; sysZone; debugFlag
]

static
[
snarfTable; chunkQ; oPageQ; freePageQ; bigZone; smallZone
smallZoneOverflows = 0
bigZoneOverflows = 0
numOverflowPages = 0
maxOverflowPages = 0
netAllocBlocks = 0
maxRetainedFreePages = 0  // set nonzero in XM configurations
dontSnarf = true  // set to False after VMem buffers made available
]

manifest
[
ecIllegalLock = 10
ecWrongLockOwner = 11
ecSnarfTable = 12
ecSnarfBuffer = 13
ecSmallZoneEmpty = 14
ecBigZoneEmpty = 15
ecNotInZoneTable = 32
ecOverflowPage = 33

stdPageLength = 1 lshift logStdPageLength
smallZoneMax = 25
bigZoneMax = stdPageLength/2-10

// The links in freePageQ items are offset from the beginning of the page
// by this amount so that a running context can destroy itself without the
// ifsCtxQ and freePageQ links interfering with each other (see the
// DestroyJob procedure in IfsRSMgrSwap.bcpl).
offsetFreePageLink = 10
]

// NOTE:  IfsAllocSpy has a private copy of these structures
structure ZC:	// zone chunk
[
link word	// link to next chunk
base word	// base of chunk
length word	// length of chunk
zone word	// zone owning chunk
]
manifest lenZC = size ZC/16

structure OPage: // overflow page
[
link word	// link to next page
zone word	// pointer to zone contained within this page
count word	// reference count
// zone created starting here
]
manifest lenOPage = size OPage/16

//----------------------------------------------------------------------------
let IFSError(errNo, p1, p2, p3, p4, p5) be
//----------------------------------------------------------------------------
   (table [ 77403b; 1401b ])("IFS.Errors", lv errNo)

//----------------------------------------------------------------------------
and SysErr(p1, errNo, p2, p3, p4, p5) be
//----------------------------------------------------------------------------
[
let temp = p1; p1 = errNo; errNo = temp
(table [ 77403b; 1401b ])("Sys.Errors", lv p1)
]

// Some general-purpose procedures for mutual exclusion.
// A Lock is a 2-word structure defined in IFS.decl.
// It controls read and write access to a resource.
// There can be any number of readers but only one writer at a given time.

//----------------------------------------------------------------------------
and Lock(lock, write, returnOnFail; numargs na) = valof
//----------------------------------------------------------------------------
// Sets a lock:  a read lock if write is false or omitted, or
// a write lock if write is true.  If returnOnFail
// is false or omitted, blocks until the lock can be set; if
// true, returns false if the lock cannot be set immediately.
[
if na eq 1 then write = false
if lock>>Lock.count ne 0 then
   if write % lock>>Lock.count ls 0 then
      [
      // Have to wait.  But if the last locker of the lock was this context,
      // a deadlock will result, so...
      if lock>>Lock.ctx eq CtxRunning then IFSError(ecIllegalLock, lock)
      if na ge 3 & returnOnFail resultis false
      test write
         ifso Block() repeatuntil lock>>Lock.count eq 0
         ifnot Block() repeatuntil lock>>Lock.count ge 0
      ]
lock>>Lock.count = (write? -1, lock>>Lock.count+1)
lock>>Lock.ctx = CtxRunning
resultis true
]

//----------------------------------------------------------------------------
and Unlock(lock) be
//----------------------------------------------------------------------------
[
if lock>>Lock.count eq 0 %
 lock>>Lock.count ls 0 & lock>>Lock.ctx ne CtxRunning then
   IFSError(ecWrongLockOwner, lock)
lock>>Lock.count = Max(lock>>Lock.count-1, 0)
lock>>Lock.ctx = 0
]

//----------------------------------------------------------------------------
and IFSAllocate(zone, length, returnOnNoSpace, even; numargs na) = valof
//----------------------------------------------------------------------------
// Allocation requests are divided into three types:
// Requests for up to smallZoneMax words are filled from smallZone,
// for smallZoneMax to bigZoneMax words are filled from bigZone, and
// for bigger than bigZoneMax are filled by snarfing buffer(s)
// from vMem (except during initialization when dontSnarf is true).

// If a zone runs out of space, does one of two things
// depending on the state of debugFlag:
//  If debugFlag is true, system personel are present, 
//   go into swat, since they should know that the zone
//   sizes need to be adjusted.
//  If debugFlag is false, the system is presumed to be in
//   service, and it should recover if possible, by borrowing
//   some space from the next bigger zone.

// If bigZone runs out of space, snarfs a buffer and makes a new zone
// out of it to satisfy this request and any future requests that
// also overflow bigZone.  The snarfed buffer is reference-counted
// and put on a queue so that it may be returned to vMem when
// all blocks allocated within it have been freed.

// If SnarfBuffers fails, and debugFlag is true, then calls 
// IFSError(ecSnarfBuffer).  Proceeding will wait a few seconds
// and then try Snarfing again.  If debugFlag is false, doesn't
// go into swat, just waits and then tries again.

// This procedure almost exactly emulates the standard Zone
// Allocate except that it does not return the largest block
// available if a request fails and returnOnNoSpace is non-zero
// and not -1 (since the largest block is not a well defined concept
// when one can borrow space from vMem).

// A pool of up to maxRetainedFreePages 1-page blocks is retained
// on freePageQ rather than immediately given back to VMem, and
// handed out during subsequent requests for 1-page blocks.
// This substantially reduces the frequency of calls to SnarfBuffers
// and UnsnarfBuffers, which are very expensive.  The pages are given
// back immediately if a VMem shortage occurs, and also periodically
// when the system is idle.

// IFSAllocate (cont'd)
[
if na ls 4 then even = false
if na ls 3 then returnOnNoSpace = false
netAllocBlocks = netAllocBlocks+1
if length le smallZoneMax then
   [
   let block = Allocate(smallZone, length, true, even)
   if block ne 0 resultis block
   if debugFlag then IFSError(ecSmallZoneEmpty, length)
   smallZoneOverflows = smallZoneOverflows+1
   ]

if length le bigZoneMax % dontSnarf then
   [
   let block = Allocate(bigZone, length, true, even)
   if block ne 0 then resultis block
   if debugFlag % dontSnarf then IFSError(ecBigZoneEmpty, length)
   bigZoneOverflows = bigZoneOverflows+1
   let oPage = oPageQ!0
   while oPage ne 0 do
      [  // try allocating from any overflow pages that presently exist
      block = Allocate(oPage>>OPage.zone, length, true, even)
      if block ne 0 then
         [ oPage>>OPage.count = oPage>>OPage.count+1; resultis block ]
      oPage = oPage>>OPage.link
      ]
   ]

// Snarf buffer(s)
let nPages = (length+(stdPageLength-1)) rshift logStdPageLength
let buf = nil
   [ // repeat
   if nPages eq 1 & freePageQ!0 ne 0 then
      [ buf = Dequeue(freePageQ)-offsetFreePageLink; break ]
   manifest nBufs = stdPageLength/256
   buf = SnarfBuffers(0, nBufs*nPages, nBufs-1)
   if buf ne 0 break
   if returnOnNoSpace then
      [ netAllocBlocks = netAllocBlocks-1; resultis 0 ]
   if debugFlag then IFSError(ecSnarfBuffer)
   NoBufsProc()
   ] repeat
let pageNum = buf rshift logStdPageLength
if snarfTable!pageNum ne 0 then IFSError(ecSnarfTable)
snarfTable!pageNum = nPages

if length le bigZoneMax then
   [  // just assigned new overflow page
   buf>>OPage.zone = InitializeZone(buf+lenOPage, stdPageLength-lenOPage,
    SysErr, 0)
   buf>>OPage.count = 1
   Enqueue(oPageQ, buf)
   numOverflowPages = numOverflowPages+1
   maxOverflowPages = Max(numOverflowPages, maxOverflowPages)
   resultis Allocate(buf>>OPage.zone, length, false, even)
   ]

resultis buf
]

//----------------------------------------------------------------------------
and IFSFree(zone, item) = valof
//----------------------------------------------------------------------------
[
netAllocBlocks = netAllocBlocks-1
let pageNum = item rshift logStdPageLength
test snarfTable!pageNum eq -1
   ifso
      [  // not a vmem page -- must be one of the permanent zones
      let chunk = chunkQ!0
      while chunk ne 0 do
         [
         if item-chunk>>ZC.base uls chunk>>ZC.length then
            [ Free(chunk>>ZC.zone, item); resultis 0 ]
         chunk = chunk>>ZC.link
         ]
      IFSError(ecNotInZoneTable, item)
      ]
   ifnot
      [  // within a vmem page
      let page = item & -1 lshift logStdPageLength
      if item ne page then
         [  // returning block to overflow page
         Free(page>>OPage.zone, item)
         page>>OPage.count = page>>OPage.count-1
         if page>>OPage.count gr 0 resultis 0
         let chunk = chunkQ!0
            [
            if chunk eq 0 then IFSError(ecOverflowPage, page)
            if chunk>>ZC.zone eq page>>OPage.zone break
            chunk = chunk>>ZC.link
            ] repeat
         unless Unqueue(chunkQ, chunk) & Unqueue(oPageQ, page) do
            IFSError(ecOverflowPage, page)
         numOverflowPages = numOverflowPages-1
         ]
      let nPages = snarfTable!pageNum
      test nPages eq 1 & QueueLength(freePageQ) ls maxRetainedFreePages
         ifso Enqueue(freePageQ, page+offsetFreePageLink)
         ifnot UnsnarfBuffers(page rshift logVMPageLength,
             nPages lshift (logStdPageLength-logVMPageLength))
      snarfTable!pageNum = 0
      ]
resultis 0
]

//----------------------------------------------------------------------------
and ReturnRetainedFreePages() = valof
//----------------------------------------------------------------------------
// Gives pages retained on freePageQ back to VMem.
// Returns the number of pages that were given back.
[
let nPages = 0
while freePageQ!0 ne 0 do
   [
   let page = Dequeue(freePageQ)-offsetFreePageLink
   UnsnarfBuffers(page rshift logVMPageLength,
    1 lshift (logStdPageLength-logVMPageLength))
   nPages = nPages+1
   ]
resultis nPages
]

//----------------------------------------------------------------------------
and IFSAddToZone(zone, base, length) be
//----------------------------------------------------------------------------
// This procedure's static's value is exchanged with that of AddToZone,
// so all callers who think they are calling AddToZone are really
// calling this procedure.
[
IFSAddToZone(zone, base, length)  // the real AddToZone, not a recursive call!
let chunk = Allocate(zone, lenZC)
chunk>>ZC.zone = zone
chunk>>ZC.base = base
chunk>>ZC.length = length
Enqueue(chunkQ, chunk)
]


// See IFSResUtila.asm for the following:
// SysAllocate(nWords) = Allocate(sysZone, nWords)
// SysFree(block) = Free(sysZone, block)

//----------------------------------------------------------------------------
and SysAllocateZero(nWords) = valof
//----------------------------------------------------------------------------
// Allocates from sysZone and zeroes a block of length nWords.
[
let block = SysAllocate(nWords)
Zero(block, nWords)
resultis block
]

//----------------------------------------------------------------------------
and FreePointer(lvPointer, nil, nil, nil, nil; numargs na) be
//----------------------------------------------------------------------------
// Takes a list of up to 5 pointers to cells containing pointers to
//  allocated storage blocks.  For any nonzero cell, frees the
//  storage block and zeroes the cell.
[
for i = 0 to na-1 do
   [
   let lvP = (lv lvPointer)!i
   if @lvP ne 0 then
      [ SysFree(@lvP); @lvP = 0 ]
   ]
]

//----------------------------------------------------------------------------
and IFSIdle() be
//----------------------------------------------------------------------------
// The Idle() procedure called while TFS is waiting for the disk
[
static lastRTC
if @realTimeClock ne lastRTC then  // at once most per RTC tick
   [
   @cursorX = 20 + ((606-40-16)/nDrives)*KBLK>>KBLK.drive
   @cursorY = (KBLK>>KBLK.track ls 0? 0,
    20+MulDiv(808-40-16, KBLK>>KBLK.track, 815))
   lastRTC = @realTimeClock
   ]
Block()
]