// Alloc.bcpl -- Boundary Tag Storage Allocator
// Copyright Xerox Corporation 1979, 1981
// Last modified October 29, 1981 6:13 PM by Boggs
//
// Ed McCreight (and friends)
// Computer Sciences Laboratory
// Xerox PARC
// 3333 Coyote Hill Road,
// Palo Alto, Calif. 94304
// 415-494-4000
// Note: this module uses the builtin relational operators ugr, etc.
// so it must be compiled with BCPL/O.
// 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).
compileif newname DEBUG then [ manifest [ DEBUG = 2 ]]
external
[
// outgoing procedures
InitializeZone; AddToZone
CheckZone
// incoming procedures
SysErr; Umax; DefaultArgs
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.
// Peculiar ordering of procedures is due to compiler restrictions
// on the use of "compileif" to conditionally compile entire procedures.
compileif DEBUG gr 0 then
[
//------------------------------------------------------------------------
let CheckFreeNode(zn, sb) be
//------------------------------------------------------------------------
[
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) be
//------------------------------------------------------------------------
[
if sb ne lv zn>>ZN.anchor &
(sb+sb>>SB.length ugr zn>>ZN.maxAdr % sb uls zn>>ZN.minAdr) then
AllocBomb(zn)
]
//------------------------------------------------------------------------
and AllocBomb(zn, ec; numargs na) be
//------------------------------------------------------------------------
[
let MalFormedRtn = zn>>ZN.MalFormedRtn ? zn>>ZN.MalFormedRtn, SysErr
MalFormedRtn(zn, (na gr 1? ec, ecIllFormed))
]
] // end compileif DEBUG gr 0
compileif DEBUG gr 1 then
[
//------------------------------------------------------------------------
let CheckZone(zn) be
//------------------------------------------------------------------------
[
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 sb uls zn>>ZN.maxAdr 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 sb+addit ule sb 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)
]
] // end compileif DEBUG gr 1
//---------------------------------------------------------------------------
let InitializeZone(zn, length, OutOfSpaceRtn, MalFormedRtn;
numargs na) = valof
//---------------------------------------------------------------------------
[
compileif (offset ZN.Allocate) ne 0 % (offset ZN.Free) ne 16 then [ foo = 0 ]
DefaultArgs(lv na, 2, SysErr, SysErr) // default only missing args, not zero
zn>>ZN.Allocate = rAllocate
zn>>ZN.Free = rFree
zn>>ZN.OutOfSpaceRtn = 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 = 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 % length ugr #77776 then
AllocBomb(zn, ecZoneAdditionError)
]
sb!lSbFree = -1
compileif DEBUG gr 0 then
[
let sbLast = sb+lSbFree
let min = zn>>ZN.minAdr
test sb uls min
ifso
[
if sbLast uge min then AllocBomb(zn, ecZoneAdditionError)
sb!lSbFree = sbLast-min //New boundary tag
zn>>ZN.minAdr = sb
]
ifnot
[
let max = zn>>ZN.maxAdr
if sb uls max 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 = Umax(lSbData + lSbOverhead, minLSbFree)
compileif DEBUG eq 3 then [ if zn>>ZN.MalFormedRtn then CheckZone(zn) ]
let sbRover = zn>>ZN.rover
let sbOriginalRover = sbRover
[ // repeat
compileif DEBUG eq 1 % DEBUG eq 2 then
[ if zn>>ZN.MalFormedRtn then CheckFreeNode(zn, 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
compileif DEBUG eq 1 % DEBUG eq 2 then
[ if zn>>ZN.MalFormedRtn then CheckBounds(zn, sbRover) ]
if sbNext eq sbOriginalRover then sbOriginalRover = sbNext>>SB.pSbNext
// remove sbNext from his chains and add him to us
sbNext>>SB.pSbNext>>SB.pSbPrevious = sbNext>>SB.pSbPrevious
sbNext>>SB.pSbPrevious>>SB.pSbNext = sbNext>>SB.pSbNext
sbRover>>SB.length = sbRover>>SB.length + sbNext>>SB.length
] repeat
let sb = sbNext - lSb
let extra = sb - sbRover
let siz = sbNext - sbRover
largest = Umax(siz, largest)
// 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 % lSb ls 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
[
if returnOnNoSpace+1 ugr 1 then @returnOnNoSpace = largest-lSbOverhead
resultis 0
]
resultis zn>>ZN.OutOfSpaceRtn(zn, ecOutOfSpace, lSbData)
]
//---------------------------------------------------------------------------
and rFree(zn, sb) = valof
//---------------------------------------------------------------------------
[
// 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
resultis 0
]