;;; Copyright (c) 2021-2022 Ufasoft  http://ufasoft.com  mailto:support@ufasoft.com,  Sergey Pavlov  mailto:dev@ufasoft.com
;;;
;;; SPDX-License-Identifier: MIT

;;; Mark-and-Sweep Garbage Collector

.SBTTL	Garbage Collector

.MACRO	.MTEST
	CALL	(R3)		; CALL TSTMSK
.ENDM


; IN: R0 = pointer to heap CELL
; OUT: R0 = R0 + 4
; Clobber: R1, R4, R5
M.BIT::	MOV	R0, R1
	BIT	(R0)+, (R0)+	; R0 += 4
M.BIT1:	.MTEST
	BISB	R4, (R5)	; Else mark
R.RTI:	RTI


.MACRO	.MBIT
	IOT
.ENDM


;; Mark & Push Object to process later
;; R0: &Object + 2
;; OUTPUT R0: R0-2
M.PUSH::
	MOV	-(R0), R1
	CALL	HEAPP
	BCC	R.RTI		; Non-heap object
	.MTEST
	BNE	R.RTI		; Already marked
	BISB	R4, (R5)
;; Mark immediately if it is DOUBLE or STRING
	MOV	(R0), R5
	ROR	R5
	ROR	R5
	BCC	8$		; non-(DOUBLE or STRING)
	BPL	M.BIT1		; mark second cell of DOUBLE
				; String case
	PUSH	R2
	CLR	R2
	BISB	-7(R1), R2	; R2: String length
2$:	SUB	#4, R2
	BLO	3$
	.MTEST
	BISB	R4, (R5)
	BR	2$
3$:	POP	R2
	RTI
8$:	MOV	(R0), 2(SP)	; Postpend object for marking
	RETURN

MASKTB:	.BYTE	1, 2, 4, 10, 20, 40, 100, 200

.MACRO	.MPUSH
	BPT
.ENDM

; IN: R1 - pointer to heap object
; RETURNS:  R5: Pointer into GCBM, R4: bitmask; ZF=0 if the object is marked, R1 += 4
TSTMSK: MOV	R1, R5
	CLR	R4			; and set CF=0
	ROR	R5			; Assume CF=0 (does matter when EHEAP > 32K)
        ASR	R5
        ASR	R5
        ROL	R4
        ASR	R5
        ROL	R4
        ASR	R5              	; Get remaining bits = index in Bitmap
        ROL	R4           		; R4: lowest significant bits
        MOVB	MASKTB(R4), R4
	ADD	(PC)+, R5		; R5: address in GC bitmap
I.BMOF:	.WORD	0			;SELF-MODIFYING CODE
.IIF EQ C$VM1,	ADD	#4, R1
.IIF NE C$VM1,	BIT	(R1)+, (R1)+	; R1 += 4;
	BITB	R4, (R5)
	RETURN

GC:
.IF NE C$BK10
	MOV	(SP), (PC)+
GCRET::	.WORD	0			; Return address @GCRET at Stack may be changed by I.STOP

	PUSH	$KBCTL
	BIS	#$KBDI, $KBCTL		; Disable Keyboard interrupt to use Status Line as GC bitmap

	MOV	(PC)+, R2
GCBMSZ:: .WORD	40000 - HEAP / 32.	; GC bitmap size
	MOV	$BAZVP, R1		; Find continuous space of GCBMSZ bytes in status line for GC bitmap temporary space
	CMP	R1, R2
	BHIS	1$
	SUB	R2, R1
	BIC	#100000, R1
1$:	BIS	$ANVP, R1		; R1: address of GC bitmap
.IFF
	MOV	(PC)+, R2
GCBMSZ:: .WORD	0
	MOV	(PC)+, R1
EHEAP::
.IIF NE C$RT11	.WORD	0
.IIF NE C$BK11	.WORD	HIMEME
	ADD	R2, R1
.ENDC ; C$BK10
2$:	CLRB	-(R1)			; Clear GC bitmap
	SOB	R2, 2$
	SUB	#HEAP/32., R1
	MOV	R1, I.BMOF		;SELF-MODIFYING CODE

	MOV	#TSTMSK, R3
;; Mark all free blocks to avoid following false-positive pointer in heap
M.HEAP:	MOV	FREEL, R2	; First block
	BEQ	3$
1$:	MOV	R2, R0
	PUSH	R2		; (SP): block address
	ADD	(R2)+, (SP)	; (SP): end of block
2$:	.MBIT
	CMP	R0, (SP)
	BLO	2$
	TST	(SP)+
	MOV	(R2), R2
	BNE	1$
3$:

;; Mark all ROOTS
	MOV	#E.ROOT, R0	; Mark all objects in Roots & Stack
;; Process Root in R0
MARK:	PUSH	R0
	MOV	SP, MARKSP
	.MPUSH
	MOV	R0, @MARKSP	; Decremented
MARKL:  CMP	SP, (PC)+	; SP == MARKSP?
MARKSP:	.WORD	0		; SP at entry to mark
	POP	R0		; Next item of stack
	BHIS	2$
	MOV	R0, R1
	CLR	R2
	ROR	R1		; rely on CF==0
	BCS	M.SVLS		; SYMBOL, VECTOR, LAMBDA, STREAM
;	ASR	R1
;	BCS	M.DBL
	TST	(R2)+		; R2 = 2
	BR	M.VEC1
2$:	CMP	R0, SP
	BHI	MARK
SWEEP:
.IIF NE C$BK11	MOV	#10000, $SYREG	; Disable STOP key
	MOV	#FREEL, R0	; R0: First Free Block
	MOV	#HEAP, R1

	CALL	1$
7$:	CMP	R1, R2
	BHI	9$		; No more free blocks
	BEQ	3$
	.MTEST			; Marked sequence
	BNE	7$		; Continue marked area
	TST	(R0)+		; R0: &NEXT+2
	MOV	(R0), -(R1)	; Found free block
	CLR	-(R1)		; Init block Size
	MOV	R1, (R0)	; Link it into list
	MOV	R1, R0
6$:	CMP	R1, R2		; R0: &CurFreeBlock
	BHI	9$
	BEQ	4$		; Merge free blocks
	.MTEST
	BNE	7$
	ADD	#4, (R0)	; -2(R0): size of free block; R0: &CurFreeBlock + 2
	BR	6$

3$:	MOV	R2, R0		; R0, R2 = &NEXT
	BR	5$
4$:	ADD	(R2), (R0)	; Merge free blocks
5$:	MOV	R0, R1
	ADD	(R0)+, R1	; R1: Next cell after free bloCk
	MOV	2(R2), (R0)	; (R0) = Next free block
	PUSH	#6$
1$:	MOV	(R0), R2	; R2 = Next free block
	BNE	2$
	MOV	EHEAP, R2	; Upper bound of Heap
	DEC	R2		; R2: Upper bound of Heap - 1
2$:	TST	-(R0)		; R0: &block
.IIF NE	C$RT11 9$:
	RETURN

.IF EQ	C$RT11
9$:				; End of list
	.IIF NE C$BK10	POP	$KBCTL	; Restore keyboard interrupts
	.IIF NE C$BK10	CLR	GCRET
	.IIF NE C$BK11	CLR	$SYREG	; Enable STOP key
	RETURN
.ENDC


;; SYMBOL, VECTOR, LAMBDA, STREAM
M.SVLS:
.IIF EQ C$VM1,	DEC	R0
	MOV	(R0)+, R2
	BEQ	1$		; Symbol
	CMP	R2, #FIXEND
	BLO	M.VEC
1$:	TST	(R0)+		; R0 += 2
	.MBIT			; Mark 2nd Cell of Symbol OR LAMBDA
	BIT	#1, -10(R0)
	BNE	2$		; LAMBDA or STREAM
	TST	-(R0)		; R0 -= 2 for SYMBOLs
	BR	3$
2$:	.MPUSH			; FUNCTION or LAMBDA BODY
3$:	.MPUSH			; NEXT SYMBOL, FUNCTION OR LAMBDA BODY
	.MPUSH			; FUNCTION or LAMBDA BODY
	.MPUSH			; PLIST

.IF NE C$FILE
	CMP	(R0), #V.FILE
	BEQ	10$		; FILE-STREAM
.ENDC ; C$FILE
;; SYMBOL, LAMBDA or non-FILE-STREAM
	CLR	R2
.IF EQ C$VM1
	BISB	(R0), R2	; Symbol-Name length in case we are on Symbol
.IFF
	BISB	-(R0), R2	; Symbol-Name length in case we are on Symbol
.ENDC ; C$VM1

	BIT	#1, (R0)+
	BNE	MARKL		; LAMBDA or STREAM
5$:	BIT	(R0)+, (R0)+	; R0 += 4
	TST	(R0)
	BEQ	7$		; Symbol name is ASCII
.IF NE C$RAD40
6$:	TST	(R0)+
	BPL	MARKL		; end of RADIX-40 string
.IFF
6$:	CMP	(R0)+, #50*50
	BLO	MARKL		; end of RADIX-50 string
.ENDC
	BIT	#2, R0
	BNE	6$
	.MBIT
	CMP	-(R0), -(R0)	; R0 -= 4
	BR	6$

.IF NE C$FILE
10$:	MOV	#512. + 3, R2	; Extended FILE-STREAM struct + 512-byte sector buffer
	CMP	(R0)+, (R0)+	; R0 += 4
.ENDC ; C$FILE
7$:	CMP	(R0)+, (R0)+	; R0 += 4    Mark ASCII Symbol name
11$:	.MBIT
	SUB	#4, R2
	BHIS	11$
	BR	MARKL


M.VEC:	SUB	#FIXOFF, R2
	BEQ	MARKL
.IF NE C$MDAR
	BPL	M.VEC1
	NEG	R2
.ENDC
M.VEC1:	ADD	R2, R0
	ADD	R2, R0
1$:	.MPUSH
	.MBIT			; Mark every 4-byte cell of the array
	BIT	-(R0), -(R0)	; R0 -= 4
	SOB	R2, 1$
	BR	MARKL
