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