SUBT > Sys.Heap ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; + H E A P O R G A N I S A T I O N + ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; 'freelist' points to the first block in the list ; The link field is NIL for the last block in the list ; Block sizes must be forced to a multiple of 8 bytes for subsequent link and ; size information to be stored in them if they are disposed of by the user. ; Blocks in the free space list have the form : ; +--+--+--+--+--+--+--+--+--+ ~ -+--+ ; | long link | long size | | ; +--+--+--+--+--+--+--+--+--+ ~ -+--+ ; 0 1 2 3 4 5 6 7 8 (size-1) ^ 0 frelink # 4 fresize # 4 freblksize # 0 ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; BL code &DC - Pr_New. Address of pointer variable on TOS ; procedure new (var ^object); {NB. ISO 6.6.5.3 would quibble about this !} ; In : size = bytes to claim iNew STASH link BL GetArea ; addr -> area claimed POP temp STR addr, [temp] GRAB pc ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; BL code &DE - Pr_Dispose. Address of area to dispose on TOS ; procedure dispose (^object); ; In : size = bytes to free iDispose STASH link POP addr CMP addr, #0 BEQ eDisposeNil BL FreeArea ; addr -> area to free GRAB pc ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; BL code &FA - FnX_Claim. Integer (4b) arg on TOS ; extension function claim (size : integer) : integer; iClaim STASH link POP size BL GetArea PUSH addr ; addr -> area claimed GRAB pc ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; BL code &A8 - FnX_Release. Two integer (4b) args on TOS ; extension procedure release (block_address, size : integer); iRelease STASH link POP size POP addr BL FreeArea ; addr -> area to free GRAB pc ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; Allocate a block of memory from the heap ; This will allocate the first block of sufficiently large size in the free ; list, with an oversize block being split. The heap starts off at zero size ; (freelist = NIL), so failure to find a large enough block on the free list ; will try to claim more space for the heap from the system ; In : size = size of block required ; Out : addr -> block of length (size := ((size + 7) & &FFFFFFF8)) GetArea ROUT STASH "temp, tp, link" [ debheap BL ShowHeap ] ADD size, size, #(freblksize-1) ; Make block size granular BIC size, size, #(freblksize-1) SUB addr, globalbase, #freelist ; addr := @freelist garloop MOV tp, addr ; tp := addr - keep ptr to prev block LDR addr, [addr, #frelink] ; addr := !addr CMP addr, #Nil ; Is this block the end of the chain ? BEQ garmore ; If so, try to get more from system LDR temp, [addr, #fresize] ; If length < size then this is no good SUBS temp, temp, size ; In case this works, for below split BCC garloop [ debheap WRLN "Got a block" ] ; Now addr -> a block that our item will fit in ; If we have an exact fit (or as close as the granularity of the free list will ; allow), unlink this block and return it LDREQ temp, [addr, #frelink] ; Put this block's link field in that STREQ temp, [tp, #frelink] ; of the previous block LDMEQDB hasp!, {temp, tp, pc}^ ; RESULTIS addr [ debheap WRLN "Splitting block" ] ; Need to split the block, returning the end portion to the caller STR temp, [addr, #fresize] ; Adjust size of block remaining ADD addr, addr, temp ; addr -> block just deallocated GRABS "temp, tp, pc" ; RESULTIS addr ; Got no more blocks of length >= size, so try to allocate more heap space garmore LV addr, htop SUB addr, addr, size ; addr := (htop -:= size) SV addr, htop [ debheap WRLN "Getting more" ] LV temp, shwm CMP temp, addr ; See if this is too low to go on LDRHI link, [hasp, #-4-12] ; Get stashed link from mainline code BHI eHeapHitStack ; Library, so branch, not link GRABS "temp, tp, pc" ; RESULTIS addr ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; FreeArea - Return an area of store to the heap ; In : addr -> block to free, size = length of block ; The block to be freed is matched against those on the free list and inserted ; in it's correct place, with the list being maintained in ascending address ; order. If possible, the freed block is merged with contigous blocks above ; and below it to give less fragmentation, and if contiguous with main memory, ; is merged with that. If the latter, check to see if there is a block which ; would be made contiguous with main memory by the former's freeing, and if so, ; merge that with main memory too. Phew ! FreeArea ROUT STASH "temp, arse, bp, tp, link" [ debheap BL ShowHeap SWI Newline STRIM "Disposing of " MOV r0, addr BL HexLongSlash MOV r0, size BL HexLongLine ] ADD size, size, #(freblksize-1) ; Make block size granular BIC size, size, #(freblksize-1) ADD arse, addr, size ; arse -> end of block LV temp, htop CMP addr, temp ; Is it contiguous with main memory ? BNE %FT07 [ debheap WRLN "Cont with main memory" ] LV temp, freelist ; Does this allow any more to be freed CMP arse, temp STRNE arse, [globalbase, #-htop] LDMNEDB hasp!, {temp, arse, bp, tp, pc}^ ; Doesn't free anything else LDR arse, [temp, #fresize] ADD arse, arse, temp ; Bump up htop SV arse, htop LDR temp, [temp, #frelink] ; Copy link field to freelist SV temp, freelist GRABS "temp, arse, bp, tp, pc" ; Bye bye ! 07 SUB bp, globalbase, #freelist ; BP := @freelist ; $( TP := BP; BP := BP!fre.link $) repeatuntil (BP >= addr) or (BP = NIL) freloop MOV tp, bp ; TP := BP LDR bp, [bp, #frelink] ; BP := BP!fre.link CMP bp, #Nil ; Is this block the end of the chain ? [ debheap BNE %FT13 WRLN "End of free chain" B freblk 13 ] BEQ freblk ; If so, link ours on the end CMP bp, addr ; Correct position for insertion ? BCC freloop ; Nope, so loop ; If contiguous with next block (arse >= BP) then merge blocks ; i.e. increase size by amount in next block and point at next block after that [ debheap WRLN "Correct insertion" ] CMP arse, bp LDRCS temp, [bp, #fresize] ; size +:= BP!fre.size ADDCS size, size, temp LDRCS bp, [bp, #frelink] ; BP := BP!fre.link [ debheap BCC %FT42 WRLN "Contig with upper block" 42 ] freblk ; Link our block into the free space list ; If contiguous with previous block (TP + TP!fre.size >= addr) then merge CMP tp, globalbase ; Is tp still @freelist ? Nasty sort of check ! LDRCS temp, [tp, #fresize] ADDCS temp, tp, temp ; CC state here -> tp = @freelist, drop thru unchanged, not doing CMP CMPCS temp, addr ; Is freed blk contiguous with prev blk STRCC addr, [tp, #frelink] ; Save info 'cos we're about to exit STRCC bp, [addr, #frelink] STRCC size, [addr, #fresize] LDMCCDB hasp!, {temp, arse, bp, tp, pc}^ ; Copy freed link field to previous link, and increase size of previous block [ debheap WRLN "Contig with lower blk" ] STR bp, [tp, #frelink] ; TP!fre.link := BP SUB temp, temp, tp ; TP!fre.size +:= addr!fre.size (size) ADD size, size, temp STR size, [tp, #fresize] GRABS "temp, arse, bp, tp, pc" [ debheap ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; Dump the heap for all the world to see ! ShowHeap ROUT SWI Newline STRIM "**** Heap map **** : freelist = " STASH "r0, r1, arse, addr, bp, tp, link" LV addr, memtop LV bp, htop LV tp, freelist MOV r0, tp BL HexLongWord STRIM ", htop = " MOV r0, bp BL HexLongLine CMP tp, #Nil ; No free blocks at all ? BNE %FT10 WRLN "No Free Blocks" CMP bp, addr ; Is a block allocated at all ? MOVNE r0, bp ; htop BNE %FT40 WRLN "No Used Blocks" B %FT99 10 CMP tp, bp ; htop ; Allocated block below first free ? BEQ %FT15 MOV r0, bp ; htop BL HexUsedBlk SUB r0, tp, bp ; tp-htop BL HexLongLine 15 LDR r1, [tp, #frelink] LDR arse, [tp, #fresize] STRIM "Free Block, " MOV r0, tp BL HexLongSlash MOV r0, arse BL HexLongLine ADD r0, arse, tp ; r0 -> blkend. Adjacent free blocks don't exist CMP r1, #Nil ; If last block, then must we see if we're = memtop BEQ %FT40 BL HexUsedBlk SUB r0, r1, r0 BL HexLongLine MOV tp, r1 B %BT15 ; And loop 40 CMP r0, addr ; Is there any alllocated space after this block ? BLNE HexUsedBlk SUBNE r0, addr, r0 ; memtop-blkend BLNE HexLongLine 99 GRABS "r0, r1, arse, addr, bp, tp, pc" HexUsedBlk STRIM "Used Block, " B HexLongSlash ] LNK Sys.EndSection