nxu/alloc.tal

( 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 ,&notfound 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* )
    &notfound                         ( 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 ,&notfound JCN    ( end* arena* [addr*] )
        DUP2 ;arena-data JSR2           ( end* arena* start* [addr*] )
        STH2kr GTH2 ,&notfound 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 )
    &notfound                           ( 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