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