( alloc.tal ) ( ) ( SUMMARY ) ( ) ( this code can be used to dynamically claim and release memory. ) ( ) ( OVERVIEW ) ( ) ( memory is allocated using arenas which track which memory is free ) ( and which memory is allocated. each arena can allocate items of a ) ( fixed size (k bytes), and these arenas are configured at program ) ( start using ;init-arena. ) ( ) ( an arena that can allocate n items of k bytes each has an overhead ) ( of ceil(n/8)+6 bytes; it will occuppy n*k+ceil(n/8)+6 bytes total. ) ( ) ( each slot of memory of size k is tracked using 1 bit in the header's ) ( bitset. we will "mark" the slot using 1 when the memory is allocated ) ( and we will "free" the slot using 0 when the memory is free and ) ( ready to be used again. ) ( ) ( this system has no means of compacting memory in use to maximize ) ( contiguous free memory. however the entire arena can be efficiently ) ( cleared in a single operation. ) ( ) ( ARENA LAYOUT ) ( ) ( ADDR SIZE DESCRIPTION ) ( a 2 bytes item size (k) ) ( a+2 2 bytes next-arena-addr (a+t) ) ( a+4 2 bytes data-addr (a+6+h) ) ( a+6 ceil(n/8) bytes header bitset (h = n bits) ) ( a+6+h nk bytes n item slots ) ( a+6+h+nk ... (next arena starts here) ) ( ) ( MAJOR WORDS ) ( ) ( NAME EFFECT DESCRIPTION ) ( init-arena n* k* -> arena* create arena holding n k-byte slots ) ( clear-arena arena* -> free all memory in the given arena ) ( alloc arena* -> addr* allocate one slot of the given arena ) ( alloc-of k* -> addr* find k-byte arena and allocate slot ) ( free addr* -> find the given slot and free it ) ( ) ( ERROR DETECTION ) ( ) ( words that return arenas or addresses typically use 0000 or ffff to ) ( signal errors. however, some words (such as free) will silently fail ) ( if given invalid arguments. passing an invalid arena address will ) ( likely corrupt your program's memory. ) ( store up to n k-byte items ) ( ) ( total memory usage: n * k + ceil(n/8) + 6 ) ( ) ( returns 0000 if allocated region is larger than remaining space ) @init-arena ( n* k* -> arena* ) DUP2 ,&k STR2 ( n k ) OVR2 #0007 ADD2 #03 SFT2 DUP2 ,&h STR2 ( n k h ) STH2 ( n k [h] ) MUL2 STH2r ADD2 ( nk+h ) #0006 ADD2 ,&t STR2 ( ; t <- nk+h+6 ) ;arena-pos LDA2 DUP2 ,&t LDR2 ADD2 GTH2k ,&toobig JCN ( a0 a1=a0+t ) DUP2 ;arena-pos STA2 ( a0 a1 ) SWP2 STH2k INC2 INC2 STA2 ( [a0] ; a0+2<-a1 ) ,&k LDR2 STH2kr STA2 ( [a0] ; a0<-k ) STH2kr ,&h LDR2 ADD2 #0006 ADD2 STH2kr #0004 ADD2 STA2 ( [a0] ; a0+4<-a0+6+h ) STH2r JMP2r ( a0 ) &toobig POP2 POP2 POP2 POP2 POP2 #0000 JMP2r ( 0000 ) [ &k $2 &h $2 &t $2 ] ( free all slots in the given arena ) ( ) ( if an invalid arena is provided corruption will occur ) @clear-arena ( arena* -> ) DUP2 ;arena-data JSR2 STH2 ( arena [data] ) ;arena-header JSR2 STH2 ( [data header] ) #00 ( 00 [limit pos] ) &loop ( 00 [limit pos] ) GTH2kr STHr ,&ok JCN ( 00 [limit pos] ) ,&done JMP ( 00 [limit pos] ) &ok ( 00 [limit pos] ) DUP STH2kr STA INC2r ( 00 [limit pos+1] ) ,&loop JMP ( 00 [limit pos+1] ) &done ( 00 [limit pos] ) POP POP2r POP2r JMP2r ( ) ( allocate one slot of the given arena ) ( ) ( returns 0000 if allocation fails ) @alloc ( arena* -> addr* ) DUP2 ;find-open-slot JSR2 ( arena index ) DUP2 #ffff EQU2 ,&failed JCN ( arena index ) OVR2 OVR2 ;mark-slot JSR2 ( arena index ) STH2 DUP2 ;arena-item JSR2 STH2r MUL2 ( arena index*k ) SWP2 ;arena-data JSR2 ADD2 JMP2r ( data+index*k ) &failed DUP2 EOR2 JMP2r ( 0000 ) ( allocate one k-byte slot, finding the appropraite arena ) ( ) ( this word will fail if a k-byte arena wasn't already initialized ) ( ) ( returns 00000 if allocation fails ) @alloc-of ( k* -> addr* ) ;find-arena JSR2 ORAk ( arena* arena-is-zero^ ) ,&ok JCN JMP2r ( 0000 ) &ok ;alloc JMP2 ( addr* ) ( free the slot corresponding to the given address ) ( ) ( if the address is not part of an arena this word does nothing ) ( ) ( if an unmanaged address is provided nothing will happen ) @free ( addr* -> ) ;find-addr JSR2 ORAk #00 EQU ,&skip JCN ;erase-slot JMP2 &skip POP2 JSR2 ( reading metadata from the arena ) @arena-item ( arena* -> k* ) LDA2 JMP2r @arena-next ( arena* -> addr* ) INC2 INC2 LDA2 JMP2r @arena-data ( arena* -> addr* ) #0004 ADD2 LDA2 JMP2r @arena-header ( arena* -> addr* ) #0006 ADD2 JMP2r ( find the arena for item size k, if any. ) ( ) ( returns 0000 if no arena can be found ) @find-arena ( k* -> arena* ) STH2 ;arena-pos LDA2 ;arenas ( end* arena0* [k*] ) &loop ( end* arena ) GTH2k #00 EQU ,¬found JCN ( end* arena* ) LDA2k STH2kr EQU2 ,&found JCN ( end* arena* [k*] ) ;arena-next JSR2 ,&loop JCN ( end* next* [k*] ) &found ( end* arena* [k*] ) POP2r NIP2 JMP2r ( arena* ) ¬found ( end* addr* [k*] ) POP2r POP2 POP2 #0000 JMP2r ( 0000 ) ( find the arena and slot index (if any) for the given address ) ( ) ( returns 0000 0000 if address does not belong to an arena ) @find-addr ( addr* -> arena* index* ) STH2 ;arena-pos LDA2 ;arenas ( end* arena0* [addr*] ) &loop ( end* arena [addr*] ) GTH2k #00 EQU ,¬found JCN ( end* arena* [addr*] ) DUP2 ;arena-data JSR2 ( end* arena* start* [addr*] ) STH2kr GTH2 ,¬found JCN ( end* arena* [addr*] ) DUP2 ;arena-next JSR2 ( end* arena* next* [addr*] ) DUP2 STH2kr GTH2 ,&found JCN ( end* arena* next* [addr*] ) NIP2 ,&loop JCN ( end* next* [addr*] ) &found ( end* arena* next* [addr*] ) POP2 NIP2 ( arena* [addr*] ) DUP2 ;arena-data JSR2 STH2r ( arena* start* addr* ) SWP2 SUB2 ( arena* delta*=addr-start ) OVR2 LDA2 DIV2 JMP2r ( arena* slot*=delta/k ) ¬found ( end* arena* [addr*] ) POP2r POP2 DUP2 EOR2 DUP2 JMP2r ( 0000 0000 ) ( finds the index of the first open slot, if any ) ( ) ( returns the index of the slot ) ( ) ( if all slots are full returns ffff ) @find-open-slot ( arena* -> index* ) STH2k ;arena-data JSR2 ( data [a] ) STH2r ;arena-header JSR2 ( data h ) LIT2r 0008 LIT2r 0000 ( data h [8 0] ) &loop ( data h [8 i] ) GTH2k #00 EQU ,&failed JCN ( data h [8 i] ) LDAk #ff NEQ ,&found JCN ( data h [8 i] ) INC2 OVR2r ADD2r ( data h [8 i+8] ) ,&loop JMP ( data h [8 i+8] ) &failed ( data header [8 i] ) POP2 POP2 POP2r POP2r ( ) #ffff JMP2r ( 0000 ) &found ( data h [8 i] ) NIP2 NIP2r LDA ( bits [i] ) #80 SWP ( 80 bits [i] ) &loop2 ( 80 bits [i] ) GTHk ,&done2 JCN ( 80 bits [i] ) DUP ADD INC2r ,&loop2 JMP ( 80 bits<<1 [i+1] ) &done2 ( 80 _ [index] ) POP2 STH2r JMP2r ( index ) ( mark a given slot in the arena as allocated ) ( ) ( corruption will occur if an invalid arena or index are provided ) @mark-slot ( arena* index* -> ) SWP2 OVR2 ( index* arena* index* ) #03 SFT2 ADD2 #0006 ADD2 STH2 ( index* [addr*=arena+index/8] ) #0007 AND2 NIP #80 SWP SFT ( bit^=80>>(index&7) [addr*] ) LDAkr STHr ORA ( new^=old|bit [addr*] ) STH2r STA JMP2r ( ) ( deallocate a given slot in the arena ) ( ) ( corruption will occur if an invalid arena or index are provided ) @erase-slot ( arena* index* -> ) SWP2 OVR2 ( index* arena* index* ) #03 SFT2 ADD2 #0006 ADD2 STH2 ( index* [addr*=arena+index/8] ) #ff7f SWP2 #0007 AND2 NIP ( ff7f sh^=(index&7) [addr*] ) SFT2 NIP ( mask^=ff7f>>sh [addr*] ) LDAkr STHr AND ( new^=old&mask [addr*] ) STH2r STA JMP2r ( ) ( keeps track of the limit of our arenas ) ( ) ( this will be the memory address of the next arena ) @arena-pos :arenas ( the starting point of all arenas ) ( ) ( memory addresses before this point are guaranteed ) ( not to belong to any arena. ) @arenas