A compact, simple implementation of a garbage-collected cons-pair heap utilizing Cheney's algorithm.

Garbage.fs

\
\ Garbage.fs
\
\  A compact, simple implementation of a garbage-collected
\  cons-pair heap utilizing Cheney's algorithm.
\  Pointers to pairs are identified by a pattern in the
\  high-order bits of a value, chosen not to collide
\  with the constants "true" or "false".
\

$60000000 $40000000
cell 8 = [if] 32 lshift swap 32 lshift swap [then]
constant pair-flag constant pair-mask
pair-mask invert   constant pair-bits

: pair?   pair-mask and pair-flag = ; ( n -- flag )
: pair>   pair-bits and             ; ( pair -- addr )
: >pair   pair-flag or              ; ( addr -- pair )
: first   pair>        @            ; ( pair -- first )
: rest    pair> cell + @            ; ( pair --  rest )
: first!  pair>        !            ; ( value pair -- )
: rest!   pair> cell + !            ; ( value pair -- )
:  split  dup first swap rest       ; ( pair -- first rest )
: -split  dup rest  swap first      ; ( pair -- rest first )

4096 cells constant heap-size
create heap1 heap-size allot
create heap2 heap-size allot
variable head  heap1 head !
variable from  heap1 from !
variable to    heap2 to   !

: init-pair ( first rest -- pair )
  head @ dup >r
	2! 2 cells head +!
	r> >pair
;

: gc-copy ( pair -- )
	pair> dup from @ head @ within if
		dup dup 2@ init-pair swap !
	then drop
;

: follow ( addr -- )
	dup @ pair? if
		dup @ gc-copy
		dup @ pair> @ over !
	then drop
;

: gc-scan  do i follow cell +loop ; ( max min -- )

: gc ( -- )
	to @ head !
	sp0 @ sp@ gc-scan
	rp0 @ rp@ gc-scan

	to @ begin
		dup head @ < while
		dup follow cell +
	repeat drop

	from @ to @ from ! to !
;

: enough?  head @ from @ heap-size + <= ; ( -- flag )

: pair ( first rest -- pair )
	enough? if init-pair exit then gc
	enough? if init-pair exit then
	abort" Heap exhausted!"
;