forth/bootstrap/memory.fs

   1 \ tag: forth memory allocation
   2 \
   3 \ Copyright (C) 2002-2003 Stefan Reinauer
   4 \
   5 \ See the file "COPYING" for further information about
   6 \ the copyright and warranty status of this work.
   7 \
   8
   9 \ 7.3.3.2 memory allocation
  10
  11 \ these need to be initialized by the forth kernel by now.
  12 variable start-mem 0 start-mem !        \ start of memory
  13 variable end-mem   0 end-mem   !        \ end of memory
  14 variable free-list 0 free-list !        \ free list head
  15
  16 \ initialize necessary variables and write a valid
  17 \ free-list entry containing all of the memory.
  18 \   start-mem: pointer to start of memory.
  19 \   end-mem:   pointer to end of memory.
  20 \   free-list: head of linked free list
  21
  22 : init-mem ( start-addr size )
  23   over dup
  24   start-mem !           \ write start-mem
  25   free-list !           \ write first freelist entry
  26   2dup /n - swap !      \ write 'len'  entry
  27   over cell+ 0 swap !   \ write 'next' entry
  28   + end-mem  !          \ write end-mem
  29   ;
  30
  31 \ --------------------------------------------------------------------
  32
  33 \ return pointer to smallest free block that contains
  34 \ at least nb bytes and the block previous the the
  35 \ actual block. On failure the pointer to the smallest
  36 \ free block is 0.
  37
  38 : smallest-free-block ( nb -- prev ptr | 0 0 )
  39   0 free-list @
  40   fffffff 0 0 >r >r >r
  41   begin
  42     dup
  43   while
  44     ( nb prev pp R: best_nb best_pp )
  45     dup @ 3 pick r@ within if
  46       ( nb prev pp )
  47       r> r> r> 3drop            \ drop old smallest
  48       2dup >r >r dup @ >r       \ new smallest
  49     then
  50     nip dup                     \ prev = pp
  51     cell + @                    \ pp = pp->next
  52   repeat
  53   3drop r> drop r> r>
  54 ;
  55
  56
  57 \ --------------------------------------------------------------------
  58
  59 \ allocate size bytes of memory
  60 \ return pointer to memory (or throws an exception on failure).
  61
  62 : alloc-mem ( size -- addr )
  63
  64   \ make it legal (and fast) to allocate 0 bytes
  65   dup 0= if exit then
  66
  67   aligned                       \ keep memory aligned.
  68   dup smallest-free-block       \ look up smallest free block.
  69
  70   dup 0= if
  71     \ 2drop
  72     -15 throw \ out of memory
  73   then
  74
  75   ( al-size prev addr )
  76
  77   \ If the smallest fitting block found is bigger than
  78   \ the size of the requested block plus 2*cellsize we
  79   \ can split the block in 2 parts. otherwise return a
  80   \ slightly bigger block than requested.
  81
  82   dup @ ( d->len ) 3 pick cell+ cell+ > if
  83
  84     \ splitting the block in 2 pieces.
  85     \ new block = old block + len field + size of requested mem
  86     dup 3 pick cell+ +  (  al-size prev addr nd )
  87
  88     \ new block len = old block len - req. mem size - 1 cell
  89     over @              ( al-size prev addr nd addr->len )
  90     4 pick              ( ... al-size )
  91     cell+ -             ( al-size prev addr nd nd nd->len )
  92     over !              ( al-size prev addr nd )
  93
  94     over cell+ @        ( al-size prev addr nd addr->next )
  95                         \ write addr->next to nd->next
  96     over cell+ !        ( al-size prev addr nd )
  97     over 4 pick swap !
  98   else
  99     \ don't split the block, it's too small.
 100     dup cell+ @
 101   then
 102
 103   ( al-size prev addr nd )
 104
 105   \ If the free block we got is the first one rewrite free-list
 106   \ pointer instead of the previous entry's next field.
 107   rot dup 0= if drop free-list else cell+ then
 108   ( al-size addr nd prev->next|fl )
 109   !
 110   nip cell+     \ remove al-size and skip len field of returned pointer
 111
 112   ;
 113
 114
 115 \ --------------------------------------------------------------------
 116
 117 \ free block given by addr. The length of the
 118 \ given block is stored at addr - cellsize.
 119 \
 120 \ merge with blocks to the left and right
 121 \ immediately, if they are free.
 122
 123 : free-mem ( addr len -- )
 124
 125   \ we define that it is legal to free 0-byte areas
 126   0= if drop exit then
 127   ( addr )
 128
 129   \ check if the address to free is somewhere within
 130   \ our available memory. This fails badly on discontigmem
 131   \ architectures. If we need more RAM than fits on one
 132   \ contiguous memory area we are too bloated anyways. ;)
 133
 134   dup start-mem @ end-mem @ within 0= if
 135  \   ." free-mem: no such memory: 0x" u. cr
 136     exit
 137   then
 138
 139   /n -                          \ get real block address
 140   0 free-list @                 ( addr prev l )
 141
 142   begin                         \ now scan the free list
 143     dup 0<> if                  \ only check len, if block ptr != 0
 144       dup dup @ cell+ + 3 pick <
 145     else
 146       false
 147     then
 148   while
 149     nip dup                     \ prev=l
 150     cell+ @                     \ l=l->next
 151   repeat
 152
 153   ( addr prev l )
 154
 155   dup 0<> if                            \ do we have free memory to merge with?
 156
 157     dup dup @ cell+ + 3 pick  = if      \ hole hit. adding bytes.
 158       \ freeaddr = end of current block -> merge
 159       ( addr prev l )
 160       rot @ cell+               ( prev l f->len+cellsize )
 161       over @ +                  \ add l->len
 162       over !                    ( prev l )
 163       swap over cell+ @         \ f = l; l = l->next;
 164
 165       \ The free list is sorted by addresses. When merging at the
 166       \ start of our block we might also want to merge at the end
 167       \ of it. Therefore we fall through to the next border check
 168       \ instead of returning.
 169       true                              \ fallthrough value
 170     else
 171       false                             \ no fallthrough
 172     then
 173     >r                                  \ store fallthrough on ret stack
 174
 175     ( addr prev l )
 176
 177     dup 3 pick dup @ cell+ + = if       \ hole hit. real merging.
 178       \ current block starts where block to free ends.
 179       \ end of free block addr = current block -> merge and exit
 180                                         ( addr prev l )
 181       2 pick dup @                      ( f f->len )
 182       2 pick @ cell+ +                  ( f newlen )
 183       swap !                            ( addr prev l )
 184       3dup drop
 185       0= if
 186         free-list
 187       else
 188         2 pick cell+
 189       then                              ( value prev->next|free-list )
 190       !                                 ( addr prev l )
 191       cell+ @ rot                       ( prev l->next addr )
 192       cell+ ! drop
 193       r> drop exit                      \ clean up return stack
 194     then
 195
 196     r> if 3drop exit then               \ fallthrough? -> exit
 197   then
 198
 199   \ loose block - hang it before current.
 200
 201   ( addr prev l )
 202
 203   \ hang block to free in front of the current entry.
 204   dup 3 pick cell+ !                    \ f->next = l;
 205   free-list @ = if                      \ is block to free new list head?
 206     over free-list !
 207   then
 208
 209   ( addr prev )
 210   dup 0<> if                            \ if (prev) prev->next=f
 211     cell+ !
 212   else
 213     2drop                               \ no fixup needed. clean up.
 214   then
 215
 216   ;