;;
;;	CLU garbage collector
;;
	title	clu garbage collector
;;
;;	Original version installed 11/3/77, by EBM
;;
;;	Mod 1 - 11/13/77 - EBM - starting addition of code for purifying
;;		read-only objects such as procedures and strings
;;		also, now takes advantage of larger windows, if available
;;
;; Macros, global symbols, variables, call blocks
;;
define	$die	msg/

	.lstof
	.value	[asciz `
: msg 

`]
	.lston
	termin
;;
;; Symbols to use in .call's
;;
carg==	move		;; regular argument
clarg==	setz		;; last argument
ciarg==	movei		;; immediate argument
cliarg==setzi		;; last argument, immediate
cval==	movem		;; regular value
clval==	setzm		;; last value
cerr==	moves		;; error
clerr==	setzb		;; last error
ccnt==	movs		;; control
cicnt==	movsi		;; immediate control
;;
;; Other symbols
;;
pglog2==10.		;; log base 2 of page size
pgsize==1024.		;; page size
bpword==5		;; bytes per word for strings
numpgs==256.
badrel==0,,-pgsize/2

;;
;; Register names
;;
flags=	0		;; flag register
;;
;;		flag codes
;;
pfyflg==1		;; flag for "purifying"
atrflg==2		;; flag for "trimming arrays"
;;
;;		temporary registers
;;
a=	1
b=	2
c=	3
d=	4
e=	5
f=	6
g=	7
h=	10
i=	11
j=	12
rwleft=	13		;; number of words left in read window (or just # left in self)
rwptr=	14		;; pointer to item just read in window
wrarea=	15		;; write area number
rdarea=	16		;; read area number
sp=	17		;; gcstak pointer
;;
;;	Area numbers:
;;	static:	-1	(read only)
;;	frame:	 0	(frame save)
;;	heap:	 1
;;	pure:	 2
;;
;; Other stuff to be included
;;
;;	Type codes
;;
usrflg==-1
	.lstof
	.insrt	clusys;types >
	.lston
;;
;;	Now my type codes
;;
morbit==1		;; bit for "referred to more than once"
grlbit==2		;; bit for rel words (pure or impure)
purbit==4		;; bit for "purity"
gbdbit==10		;; bit for bad (zapped words of array stuff)
;;
t%gref=	gcbit		;; marks first words of objects referred to once
t%grf2=	gcbit+morbit	;; marks first words of objects referred to more than once
t%grel=	gcbit+grlbit	;; marks all but first words of objects
t%gprf=	gcbit+purbit	;; marks first word of pure objects referred to once
t%gpr2= gcbit+purbit+morbit	;; marks first word of those referred to more than once
t%gprl=	gcbit+purbit+grlbit	;; marks all but first words of pure objects
t%gbad=	gcbit+gbdbit	;; marks zapped words of array real stuff

;;
;; LOC to start it
;;
	loc pgsize
begin:	jrst go
;;
;; Arguments and Variables
;;
;;	convention: C - static, K - stack, H - heap.
;;
;;	first, arguments (they MUST be in this order)
;;
sargs==	.
basptr:	0		;; pointer to vector of basic areas
rtnadr:	0		;; return address
kstrt:	0		;; start of stack
kend:	0		;; end of stack
hstrt:	0		;; start of heap
hend:	0		;; end of heap
frmptr:	0		;; pointer to frame to trace frames from
flgwrd:	0		;; flag bits
			;; 0 - 1 => do not trim arrays
			;; 1 - 1 => purify
			;; rest - ignored
arry1:	0		;; first array not to trim
arry2:	0		;; second array not to trim
nargs==	.-sargs
;;
pgsoff:	0		;; number of pages offset
oldend:	0		;; old end of heap (from previous time called)
purpgs:	0		;; blt form pointer to saved pure pages
			;; 0 => none saved
nhread:	0		;; number of times the heap has been read
;;
.nhwpg:	0		;; highest numbered page allocated to non-heap write windows
.fepag:	0		;; last frame save page
.hspag:	0		;; first page for heap in inferior
.hepag:	0		;; last page for heap in inferior
.pspag:	0		;; (current) start of pure area (and other areas) in inferior
.pepag:	0		;; end of other areas in inferior
pagtab:	block	numpgs	;; table for other areas
fixtab:	block	numpgs	;; table for fixing up
;;
;; entries in pagtab give the area number of the page (only for pure and other
;; non-heap areas); fixtab is given a value to XOR with the page number
;; to fix pointers to that page in the fixup phase.
;; (XORing wins because there is no overflow, etc.)
;;

;;
;;	pointers
;;
rptr:	0		;; virtual address being read from (job from context)
wptr:	0		;; virtual pointer for writing to frame save area
	0		;; virtual pointer for writing to heap area
	0		;; virtual pointer for writing to pure area
wwptr:	0		;; window pointers corresponding to the above
	0
	0
wwleft:	0		;; number of window words left for each window
	0
	0
rwpage:	0		;; first window page of each flavor
wwpage:	0
	0
	0
nrwpag:	0		;; number of window pages of each flavor
nwwpag:	0
	0
	0
a.pure:	0		;; the area to write pure things to
refcod==:.-1
	t%gref		;; type code for refs in heap area
	t%gprf		;; and for pure area
;;
;;		statistics
;;
sstrt==	.		;; start of statistics area
	0		;; no. refs from static area and stack
nrefs:	0		;; (blank to make area numbers index this table)
	0		;; no. refs from heap
	0		;; no. refs from pure area
	0		;; no. objects in static area and stack
nobjs:	0		;; (blank)
	0		;; no. objects in heap
	0		;; no. objects purified
nmobjs:	0		;; no. objects multiply referred to
nrels:	0		;; no. of rels found
nfrels:	0		;; no. rels handled in fixup pass
nbrels:	0		;; no. of bad rels
nframe:	0		;; no. of frames in the stack
natrim:	0		;; number of arrays trimmed
ntrsav:	0		;; number of words trimming saved
send==:	.-1		;; end of statistics area
stinit==:.
	sstrt,,sstrt+1	;; for blt to init stats
;;
;;	gc stack area
;;
stklen==40	;; 32 words had better be enough!
gcstak==:.
	-stklen,,.
	block stklen

;;
;;	interrupt hacking stuff
;;
intptr==42			;; loc of pointer to interrupt table
optr==:	.
	0			;; old pointer to interrupt table
inttab==:.
	-intlen,,intrup		;; new interrupt table word
;;
;;	new interrupt table
;;
intrup==:.
	400020,,intpdl		;; push all regs, and debugging info
				;; intpdl is intr gcstak ptr
	%pipdl	? 0 ? %pipdl ? 0 ? pdlov
		;; pdl is 1st word, masks self, handler is pdlov
	%pimpv	? 0 ? %pimpv ? 0 ? mpvint
		;; mpv is 1st word, masks self, handler is mpvint
intlen==.-intrup
;;
;;	new interrupt stack pointer and stack
;;
istkln==48.		;; room for 2 interrupts
intpdl==:.
	-istkln,,.	;; new interrupt stack pointer
	block	istkln	;; new interrupt stack, room for 2 interrupts
;;
;;	new interrupt mask, etc. set up info and save locs
;;
su1==:.
	.rdf1,,df1sav
	.rdf2,,df2sav
	.rrunt,,sruntm
suptr1==:.
	su1-.,,su1
df1sav==:.
	0
df2sav==:.
	0
sruntm==:.
	0
su2==:.
	.sdf1,,[<-1>#<%pimpv+%pipdl>]
	.sdf2,,[-1]
suptr2==:.
	su2-.,,su2
su3==:.
	.sdf1,,df1sav
	.sdf2,,df2sav
	.rrunt,,eruntm
suptr3==:.
	su3-.,,su3
eruntm==:.
	0

;;
;;	interrupt handlers
;;
;;		PDL Overflow handler
;;
pdlov:	$die	Push down gcstak overflow
	.call	intdis		;; dismiss (assume DDT took care of it)
	 $die	Couldn't dismiss PDL OV interrupt
;;
;;		MPV interrupt handler
;;
mpvint:	$die	MPV interrupt
	.call	intdis		;; dismiss (assume DDT took care of it)
	 $die	Couldn't dismiss MPV interrupt
;;
;; GC CALLS
;;
;; All calls for the garbage collector are gathered together here
;; for easy reference; they are grouped by category - job hacking
;; calls, page hacking calls, etc.
;;
;; JOB HACKING CODE
;;
;;	a subroutine to set up interrupts properly
;;
intsup:	move	a,suptr1	;; read out defer words and save them
	.suset	a
	move	a,suptr2	;; set them to defer all interrupts
	.suset	a
	move	a,inttab	;; install my interrupt table
	exch	a,intptr
	movem	a,optr
	popj	sp,
;;
;;	a subroutine to restore interrupts
;;
intrst:	move	0,suptr3
	.suset	0
	jrst	(1)	;; was called by a jsp 1,intrst

;;
;;	subroutine for creating the inferior
;;
makjob:	move	a,[sixbit /CLUGC0/]	;; set up name
	movem	a,jobnam
	.call	chpush		;; push channel for job
	 $die	Could not push channel for job
tryit:	.call	jexist		;; this call skips if a job with the given name exists
	 jrst	chkit
	.call	jclose
	 $die	Close failed
again:	aos	jobnam		;; try another name
	jrst	tryit

chkit:	move	c,errcod	;; error code meaning job exists
	caie	c,4
	 $die	Call to see if job exists failed in wrong way!!
makeit:	.call	jmake		;; this actually creates the job
	 jrst	.+2
	  popj	sp,
	move	c,errcod	;; check error code
	cain	c,12		;; 12 => job not inferior
	 jrst	again
	cain	c,6		;; 6 => no job slots
	 $die	No jobs slots available for GC
	cain	c,5		;; 5 => already have 8 inferiors
	 $die	No inferiors available for GC
	$die	Couldn't get job for GC (strange error)
;;
;;	here are the call blocks for job hacking
;;
usro==	17			;; channel number for job for regular stuff
jobnam:	0			;; word for job name
ubpfj.==10			;; code for random control bit in call below
;;
;;	Call that skips if job exists
;;
jexist:	setz
	sixbit	/open/		;; open job with
	cicnt	ubpfj.+.uii	;; random bit (see system documentation), unit image
				;; input mode
	ciarg	usro		;; on channel usro
	carg	[sixbit	/usr/]	;; device name is USR
	ciarg	0		;; use my first name
	carg	jobnam		;; use jobnam as second name
	clerr	errcod
;;
;;	Call to create a new job
;;
jmake:	setz
	sixbit	/open/		;; open job
	cicnt	.uio		;; in unit image output mode
	ciarg	usro		;; on channel usro
	carg	[sixbit	/usr/]	;; device name is USR
	ciarg	0		;; use my first name
	carg	jobnam		;; use jobnam for second name
	clerr	errcod

;;
;; PAGE HACKING CALLS
;;
;;	Call to see if page exists
;;
pgtype:	setz
	sixbit	/cortyp/		;; CORTYP
	carg	pgsrc			;; page is in self, # in pgsrc
	cval	pgdest			;; put value in pgdest
	clerr	errcod			;; error code
;;
;;	Call to get fresh pages for self
;;
getpgs:	setz
	sixbit	/corblk/		;; CORBLK
	ciarg	%cbndr+%cbndw		;; need read and write
	ciarg	%jself			;; give to self
	carg	pgdest			;; pgdest is aobjn pointer
	ciarg	%jsnew			;; get new pages
	clerr	errcod			;; put error code in corerr
;;
;;	Call to map inferior's pages in
;;
mapin:	setz
	sixbit	/corblk/	;; CORBLK
	ciarg	%cbndr+%cbndw	;; need to read and write it
	ciarg	%jself		;; give to self
	carg	pgdest		;; put where pgdest points
	ciarg	usro		;; get from inferior
	carg	pgsrc		;; from pgsrc
	clerr	errcod
;;
;;	Call to map a page out
;;
mapout:	setz
	sixbit	/corblk/	;; CORBLK
	ciarg	%cbndr+%cbndw	;; need read and write
	ciarg	usro		;; map to inferior
	carg	pgdest		;; pgdest has page number
	ciarg	%jself		;; map from self
	carg	pgsrc		;; gives page number
	clerr	errcod
;;
;;	Call to delete page(s) form self
;;
pagdel:	setz
	sixbit	/corblk/
	ciarg	0		;; 0 deletes from page map
	ciarg	%jself		;; delete from self
	carg	pgdest		;; gives number(s) of page(s)
	clerr	errcod

;;
;;	Call to move pages within self
;;
movpgs:	setz
	sixbit	/corblk/
	ciarg	%cbndr+%cbwrt	;; need to read, get write if can
	ciarg	%jself
	carg	pgdest
	ciarg	%jself
	carg	pgsrc
	clerr	errcod
;;
;;	Call to map pure pages out
;;
pmpout:	setz
	sixbit	/corblk/
	ciarg	%cbndr
	ciarg	usro
	carg	pgdest
	ciarg	%jself
	carg	pgsrc
	clerr	errcod
;;
;;	Call to map pure pages in
;;
pmpin:	setz
	sixbit	/corblk/
	ciarg	%cbndr		;; note: this purifies as it maps in
	ciarg	%jself
	carg	pgdest
	ciarg	usro
	carg	pgsrc
	clerr	errcod
;;
;;	Call to close channel opened to job
;;
jclose:	setz
	sixbit	/close/
	ciarg	usro
	clerr	errcod
;;
;;	Call to push (and hence free) channel for job
;;
chpush:	setz
	sixbit	/iopush/
	ciarg	usro
	clerr	errcod
;;
;;	Matching call to pop channel
;;
chpop:	setz
	sixbit	/iopop/
	ciarg	usro
	clerr	errcod

;;
;;	Variables for page hacking calls
;;
pgsrc:	0			;; source pages for calls
pgdest:	0			;; destination pages for calls
;;
;; MISCELLANEOUS CALLS
;;
;;	Call to dismiss interrupts
;;
intdis:	setz
	sixbit	/dismis/
	cicnt	400020		;; throw away debugging words, pop all AC's
	carg	intpdl		;; intr gcstak pointer is intpdl
	clerr	errcod
;;
;; Error code word for all .call's
;;
errcod:	0
;;
;; Arguments and initialization
;;
;;	Arguments are as follows:
;;
;;	register 1	pointer to vector of aobjn pointer for basic areas
;;		 2	return address
;;		 3	start of stack
;;		 4	end of stack
;;		 5	start of heap
;;		 6	end of heap
;;		 7	frame pointer
;;		10	flags
;;			0 - 1 => do not trim arrays
;;			1 - 1 => purify
;;			rest - ignored
;;		11	first array not to trim
;;		12	other array not to trim
;;

;;
;; First, check and store arguments
;;
go:	movei	2,(2)	;; clear left halves of all addresses
	movei	3,(3)
	movei	4,(4)
	movei	5,(5)
	movei	6,(6)
	movei	7,(7)
	movei	11,(11)
	movei	12,(12)
	move	0,[1,,sargs]
	blt	0,sargs+nargs-1
	movei	1,(1)	;; clear left half for comparison test
;;
;; In checking, they should be
;;	3<4<5<6, 3<=7<=4, and 1,2 not between 3,4 or 5,6
;;
	cail	3,(4)
	 jsp	0,badarg
	cail	4,(5)
	 jsp	0,badarg
	cail	5,(6)
	 jsp	0,badarg
	caile	3,(7)
	 jsp	0,badarg
	caile	7,(4)
	 jsp	0,badarg
	cail	1,(3)
	 caile	1,(4)
	  jrst	.+2
	   jsp	0,badarg
	cail	1,(5)
	 caile	1,(6)
	  jrst	.+2
	   jsp	0,badarg
	cail	2,(3)
	 caile	2,(4)
	  jrst	.+2
	   jsp	0,badarg
	cail	2,(5)
	 caile	2,(6)
	  jrst	clstat
	   jsp	0,badarg
badarg:	 $die	GC received bad arguments! (0 has addr+2 of failing test)
;;
;;	clear statistics, init stack pointer
;;
clstat:	setzm	sstrt
	move	sp,stinit
	blt	sp,send
	move	sp,gcstak

;;
;;	init flag register, and other minor goodies
;;
	setz	flags,
	move	a,flgwrd
	trnn	a,1		;; trim arrays?
	 tron	flags,atrflg
	trnn	a,2		;; purify?
	 jrst	nodpur
	tron	flags,pfyflg
	move	a,hend		;; de-purify all pages above heap
	lsh	a,-pglog2
	movei	a,1(a)		;; bump page number
	movei	b,pgsize*<numpgs-2>-1
	movem	b,hend
	jrst	dprtst

dprlup:	movei	b,numpgs-1	;; get a page
	movem	b,pgdest
	.call	getpgs
	 $die	Couldn't get fresh page in depurification
	movei	b,(a)
	lsh	b,pglog2
	hrli	b,pgsize*<numpgs-1>
	movs	b,b
	blt	b,-1		;; effective address is last word of memory
	movem	a,pgdest	;; move copy into position
	movei	b,numpgs-1
	movem	b,pgsrc
	.call	movpgs
	 $die	Couldn't move depurified page down
	movei	a,1(a)
dprtst:	caige	a,numpgs-2
	 jrst	dprlup
	movei	a,numpgs-1	;; clear high page frame just in case
	movem	a,pgdest
	.call	pagdel
	 $die	Couldn't delete extra copy of depurified page
	setom	.nhwpg		;; set non-heap area window page allocation word
;;
;; Set up new interrupt stuff, but first init area variable
;;
nodpur:	movei	a,1
	trne	flags,pfyflg
	 movei	a,2
	movem	a,a.pure
	pushj	sp,intsup
;;
;; Create inferior job (we use its address space as storage)
;;
	pushj	sp,makjob
	jrst	cont21

;;
;;	Stack frame transformation
;;
;;	The format of a frame as used in the CLU system is:
;;			-1:  mr,,ra
;;		ptr->	 0: ier,,oer
;;	where:
;;		mr = module register (rh of a ref)
;;		ra = return address (rh of a rel)
;;		oer = old environment register (points to a frame or = 0)
;;		ier = iterator environment register (same format as oer)
;;	We save two words (in the order presented)
;;		ptr
;;		ier,,oer
;;	and transform the frame into this (which is acceptable to the usual
;;	tracing routines in the garbage collector):
;;			-1: trel,,ra
;;		ptr->	 0: tref,,mr
;;	A later segment restores the frames before we return from GC,
;;	using the information saved now.
;;
;;
;;	Subroutines for reading and writing
;;		sequentially through windows;
;;		page mapping done automatically
;;
;; wr.ini - subroutine to set up for writing to inferior;
;;	sets up wptr, wwptr, wwpage, etc., based on wrarea
;;	for areas both read and written, write init should be done first
;;	also: init heap before other copy areas!
;;
wr.ini:	jumpn	wrarea,wri.nf	;; go init non-frame areas
	setzm	pagtab		;; clear the page table (now is a convenient time)
	move	a,[pagtab,,pagtab+1]
	blt	a,pagtab+numpgs-1
	setzm	wptr(wrarea)	;; now do pointers, etc.
	setzm	wwptr(wrarea)
	movei	a,numpgs-2
	movem	a,wwpage(wrarea)
	movei	a,1
	movem	a,nwwpag(wrarea)
	setzm	wwleft(wrarea)
	setzm	.fepag
	popj	sp,

wri.nf:	caie	wrarea,1
	 jrst	wri.nh		;; go init non-heap areas
	setzm	nhread		;; reset number of times the heap has been read
	move	a,kend		;; see what page to start with
	lsh	a,-pglog2
	camg	a,.fepag	;; max of end of stack and frame save
	 move	a,.fepag
	movem	a,.hepag
	movei	a,1(a)
	movem	a,.hspag
	setzm	wptr(wrarea)	;; first write will init wptr,
	setzm	wwptr(wrarea)	;; and wwptr
	setzm	wwleft(wrarea)	;; set wwleft to 0 to trap on first write
	trnn	flags,pfyflg	;; if not purifying, try to get many window pages
	 jrst	wri.np
	movei	a,numpgs-2	;; use next to last page for heap write window
	movem	a,wwpage(wrarea)
	movem	a,.pspag	;; set up .pspag, .pepag to prevent overwrites
	movei	a,1(a)
	movem	a,.pepag
	movei	a,1
	movem	a,nwwpag(wrarea)
	popj	sp,

wri.np:	move	a,hend		;; see how many pages we have
	lsh	a,-pglog2
	subi	a,numpgs-1
	movn	a,a		;; a now has # pages available
	caig	a,2
	 jrst	wri.nm		;; no mapping needed if only 2 pages
	movni	b,-2(a)		;; Note: I assume that all pages above
	hrlm	b,pgdest	;; heap (except last two) are pure
	addi	b,numpgs-2
	hrrm	b,pgdest
	movem	b,pgsrc
	move	b,pgdest
	movem	b,purpgs	;; save this for mapping in later
	.call	pmpout
	 $die	Couldn't map out pure area!
	hrrz	b,purpgs
	movem	b,.pspag	;; this will prevent destroying goodies
	movei	b,numpgs-1
	movem	b,.pepag	;; for consistency
	jrst	wri.jn		;; join up with other code below

wri.nm:	setzm	purpgs
	movei	b,numpgs-2	;; set up .pspag and .pepag
	movem	b,.pspag
	movei	b,1(b)
	movem	b,.pepag

wri.jn:	movei	b,numpgs	;; now set up windows
	sub	b,a		;; (give all to writing to start with)
	movem	b,wwpage(wrarea)
	movei	a,-1(a)		;; leave last page for read window
	movem	a,nwwpag(wrarea)
	popj	sp,

wri.nh:	aosg	a,.nhwpg	;; see if any write windows have been allocated before
	 jrst	wri.aa		;; already allocated some
	move	a,kend
	lsh	a,-pglog2
	movei	a,1(a)
	movem	a,.nhwpg

wri.aa:	move	b,hstrt		;; make sure it is OK
	lsh	b,-pglog2
	cail	a,(b)
	 $die	No more room for windows
	movem	a,wwpage(wrarea)
	movei	a,1
	movem	a,nwwpag(wrarea)
	setzm	wptr(wrarea)	;; clear all pointers
	setzm	wwptr(wrarea)
	setzm	wwleft(wrarea)
	popj	sp,

;;
;; write - macro to write a word to inferior (through window);
;;	word is in a;
;;
define	write

	sosge	wwleft(wrarea)
	 pushj	sp,wr.map
	movem	a,@wwptr(wrarea)
	aos	wptr(wrarea)
	aos	wwptr(wrarea)
	termin
;;
;;	Internal subroutine, wr.map (to get pages to write into)
;;
wr.map:	push	sp,a		;; get a temp reg
	jumpn	wrarea,wrm.nf	;; go do non frame save stuff
	move	a,wwpage(wrarea)	;; get a fresh page
	movem	a,pgdest
	.call	getpgs
	 $die	Couldn't get fresh page for saving stack frame info
	movem	a,pgsrc		;; map out to right place
	move	a,wptr(wrarea)
	lsh	a,-pglog2
	movem	a,pgdest
	movem	a,.fepag
	.call	mapout
	 $die	Couldn't map out frame save info
	movei	a,pgsize-1
	movem	a,wwleft(wrarea)
	move	a,wwpage(wrarea)
	lsh	a,pglog2
	movem	a,wwptr(wrarea)
	pop	sp,a
	popj	sp,

wrm.nf:	caie	wrarea,1
	 jrst	wrm.nh		;; go do non-heap areas
	push	sp,b		;; need two more temps in this branch
	push	sp,c
	skipe	wwptr(wrarea)	;; is this the first time?
	 jrst	wrm.ha		;; do stuff for heap after first time
	move	a,.hspag	;; init wptr
	lsh	a,pglog2
	movem	a,wptr(wrarea)
wrm.ha:	move	a,.pspag	;; see how many pages we have
	sub	a,.hepag
	subi	a,1
	caml	a,nwwpag(wrarea)
	 move	a,nwwpag(wrarea)	;; use min of avail and window size
	jumpg	a,.+2
	 $die	No more room!
	move	b,.hepag
	addm	a,.hepag
	movni	c,(a)		;; get new pages
	hrl	c,wwpage(wrarea)
	movsm	c,pgdest
	.call	getpgs
	 $die	Couldn't get new pages for heap
	hrli	c,1(b)		;; map them out
	movsm	c,pgdest
	move	b,wwpage(wrarea)
	movem	b,pgsrc
	.call	mapout
	 $die	Couldn't map new heap pages out
	lsh	a,pglog2
	movei	a,-1(a)
	movem	a,wwleft(wrarea)
	lsh	b,pglog2
	movem	b,wwptr(wrarea)
	pop	sp,c		;; restore regs
	pop	sp,b
	pop	sp,a
	popj	sp,

wrm.nh:	sos	a,.pspag	;; allocate a page
	camg	a,.hepag	;; make sure it is OK
	 $die	No more room! (non-heap area)
	hrlm	wrarea,pagtab(a)	;; mark the page for this area
	lsh	a,pglog2
	movem	a,wptr(wrarea)
	move	a,wwpage(wrarea)
	lsh	a,pglog2
	movem	a,wwptr(wrarea)
	movei	a,pgsize-1
	movem	a,wwleft(wrarea)
	pop	sp,a
	popj	sp,

;;
;; writem - write multiple words
;;	a has starting address in rh;
;;	b has number of words to write;
;;	c is set to address written to;
;;	a, b are not modified;
;;	regs d, e, f, g, h, i used;
;;	area taken from wrarea
;;
writem:	jumpg	b,.+2		;; make sure there is something to do!
	 $die	Writem to write nothing?
	movei	d,(a)		;; d will hold current starting address
	movei	e,(b)		;; e will hold current length
writm1:	sosge	f,wwleft(wrarea)	;; see how many words are left
	 pushj	sp,[	pushj	sp,wr.map	;; if none left, get new page(s)
			move	f,wwleft(wrarea)
			popj	sp,]
	hrrz	c,wptr(wrarea)	;; go ahead and set c
	movei	g,1(f)		;; get min(len of obj, amt left in page) in g
	caile	g,(e)
	 movei	g,(e)
	hrli	h,(d)		;; form blt pointer in h
	hrr	h,wwptr(wrarea)
	movei	i,(h)		;; use i to compute end
	addi	i,(g)
	blt	h,-1(i)		;; copy part of object
	addm	g,wptr(wrarea)	;; bump pointers
	addm	g,wwptr(wrarea)
	addi	d,(g)
	subi	e,(g)
	movni	g,-1(g)
	addm	g,wwleft(wrarea)
	jumpn	e,writm1	;; if more to do, do it!
	popj	sp,		;; return if no more to do
;;
;; rd.ini - subroutine to set up for reading from self;
;;	starting address is rh of a;
;;	len is in rh of b;
;;	sets up rptr, rwptr, rwleft, rdarea
;;
rd.ini:	jumple	b,rd.die	;; len <= 0 is nonsense
	movei	a,(a)
	movem	a,rptr
	movei	rwptr,-1(a)
	movei	rwleft,(b)
	movni	rdarea,1
	popj	sp,

;;
;; rdi.in - subroutine to set up for reading from inferior;
;;	sets up rptr, rwleft, and window stuff;
;;	should only be done after write setup;
;;	tells what to do by contents of rdarea
;;
rdi.in:	cain	rdarea,1	;; heap is special
	 jrst	rdi.hp
	setzm	rptr
	setz	rwptr,
	setz	rwleft,
	movei	a,numpgs-1
	movem	a,rwpage
	movei	a,1
	movem	a,nrwpag
	popj	sp,

rdi.hp:	move	a,.hspag	;; init rptr
	lsh	a,pglog2
	movem	a,rptr
	setz	rwleft,
	setz	rwptr,
	movei	a,numpgs-1
	movem	a,rwpage
	movei	a,1
	movem	a,nrwpag
	aos	a,nhread
	trne	flags,pfyflg	;; extra work if not purifying
	 popj	sp,
	cain	a,2		;; first time, split pages
	 jrst	rdi.hf		;; but on fixup, take all
	move	a,nwwpag(rdarea)	;; now is the time to split the window pages
	movei	a,1(a)		;; (we get the last page, too)
	lsh	a,-1
	movem	a,nrwpag
	movni	a,-1(a)		;; reader already had one
	addm	a,nwwpag(rdarea)	;; delete from write area
	addi	a,numpgs-1
	movem	a,rwpage
	move	b,wwptr(rdarea)		;; see where the writer is, and fix him up
	lsh	b,-pglog2
	caige	b,(a)
	 jrst	rdi.pa		;; must go adjust only pointers
	move	a,wwpage(rdarea)	;; must move pages down
	move	b,nwwpag(rdarea)
	movni	b,(b)
	hrli	a,(b)
	movem	a,pgdest
	move	a,wwpage(rdarea)
	add	a,nrwpag
	movei	a,-1(a)
	movem	a,pgsrc
	.call	movpgs
	 $die	Couldn't move pages!
	lsh	a,pglog2
	movni	a,(a)
	addm	a,wwptr(rdarea)		;; adjust wwptr
rdi.pa:	move	a,nrwpag	;; in this case we merely decrease wwleft
	movni	a,-1(a)
	addm	a,.hepag	;; and .hepag
	lsh	a,pglog2
	addm	a,wwleft(rdarea)
	popj	sp,

rdi.hf:	move	a,wwpage(rdarea)
	movem	a,rwpage
	movni	a,(a)
	addi	a,numpgs
	movem	a,nrwpag	;; use all pages to end of memory
	popj	sp,

;;
;; read - macro to read a word;
;;	leaves rwptr pointing to it;
;;
define	read

	sojge	rwleft,.+2
	 pushj	sp,rd.map
	aos	rptr
	movei	rwptr,1(rwptr)
	termin
;;
;;	now the subroutine called above
;;
rd.map:	push	sp,a
	jumpl	rdarea,rd.die	;; better not run off the end in the superior!
	jumpg	rdarea,rdm.nf	;; go do non frame save area
	move	rwptr,rwpage
	movem	rwptr,pgdest
	lsh	rwptr,pglog2
	move	a,rptr
	lsh	a,-pglog2
	movem	a,pgsrc
	.call	mapin
	 $die	Couldn't map in frame save page
	move	a,rptr
	andi	a,pgsize-1
	addi	rwptr,(a)
	movei	rwptr,-1(rwptr)	;; -1 because rwptr stays 1 behind
	movei	rwleft,pgsize-1	;; -1 because the instruction before the call
	subi	rwleft,(a)	;; decrements it
	pop	sp,a
	popj	sp,

rdm.nf:	caie	rdarea,1
	 jrst	rdm.nh		;; go map in page for non heap area
	move	rwptr,rwpage
	movem	rwptr,pgdest	;; have starting page in superior
	lsh	rwptr,pglog2	;; easy to init rwptr
	move	a,rptr
	lsh	a,-pglog2
	movem	a,pgsrc		;; have starting page in inferior
	movni	a,(a)		;; now need to find how many pages we can map in
	add	a,.hepag
	movei	a,1(a)
	camle	a,nrwpag	;; take min number possible and window pages
	 move	a,nrwpag
	jumpg	a,.+2
	 $die	Couldn't read more of heap (ran off end)
	movei	rwleft,(a)
	lsh	rwleft,pglog2
	movni	a,(a)
	hrlm	a,pgdest
	.call	mapin		;; map the pages in
	 $die	Couldn't map new heap pages in
	move	a,rptr
	andi	a,pgsize-1
	addi	rwptr,(a)
	movei	rwptr,-1(rwptr)
	subi	rwleft,1(a)
	pop	sp,a
	popj	sp,

rdm.nh:	push	sp,b
	jumpn	rwptr,rdm.af	;; go do stuff for after first time
	movei	a,numpgs-1	;; (search from the top)
	jrst	rdm.sr		;; go and search

rdm.af:	move	a,rptr
	lsh	a,-pglog2
	subi	a,2		;; start searching one below last page

rdm.sr:	camg	a,.hepag
	 $die	Couldn't find non-heap page to read it
	hlrz	b,pagtab(a)	;; get code for that page
	caie	b,(rdarea)
	 soja	a,rdm.sr	;; continue searching
	movem	a,pgsrc
	lsh	a,pglog2
	exch	a,rptr
	andi	a,pgsize-1
	iorm	a,rptr
	movei	rwleft,pgsize-1
	subi	rwleft,(a)
	move	rwptr,rwpage
	movem	rwptr,pgdest
	lsh	rwptr,pglog2
	iori	rwptr,-1(a)
	.call	mapin
	 $die	Couldn't map in non-heap area page
	pop	sp,b
	pop	sp,a
	popj	sp,

;;
;;	macro to skip over words
;;		number of words to skip is in reg
;;
define	rd.skp	reg

	jumple	reg,rd.die
	addm	reg,rptr
	addi	rwptr,(reg)
	subi	rwleft,(reg)
	cail	rdarea,2	;; for non-linear areas, must be more careful
	 pushj	sp,rds.nh
	termin
;;
;;	subroutine called above
;;
rds.nh:	push	sp,a		;; get a temp
	movn	a,rwleft
	caile	a,pgsize	;; always OK if within a page (but fast test)
	 jrst	rds.hr		;; go try harder
	pop	sp,a
	popj	sp,
rds.hr:	push	sp,b
	move	b,rptr
	addi	a,(b)
	lsh	a,-pglog2
	lsh	b,-pglog2
	subi	a,(b)
	sojg	a,rds.hd	;; if within a page, is OK (slower test)
	pop	sp,b
	pop	sp,a
	popj	sp,

rds.hd:	push	sp,c		;; need yet another reg
	move	b,rptr		;; a has number of pages to skip over
	lsh	b,-pglog2
	subi	b,2		;; start searching for pages in page table
rds.lp:	camg	b,.hepag
	 $die	Rd.skp went too far in non heap area
	hlrz	c,pagtab(b)
	caie	c,(rdarea)	;; see if is this area
	 soja	b,rds.lp
	addi	rwleft,pgsize
	sojge	a,rds.lp	;; see if we have done enough
	iori	rwptr,pgsize*<numpgs-1>	;; to avoid wrap around
	movei	a,pgsize	;; fix rptr
	andm	a,rptr
	movei	b,1(b)		;; to page above the one it would have been reading
	lsh	b,pglog2
	iorm	b,rptr
	pop	sp,c
	pop	sp,b
	pop	sp,a
	popj	sp,

;;
;;	place to go for die message
;;
rd.die:	$die	Tried to read beyond end
;;
;;	set up to write frame save stuff
;;
cont21:
;;
;; init pointers
;;
	setz	wrarea,		;; prepare to write frames
	pushj	sp,wr.ini
	setz	rdarea,
	pushj	sp,rdi.in	;; set up to read from inferior also
;;
;;	do first frame
;;
	hrrz	b,frmptr
	pushj	sp,dofrm
;;
;;	now loop reading, fixing up, writing
;;
fixlup:	move	a,rptr
	caml	a,wptr(wrarea)
	 jrst	cont22
	read
	read
	move	a,(rwptr)
	movei	b,(a)		;; split into two pointers
	hlrz	c,a
	push	sp,c
	pushj	sp,dofrm
	pop	sp,b
	pushj	sp,dofrm
	jrst	fixlup

;;
;;	internal subroutine to handle one frame
;;		address of frame is in b
;;
dofrm:	jumpn	b,.+2		;; don't follow null pointers
	 popj	sp,
	caml	b,kstrt		;; make sure points into stack
	 camle	b,kend
	  $die	A frame pointer not in stack
	hlrz	a,(b)
	cain	a,t%ref		;; return if already done
	 popj	sp,
	aos	nframe		;; bump frame count
	movei	a,(b)
	write			;; write its address
	move	a,(a)
	write			;; and ier,,oer word
	move	c,-1(b)		;; get mr,,ra word of a frame
	hlr	d,c		;; d gets mr word
	hrli	c,t%rel		;; make into t%rel,,ra
	hrli	d,t%ref		;; make into t%ref,,mr
	movem	d,(b)		;; write words back
	movem	c,-1(b)
	popj	sp,
;;
;;	label for jumping over subroutine
;;
cont22:
;;
;; Clu garbage collector - step 3
;;	Actual garbage collection - copy phase
;;
;;	Set up to read from static area; write to inferior
;;
	movei	wrarea,1
	pushj	sp,wr.ini	;; init writing to heap
	trnn	flags,pfyflg	;; init pure area if purifying
	 jrst	basdo
	movei	wrarea,2
	pushj	sp,wr.ini

;;
;;	Now do basic area(s) one by one
;;
basdo:	hrrz	a,basptr
	hrrz	b,(a)		;; get len of vector
	movni	b,(b)		;; form aobjn pointer
	hrli	a,(b)
	aobjp	a,btrdun	;; if len not > 1, then basic trace is done
bastr:	push	sp,a		;; save the aobjn pointer
	move	a,(a)		;; get aobjn pointer to stuff to trace
	hlre	b,a		;; compute length
	movn	b,b
	movei	a,(a)		;; clear left half of a
	pushj	sp,rd.ini	;; get set to read
	pushj	sp,cscan	;; scan and trace the area
	pop	sp,a		;; get pointer back
	aobjn	a,bastr		;; if more, go do it
btrdun:
;;
;;	Now do stack
;;
	hrrz	a,kstrt
	hrrz	b,kend
	subi	b,-1(a)
	pushj	sp,rd.ini
	pushj	sp,cscan
;;
;;	and lastly, the HEAP!
;;
	movei	rdarea,1
	pushj	sp,rdi.in	;; this time, read from inferior
	pushj	sp,cscan
	trnn	flags,pfyflg	;; and pure area if purifying
	 jrst	start4		;; go to step 4
	movei	rdarea,2
	pushj	sp,rdi.in
	pushj	sp,cscan
	jrst	start4

;;
;;	the scanning subroutine
;;
cscan:	jumpge	rdarea,cscana	;; different test if reading from self
	sojge	rwleft,.+2
	 popj	sp,
	movei	rwptr,1(rwptr)
	aos	rptr
	jrst	cscanb

cscana:	move	a,rptr
	caml	a,wptr(rdarea)
	 popj	sp,
	read

cscanb:	move	a,(rwptr)
	tlne	a,refbit	;; see if rel or ref
	 jrst	cs.ref
	tlzn	a,repbit	;; see if a rep
	 jrst	cscan		;; skip everything else (i.e., rsb's)
	caml	a,[typrep,,0]	;; make sure is valid rep
	 caml	a,[typrsb,,0]
	  $die	Bad rep in copy-scan
	hlrz	b,a		;; get type code and do indexed jump to routine
	jrst	@cstab-typrep(b)

cs.ref:	tlne	a,relbit	;; skip over rels
	 jrst	cscan
	pushj	sp,trace	;; copy object pointed to
	movem	a,(rwptr)
	jrst	cscan
;;
;;	indexed jump table for individual rep handlers
;;
cstab:	cs0			;; array
	cs1			;; call block
	cs2			;; descriptor
	cs3			;; entry
	cs4			;; pure part
	cs5			;; oneof
	cs6			;; string
	cs7			;; vector
	cs8			;; word vector
	cs9			;; ref vector

;;
;; Here are the copy routines:
;;
;;	copy - array dope vector handler
;;
cs0:	jumpg	rdarea,cs0a	;; if doing heap, tracing already done
	hlre	a,1(rwptr)	;; check for size = 0
	jumple	a,.+2		;; make sure size is OK
	 $die	Array size is negative!
	jumpe	a,cs0b		;; if is 0, zap rel, else compute delta
	hrrz	a,2(rwptr)
	jumpn	a,.+2		;; make sure has real stuff
	 $die	Array with size not 0 has no real stuff
	hrrz	b,1(rwptr)	;; get rel, and make delta
	subi	b,(a)
	jumpg	b,.+2		;; delta should not be <= 0
	 $die	Array rel <= real stuff pointer
	hrrm	b,1(rwptr)	;; store delta back
	jrst	.+2		;; skip over other part of if-then-else
cs0b:	setzm	1(rwptr)
	hrrz	a,2(rwptr)	;; get and trace pointer
	jumpe	a,cs0a		;; no need if 0
	hrli	a,t%ref
	hlrz	b,(a)		;; make sure is a vector
	cain	b,t%vec
	 jrst	cs0c
	cain	b,t%gref	;; (but OK if marked already)
	 jrst	cs0c
	cain	b,t%grf2
	 jrst	cs0c
	$die	Array real stuff not a vector!
cs0c:	pushj	sp,trace	;; works even if marked
	hrrm	a,2(rwptr)	;; fix ref
	skipn	1(rwptr)	;; fix rel if size not 0
	 jrst	cs0a
	movei	a,(a)		;; clear left half
	addm	a,1(rwptr)
cs0a:	movei	a,2
	rd.skp	a
	jrst	cscan
;;
;;	copy - call block handler
;;
cs1:	movei	a,2
	rd.skp	a
	jrst	cscan

;;
;;	copy - descriptor block handler
;;
cs2:	read
	move	a,(rwptr)
	pushj	sp,tracef
	movem	a,(rwptr)
	read			;; skip special bits
	jrst	cscan
;;
;;	copy - entry block handler
;;
cs3:	hrrz	b,(rwptr)	;; get size
	push	sp,b
	read
	read			;; now at lr,,pr pair
	hrr	a,(rwptr)
	hrli	a,t%ref
	pushj	sp,trace
	hrrm	a,(rwptr)
	hlr	a,(rwptr)
	pushj	sp,trace
	hrlm	a,(rwptr)
	read
	hlrz	a,(rwptr)	;; get ref+1 to var init pair
	sojl	a,cs3a		;; skip stuff if = 0 (efficiency hack)
	pushj	sp,trace
	movei	a,1(a)
	hrlm	a,(rwptr)
cs3a:	pop	sp,b
	subi	b,4
	jumple	b,cscan
	push	sp,b
	read
	hrr	a,(rwptr)	;; cluster parm,,proc parm pair
	pushj	sp,trace
	hrrm	a,(rwptr)
	hlr	a,(rwptr)
	pushj	sp,trace
	hrlm	a,(rwptr)
	pop	sp,b
	sojle	b,cscan
	read
	hrr	a,(rwptr)	;; one more half-word ref
	pushj	sp,trace
	hrrm	a,(rwptr)
	jrst	cscan

;;
;;	copy - pure part handler
;;
cs4:	read			;; skip to error blocks
	hrrz	a,(rwptr)
	subi	a,2
	rd.skp	a
	jrst	cscan
;;
;;	copy - oneof rep handler
;;
cs5=:	cscan
;;
;;	copy - string rep handler
;;
cs6:	hrrz	a,(rwptr)	;; compute length
	movei	a,bpword-1(a)
	idivi	a,bpword
	rd.skp	a
	jrst	cscan
;;
;;	copy - vector handler
;;
cs7=:	cscan
;;
;;	copy - word vector handler
;;
cs8:	hrrz	a,(rwptr)
	movei	a,-1(a)
	rd.skp	a
	jrst	cscan
;;
;;	copy - xvec handler (an xvec is a number of rsb,,ref words)
;;
cs9:	hrrz	a,(rwptr)	;; a has len
	push	sp,a
	jrst	cs9b
cs9a:	read
	hrrz	a,(rwptr)	;; fix one pointer
	hrli	a,t%ref
	pushj	sp,trace
	hrrm	a,(rwptr)
cs9b:	sosle	(sp)
	 jrst	cs9a
	pop	sp,a		;; fix stack back
	jrst	cscan		;; return

;;
;;	the tracef subroutine - traces a full-word ref in a;
;;		puts new word in a
;;
tracef:	hlrz	b,a		;; get type code
	trne	b,refbit	;; check refbit (0 => not a ref)
	 trne	b,relbit	;; make sure not a rel
	  popj	sp,		;; fall through to trace
;;
;;	the trace subroutine - follows the fullword ref in a;
;;		puts new ref in a
;;
trace:	movei	b,(a)		;; get address in b register
	caml	b,hstrt		;; make sure is in heap
	 camle	b,hend
	  popj	sp,
	hlrz	b,(a)		;; get type code of object
	trne	b,gcbit		;; see if a gc type code
	 jrst	marked
	trne	b,refbit	;; should not be a ref
	 jrst	trdie
	trzn	b,repbit	;; should not be an rsb either
	 jrst	trdie
	cail	b,typrep	;; make sure is a rep if not marked
	 cail	b,typrsb
trdie:	  $die	Trace given pointer to non-rep object
	jrst	@trtab-typrep(b)

marked:	movei	c,(b)		;; see if OK (must have gcbit, may have morbit, purbit
	trzn	c,gcbit		;; but no others!
mrkbad:	 $die	Bad code in object to be traced (addr is in a, code in rh b)
	trz	c,morbit+purbit
	jumpn	c,mrkbad
	tron	b,morbit	;; set morbit
	 aos	nmobjs		;; bump number of multiply referred to objs
	hrlm	b,(a)		;; store new type code back
	hrr	a,(a)		;; put in forwarding address
	popj	sp,

trtab:	tr0			;; routines to handle objects
	tr1			;; tr is for "trace length",
	tr2			;; because most of these just get length
	tr3
	tr4
	tr5
	tr6
	tr7
	tr8
	tr9

;;
;;	trace - array dope vector handler
;;
tr0:	hlre	b,1(a)		;; set rel to 0 if size = 0
	jumple	b,.+2		;; make sure size is ok
	 $die	Array size is negative
	jumpn	b,.+2
	 setzm	1(a)
	hrrz	b,2(a)		;; branch based on real stuff
	jumpn	b,tr0a		;; if none, check it out
	skipe	1(a)		;; if no real stuff, better have size = 0
	 $die	Array of size not 0 has no real stuff
	jrst	tr0d

tr0a:	hlrz	c,(b)		;; get the type code of the real stuff
	caml	b,hstrt		;; see if real stuff is in heap
	 camle	b,hend
	  jrst	tr0c
	cain	c,t%vec
	 jrst	atrimc		;; let atrim do its stuff!
	caie	c,t%gref	;; see if already copied
	 cain	c,t%grf2
	  jrst	.+2
	   $die	Bad type code for array real stuff
	push	sp,a		;; save ref to dope vector
	movei	a,(b)		;; form ref to real stuff
	hrli	a,t%ref
	pushj	sp,trace	;; fix the ref
	movei	b,(a)		;; get stuff back in convenient places
	pop	sp,a
	skipn	1(a)		;; more work if there is a rel
	 jrst	tr0b
	hrrz	c,2(a)		;; get old ref
	hrrz	d,1(a)		;; and old rel
	subi	d,(c)		;; form delta
	jumpg	d,.+2
	 $die	Bad rel in array
	addi	d,(b)		;; form new rel
	hrrm	d,1(a)		;; store it back
tr0b:	hrrm	b,2(a)		;; fix ref
	jrst	tr0d

tr0c:	caie	c,t%vec		;; make sure real stuff is a vector
	 $die	Array real stuff not a vector

tr0d:	movei	b,3
	jrst	cpmrki		;; copy dope vector (impure)

;;
;;	trace - all standard, impure blocks with len in right halfword
;;
tr1:		;; call block
tr2:		;; descriptor block
tr3:		;; entry block
tr7:		;; vectors
tr8:		;; word vectors
tr9:		;; ref vectors
	hrrz	b,(a)		;; get len in b
	jrst	cpmrki		;; "call" cpmark and let it return for us (all impure)
;;
;;	trace - pure parts
;;
tr4:	hrrz	b,(a)		;; get len
	jrst	cpmrkp		;; copy it to pure area
;;
;;	trace - oneof objects (all impure for now)
;;
tr5:	movei	b,2
	jrst	cpmrki
;;
;;	trace - strings
;;
tr6:	hrrz	b,(a)
	movei	b,2*bpword-1(b)
	idivi	b,bpword
	jrst	cpmrkp		;; strings are pure
;;
;;	copy and mark subroutine
;;		original ref is in a;
;;		length is in b
;;
cpmrkp:	skipa	wrarea,a.pure	;; loads and skips
cpmrki:	 movei	wrarea,1	;; use heap area for impure things
	pushj	sp,writem	;; write it
	movei	d,(a)		;; use d as pointer
	hrri	a,(c)		;; fix a for caller
	hrl	c,refcod(wrarea)	;; mark it
	movem	c,(d)
	tlo	c,grlbit	;; change to rel
	movni	b,(b)
	hrli	d,(b)		;; form aobjn pointer
	jrst	.+2
cpmlup:	 movem	c,(d)
	addi	c,1
	trnn	c,pgsize-1	;; when crossing boundary, adjustment may be necessary
	 pushj	sp,adjust
	aobjn	d,cpmlup	;; loop marking
	popj	sp,

adjust:	cain	wrarea,1	;; heap is always OK
	 popj	sp,
	lsh	c,-pglog2
	subi	c,2		;; search for next page in table
	push	sp,a		;; need temp
adjlup:	camg	c,.hepag
	 $die	Ran off end of non heap area when marking an object
	hrlz	a,pagtab(c)
	caie	a,(wrarea)
	 soja	c,adjlup
	lsh	c,pglog2
	pop	sp,a
	popj	sp,
;;
;;	array trimming and copying subroutine
;;		algorithm:
;;	1: If array is empty, flush real part, else
;;	2: If atrimf=0 then don't trim array, else
;;	3: If array is one of the ones not to hack, then don't, else
;;	4: new len is max(size, min(abs_val(predict),len))
;;	   if predict<0, is put at start, else at end
;;	NOTE: only arrays with real stuff, which is a t%vec in the heap
;;		are ever given to atrimc
;;
atrimc:	hlre	c,1(a)		;; get -size in c
	jumple	c,.+2
	 $die	Array with negative size found!
	jumpn	c,trim1
trim2:	hllzs	2(a)		;; If size = 0 then flush real stuff
	setzm	1(a)		;; ensure clear rel field
trim2a:	movei	b,3		;; just copy dope vector and return
	jrst	cpmrki

trim1:	trne	flags,atrflg
	 jrst	trim3
	movei	b,(a)		;; make sure ok to trim this one
	came	b,arry1
	 camn	b,arry2
	  jrst	trim3
	aos	natrim		;; bump count of number of arrays hacked
	hlre	b,1(a)		;; b gets size
	movn	b,b
	hlre	c,2(a)		;; c gets predict
	movm	c,c
	hrrz	d,2(a)		;; d gets len
	hrrz	d,(d)
	movei	d,-1(d)
	cail	c,(d)		;; compute min(abs_val(predict),len)
	 movei	c,(d)
	caig	b,(c)		;; compute max(size,min(...))
	 movei	b,(c)
	subi	d,(b)		;; d gets number of words saved
	addm	d,ntrsav	;; bump count of number of words saved
	jumpe	b,trim2		;; if new len is 0, throw real stuff away

;;
;;	we now compute these numbers:
;;		in c - the number of 0 words to precede the real stuff in the copy
;;		in d - the number of 0 words to follow the real stuff in the copy
;;	(the numbers are different if size=0, or size not 0 and predict>0,
;;	 or size not 0 and predict <= 0)
;;
	skipn	1(a)		;; see if size = 0
	 jrst	trim4a
	hlre	c,1(a)		;; get number of extra words in c
	addi	c,(b)
	setz	d,		;; clear d
	skipl	2(a)		;; this is right for predict < 0
	 exch	c,d		;; swap for predict >= 0
	jrst	trim4

trim4a:	movei	c,(b)		;; since size = 0, all words are 0
	setz	d,

trim4:	movei	e,1(b)		;; form new header word
	hrli	e,t%vec
	exch	a,e		;; save pointer and get word in a
	push	sp,wptr		;; save address for later
	write
	setz	a,		;; write the preceding 0's
	push	sp,c		;; save c, too
	jrst	trim5
trim5a:	write
trim5:	sojge	c,trim5a
	move	a,e		;; get address of dope vector in a
	pop	sp,c
	skipn	1(a)		;; see if real stuff to copy
	 jrst	trim6
	push	sp,a		;; save a,b,c,d
	push	sp,b
	push	sp,c
	push	sp,d
	hrrz	b,1(a)		;; get rel
	hlre	a,1(a)		;; get size
	movn	a,a
	exch	a,b		;; get things in right place
	push	sp,a		;; save rel for convenience
	pushj	sp,cpmrki	;; copy real stuff and mark it
	pop	sp,b		;; make first word a grel instead of gref
	movei	a,t%grel
	hrlm	a,(b)
	pop	sp,d		;; get regs back
	pop	sp,c
	pop	sp,b
	jrst	.+2
trim6:	push	sp,a
	setz	a,
	jrst	trim7b		;; now clear rest of stuff
trim7a:	write
trim7b:	sojge	d,trim7a
	pop	sp,a		;; get a back

;;
;;	real stuff has now been copied -
;;		here we zap trimmed words to avoid errors
;;
	hrrz	d,2(a)		;; start from ref
	hrrz	e,1(a)		;; e gets number to zap before stuff
	hrrz	g,(d)		;; save old len
	jumpn	e,trim8a	;; if rel = 0, then size = 0, so zap old len + 1 words
	movei	e,(g)
	jrst	trim8
trim8a:	subi	e,(d)		;; number to clear is rel-ref
	jumpg	e,.+2		;; (better be > 0)
	 $die	Array has bad rel
trim8:	movni	e,(e)
	hrli	d,(e)		;; form aobjn pointer
	movsi	f,t%gbad	;; write t%gbad,,0 in each word
	jumpge	d,trim8b
	movem	f,(d)
	aobjn	d,.-1
trim8b:	addi	g,(e)		;; g has number of locs left to handle
	jumple	g,trim9
	skipn	d,1(a)		;; get size and rel
	 jrst	trim9
	hlre	e,d		;; skip over actual elements
	movn	e,e
	addi	d,(e)
	subi	g,(e)		;; g now has number left to do
	movni	g,(g)
	hrli	d,(g)		;; form aobjn pointer
	jumpge	d,trim9
	movem	f,(d)
	aobjn	d,.-1

;;
;; now fix and copy dope vector
;;
trim9:	pop	sp,b		;; get back new address of vector
	hrrm	b,2(a)		;; fix ref
	addi	b,1(c)		;; number of 0's + 1 + ref is new rel
	skipe	1(a)		;; (fix only if size not 0)
	 hrrm	b,1(a)
	jrst	trim2a		;; do the dope vector

trim3:	skipn	1(a)		;; see if has a rel
	 jrst	trim3a
	hrrz	b,2(a)		;; form delta
	hrrz	c,1(a)
	subi	c,(b)
	jumpg	c,.+2
	 $die	Delta <= 0 in array trim
	hrrm	c,1(a)
trim3a:	push	sp,a
	hrrz	a,2(a)		;; trace and copy real stuff
	hrli	a,t%ref
	pushj	sp,trace
	movei	b,(a)		;; fix dope vector
	pop	sp,a
	hrrm	b,2(a)		;; fix ref
	skipe	1(a)		;; if has rel, fix it
	 addm	b,1(a)
	jrst	trim2a		;; copy dope vector

;;
;;	start of next module - fixup phase
;;
start4:
;;
;; Clu garbage collector - step 4
;;	Fixup phase - in this pass, all heap refs have an offset added
;;		to compensate for the entire heap being installed as
;;		high as possible; rels are fixed (if possible);
;;		bad rels are set to point to the middle
;;		of a non-existent page (the highest page)
;;
;;	Compute table for fixing pointers
;;
	setzm	fixtab		;; clear the fixup table
	move	a,[fixtab,,fixtab+1]
	blt	a,fixtab+numpgs-1
	move	b,.pspag	;; see how many free pages there are
	sub	b,.hepag
	movei	b,-1(b)
	movem	b,pgsoff
	move	a,.hspag	;; set entries in table
	addi	b,(a)
tablup:	camle	a,.hepag
	 jrst	tabcnt
	movei	c,(a)
	xori	c,(b)
	lsh	c,pglog2
	movem	c,fixtab(a)
	movei	b,1(b)
	aoja	a,tablup

tabcnt:	trnn	flags,pfyflg	;; set up the table if purifying
	 jrst	fixdo
	move	a,.hepag
	movei	a,1(a)		;; first page number
	move	b,.pepag	;; start at top and work down
tblup2:	camge	b,.pspag
	 jrst	fixdo
	hlrz	c,pagtab(b)
	caie	c,2		;; pure area is area 2
	 $die	Non heap area other than pure area ??
	hrrm	a,pagtab(b)	;; remember where it goes in the page table
	movei	c,(a)
	xori	c,(b)
	movem	c,fixtab(b)	;; put correcting value in fixtab
	movei	a,1(a)
	soja	b,tblup2

bytsiz==18.-pglog2
bytpos==pglog2
fixdo:	move	j,[<<bytpos*10000>+<bytsiz*100>>,,a]
			;; this is a byte pointer to extract the page number
			;; from an address in the rh of a
;;
;;	Fix up static area(s)
;;
	hrrz	a,basptr	;; get pointer to vector of areas
	hrrz	b,(a)		;; form aobjn pointer
	movni	b,(b)
	hrli	a,(b)
	aobjp	a,bfixdn	;; if none to do, skip loop
basfix:	push	sp,a		;; save aobjn pointer
	move	a,(a)		;; get aobjn pointer to area
	hlre	b,a		;; compute len
	movn	b,b
	pushj	sp,rd.ini	;; init to read from self
	pushj	sp,fscan	;; scan fixing up until run out of stuff
	pop	sp,a		;; get aobjn pointer back
	aobjn	a,basfix
bfixdn:
;;
;;	Now do stack
;;
	hrrz	a,kstrt
	hrrz	b,kend
	subi	b,-1(a)
	pushj	sp,rd.ini
	pushj	sp,fscan
;;
;;	and lastly, the HEAP!
;;
	movei	rdarea,1
	pushj	sp,rdi.in	;; this time, read from inferior
	pushj	sp,fscan	;; note: stops because wptr
				;; is not bothered from copy phase
	trnn	flags,pfyflg	;; scan pure area if necessary
	 jrst	start5		;; go to step 5
	movei	rdarea,2
	pushj	sp,rd.ini
	pushj	sp,fscan
	jrst	start5
;;
;;	First, a simple macro for fixing one ref
;;		fixes ref in right half of a, using given reg as a temp;
;;		left half of a is undisturbed
;;
define	fix	reg

	ldb	reg,j		;; extract page number from a
	xor	a,fixtab(reg)	;; don't fix ones without an entry
	aos	nrefs(rdarea)	;; bump count of number of refs
	termin

;;
;;	the scanning subroutine
;;
fscan:	jumpge	rdarea,fscana	;; different test if reading from self
	sojge	rwleft,.+2
	 popj	sp,
	movei	rwptr,1(rwptr)
	aos	rptr
	jrst	fscanb

fscana:	move	a,rptr
	caml	a,wptr(rdarea)
	 popj	sp,
	read

fscanb:	move	a,(rwptr)
	tlne	a,refbit	;; see if rel or ref
	 jrst	fs.ref
	tlzn	a,repbit	;; see if a rep
	 jrst	fscan		;; skip everything else (i.e., rsb's)
	caml	a,[typrep,,0]	;; make sure is valid rep
	 caml	a,[typrsb,,0]
	  $die	Bad rep in copy-scan
	hlrz	b,a		;; get type code and do indexed jump to routine
	aos	nobjs(rdarea)	;; bump count of objects encountered
	jrst	@fstab-typrep(b)

fs.ref:	tlne	a,relbit	;; handle rels differently
	 jrst	fs.rel
	fix	b
	hrrm	a,(rwptr)
	jrst	fscan

fs.rel:	pushj	sp,fixrel
	movem	a,(rwptr)	;; store fixed rel back
	jrst	fscan
;;
;;	indexed jump table for individual rep handlers
;;
fstab:	fs0			;; array
	fs1			;; call block
	fs2			;; descriptor
	fs3			;; entry
	fs4			;; pure part
	fs5			;; oneof
	fs6			;; string
	fs7			;; vector
	fs8			;; word vector
	fs9			;; ref vector

;;
;; Here are the fixup routines:
;;
;;	fixup - array dope vector handler
;;
fs0:	read			;; go to -size,,rel word
	skipn	a,(rwptr)	;; if size=0, leave rel alone, else add offset to it
	 jrst	fs0a
	fix	b
	sos	nrefs(rdarea)	;; correction
	hrrm	a,(rwptr)
	aos	nfrels
fs0a:	read
	move	a,(rwptr)
	fix	b
	hrrm	a,(rwptr)
	jrst	fscan
;;
;;	fixup - call block handler
;;
fs1:	movei	a,2
	rd.skp	a
	jrst	fscan
;;
;;	fixup - descriptor block handler
;;
fs2:	read
	move	a,(rwptr)
	pushj	sp,fixf
	movem	a,(rwptr)
	read			;; skip special bits
	jrst	fscan

;;
;;	fixup - entry block handler
;;
fs3:	hrrz	b,(rwptr)	;; get size
	read			;; get and fix rel
	hrrz	a,(rwptr)
	pushj	sp,fixrel
	hrrm	a,(rwptr)
	read			;; fix lr,,pr pair (en.lpr)
	move	a,(rwptr)
	fix	c
	movs	a,a
	fix	c
	movsm	a,(rwptr)
	read			;; fix variable init (en.vi)
	hlrz	a,(rwptr)	;; get ref+1 to var init pair
	sojl	a,fs3a		;; don't fix if there is none
	fix	c
	movei	a,1(a)
	hrlm	a,(rwptr)
fs3a:	subi	b,4
	jumple	b,fscan
	read			;; fix parm vectors (en.par)
	move	a,(rwptr)
	fix	c
	movs	a,a
	fix	c
	movsm	a,(rwptr)
	sojle	b,fscan
	read
	jrst	fscan		;; go fix any remaining refs
;;
;;	fixup - pure part handler
;;
fs4:	read
	hrrz	a,(rwptr)	;; skip to error info
	subi	a,2
	rd.skp	a
	jrst	fscan
;;
;;	fixup - oneof rep handler
;;
fs5=:	fscan
;;
;;	fixup - string rep handler
;;
fs6:	hrrz	a,(rwptr)	;; compute length
	movei	a,bpword-1(a)
	idivi	a,bpword
	rd.skp	a
	jrst	fscan
;;
;;	fixup - vector handler
;;
fs7=:	fscan
;;
;;	fixup - word vector handler
;;
fs8:	hrrz	a,(rwptr)
	movei	a,-1(a)
	rd.skp	a
	jrst	fscan

;;
;;	fixup - xvec handler (an xvec is a number of rsb,,ref words)
;;
fs9:	hrrz	b,(rwptr)	;; a has len
fs9a:	sojle	b,fscan
	read
	move	a,(rwptr)	;; fix one pointer
	fix	c
	hrrm	a,(rwptr)
	jrst	fs9a
;;
;;	fixf - fix a fullword subroutine
;;		word is in a
;;
fixf:	tlnn	a,refbit	;; see if is a ref or rel
	 popj	sp,		;; (note: does not catch reps)
	tlne	a,relbit	;; handle rels differently
	 jrst	fixrel
	fix	b		;; fix the ref
	popj	sp,
;;
;;	fixrel - fix a rel subroutine (rel is in a)
;;
fixrel:	aos	nrels
	movei	b,(a)
	caml	b,hstrt		;; no fix required if not in heap
	 camle	b,hend		;; NOTE: this test works during purification, too
	  popj	sp,
	hlrz	b,(a)		;; get type code half
	trzn	b,gcbit		;; must be marked
	 jrst	fxbrel
	trz	b,morbit+grlbit+purbit
	jumpn	b,fxbrel
	hrr	a,(a)		;; get forwarding address
	fix	b
	aos	nfrels
	popj	sp,

fxbrel:	hrri	a,badrel	;; make it a bad rel
	aos	nbrels		;; bump count of number of bad rels
	popj	sp,		;; return

;;
;;	start of next module - stack restoration phase
;;
start5:
;;
;; Clu garbage collector - step 5
;;	Stack frame restoration and finalization
;;
;;	Recall that the format of a frame as used in the CLU system is:
;;			-1:  mr,,ra
;;		ptr->	 0: ier,,oer
;;	where:
;;		mr = module register (rh of a ref)
;;		ra = return address (rh of a rel)
;;		oer = old environment register (points to a frame or = 0)
;;		ier = iterator environment register (same format as oer)
;;	We saved two words (in the order presented)
;;		ptr
;;		ier,,oer
;;	and transformed the frame into this:
;;			-1: t%rel,,ra
;;		ptr->	 0: t%ref,,mr
;;	Here we restore the frames to their original format.
;;
	setz	rdarea,		;; start reading frame area back
	pushj	sp,rdi.in
	move	i,nframe	;; i keeps number of frames left to do
	jrst	loop5e

loop5:	read
	move	a,(rwptr)	;; get address of frame in a
	hrrz	b,(a)		;; get mr part,
	hrlm	b,-1(a)		;; and stuff it back
	read
	move	b,(rwptr)	;; fix other word
	movem	b,(a)
loop5e:	sojge	i,loop5

;;
;;	Now we map the heap back in, throw away extra pages, and kill the inferior
;;
	move	a,.hspag	;; starting page in inferior
	movem	a,pgsrc
	movei	b,(a)
	add	a,pgsoff	;; see where to map pages in
	sub	b,.hepag	;; compute how many to map
	subi	b,1
	hrli	a,(b)		;; form blt pointer
	movem	a,pgdest
	.call	mapin
	 $die	Couldn't map the heap back in
	skipn	a,purpgs	;; see if any (previously) pure pages to map back
	 jrst	purmap		;; go see if new pure pages to map in
	movem	a,pgdest
	hrrzm	a,pgsrc
	.call	pmpin
	 $die	Couldn't get old pure pages back!
	jrst	delpgs

purmap:	tlnn	flags,pfyflg	;; if purifying, map those pages in
	 jrst	delpgs
	move	a,.pspag
pmloop:	camle	a,.pepag
	 jrst	delpgs
	movem	a,pgdest
	hrrz	b,pagtab(a)
	movem	b,pgsrc
	.call	pmpin
	 $die	Could not get purified page back!
	aoja	a,pmloop

delpgs:	move	a,[-2,,numpgs-2]	;; delete top two pages
	movem	a,pgdest
	.call	pagdel
	 $die	Could delete top two pages

;;
;;	Now, get rid of extra pages between heap and stack
;;		(for efficiency, leave one below heap if possible;
;;			it must be zeroed!)
;;
	move	a,kend
	lsh	a,-pglog2
	movei	a,1(a)		;; a now has number of page just above stack
	movei	b,(a)
	move	c,.hspag
	add	c,pgsoff
	subi	a,-1(c)
	hrli	b,(a)
	movem	b,pgdest
	jumpge	a,pgtest
	.call	pagdel
	 $die	Couldn't delete extra pages!
pgtest:	lsh	c,pglog2	;; see if page just below heap exists
	camg	c,hstrt
	 jrst	gcdone		;; note: c contains new low bound of allocated stuff
	subi	c,pgsize	;; set c and clear the page
	setzm	(c)
	movei	a,(c)
	hrli	a,(a)
	addi	a,1
	blt	a,pgsize-1(c)
;;
;;	Now finished!
;;
gcdone:	.uclose	usro,		;; kill inferior

;;
;;	We must give some info back
;;
;;		 4	end of stack
;;		 5	start of heap
;;		 6	new "memlo" (lowest existing word for allocation)
;;		 7	number of words "saved" by GC
;;		10	end of heap
;;
	move	6,c		;; c has this value from above
	move	7,oldend
	jumpn	7,.+2
	 move	7,hend
	sub	7,hstrt		;; number of words at start of GC
	move	a,.hspag
	lsh	a,pglog2
	movni	a,(a)
	add	a,wptr+1
	subi	7,-1(a)		;; 7 gets # of words saved
	move	5,.hspag
	add	5,pgsoff
	lsh	5,pglog2
	hrr	4,kend
	hrli	4,600000	;; avoids pdl under/overflow
	move	10,pgsoff
	lsh	10,pglog2
	add	10,wptr+1
	movei	10,-1(10)
	movem	10,oldend
	move	17,4		;; must give CLUSYS its stack pointer
	setzb	11,12		;; clear all of CLUSYS' special regs
	setzb	13,14
	setzb	15,16
	jsp	1,intrst	;; restore interrupts
	jrst	@rtnadr		;; return
	.lstof
	end
