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