#comment
     This file is part of Z80 Scheme Interpreter     

     Z80 Scheme Interpreter is free software; you can redistribute it and/or modify
     it under the terms of the GNU General Public License as published by
     the Free Software Foundation; either version 2 of the License, or
     (at your option) any later version.
 
     This program is distributed in the hope that it will be useful,
     but WITHOUT ANY WARRANTY; without even the implied warranty of
     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     GNU General Public License for more details.
 
     You should have received a copy of the GNU General Public License
     along with this program; if not, write to the Free Software
     Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
 
     Copyright 2007, Spencer Putt
#endcomment

; top of the heap
heap			= $9d98		; align it by 4s
; allocation pointer
ap			= textShadow
from_space 		= ap + 2
stack_start 		= from_space + 2
stack_size		= 3000



heap_size	= 17616


; allocate memory for heap
heap_initialize:
	ld (stack_start),sp

	ld hl,heap_size + stack_size
	ld de,heap
	bcall(_insertmem)

	ld hl,heap
	ld (ap),hl
	ld (from_space),hl
	ret



; input
;	none
; output
;	hl - pointer to allocated cons cell
alloc:
	push bc
	push de
	
	ld hl,(ap)
	push hl
		
	ld bc,4
	bit 6,h
	add hl,bc
	ld (ap),hl
	jr nz,_
	ld de,heap + (heap_size/2)
	ld c,l \ ld b,h
	jr ++_
_	ld de,heap + heap_size
	ld bc,heap
_
	sbc hl,de
	jr c,_

	ld (ap),bc
	push bc
	call garbage_collect
	pop hl
	ld (from_space),hl
	
	call alloc
	ex (sp),hl
	
_
	pop hl
	
	pop de
	pop bc
	ret
	
	
; input
;	hl - length of block
; output
;	hl - address of block
;	z - block allocated successfully
;	nz - block couldn't be allocated
#comment
Block format:
	header: first 10 bits size, last 6 bits tag
#endcomment
alloc_block:
	push hl				; save original length
	inc hl
	sra h\ rr l			; /2
	ld b,h
	ld c,l
	
	pop de
	call alloc
	call set_car!_skip		; store the length in cons cells
	ld de,tag_block
	call set_cdr!_skip
	push hl				; save the header address
	
alloc_block_loop:
	call alloc
	
	dec bc
	ld a,b
	or c
	jp nz,alloc_block_loop
alloc_block_done:
	pop hl				; return header address
	ld a,l
	or tag_pair
	ld l,a
	ret
	
alloc_block_fail:
	xor a\ inc a			; reset z
	ret	

	
	
; input
;	hl - block
;	de - index
;	bc - value to write
; output
;	hl - block
;	bc - value written
block_write:
	call block_offset
	ld (hl+),c
	ld (hl),b
	ex de,hl
	ret
	
	
; input
;	hl - block
; output
;	hl - block size
block_size:
	strip_tag(hl)
	ld hl,a,(hl)
	ret
	
; input
;	hl - block
;	de - index
; output
;	hl - value
block_read:
	call block_offset
	ld hl,a,(hl)
	ret


; input
;	hl - block
;	de - offset
; output
;	hl - element address
;	de - block
block_offset:
	strip_tag(hl)
	ex de,hl
	add hl,hl			; put the index in bytes
	inc hl\ inc hl			; skip header
	add hl,de			; get the true address
	ret	
	


; clear up memory taken for heap
heap_deinitialize:
heap_uninitialize:
	ld de,heap_size + stack_size
	ld hl,heap
	bcall(_delmem)
	ret
	
	
	
; input
;	hl - value to store
; output
;	hl - store address
store:
	push de
	ex de,hl
	call alloc
	ld a,l
	or tag_pair
	ld l,a
	call set_car!
	ld de,0
	call set_cdr!
	pop de
	ret
	
	
; input
;	bc - value to store
; output
;	bc - store address
store_bc:
	push hl
	ld h,b\ ld l,c
	call store
	ld b,h\ ld c,l
	pop hl
	ret
	
; input
;	hl - store address
; output
;	hl - value that was stored
unstore:
	jp list_car
	

; input
;	none
; output
;	none
#comment	
First task is to loop through all of the roots.
The roots are contained in a stack called "root_stack."

For each root, copy the cons cell to to-space.  In the 
"car" of the from-space cons cell, place a pointer to the
to-space cell.
	
After all the roots' direct children are in to-space,
loop through the cars and cdrs of the to-space
cons cells and move any cells occur in
from-space to to-space.
#endcomment


garbage_collect:
	ld hl,(ap)
	push hl
	ld (sp_save),sp
	
copy_root_loop:
	xor a
	ld h,a\ ld l,a
	add hl,sp
	ld de,(stack_start)
	sbc hl,de
	jr z,copy_root_done
	
	pop hl				; pop the first root
	call new_cell_loc
	push hl				; restore the address back to the root
	pop hl
	jp copy_root_loop
	
copy_root_done:
	ld sp,(sp_save)
	pop hl				; restore start of stack

child_update_loop:
	ld de,(ap)	
	or a
	sbc hl,de
	ret nc
	add hl,de

	ld e,(hl)\ inc l
	ld d,(hl)\ dec l
	push hl

	ex de,hl
	call new_cell_loc
	
	ex de,hl
	pop hl
	ld (hl),e\ inc l
	ld (hl),d\ inc hl
	jp child_update_loop
	
; input
;	hl - single word address referring to heap structure
; output
;	hl - new word
new_cell_loc:
	bit 0,l				; check to see if it's a heap structure
	ret z

	or a
	ld de,(from_space)
	ld c,l\ ld b,h
	sbc hl,de
	jr c,ex_heap
	ld de,heap_size/2
	sbc hl,de
	ld l,c\ ld h,b
	ret nc				; is the address inside the heap?

	ld a,tag_mask
	and l
	ld c,a				; c has the tag
	xor l
	ld l,a
	ld e,(hl+)
	ld d,(hl)			; hl has object's heap address + 1
	
	bit 0,e
	ex de,hl
	jr z,new_cell_copy
	
	ld a,(ap+1)
	xor h				; if the pointer inside refers to the same heap
	bit 6,a				; as the allocation pointer, it MUST be a forwarding
	ret z				; pointer
	
new_cell_copy:
	dec e				; de refers to the first byte of the cons cell			
	ld a,c				; a <- tag
	cp tag_pair
	jr nz,single_cell_copy
	
	ld h,d\ ld l,e
	inc hl
	inc hl
	ld hl,a,(hl)		
	and escape_mask
	cp tag_block
	jr nz,single_cell_copy
	
	ld h,d\ ld l,e
	ld hl,a,(hl)			; car is block size (FORMERLY: CALL BLOCK_SIZE)
	inc hl				; add header cell
	ld a,l
	rra
	adc hl,hl			; put length in bytes
	ld b,h\ ld c,l
	ld a,tag_pair
	jr block_copy
	
single_cell_copy:
	ld a,c
	ld bc,4
block_copy:
	ld hl,(ap)
	add hl,bc
	ld (ap),hl
	ex de,hl
	add hl,bc			; move both to the end
	
	dec hl
	dec de
	lddr				; copy the cons cell to to-space
	
	inc hl
	inc de
	
	or e
	ld e,a				; put the tag back on de
	ld (hl),e\ inc l
	ld (hl),d			; place the forwarding address
	ex de,hl
	ret
	
ex_heap:
	ld l,c
	ld h,b
	ret