1 \ BASE must be DECIMAL.
\r
2 \ 'heapsize' is adjusted to 8 k CELLS from original 16 k CELLS for 8086 hForth.
\r
3 \ Implementation words are hidden in MEMORY-ALLOC-WORDLIST.
\r
8 CHAR " PARSE model" ENVIRONMENT? DROP
\r
9 CHAR " PARSE ROM Model" COMPARE 0=
\r
10 [IF] RAM/ROM@ RAM [THEN]
\r
11 GET-ORDER GET-CURRENT
\r
13 FORTH-WORDLIST SET-CURRENT
\r
14 WORDLIST WORDLIST-NAME MEMORY-ALLOC-WORDLIST
\r
15 MEMORY-ALLOC-WORDLIST SET-CURRENT
\r
16 GET-ORDER MEMORY-ALLOC-WORDLIST SWAP 1+ SET-ORDER
\r
18 \ This is freeware, copyright Gordon Charlton, 12th of September 1994.
\r
19 \ Copy and distribute it. Use it. Don't mess with this file. Acknowledge
\r
20 \ its use. I make no guarentees as to its fitness for any purpose. Tell
\r
21 \ me about any bugs. Tell me how much you like it.
\r
25 \ This is an implementation of the ANS Forth Memory-Allocation Word Set.
\r
26 \ This is an ANS standard program that has the following environmental
\r
27 \ dependency - two's complement arithmetic. It requires four words
\r
28 \ from the core extension: 0> NIP TUCK \
\r
30 \ (If you go to the trouble of checking these claims, please e-mail me
\r
31 \ with your findings; gordon@charlton.demon.co.uk)
\r
33 \ There are five broad areas that the program covers;
\r
35 \ 1, General purpose extensions to the Forth system.
\r
37 \ 2, Creation of the heap and associated use of the data space.
\r
39 \ 3, Allocation of space from the heap.
\r
41 \ 4, Releasing space back to the heap.
\r
43 \ 5, Altering the size of allocated heap space.
\r
46 \ The ANS word set consists of three words, ALLOCATE, FREE, and RESIZE
\r
47 \ which give the minimum functionality required to use the heap. These are
\r
48 \ given in areas 3, 4 and 5 respectively.
\r
50 \ The heap is maintained as a doubly linked ordered circular list of nodes
\r
51 \ with an additional field noting the size of each node and whether it is in
\r
52 \ use. The size of the heap is specified by the constant HEAPSIZE. The
\r
53 \ constant HYSTERESIS controls the amount of spare space that is added to
\r
54 \ an allocation, to reduce the need for block moves during resizing.
\r
56 \ Initially there is only one node, the size of the heap. Aditional nodes
\r
57 \ are created by dividing an existing node into two parts. Nodes are removed
\r
58 \ by marking as free, and merging with adjoining free nodes. Nodes are
\r
59 \ altered in size by merging with a following free node, if possible, and a
\r
60 \ node being created above the new size of the node, if needed, or by
\r
61 \ allocating a new node and block moving the data field if necessary.
\r
63 \ Finding an available node is done by sequential search and comparison. The
\r
64 \ first node to be found that is large enough is used for allocation. Each
\r
65 \ search starts from the node most recently allocated, making this a
\r
66 \ "nextfit" algorithm. The redundancy in the head fields is required to
\r
67 \ optimise the search loop, as is the use of a sentinel to terminate the
\r
68 \ search once every node has been looked at, by always succeeding. A final
\r
69 \ refinement is the use of the sign bit of the size field to mark "in-use"
\r
70 \ nodes so that they are disregarded without a separate test.
\r
73 \ **1** General Purpose Extensions
\r
75 : unique ( ) VARIABLE ;
\r
77 \ Defining word. Each child returns a different non-zero number. The
\r
78 \ standard introduces the need for unique identifiers in the form of IORs
\r
79 \ and THROW codes, but provides no means for generating them. This does
\r
82 : k ( n--n) 1024 * ;
\r
84 \ A convenient way of referring to large numbers. Multiplies a number by
\r
87 0 1 2 UM/MOD NIP 1- CONSTANT maxpos
\r
89 \ The largest positive single length integer.
\r
92 \ **2** Heap Creation
\r
94 \ ANSI Heap --- Constants
\r
96 8 k CELLS CONSTANT heapsize
\r
98 \ Number of address units of data space that the heap occupies.
\r
100 4 CELLS 1- CONSTANT hysteresis
\r
102 \ Node lengths are rounded up according to the value of HYSTERESIS to
\r
103 \ reduce the number of block moves during RESIZE operations. The value of
\r
104 \ this constant must be one less than a power of two and at least equal to
\r
105 \ one less than the size of a cell.
\r
107 unique allocationerror
\r
109 \ Indicates there is less contiguous heap space available than required.
\r
111 3 CELLS CONSTANT headsize
\r
113 \ A node on the heap consists of a three cell head followed by a variable
\r
114 \ length data space. The first cell in the head points to the next node in
\r
115 \ the heap. The second cell indicates the size of the node, and the third
\r
116 \ points to the previous node. The second cell is negated to indicate the
\r
117 \ node is in use. The heap consists of a doubly linked circular list. There
\r
118 \ is no special notation to indicate an empty list, as this situation
\r
121 : adjustsize ( n--n) headsize + hysteresis OR 1+ ;
\r
123 \ The amount of space that is requested for a node needs adjusting to
\r
124 \ include the length of the head, and to incorporate the hysteresis.
\r
126 0 adjustsize CONSTANT overhead
\r
128 \ The size of the smallest possible node.
\r
131 \ ANSI Heap --- Structure
\r
133 CREATE sentinel HERE CELL+ , maxpos , 0 , 0 ,
\r
135 \ A dummy node used to speed up searching the heap. The search, which is
\r
136 \ for a node larger than or equal to the specified size will always succeed.
\r
137 \ The cell that points to the next node is set up so that the there is a zero
\r
138 \ three cells ahead of where it points, where the pointer to the previous
\r
139 \ node (ie the sentinel) should be. This is a special value that indicates the
\r
140 \ search has failed.
\r
142 CREATE heap heapsize ALLOT
\r
144 \ The heap is as described in HEADSIZE.
\r
148 \ Searching is done using a "nextfit" algorithm. NEXTNODE points to the
\r
149 \ most recently allocated node to indicate where the next search is to
\r
152 : >size ( addr--addr) CELL+ ;
\r
154 \ Move from the "next" cell in the node head to the "size" cell. Within the
\r
155 \ word set nodes are referred to by the address of the "next" cell.
\r
156 \ Externally they are referred to by the address of the start of the data
\r
159 : >prev ( addr--addr) 2 CELLS + ;
\r
161 \ Move from the "next" cell to the "previous" cell.
\r
163 : init-heap ( ) heap DUP nextnode !
\r
165 DUP heapsize OVER >size !
\r
168 \ Initially the heap contains only one node, which is the same size as the
\r
169 \ heap. Both the "next" cell and the "previous" cell point to the "next"
\r
170 \ cell, as does NEXTNODE.
\r
174 \ **3** Heap Allocation
\r
176 \ ANSI Heap --- List Searching
\r
178 : attach ( addr) >prev @
\r
182 \ The sentinel is joined into the nodelist. The "next" field of the node
\r
183 \ preceding the one specified (addr) is set to point to the sentinel, and
\r
184 \ the "prev" field of the sentinel to point to the node that points to the
\r
187 : search ( addr size--addr|0)
\r
188 >R BEGIN 2@ SWAP R@ < INVERT UNTIL
\r
191 \ Search the nodelist, starting at the node specified (addr), for a free
\r
192 \ node larger than or equal to the specified size. Return the address of the
\r
193 \ first node that matches, or zero for no match. The heap structure is set up
\r
194 \ to make this a near optimal search loop. The "size" field is next to the "next"
\r
195 \ field so that both can be collected in a single operation (2@). Nodes in
\r
196 \ use have negated sizes so they never match the search. The "previous"
\r
197 \ field is included to allow the search to overshoot the match by one node
\r
198 \ and then link back outside the loop, rather than remembering the address
\r
199 \ of the node just examined. The sentinel removes the need for a separate
\r
200 \ test for failure. SEARCH assumes the sentinel is in place.
\r
202 : detach ( addr) DUP >prev @ ! ;
\r
204 \ Remake the link from the node prior to the one specified to the one
\r
205 \ specified. This will remove the sentinel if it is attached here. (It will
\r
208 : findspace ( size--addr|0) nextnode @
\r
213 \ Search the nodelist for a node larger or equal to that specified. Return
\r
214 \ the address of a suitable node, or zero if none found. The search starts at
\r
215 \ the node pointed to by NEXTNODE, the sentinal temporarily attached, the
\r
216 \ search proceeded with and the sentinel detached.
\r
219 \ ANSI Heap --- Head Creation
\r
221 : fits ( size addr--flag) >size @ SWAP - overhead < ;
\r
223 \ Returns TRUE if the size of the node specified is the same as the
\r
224 \ specified size, or larger than it by less than the size of the smallest
\r
225 \ possible node. Returns FALSE otherwise.
\r
227 : togglesize ( addr) >size DUP @ NEGATE SWAP ! ;
\r
229 \ Negate the contents of the "size" field of the specified node. If the
\r
230 \ node was available it is marked as in use, and vice versa.
\r
232 : next! ( addr) nextnode ! ;
\r
234 \ Make the specified node the starting node for future searches of the node
\r
237 : sizes! ( size addr--addr) 2DUP + >R
\r
238 >size 2DUP @ SWAP -
\r
240 SWAP NEGATE SWAP ! R> ;
\r
242 \ Given a free node (addr), reduce its size to that specified and mark it
\r
243 \ as in use. Start to construct a new node within the specified node beyond
\r
244 \ its new length, by storing the length of the remainder of the node in the
\r
245 \ size field of the new node. Return the address of the partially
\r
246 \ constructed node.
\r
248 : links! ( addr1 addr2) 2DUP SWAP @ 2DUP SWAP ! >prev !
\r
249 2DUP >prev ! SWAP ! ;
\r
252 \ Addr1 is an existing node. Addr2 is the address of a new node just above
\r
253 \ the existing node. Break the links from the existing node to the next
\r
254 \ node and from the next node to the existing node and join the new node to
\r
258 \ ANSI heap --- Node Construction ALLOCATE
\r
260 : newnode ( size addr) TUCK sizes! links! ;
\r
262 \ Given a free node at addr split it into an in-use node of the specified
\r
263 \ size and a new free node above the in-use node.
\r
265 : makenode ( size addr) 2DUP fits IF togglesize DROP
\r
269 \ Given a free node at addr make an in-use node of the specified size
\r
270 \ and free the remainder, if there is any usable space left.
\r
272 FORTH-WORDLIST SET-CURRENT
\r
273 : ALLOCATE ( u--addr ior)
\r
274 DUP 0< IF allocationerror
\r
280 ELSE DROP allocationerror
\r
283 MEMORY-ALLOC-WORDLIST SET-CURRENT
\r
285 \ Make an in-use node with a data field at least u address units long.
\r
286 \ Return the address of the data field and an ior of 0 to indicate success.
\r
287 \ If the space is not available return any old number and an ior equal to the
\r
288 \ constant ALLOCATIONERROR. The standard specifies that the argument to
\r
289 \ ALLOCATE is unsigned. As the implementation uses the sign bit of the size
\r
290 \ field for its own purposes any request for an amount of space greater
\r
291 \ than MAXPOS must fail. As this would be a request for half the
\r
292 \ addressable memory or more this is not unreasonable.
\r
294 \ **4** Releasing Space
\r
296 \ ANSI heap --- Head Destruction
\r
298 : mergesizes ( addr addr)
\r
299 >size @ SWAP >size +! ;
\r
301 \ Make the size field of the node at addr1 equal to the sum of the sizes of
\r
302 \ the two specified nodes. In usage the node at addr2 will be the one
\r
303 \ immediately above addr1.
\r
305 : mergelinks ( addr addr)
\r
309 \ The node at addr2 is removed from the node list. As with MERGESIZES the
\r
310 \ node at addr2 will be immediately above that at addr1. Destroy the link
\r
311 \ from node1 to node2 and relink node1 to the node above node2. Destroy the
\r
312 \ backward link from the node above node2 and relink it to node1.
\r
315 nextnode @ @ >prev @ next! ;
\r
317 \ There is a possibility when a node is removed from the node list that
\r
318 \ NEXTNODE may point to it. This is cured by making it point to the node
\r
319 \ prior to the one removed. We do not want to alter the pointer if it does
\r
320 \ not point to the removed node as that could be detrimental to the
\r
321 \ efficiency of the nextfit search algorithm. Rather than testing for this
\r
322 \ condition we jiggle the pointer about a bit to settle it into a linked
\r
323 \ node. This is done for reasons of programmer amusement. Specifically
\r
324 \ NEXTNODE is set to point to the node pointed to by the "previous" field
\r
325 \ of the node pointed to in the "next" field of the node pointed to by
\r
326 \ NEXTNODE. Ordinarily this is a no-op (ie I am my father's son) but when
\r
327 \ the node has had its links merged it sets NEXTNODE to point to the node
\r
328 \ prior to the node it pointed to (ie when I died my father adopted my son,
\r
329 \ so now my son is my father's son).
\r
332 DUP @ 2DUP mergesizes
\r
333 mergelinks jiggle ;
\r
335 \ Combine the node specified with the node above it. Merge the sizes, merge
\r
336 \ the lengths and jiggle.
\r
339 \ ANSI Heap --- Node Removal FREE
\r
341 : ?merge ( addr1 addr2) >size @
\r
347 \ Merge the node at addr1 with the one above it on two conditions, firstly
\r
348 \ that the node at addr2 is free, and secondly that the node pointed to by
\r
349 \ the next field in addr1 is actually above addr1 (ie that it does not wrap
\r
350 \ around because it is the topmost node). In usage addr2 will be either
\r
351 \ addr1 or the node above it. In each instance the other affected node
\r
352 \ (either the node above addr1 or addr1) is known to be free, so no test is
\r
355 : ?mergenext ( addr) DUP @ ?merge ;
\r
357 \ Merge the node following the specified node with the specified node, if
\r
358 \ following node is free.
\r
360 : ?mergeprev ( addr) >prev @ DUP ?merge ;
\r
362 \ Merge the specified node with the one preceding it, if the preceding node
\r
365 FORTH-WORDLIST SET-CURRENT
\r
366 : FREE ( addr--ior) headsize -
\r
370 MEMORY-ALLOC-WORDLIST SET-CURRENT
\r
372 \ Mark the specified in-use word as free, and merge with any adjacent free
\r
373 \ space. As this is a standard word addr is the address of the data field
\r
374 \ rather than the "next" field. As there is no compelling reason for this
\r
375 \ to fail the ior is zero.
\r
378 \ **5** Resizing Allocated Space
\r
380 \ ANSI Heap --- Node Repairing
\r
384 \ The RESIZE algorithm is simplified and made faster by assuming that it
\r
385 \ will always succeed. STASH holds the minimum information required to make
\r
386 \ good when it fails.
\r
388 : savelink ( addr) @ stash ! ;
\r
390 \ Saves the contents of the >NEXT field of the node being RESIZEd in STASH
\r
393 : restorelink ( addr) stash @ SWAP ! ;
\r
395 \ Converse operation to SAVELINK (above).
\r
397 : fixprev ( addr) DUP >prev @ ! ;
\r
399 \ The >NEXT field of the node prior to the node being RESIZEd should point
\r
400 \ to the node being RESIZEd. It may very well do already, but this makes
\r
403 : fixnext ( addr) DUP @ >prev ! ;
\r
405 \ The >PREV field of the node after the node resized may need correcting.
\r
406 \ This corrects it whether it needs it or not. (Its quicker just to do it
\r
407 \ than to check first.)
\r
409 : fixlinks ( addr) DUP fixprev DUP fixnext @ fixnext ;
\r
411 \ RESIZE may very well merge its argument node with the previous one. It
\r
412 \ may very well merge that with the next one. This means we need to fix the
\r
413 \ previous one, the next one and the one after next. To extend the metaphor
\r
414 \ started in the description of JIGGLE (above), not only did I die, but my
\r
415 \ father did too. This brings my grandfather into the picture as guardian
\r
416 \ of my son. Now to confound things we have all come back to life. I still
\r
417 \ remember who my son is, and my father remembers who his father is. Once I
\r
418 \ know who my father is I can tell my son that I am his father, I can tell
\r
419 \ my father that I am his son and my grandfather who his son is. Thankfully
\r
420 \ we are only concerned about the male lineage here! (In fact nodes
\r
421 \ reproduce by division, like amoebae, which is where the metaphor breaks
\r
422 \ down -- (1) they are sexless and (2) which half is parent and which
\r
425 : fixsize ( addr) DUP >size @ 0>
\r
427 IF OVER - SWAP >size !
\r
433 \ Reconstruct the size field of a node from the address of the head and the
\r
434 \ contents of the >NEXT field provided that the node is free and it is not
\r
435 \ the topmost node in the heap (ie there is no wraparound). Both these
\r
436 \ conditions need to be true for the node to have been merged with its
\r
439 : fixsizes ( addr) DUP fixsize >prev @ fixsize ;
\r
441 \ The two nodes whose size fields may need repairing are the one passed as
\r
442 \ an argument to RESIZE (damaged by ?MERGENEXT) and its predecessor
\r
443 \ (damaged by ?MERGEPREV).
\r
445 : repair ( addr) DUP restorelink
\r
446 DUP fixlinks DUP fixsizes
\r
449 \ Make good the damage done by RESIZE. Restore the >next field, fix the
\r
450 \ links, fix the size fields and mark the node as in-use. Note that this
\r
451 \ may not restore the system to exactly how it was. In particular the pointer
\r
452 \ NEXTNODE may have moved back one or two nodes by virtue of having been
\r
453 \ JIGGLEd about if it happened to be pointing to the wrong node. This is not
\r
454 \ serious, so I have chosen to ignore it.
\r
457 \ ANSI Heap --- Node Movement
\r
459 : toobig? ( addr size--flag)
\r
462 \ Flag is true if the node at addr is smaller than the specified size.
\r
464 : copynode ( addr1 addr2)
\r
465 OVER >size @ headsize -
\r
466 ROT headsize + ROT ROT MOVE ;
\r
468 \ Move the contents of the data field of the node at addr1 to the data
\r
469 \ field at addr2. Assumes addr2 is large enough. It will be.
\r
471 : enlarge ( addr1 size--addr2 ior)
\r
478 \ Make a new node of the size specified. Copy the data field of addr1 to
\r
479 \ the new node. Merge the node at addr1 with the one preceding it, if
\r
480 \ possible. This last behaviour is to finish off removing the node at
\r
481 \ addr1. The word ADJUST (below) starts removing the node. The node is
\r
482 \ removed before allocation to increase the probability of ALLOCATE
\r
483 \ succeeding. The address returned by ENLARGE is that returned by ALLOCATE,
\r
484 \ which is that of the data field, not the head. If the allocation fails
\r
485 \ repair the damage done by removing the node at addr1.
\r
488 \ ANSI Heap --- Node Restructuring RESIZE
\r
490 : adjust ( addr1 size1--addr2 size2) adjustsize >R
\r
494 DUP ?mergenext R> ;
\r
496 \ Addr1 points to the data field of a node, not the "next" field. This
\r
497 \ needs correcting. Size1 also needs adjusting as per ADJUSTSIZE. In
\r
498 \ addition it is easier to work with free nodes than live ones as the size
\r
499 \ field is correct, and, as we intend to change the nodes size we will
\r
500 \ inevitably want to muck about with the next node, if its free, so lets
\r
501 \ merge with it straight away. Sufficient information is first saved to put
\r
502 \ the heap back as it was, if necessary. Now we are ready to get down to
\r
505 FORTH-WORDLIST SET-CURRENT
\r
506 : RESIZE ( addr1 u--addr2 ior)
\r
507 DUP 0< IF DROP allocationerror
\r
514 MEMORY-ALLOC-WORDLIST SET-CURRENT
\r
516 \ Resize the node at addr1 to the specified size. Return the address of the
\r
517 \ resized node (addr2) along with an ior of zero if successful and
\r
518 \ ALLOCATIONERROR if not. Addr2 may be the same as, or different to, addr1.
\r
519 \ If ior is non-zero then addr2 is not meaningful. Being a standard word
\r
520 \ the arguments need adjusting to the internal representation on entry, and
\r
521 \ back again on exit. If after the first merge the requested size is still
\r
522 \ too large to reuse the specified node then it is moved to a larger node
\r
523 \ and the specified node released. If, on the other hand the request is not
\r
524 \ too big for the node, then we remake the node at the right length, and
\r
525 \ free any space at the top using MAKENODE, which has just the right
\r
526 \ functionality. In this case the ior is zero. As this is a standard word it
\r
527 \ takes an unsigned size argument, but excessive requests fail
\r
528 \ automatically, as with ALLOCATE.
\r
530 envQList SET-CURRENT
\r
531 -1 CONSTANT MEMORY-ALLOC
\r
533 SET-CURRENT SET-ORDER
\r
535 CHAR " PARSE model" ENVIRONMENT? DROP
\r
536 CHAR " PARSE ROM Model" COMPARE 0=
\r
537 [IF] RAM/ROM! [THEN]
\r
540 CHAR " PARSE FILE" ENVIRONMENT?
\r
542 0= [IF] << CON [THEN]
\r
public / hf86v099.git / blob