![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to memory.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / bootstrap|
Return to memory.fs CVS log | Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / bootstrap |
1.1 ! root 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: ;
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.