![[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.