2.9BSD/usr/src/ucb/lisp/v7source/gcol.m11
; Copyright (c) 1981 Harvard-Radcliffe Student Timesharing System
; Science Center, Harvard University
.psect shrcode con
;
;;this section of code is the garbage collector
;;it reclaims unused atoms, dtprs, numbers, and bcd
;;
;;in interest of speed, the collection of atoms is not enabled
;;normally. if one feels that he can use this feature, then
;;there is a language level switch
;;that enables full collection
;;
;;
;;this code is the recursive part of the collector that does the marking
;;the driver and marker follow
;;
;;note that the gc bit on each object is the 0 bit in the first
;;word of that object. this gives a quick check as to whether the
;;object is already loved or not, and therefore whether on needs to fool
;;around with it.
;
;
gcolinr:
.if eq,multiseg
.if ne,nilas0
jmpifnil a,31$
.endc
.endc
mov b,np ;use np to tell how many things on stack
br 21$
10$: pop a
20$:
.if eq,multiseg
.if ne,nilas0
jmpifnil a,2$,nl
.endc
.endc
21$: bit b,(a) ;b is loaded with constant 1
bne 2$
7$:
dispatch
br 3$ ;if number
.word 0 ;for dispatch allowing 2 words/inst
br 4$ ;dtpr
.word 0
br 5$ ;atom
.word 0
br 6$ ;bcd
1$: bis b,(a) ;hole...
2$: sob np,10$ ;port + other stuff
31$: ret
3$: brifsmalint a,2$ ;integer code
br 1$
5$: jmpifnil (a),35$ ;save push if possible
push (a) ;trace atom out
inc np
35$: bis b,(a)+ ;mark it
tst (a)+ ;point to fb
jmpifnil (a),36$ ;and this one
push (a) ;trace shallowest (probably) first
inc np
36$: mov -(a),a ;get middle
br 20$
4$: tst (a)+ ;want to push on cdr,trace car
jmpifnil (a),37$ ;again, don't push nil on
push (a)
inc np ;one deeper
37$:
bis b,-(a)
mov (a),a ;get car
bic b,a ;and clear it
br 20$
6$: tstb supcol
beq 8$
.if eq,multiseg
cmp a,#firpage
blos 8$
.endc
bis b,(a)
8$:
mov 2(a),a
br 20$
.rsect shrcode
nogcol: ;not enough stack space
add #100.+20,sp ;see if np is too large
mov npbottom,np
cmp sp,np
blo 1$
add #20,npbottom ;help in future gcol's
1$:
mov np,sp
generm </not enough stack space to attempt gcol/<12>//>
mov #tmp-<^pl errorm>,a
call geterr
loadnil @np
call putstr
jmp lsploop
;this is the collector driver
gcol: incb noint ;do not allow 5^c's
mov j1,-(sp) ;save r0
$sig
11. ;seg fault
nogcol
mov %0,$$sig+4 ;prepare to reset trap
add #-100.,sp ;gotta make sp point...
mov sp,j1 ;first move sp to j1 and
bic #17777,j1 ;see about testing somebody's seg
cmp j1,$$break+2 ;instead of nowhere
blos nogcol ;woops--this is owned!!!
tst (sp) ;now see if is in no man's land
add #100.,sp ;there had to be room
mov #11.,$$sig+2 ;and trap type
$indir
$$sig
push a
push b
push j2
push j3
push np
mov sp,gcolf ;save sp
.if df,gctrace
.globl gcex,gcem
npush #anil
outstr gcem
call dmpport
.if df,width
clrb poport+1
.endc
add #-4,np
.endc
resgcol:
mov #1,b
tstb supcol
beq 10$ ;if in short mode, save all atoms
.if eq, hash
.ift
mov xoblist,j1
1$: bic b,j1 ;clear tracebit if nec.
jmpifnil j1,20$
car j1,j2
bis b,(j1)
bit b,(j2)
bne 9$
cmp j2,#lsatm
blo 2$
.if ne,nilas0
tst (j2)
bne 2$
tst 2(j2)
bne 2$
tst 4(j2)
beq 9$
.iff
cmp (j2),#anil
bne 2$
cmp 2(j2),#anil
bne 2$
jmpifnil 4(j2),9$
.endc
2$: mov j2,a
call gcolinr
9$: cdr j1,j1
br 1$
.iff
mov #<2*hash>,j3
7$: mov <hasht-2>(j3),j1
1$: bic b,j1
jmpifnil j1,9$
car j1,j2
bis b,(j1)+
bit b,(j2)
bne 8$
mov j2,a
cmp j2,#lsatm
blo 6$
.if ne,nilas0
tst (j2)+
bne 6$
tst (j2)+
bne 6$
tst (j2)
beq 8$
.iff
jmpnnil (j2)+,6$
jmpnnil (j2)+,6$
jmpifnil (j2),8$
.endc
6$: call gcolinr
8$: mov @j1,j1
br 1$
9$: bit #2,j3
beq 2$
bis b,<hasht-2>(j3)
2$: dec j3
sob j3,7$
.endc
10$: mov xoblist,a
call gcolinr
;now we trace the namestack
;j1-j3 are available
20$: mov (sp),j1
mov cptop,j2
tst (j2)+ ;get to first entry
11$: cmp j2,j1
bhi 19$ ;if past stack, quit
mov (j2)+,a
call gcolinr
br 11$
;and now the cstk
;the things that are traced are oddaddresses, and things protected by snags
;which are at the moment eexit,(eexit1),brksnag,register snags
19$: mov sp,j1
add #14,j1
mov cptop,j2
21$: bit b,(j1)
beq 22$
mov (j1)+,a
bic b,a
call gcolinr
br 23$
22$: cmp #eexit,(j1)
bne 29$
28$: tst (j1)+
mov (j1)+,a
call gcolinr
tst (j1)+
mov (j1)+,a
call gcolinr
br 23$
29$:
.if ne,xfer
cmp #eexit1,(j1)
beq 28$
.endc
cmp #brksnag,(j1)
beq 56$
cmp #r4rres,(j1)
beq 55$
cmp #r3rres,(j1)
beq 54$
cmp #r2rres,(j1)
beq 52$
cmp #r1rres,(j1)+
beq 51$
br 23$
56$: cmp (j1)+,(j1)+
55$: tst (j1)+
54$: tst (j1)+
52$: tst (j1)+
tst (j1)+
51$: tst (j1)+
23$: cmp j1,j2
blo 21$
;well, that it for the tracing.
;now we gotta go around and collect the stuff we've played with
;and reset the gcbits back to 0
;refreshing our memory on the qmap values
; -5 owned by monitor
; -4 stack space(np+cp)
; -3 not allocated but owned by us
; -2 allocatecd by port
; -1 binary code
; 0 word
; 1 dtpr
; 2 atom
; 3 bcd(p)
; 4 port
;
;first we gotta get rid of the freelists
loadnil fnumber
loadnil fdtpr
tstb supcol
beq 30$
loadnil fbcd
30$: clr cdtpr
clr cnumber
;reminder a,j1-np are available for the gathering process
;b still contains 1
.if eq,multiseg
.ift
mov #firpage,np
.iff
mov #starbc,np
.endc
colloop: mov np,j3
swab j3
movb qmap(j3),j2
1$: add #^d256,np
asl j2; mult by two
jmp @gcjmtbl(j2)
.psect shrwddat con
gcfinup ;if in monitor core
gcfinup ;or in stack space
colloop
colloop ;if port or free ignore page
colloop ;ditto for sys
gcjmtbl: gccolwd
gccoldt
colloop ;atoms are taken care of latter
gccolbcd ;for bcd
colloop ;take care of ports
.psect shrcode con
gccoldt: mov fdtpr,j1
mov cdtpr,j2
call gcwdat
mov j1,fdtpr
mov j2,cdtpr
br colloop
gccolwd: mov fnumber,j1
mov cnumber,j2
call gcwdatt
mov j1,fnumber
mov j2,cnumber
br colloop
gcwdat: mov np,a
mov #^d64,j3
1$: add #-4,a
bit b,(a)
beq 2$
bic b,(a)
sob j3,1$
ret
2$: mov j1,(a)
inc j2
mov a,j1
sob j3,1$
ret
gccolbcd: tstb supcol
bne 2$
6$: br colloop
2$:
.if eq,multiseg
.ift
mov np,a
sub #^d256,a
3$: mov (a),j1
bic #177001,j1
bit b,(a)
bne 4$
mov fbcd,2(a)
mov a,fbcd
4$: bic b,(a)
add j1,a
cmp a,np
blo 3$
br 6$
.iff
mov np,a
mov np,j3
sub #6,j3
sub #^d256,a
4$: bit b,(a)
bne 5$
mov fbcd,2(a)
mov a,fbcd
5$: bic b,(a)
add #6,a
cmp a,j3
blo 4$
br 6$
.endc
gcfinup: tstb supcol
beq 20$
.if eq,hash ;implement supercolect on atoms...
mov #<xoblist-2>,a
9$: cdr a,j1
jmpifnil j1,30$,nl
car j1,j3
bit b,(j3)
beq 10$
bic b,(j3)
mov j1,a
br 9$
10$: cdr j1,2(a)
mov fdtpr,(j1)
mov j1,fdtpr
inc cdtpr
mov #4,j2
mov j3,np
add #6,np
11$: inc np
tstb (np)+
beq 12$
inc j2
br 11$
12$: mov j2,2(j3) ;save count
mov fratom,(j3)
mov j3,fratom
br 9$
.iff
mov #<2*hash>,np
5$: mov np,a
add #<hasht-2>,a
jmpifnil (a),14$
6$: mov @a,j1
jmpifnil j1,14$,nl
mov (j1)+,j2
bit b,(j2)
beq 10$
bic b,(j2)
mov j1,a
br 6$
10$: mov @j1,(a)
mov fdtpr,-(j1)
mov j1,fdtpr
inc cdtpr
mov #4,j3
mov j2,j1
add #6,j1
11$: inc j1
tstb (j1)+
beq 12$
inc j3
br 11$
12$: mov j3,2(j2)
mov fratom,(j2)
mov j2,fratom
br 6$
14$: dec np
sob np,5$
br 30$
.endc
20$: ;here if not supcol, to clear oblist bits
call clrobl ;clear bits...
; br 30$ ;and finish up
30$: cmp mfdtpr,cdtpr
blos 31$
call globallc
mov a,np
beq fgcexit
movb #1,qmap(a)
swab np
add #400,np
mov cdtpr,j2
mov fdtpr,j1
call gcwdat
mov j1,fdtpr
mov j2,cdtpr
31$: cmp mfnumb,cnumber
blos 32$
call globallc
mov a,np
beq fgcexit
clrb qmap(a)
swab np
add #400,np
mov cnumber,j2
mov fnumber,j1
call gcwdatt
mov j1,fnumber
mov j2,cnumber
br 30$
32$:
cmp mfdtpr,cdtpr
bhi 30$
resstack:
pop np
.if df,gctrace
npush #anil
outstr gcex
call dmpport
.if df,width
clrb poport+1
.endc
add #-4,np
.endc
pop j3
pop j2
pop b
pop a
pop j1
clr gcolf
decb noint ;and allow ^c's
ret
fgcexit:
mov 14(sp),saveloc ;save real return
mov #1$,14(sp)
br resstack ;pop off things
1$: ;and return here...
.if ne,xfer ;if we are env xfer material
call noroom ;go to routine
nroomg: ;leaving trail......
.iff
push saveloc ;push return back on
save1
mov a,j3 ;this saves register a
;now we go into the error routine
;if no more dtprs avail, and brksig#0, then give differnt error, and
;allow break to return to tl.
.if ne, brksig
tst cdtpr
beq fgcebrk
.iftf
error </cannot reclaim required amount of ints or dtprs/>,3$
3$: mov j3,a
mov 2(sp),j3
cmp (sp)+,(sp)+
4$: jmp gcol
.ift
fgcebrk:
$sig
brksig
lsploop
error </no more dtprs--hit break to return to top level/>
.endc
.endc
.rsect shrcode
clrobl: ;this file clears the oblist bits
;used when overflow occurs
;and when gcfinup finishes up
.if eq,hash
mov xoblist,a
21$:
jmpifnil a,30$,nl
bic b,(a) ;clear the mark bit
car a,j1
bic b,(j1)
cdr a,a
br 21$
.iff
mov #<2*hash>,j1
21$: bic b,<hasht-2>(j1)
mov <hasht-2>(j1),a
22$:
jmpifnil a,23$,nl
bic b,(a)
mov (a)+,j2 ;get ready for cdr as well as take car
bic b,(j2)
mov (a),a ;the cdr refered to above
br 22$
23$: dec j1
sob j1,21$
.endc
ret
.rsect shrcode
gcolovr: ;this routine takes care of
;gc overflow..............
;first, restore stack
mov gcolf,sp
.if ne,gcrec
;rearm stack ovr
$sig
11.
segfault
.if df,gctrace ;get out message...
loadnil -(sp) ;load nil on sp
mov sp,np ;and fool np
generm <//<12>/***attempt to recover from gcol stack overflow ***/<12>//>
mov #tmp-<^pl errorm>,a
call geterr
call putstr
call dmpport
.if df,width
clrb poport+1
.endc
tst (sp)+ ;back up sp
.endc
mov #1,b ;leave b ok
;and now scan the env to fix things up...
.if eq,multiseg
mov #firpage,j3
.iff
mov #starbc,j3
.endc
1$: mov j3,j2
mov j3,a
swab a
add #400,j3
movb qmap(a),a
bmi 10$
cmp a,#1
beq 5$
cmp a,#3
bne 1$ ;loop for more...
2$: ;here for binary code
.if eq,multiseg ;case for d space only
cmp j2,j3
bhis 1$ ;done...
mov 2(j2),a ;get arg ready
mov (j2),j1
bic #177000,j1
add j1,j2 ;and make j2 point to next
bit b,j2 ;if odd, we collect
beq 3$
call gcolinr ;collect thing
3$:
bic b,j2
br 2$
.iff
mov j2,j1
add #6,j2
cmp j2,j3
bhis 1$
bit b,(j1)+
beq 2$
mov (j1)+,a
call gcolinr
br 2$
.endc
5$: ;here for dtprs...
bit b,(j2)
beq 6$
mov (j2)+,a
bic b,a ;clear it
call gcolinr
mov (j2)+,a
call gcolinr
br 8$
6$:
cmp (j2)+,(j2)+
8$:
cmp j2,j3
blo 5$
br 1$
10$:
.if df,gctrace
generm <//<12>/*** about to clear all those oblist bits ***/<12>//>
mov #tmp-<^pl errorm>,a
call geterr
loadnil -(sp)
mov sp,np
call putstr
call dmpport
.if df,width
clrb poport+1
.endc
tst (sp)+
mov #1,%0
.endc
call clrobl ;clear the oblist bits....
.if ne,hash ;gotta clear oblist
mov xoblist,a
mov #<hash/2>,j1
12$: bic b,(a)+
mov (a),a
sob j1,12$
.endc
.if df,gctrace
generm </about to jump to gcresume/<12>//>
mov #tmp-<^pl errorm>,a
call geterr
loadnil -(sp)
mov sp,np
call putstr
call dmpport
.if df,width
clrb poport+1
.endc
tst (sp)+
mov #1,b
.endc
jmp resgcol
.iff
generm <//<12>/gc stack overflow--lisp exit/<12>/**********/>
mov #tmp-<^pl errorm>,a
call geterr
loadnil -(sp)
mov sp,np
call putstr
call dmpport
$exit
.endc