// Alloc.bcpl -- BOUNDARY TAG STORAGE ALLOCATOR
//
// last modified August 8, 1977  4:10 PM
//
// Ed McCreight (and friends)
// Computer Sciences Laboratory
// Xerox PARC
// 3333 Coyote Hill Road,
// Palo Alto, Calif.  94304
//	415-494-4000

// zone = InitializeZone(start, length [,outOfSpaceRtn [,malFormedRtn]])
// AddToZone(zone, start, length)
// ptr = Allocate(zone, size [,returnOnNoSpace [,even]])
//    ... or ptr = (zn>>ZN.Allocate)(zn, size [,returnOnNoSpace [,even]])
// Free(zone, ptr)
//    ... or (zn>>ZN.Free)(zn, ptr)
// CheckZone(zone)

// WARNING: a zone must not be bigger than 32k-1 words

//Debugging facilities:
// The manifest constant DEBUG may be set to a variety of things which
// cause conditional compilation to include ever more stringent checking.
// There are two kinds of checking:
//	a. Individual checking of each request (Allocate & Free)
//	   Just checks the request itself.
//	b. Check entire data structure fairly stringently (slow).
//	   This procedure may be called from SWAT, and is called
//	   CheckZone.
//
// The setting of DEBUG governs which kinds of checking are done:
//	DEBUG = 0	No checking.
//	DEBUG = 1	Type (a) on each request.
//	DEBUG = 2	Type (a) on each request, but code for
//			CheckZone is compiled & can be called from Swat
//	DEBUG = 3	Type (a) and (b) on each request (VERY slow).

manifest DEBUG = 3

external
[
// outgoing procedures
InitializeZone; AddToZone
Allocate; Free
CheckZone

// incoming procedures
SysErr		// SysErr(param, errNo)
Usc		// Usc(a, b) -1 if a < b, 0 if a = b; 1 if a > b unsigned
Call0; Call1
]

// local statics (only needed if compiled alone...)
static [ Allocate; Free ]

// error codes
manifest
[
ecOutOfSpace = 1801
ecZoneAdditionError = 1802
ecBlockNotAllocated = 1803
ecIllFormed = 1804
ecBadRequest = 1805
]

//---------------------------------------------------------------------------
structure SB:  // storage block
//---------------------------------------------------------------------------
[
length word	// + for free blocks, - for allocated ones
data word =	// allocated block: start of data space
   [		// free block only
   pSbNext word
   pSbPrevious word
   ]
]
manifest
[
lSbOverhead = offset SB.data/16
minLSbFree = size SB/16
offsetSbData = offset SB.data/16
]

//---------------------------------------------------------------------------
structure ZN:  //Zone object
//---------------------------------------------------------------------------
[
Allocate word
Free word
OutOfSpaceRtn word	// Non-zero to report insufficient space
MalFormedRtn word	// Non-zero to do consistency checks
anchor @SB
rover word 
minAdr word
maxAdr word
]
manifest
[
lZn = size ZN/16
lZnOverhead = lZn + lSbOverhead
]

// Actually a zone is a zone header, followed by a consecutive sequence of
// blocks followed by a dummy used block, which is a word containing -1.
// The sb in the header acts as an anchor for the free chain.

//---------------------------------------------------------------------------
let InitializeZone(zn,length,OutOfSpaceRtn,MalFormedRtn; numargs na) = valof
//---------------------------------------------------------------------------
[
compileif (offset ZN.Allocate) ne 0 % (offset ZN.Free) ne 16 then [ foo = 0 ]
Allocate = Call0
Free = Call1

zn>>ZN.Allocate = rAllocate
zn>>ZN.Free = rFree
zn>>ZN.OutOfSpaceRtn = na ls 3? SysErr, OutOfSpaceRtn

let sbAnchor = lv zn>>ZN.anchor
sbAnchor>>SB.length = 0
sbAnchor>>SB.pSbNext = sbAnchor
sbAnchor>>SB.pSbPrevious = sbAnchor

let firstFree = zn + lZn
zn>>ZN.rover = firstFree

compileif DEBUG gr 0 then
   [
   zn>>ZN.MalFormedRtn = na ls 4? SysErr, MalFormedRtn
   zn>>ZN.minAdr = firstFree
   zn>>ZN.maxAdr = firstFree
   ]

AddToZone(zn,firstFree,length-lZn)
resultis zn
]

//---------------------------------------------------------------------------
and AddToZone(zn, sb, length) be
//---------------------------------------------------------------------------
[
let lSbFree = length-lSbOverhead	//Account for -1 at end
compileif DEBUG gr 0 then
   [
   if lSbFree ls minLSbFree % Usc(length,#77776) gr 0 then
      AllocBomb(zn, ecZoneAdditionError)
   ]

sb!lSbFree = -1

compileif DEBUG gr 0 then
   [
   let sbLast = sb+lSbFree
   let min = zn>>ZN.minAdr
   test Usc(sb,min) ls 0
      ifso
         [
         if Usc(sbLast,min) ge 0 then AllocBomb(zn, ecZoneAdditionError)
         sb!lSbFree = sbLast-min //New boundary tag
         zn>>ZN.minAdr = sb
         ]
      ifnot
         [
         let max = zn>>ZN.maxAdr
         if Usc(sb,max) ls 0 then AllocBomb(zn, ecZoneAdditionError)
         @max = max-sb  //Clobbers sb>>SB.length first time
         zn>>ZN.maxAdr = sbLast
         ]
   ]

sb>>SB.length = -lSbFree
Free(zn, sb+offsetSbData)
]

//---------------------------------------------------------------------------
and rAllocate(zn, lSbData, returnOnNoSpace, even; numargs na) = valof
//---------------------------------------------------------------------------
[
if na ls 3 then returnOnNoSpace = false
if na ls 4 then even = false

if even then lSbData = lSbData +1	//Get one more
let largest = 0				//Keep track of free blocks
let lSb = lSbData + lSbOverhead

//It wan't me!  It was smashed before I got here!
compileif DEBUG eq 3 then [ if zn>>ZN.MalFormedRtn then CheckZone(zn) ]

if Usc(lSb,minLSbFree) ls 0 then lSb = minLSbFree

let sbRover = zn>>ZN.rover
let sbOriginalRover = sbRover
   [
   let sbNext = nil
      [  // loop while next neighbor is free, coalescing him with rover
      sbNext = sbRover + sbRover>>SB.length
      if sbNext>>SB.length le 0 break
      if sbNext eq sbOriginalRover then
         sbOriginalRover = sbNext>>SB.pSbNext
      // remove sbNext from his chains
      sbNext>>SB.pSbNext>>SB.pSbPrevious = sbNext>>SB.pSbPrevious
      sbNext>>SB.pSbPrevious>>SB.pSbNext = sbNext>>SB.pSbNext
      // and add him to us
      sbRover>>SB.length = sbRover>>SB.length + sbNext>>SB.length
      ] repeat

   let sb = sbNext - lSb
   let extra = sb - sbRover
   let siz = sbNext - sbRover
   if siz gr largest then largest = siz
   // loop if block not big enough, or if request too large to be legal
   // (large size may be calling us just to compute largest block)
   if extra ls 0 % Usc(lSb, #100000) ge 0 then
      [ sbRover = sbRover>>SB.pSbNext; loop ]

   test extra ge minLSbFree
      ifso
         [  // split block
         sbRover>>SB.length = extra
         zn>>ZN.rover = sbRover
         // set the length and mark the new block used
         sb>>SB.length = -lSb
         ]
      ifnot
         [  // remove rover from his chains
         sbRover>>SB.pSbNext>>SB.pSbPrevious = sbRover>>SB.pSbPrevious
         sbRover>>SB.pSbPrevious>>SB.pSbNext = sbRover>>SB.pSbNext
         zn>>ZN.rover = sbRover>>SB.pSbNext
         // and mark the new block used
         sb = sbRover
         sb>>SB.length = -sb>>SB.length
         ]
   let ans = sb + offsetSbData
   if even then [ ans!0 = 0; ans = (ans+1)&(-2) ]
   resultis ans
   ] repeatwhile sbRover ne sbOriginalRover

zn>>ZN.rover = sbRover
if (returnOnNoSpace ne 0) % (zn>>ZN.OutOfSpaceRtn eq 0) then
   [
   // Following will clobber location zero, but....
   if returnOnNoSpace ne -1 then @returnOnNoSpace = largest-lSbOverhead
   resultis 0
   ]
resultis zn>>ZN.OutOfSpaceRtn(zn, ecOutOfSpace, lSbData)
]

//---------------------------------------------------------------------------
and rFree(zn, sb) be
//---------------------------------------------------------------------------
[
// This can be called with the result of a call to Allocate rounded up by
// anything from 0 to 1 (if even)
if sb!-1 eq 0 then sb = sb -1	//Was even allocation
sb = sb - offsetSbData  //-> boundary tag
compileif DEBUG gr 0 then
   [ if sb>>SB.length ge 0 then AllocBomb(zn, ecBlockNotAllocated) ]
let sbAnchor = lv zn>>ZN.anchor

compileif DEBUG eq 3 then [ if zn>>ZN.MalFormedRtn then CheckZone(zn) ]

// mark the block free
sb>>SB.length = -sb>>SB.length

compileif DEBUG gr 0 then
   [
   if zn>>ZN.MalFormedRtn then
      [
      CheckBounds(zn, sb)
      CheckFreeNode(zn, sbAnchor)
      ]
   ]
//insert between anchor and anchor.next
let sbT = sbAnchor>>SB.pSbNext
sb>>SB.pSbPrevious = sbAnchor; sb>>SB.pSbNext = sbT
sbAnchor>>SB.pSbNext = sb; sbT>>SB.pSbPrevious = sb
]

//---------------------------------------------------------------------------
and CheckZone(zn) be
//---------------------------------------------------------------------------
[
compileif DEBUG gr 1 then
   [
   if (rv zn>>ZN.maxAdr) ne -1 then AllocBomb(zn)
   //Go through core by believing boundary tags, counting free blocks
   let freeCount = 0
   let sb = zn>>ZN.minAdr  //First block
   while Usc(zn>>ZN.maxAdr, sb) gr 0 do
      [
      let addit = sb>>SB.length
      test addit ge 0
         ifso
            [  //Free node
            CheckFreeNode(zn, sb)
            freeCount = freeCount+1
            ]
         ifnot addit = -addit  //Allocated one
      if Usc(sb+addit, sb) le 0 then AllocBomb(zn)
      sb = sb+addit
      ]
   if sb ne zn>>ZN.maxAdr then AllocBomb(zn)
   //Go through free list, checking, decrementing free count
   let cnt = -22000		// 64000/minLSbFree iterations
   let sbAnchor = lv zn>>ZN.anchor
   sb = sbAnchor>>SB.pSbNext
   while sb ne sbAnchor do
      [
      CheckFreeNode(zn, sb)
      freeCount = freeCount -1
      cnt = cnt-1; if cnt eq 0 then AllocBomb(zn)
      sb = sb>>SB.pSbNext
      ]
   if freeCount ne 0 then AllocBomb(zn)
   ]
]

//---------------------------------------------------------------------------
and CheckFreeNode(zn, sb) be
//---------------------------------------------------------------------------
[
compileif DEBUG gr 0 then
   [
   CheckBounds(zn, sb)
   CheckBounds(zn, sb>>SB.pSbNext)
   CheckBounds(zn, sb>>SB.pSbPrevious)
   if (sb ne lv zn>>ZN.anchor & sb>>SB.length ls minLSbFree) %
      sb>>SB.pSbNext>>SB.pSbPrevious ne sb then AllocBomb(zn)
   ]
]

//---------------------------------------------------------------------------
and CheckBounds(zn, sb) = valof
//---------------------------------------------------------------------------
[
compileif DEBUG gr 0 then
   [
   if sb ne lv zn>>ZN.anchor &
    (Usc(sb+sb>>SB.length, zn>>ZN.maxAdr) gr 0 %
    Usc(sb,zn>>ZN.minAdr) ls 0) then AllocBomb(zn)
   ]
]

//---------------------------------------------------------------------------
and AllocBomb(zn, ec; numargs na) be 
//---------------------------------------------------------------------------
[
if na le 1 then ec = ecIllFormed
let MalFormedRtn = zn>>ZN.MalFormedRtn ? zn>>ZN.MalFormedRtn, SysErr
MalFormedRtn(zn, ec)
]