PDP-10.its/src/mudsys/utilit.106

TITLE	UTILITY FUNCTIONS FOR MUDDLE

RELOCATABLE

.INSRT MUDDLE >

SYSQ

IFE ITS,[
.INSRT STENEX >
XJRST==JRST 5,
]

.GLOBAL GODUMP,IPURIF,EGCDUM,EPURIF,LODGC,KILGC,CALER,RBLDM,CPOPJ,C1POPJ,INQAGC,FRETOP
.GLOBAL SAT,PGFIND,PGGIVE,PGTAKE,PINIT,ERRKIL,CKPUR,GCSET,MKTBS,PFLG,NPWRIT,GETNUM
.GLOBAL AGC,AAGC,%CLSM1,%SHWND,IBLOCK,FINAGC,PGINT,CPOPJ1,REHASH,FRMUNG,MAXLEN,TOTCNT
.GLOBAL NWORDT,NWORDS,MSGTYP,IMTYO,MULTSG,MULTI,NOMULT,GCDEBU
.GLOBAL	PURCOR,INCORF,BADCHN,INTHLD,%MPIN1,WNDP,WIND,ACCESS,PURTOP,GCPDL,CTIME,P.CORE
.GLOBAL IAGC,IAAGC,TYPVEC,PURBOT,PURTOP,MOVPUR,PURVEC,PMAPB,CURPLN,RFRETP,NOWFRE,FREMIN
.GLOBAL MAXFRE,TPGROW,PDLBUF,CTPMX,PGROW,PDLBUF,CPMX,SAVM,NOWP,NOWTP,MPOPJ,GCFLG,GCDOWN
.GLOBAL GCTIM,NOSHUF,P.TOP,GETPAG,ITEM,INDIC,ASOVEC,ASOLNT,GETBUF,KILBUF,PAT,PATEND
.GLOBAL PATCH,DSTORE,PVSTOR,SPSTOR,SQKIL,IAMSGC,FNMSGC,RNUMSP,NUMSWP,SWAPGC,SAGC,GCSTOP
.GLOBAL ISECGC
.GLOBAL C%11,C%22,C%33,C%44,C%55,C%66,C%0,C%1,C%2,C%3,C%M1,C%M2,C%M10
.GLOBAL C%M20,C%M30,C%M40,C%M60

FPAG==2000

; GC-DUMP TAKES AN OBJECT AND MAPS IT INTO A FILE DIRECTLY USING THE GARBAGE
; COLLECTOR.  ALL OBJECTS HAVE RELATIVIZED POINTERS AND WILL BE SET UP UPON
; READIN (USING GC-READ).
; IT TAKES TWO ARGUMENTS. THE FIRST IS THE OBJECT THE SECOND MUST BE A "PRINTB"
; CHANNEL.

MFUNCTION GCDUMP,SUBR,[GC-DUMP]

	ENTRY

IFE ITS,[
	PUSH	P,MULTSG
	SKIPE	MULTSG			; MUST RUN I 0 SEXTION MODE
	 PUSHJ	P,NOMULT
]
	MOVE	PVP,PVSTOR+1
	IRP	AC,,[FRM,P,R,M,TP,TB,AB]
	MOVEM	AC,AC!STO"+1(PVP)
	TERMIN

	SETZM	PURCOR
	SETZM	INCORF			; SET UP PARAMS
	CAML	AB,C%M20		; CHECK ARGS
	 JRST	TFA
	CAMG	AB,C%M60
	 JRST	TMA
	GETYP	A,2(AB)			; SEE WHETHER THE CHANNEL IS A WINNER
	CAIN	A,TFALSE		; SKIP IF NOT FALSE
	 JRST	UVEARG
	CAIE	A,TCHAN
	 JRST	WTYP2			; ITS NOT A CHANNEL. COMPLAIN
	MOVE	B,3(AB)			; CHECK BITS IN CHANNEL
	HRRZ	C,-2(B)
	TRC	C,C.PRIN+C.OPN+C.BIN
	TRNE	C,C.PRIN+C.OPN+C.BIN
	 JRST	BADCHN
	PUSH	P,1(B)			; SAVE CHANNEL NUMBER
	CAMGE	AB,C%M40		; SEE IF THIRD ARG WAS SNUCK IN
	 JRST	TMA
	JRST	IGCDUM

UVEARG:	SETOM	INCORF			; SET UP FLAG INDICATING UVECTOR
	CAML	AB,C%M40			; SEE IF THIRD ARG
	 JRST	IGCDUM
	GETYP	A,5(AB)
	CAIE	A,TFALSE
	 SETOM	PURCOR
IGCDUM:	SETZM	SWAPGC
	PUSHJ	P,LODGC				; GET THE GARBAGE COLLECTOR
	SETOM	INTHLD
	JRST	GODUMP

EGCDUM:	PUSH	P,A				; SAVE LENGTH
	PUSHJ	P,KILGC				; KILL THE GARBAGE COLLECTOR
	POP	P,A
	SETZM	INTHLD
	SKIPN	INCORF				; SKIP IF TO UVECTOR
	JRST	OUTFIL
	SKIPN	PURCOR				; SKIP IF PURE UVECTOR
	JRST	BLTGCD

; ROUTINE TO CREATE A UVECTOR IN PURE STORAGE CONTAINING GC-DUMPED
; OBJECTS.

	ADDI	A,1777				; ROUND
	ANDCMI	A,1777
	ASH	A,-10.				; TO BLOCKS
	PUSH	P,A				; SAVE IT
TRAGN:	PUSHJ	P,PGFIND			; TRY TO GET PAGES
	JUMPL	B,GCDPLS			; LOSSAGE?
	POP	P,A				; GET # OF PAGES
	PUSH	P,B				; SAVE B
	MOVNS	A				; BUILD AOBJN POINTER
	HRLZS	A
	ADDI	A,FPAG/2000			; START
	HLL	B,A				; SAME # OF PAGES
	PUSHJ	P,%MPIN1
	POP	P,B				; RESTORE # OF FIRST PAGE
	ASH	B,10.				; TO ADDRESS
	POP	P,A				; RESTORE LENGTH IN WORDS
	MOVNI	A,-2(A)				; BUILD AOBJN
	HRL	B,A
	MOVE	A,$TUVEC			; TYPE WORD
	JRST	DONDUM				; FINISH

; HERE WHEN EFFORTS TO GE PURE STORAGE FAIL.

GCDPLS:	MOVE	A,(P)				; GET # OF PAGES
	ASH	A,10.				; TO WORDS
	ADDI	A,1777
	ANDCMI	A,1777				; ROUND AND TO PAGE
	MOVEM	A,GCDOWN
	MOVE	C,[13.,,9.]			; CAUSE INDICATOR
	PUSHJ	P,AGC				; CAUSE AGC TO HAPPEN
	MOVE	A,(P)				; GET # OF PAGES
	JRST	TRAGN				; TRY AGAIN

; HERE TO TRANSFER FROM INFERIOR TO THE FILE
OUTFIL:	PUSH	P,A				; SAVE LENGTH OF FILE
	PUSHJ	P,SETBUF
	MOVE	A,(P)
	ANDCMI	A,1777
	ASH	A,-10.				; TO PAGES
	MOVNS	A				; SET UP AOBJN POINTER
	HRLZS	A
	ADDI	A,1				; STARTS ON PAGE ONE
	MOVE	C,-1(P)				; GET ITS CHANNEL #
	MOVE	B,BUFP				; WINDOW PAGE
	JUMPGE	A,DPGC5
IFN ITS,[
DPGC3:	MOVE	D,BUFL
	HRLI	D,-2000				; SET UP BUFFER IOT POINTER
	PUSHJ	P,%SHWND			; SHARE INF PAGE AND WINDOW
	DOTCAL	IOT,[C,D]
	FATAL GCDUMP-- IOT FAILED
	AOBJN	A,DPGC3
]
IFE ITS,[
DPGC3:	MOVE	B,BUFP
	PUSHJ	P,%SHWND
	PUSH	P,A				; SAVE A
	PUSH	P,C				; SAVE C
	MOVE	A,C				; CHANNEL INTO A
	MOVE	B,BUFL				; SET UP BYTE POINTER
	HRLI	B,444400
	MOVNI	C,2000
	SOUT					; OUT IT GOES
	POP	P,C
	POP	P,A				; RESTORE A
	AOBJN	A,DPGC3
]

DPGC5:	MOVE	D,(P)				; CALCULATE AMOUNT LEFT TO SEND OUT
	MOVE	0,D
	ANDCMI	D,1777				; TO PAGE BOUNDRY
	SUB	D,0				; SET UP AOBJN PTR FOR OUTPUT
IFN ITS,[
	HRLZS	D
	ADD	D,BUFL
	MOVE	B,BUFP				; SHARE WINDOW
	PUSHJ	P,%SHWND
	DOTCAL	IOT,[C,D]
	FATAL	GCDUMP-- IOT FAILED
]
IFE ITS,[
	MOVE	B,BUFP				; SET UP WINDOW
	PUSHJ	P,%SHWND
	MOVE	A,C				; CHANNEL TO A
	MOVE	C,D
	MOVE	B,BUFL				; SET UP BYTE POINTER
	HRLI	B,444400
	SOUT
]	POP	P,D
	MOVE	B,3(AB)				; GET CHANNEL
	ADDM	D,ACCESS(B)

	PUSHJ	P,KILBUF
	MOVE	A,(AB)				; RETURN WHAT IS GIVEN
	MOVE	B,1(AB)
DONDUM:	PUSH	TP,A				; SAVE RETURNS
	PUSH	TP,B
	PUSHJ	P,%CLSM1
	SUB	P,C%11
IFE ITS,[
	POP	P,MULTSG
	SKIPE	MULTSG
	 PUSHJ	P,MULTI
]
	POP	TP,B
	POP	TP,A
	JRST	FINIS


; HERE TO BLT INTO A UVECTOR IN GCS

BLTGCD:	PUSH	P,A				; SAVE # OF WORDS
	PUSHJ	P,SETBUF
	MOVE	A,(P)
	PUSHJ	P,IBLOCK			; GET THE UVECTOR
	PUSH	TP,A				; SAVE POINTER TO IT
	PUSH	TP,B
	MOVE	C,(P)				; GET # OF WORDS
	ASH	C,-10.				; TO PAGES
	PUSH	P,C				; SAVE C
	MOVNS	C
	HRLZS	C
	ADDI	C,FPAG/2000
	MOVE	B,BUFP				; WINDOW ACTS AS A BUFFER
	HRRZ	D,(TP)				; GET PTR TO START OF UVECTOR
	JUMPGE	C,DUNBLT			; IF < 1 BLOCK
LOPBLT:	MOVEI	A,(C)				; GET A BLOCK
	PUSHJ	P,%SHWND
	MOVS	A,BUFL				; SET UP TO BLT INTO UVECTOR
	HRRI	A,(D)
	BLT	A,1777(D)			; IN COMES ONE BLOCK
	ADDI	D,2000				; INCREMENT D
	AOBJN	C,LOPBLT			; LOOP
DUNBLT:	MOVEI	A,(C)				; SHARE LAST PAGE
	PUSHJ	P,%SHWND
	MOVS	A,BUFL				; SET UP BLT
	HRRI	A,(D)
	MOVE	C,-1(P)				; GET TOTAL # OF WORDS
	MOVE	0,(P)
	ASH	0,10.
	SUB	C,0				; CALCULATE # LEFT TO GO
	ADDI	D,-1(C)				; END OF UVECTOR
	BLT	A,(D)
	SUB	P,C%22			; CLEAN OFF STACK
	PUSHJ	P,KILBUF
	POP	TP,B
	POP	TP,A
	JRST	DONDUM				; DONE

SETBUF:	MOVEI	A,1
	PUSHJ	P,GETBUF
	MOVEM	B,BUFL
	ASH	B,-10.
	MOVEM	B,BUFP
	POPJ	P,


; LITTLE ROUTINES USED ALL OVER THE PLACE

MSGTYP: HRLI	B,440700	;MAKE BYTE POINTER
MSGTY1:	ILDB	A,B		;GET NEXT CHARACTER
	JUMPE	A,CPOPJ		;NULL ENDS STRING
	CAIE	A,177		; DONT PRINT RUBOUTS
	PUSHJ	P,IMTYO
	JRST	MSGTY1		;AND GET NEXT CHARACTER
CPOPJ:	POPJ	P,


; ROUTINE TO PURIFY A STRUCTURE AND FREEZE ATOMS POINTED TO BY IT.
; TAKES ONE ARGUMENT, THE ITEM TO PURIFY

MFUNCTION PURIF,SUBR,[PURIFY]

	ENTRY

	JUMPGE	AB,TFA			; CHECK # OF ARGS

IFE ITS,[
	PUSH	P,MULTSG
	SKIPE	MULTSG			; MUST RUN I 0 SEXTION MODE
	 PUSHJ	P,NOMULT
]
	MOVE	C,AB
	PUSH	P,C%0				; SLOT TO SEE IF WINNER
PURMO1:	HRRZ	0,1(C)
	CAML	0,PURTOP
	JRST	PURMON				; CHECK FOR PURENESS
	GETYP	A,(C)				; SEE IF ITS MONAD
	PUSHJ	P,SAT
	ANDI	A,SATMSK
	CAIE	A,S1WORD
	CAIN	A,SLOCR
	JRST	PURMON
	CAIN	A,SATOM
	JRST	PURMON
	SKIPE	1(C)				; SKIP IF EMPTY
	SETOM	(P)
PURMON:	ADD	C,C%22			; INC AND GO
	JUMPL	C,PURMO1
	POP	P,A				; GET MARKING
	JUMPN	A,PURCON
NPF:	MOVE	A,(AB)				; FINISH IF MONAD
	MOVE	B,1(AB)
IFE ITS,[
	POP	P,MULTSG
	SKIPE	MULTSG
	 PUSHJ	P,MULTI
]
	JRST	FINIS

PURCON:	SETZM	SWAPGC
	PUSHJ	P,LODGC				; LOAD THE GARBAGE COLLECTOR
	SETOM	INTHLD
	SETOM	NPWRIT
	JRST	IPURIF

EPURIF:	PUSHJ	P,KILGC
	SETZM	INTHLD
	SETZM	NPWRIT
IFE ITS,[
	SKIPN	MULTSG
	 JRST	NPF
	POP	P,B
	HRRI	B,NPF
	MOVEI	A,0
	XJRST	A
]
IFN ITS,[
	JRST	NPF
]



; ROUTINE TO DO A SPECIAL GARBAGE COLLECT, CALLED FOR FREE STORAGE GARBAGE
;	COLLECTS
; AND CAN RUN A MARK/SWEEP GARBAGE COLLECT

SAGC:
IFE ITS,[
	JRST	@[.+1]			; RETURN WITH US NOW TO THE THRILLING
					; DAYS OF SEGMENT 0
]
	SOSL	NUMSWP			; GET NUMBER OF SWEEP GARBAGE COLLECTS
	JRST	MSGC			; TRY MARK/SWEEP
	MOVE	RNUMSP			; MOVE IN RNUMSWP
	MOVEM	NUMSWP			; SMASH IT IN
	JRST	GOGC
MSGC:	SKIPN	PGROW			; CHECK FOR STACK OVERFLOW
	SKIPE	TPGROW
	JRST	AGC			; IF SO CAUSE REAL GARBAGE COLLECT
	PUSH	P,C
	PUSH	P,D
	PUSH	P,E
	SETOM	SWAPGC			; LOAD MARK SWEEP VERSION
	PUSHJ	P,AGC1			; CAUSE GARBAGE COLLECT
	HRRZ	0,MAXLEN		; SEE IF REQUEST SATISFIED
	CAMGE	0,GETNUM
	JRST	LOSE1
	MOVE	C,FREMIN		; GET FREMIN
	SUB	C,TOTCNT		; CALCULATE NEEDED
	SUB	C,FRETOP
	ADD	C,GCSTOP
	JUMPL	C,DONE1
	JSP	E,CKPUR			; GO CHECK FOR SOME STUFF
	MOVE	D,PURBOT
IFE ITS,	ANDCMI	D,1777		; MAKE LIKE AN ITS PAGE
	SUB	D,CURPLN		; CALCULATE PURENESS
	SUB	D,P.TOP
	CAIG	D,(C)			; SEE IF PURENESS EXISTS
	JRST	LOSE1
	PUSH	P,A
	ADD	C,GCSTOP
	MOVEI	A,1777(C)
	ASH	A,-10.
	PUSHJ	P,P.CORE
	FATAL	P.CORE FAILED
	HRRZ	0,GCSTOP
	SETZM	@0
	HRLS	0
	ADDI	0,1
	HRRZ	A,FRETOP
	BLT	0,-1(A)
	PUSHJ	P,RBLDM
	POP	P,A
DONE1:	POP	P,E
	POP	P,D
	POP	P,C
IFN ITS,	POPJ	P,
IFE ITS,[
	SKIPN	MULTSG
	 POPJ	P,
	SETZM	20
	POP	P,21			; BACK TO CALLING SEGMENT
	XJRST	20	
]
LOSE1:	POP	P,E
	POP	P,D
	POP	P,C
GOGC:	
	

AGC:
IFE ITS,[
	SKIPE	MULTSG
	 SKIPE	GCDEBU
	  JRST	@[SEC1]
	XJRST	.+1
		0
		FSEG,,SEC1
SEC1:
]
	 MOVE	0,RNUMSP
	MOVEM	0,NUMSWP
	SETZM	SWAPGC
AGC1:	SKIPE	NPWRIT
	JRST	IAGC
	EXCH	P,GCPDL
	PUSHJ	P,SVAC				; SAVE ACS
	PUSHJ	P,SQKIL
	PUSHJ	P,CTIME
	MOVEM	B,GCTIM
	PUSHJ	P,LODGC				; LOAD GC
	PUSHJ	P,RSAC				; RESTORE ACS
	EXCH	P,GCPDL
	SKIPE	SWAPGC
	JRST	IAMSGC
IFE ITS,[
	SKIPE	MULTSG
	JRST	ISECGC
]
	JRST	IAGC

AAGC:	SETZM	SWAPGC
	EXCH	P,GCPDL
	PUSHJ	P,SVAC				; SAVE ACS
	PUSHJ	P,LODGC				; LOAD GC
	PUSHJ	P,RSAC				; RESTORE ACS
	EXCH	P,GCPDL
	JRST	IAAGC

FNMSGC:
FINAGC:	SKIPE	NPWRIT
	JRST	FINAGG
	PUSHJ	P,SVAC				; SAVE ACS
	PUSHJ	P,KILGC
	PUSHJ	P,RSAC
FINAGG:
IFN ITS,	POPJ	P,
IFE ITS,[
	SKIPN	MULTSG
	 POPJ	P,
	SETZM	20
	POP	P,21			; BACK TO CALLING SEGMENT
	XJRST	20	
]

; ROUTINE TO SAVE THE ACS

SVAC:	EXCH	0,(P)
	PUSH	P,A
	PUSH	P,B
	PUSH	P,C
	PUSH	P,D
	PUSH	P,E
	JRST	@0

; ROUTINE TO RESTORE THE ACS

RSAC:	POP	P,0
	POP	P,E
	POP	P,D
	POP	P,C
	POP	P,B
	POP	P,A
	EXCH	0,(P)
	POPJ	P,




; INTERNAL FUNCTION TO GET STRAGE ALLOCATION TYPE
; GETS THE TYPE CODE IN A AND RETURNS SAT IN A.

SAT:	LSH	A,1				; TIMES 2 TO REF VECTOR
	HRLS	A  				; TO BOTH HALVES TO HACK AOBJN
						;	POINTER
	ADD	A,TYPVEC+1			; ACCESS THE VECTOR
	HRR	A,(A)				; GET PROBABLE SAT
	JUMPL	A,.+2				; DID WE REALLY HAVE A VALID
						;	TYPE
	MOVEI	A,0				; NO RETURN 0
	ANDI	A,SATMSK
	POPJ	P,  				; AND RETURN

; FIND AND ALLOCATE AS MANY CONTIGUOUS PAGES AS INDICATED BY REG A
; RETURN THE NUMBER (0-255.) OF THE FIRST SUCH PAGE IN REG B
; RETURN -1 IN REG B IF NONE FOUND

PGFIND:
	JUMPLE	A,FPLOSS
	CAILE	A,256.
	JRST	FPLOSS

	PUSHJ	P,PGFND1			; SEE IF ALREADY ENOUGH
	SKIPN	NOSHUF				; CAN'T MOVE PURNESS
	SKIPL	B				; SKIP IF LOST
	POPJ	P,

	SUBM	M,(P)
	PUSH	P,E
	PUSH	P,C
	PUSH	P,D
PGFLO4:	MOVE	C,PURBOT			; CHECK IF ROOM AT ALL
						; 	(NOTE POTENTIAL FOR INFINITE LOOP)
	SUB	C,P.TOP				; TOTAL SPACE
	MOVEI	D,(C)				; COPY FOR CONVERSION TO PAGES
	ASH	D,-10.
	CAIGE	D,(A)				; SKIP IF COULD WIN
	JRST	PGFLO1

	MOVNS	A				; MOVE PURE AREA DOWN "A" PAGES
	PUSHJ	P,MOVPUR
	MOVE	B,PURTOP			; GET FIRST PAGE ALLOCATED
	ASH	B,-10.				; TO PAGE #
PGFLOS:	POP	P,D
	POP	P,C
	POP	P,E
	PUSHJ	P,RBLDM				; GET A NEW VALUE FOR M
	JRST	MPOPJ

; HERE TO SHUFFLE PURE SPACE TO TRY TO FIND PAGES

PGFLO1:	SKIPE	GCFLG				; SKIP IF NOT IN GC
	JRST	PGFLO5				; WE LOST
	MOVE	C,PURTOP
	SUB	C,P.TOP
	HRRZ	D,FSAV(TB)			; ARE WE IN A PURE RSUBR?
	CAIL	D,HIBOT				; ARE WE AN RSUBR AT ALL?
	JRST	PGFLO2
	GETYP	E,(R)				; SEE IF PCODE
	CAIE	E,TPCODE
	JRST	PGFLO2
	HLRZ	D,1(R)				; GET OFFSET TO PURVEC
	ADD	D,PURVEC+1
	HRROS	2(D)				; MUNG AGE
	HLRE	D,1(D)				; GET LENGTH
	ADD	C,D
PGFLO2:	ASH	C,-10.
	CAILE	A,(C)
	JRST	PGFLO3
	PUSH	P,A
IFE ITS,	ASH	A,1			; TENEX PAGES ARE HALF SIZE
	PUSHJ	P,GETPAG			; SHUFFLE THEM AROUND
	FATAL	PURE SPACE LOSING
	POP	P,A
	JRST	PGFLO4

; HERE TO CAUSE AGC IF PAGES ARE NOT AVAILABLE EVEN AFTER MAPPING OUT THE WORLD


PGFLO3:	PUSH	P,A				; ASK GC FOR SPACE
	ASH	A,10.
	MOVEM	A,GCDOWN			; REQUEST THOSE PAGES
	MOVE	C,[8.,,9.]
	PUSHJ	P,AGC				; GO GARBAGE COLLECT
	POP	P,A
	JRST	PGFLO4				; GO BACK TO POTENTIAL LOOP

	
PGFLO5:	SETOM	B				; -1 TO B
	JRST	PGFLOS				; INDICATE LOSSAGE

PGFND1:	PUSH	P,E
	PUSH	P,D
	PUSH	P,C
	PUSH	P,C%M1		; POSSIBLE CONTENTS FOR REG B
	PUSH	P,A		; SAVE LENGTH OF BLOCK DESIRED FOR LATER USE
	SETZB	B,C		; INITIAL SECTION AND PAGE NUMBERS
	MOVEI	0,0		; COUNT OF PAGES ALREADY FOUND
	PUSHJ	P,PINIT
PLOOP:	TDNE	E,D		; FREE PAGE ?
	JRST	NOTFRE		; NO
	JUMPN	0,NFIRST	; FIRST FREE PAGE OF A BLOCK ?
	MOVEI	A,(B)		; YES SAVE ADDRESS OF PAGE IN REG A
	IMULI	A,16.
	ASH	C,-1		; BACK TO PAGES
	ADDI	A,(C)
	ASH	C,1		; FIX IT TO WHAT IT WAS
NFIRST:	ADDI	0,1
	CAML	0,(P)		; TEST IF ENOUGH PAGES HAVE BEEN FOUND
	JRST	PWIN		; YES, FINISHED
	SKIPA	
NOTFRE:	MOVEI	0,0		; RESET COUNT
	PUSHJ	P,PNEXT	; NEXT PAGE
	JRST	PLOSE		; NONE--LOSE RETURNING -1 IN REG B
	JRST	PLOOP

PWIN:	MOVEI	B,(A)		; GET WINNING ADDRESS
	MOVEM	B,(P)-1		; RETURN ADDRESS OF WINNING PAGE
	MOVE	A,(P)		; RELOAD LENGTH OF BLOCK OF PAGES
	MOVE	0,[TDO E,D]	; INST TO SET "BUSY" BITS
	JRST	ITAKE

; CLAIM OR RETURN TO FREE STORAGE AS MANY CONTIGUOUS PAGES AS INDICATED BY REG A
; THE NUMBER (0 - 255.) OF THE FIRST SUCH PAGE IS IN REG B
PGGIVE:	MOVE	0,[TDZ E,D]	; INST TO SET "FREE" BITS
	SKIPA
PGTAKE:	MOVE	0,[TDO E,D]	; INST TO SET "BUSY" BITS
	JUMPLE	A,FPLOSS
	CAIL	B,0
	CAILE	B,255.
	JRST	FPLOSS
	PUSH	P,E
	PUSH	P,D
	PUSH	P,C
	PUSH	P,B
	PUSH	P,A
ITAKE:	IDIVI	B,16.
	PUSHJ	P,PINIT
	SUBI	A,1
RTL:	XCT	0		; SET APPROPRIATE BIT
	PUSHJ	P,PNEXT	; NEXT PAGE'S BIT
	JUMPG	A,FPLOSS	; TOO MANY ?
	SOJGE	A,RTL
	MOVEM	E,PMAPB(B)	; REPLACE BIT MASK
PLOSE:	POP	P,A
	POP	P,B
	POP	P,C
	POP	P,D
	POP	P,E
	POPJ	P,


PINIT:	MOVE	E,PMAPB(B)	; GET BITS FOR THIS SECTION
	HRLZI	D,400000	; BIT MASK
	IMULI	C,2
	MOVNS	C
	LSH	D,(C)		; SHIFT TO APPROPRIATE BIT POSITION
	MOVNS	C
	POPJ	P,

PNEXT:	AOS	(P)		; FOR SKIP RETURN ON EXPECTED SUCCESS
	LSH	D,-2		; CONSIDER NEXT PAGE
	CAIL	C,30.		; FINISHED WITH THIS SECTION ?
	JRST	PNEXT1
	AOS	C
	AOJA	C,CPOPJ		; NO, INCREMENT AND CONTINUE
PNEXT1:	MOVEM	E,PMAPB(B)	; REPLACE BIT MASK
	SETZ	C,
	CAIGE	B,15.		; LAST SECTION ?
	AOJA	B,PINIT		; NO, INCREMENT AND CONTINUE
	SOS	(P)		; YES, UNDO SKIP RETURN
	POPJ	P,

FPLOSS:	FATAL PAGE LOSSAGE

PGINT:	MOVEI	B,HIBOT		; INITIALIZE MUDDLE'S PAGE MAP TABLE
	IDIVI	B,2000		; FIRST PAGE OF PURE CODE
	MOVE	C,HITOP
	IDIVI	C,2000
	MOVEI	A,(C)+1
	SUBI	A,(B)		; NUMBER OF SUCH PAGES
	PUSHJ	P,PGTAKE	; MARK THESE PAGES AS TAKEN
	POPJ	P,




ERRKIL:	PUSH	P,A
	PUSHJ	P,KILGC		; KILL THE GARBAGE COLLECTOR
	POP	P,A
	JRST	CALER

; IF IN A PURE RSUBR, FIND ITS LENGTH AND FUDGE ITS LRU

CKPUR:	HRRZ	A,FSAV(TB)	; GET NAME OF CURRENT GOODIE
	SETZM	CURPLN		; CLEAR FOR NONE
	CAIL	A,HIBOT		; IF LESS THAN TOP OF PURE ASSUME RSUBR
	JRST	(E)
	GETYP	0,(A)		; SEE IF PURE
	CAIE	0,TPCODE	; SKIP IF IT IS
	JRST	NPRSUB
NRSB2:	HLRZ	B,1(A)		; GET SLOT INDICATION
	ADD	B,PURVEC+1	; POINT TO SLOT
	HRROS	2(B)		; MUNG AGE
	HLRE	A,1(B)		; - LENGTH TO A
	TRZ	A,1777
	MOVNM	A,CURPLN	; AND STORE
	JRST	(E)
NPRSUB:	SKIPGE	B,1(R)		; SEE IF PURE RSUBR
	JRST	(E)
	MOVE	A,R
	JRST	NRSB2
	
; THIS IS THE SCHEME USED TO UPDATE CERTAIN IMFORMATION USED BY THE
; BLOAT-SPEC ROUTINE TO GIVE USERS IMFORMATION ABOUT USE OF SPACE BY
; THEIR MUDDLE.

GCSET:	MOVE	A,RFRETP	; COMPUTE FREE SPACE AVAILABLE
	SUB	A,PARTOP
	MOVEM	A,NOWFRE
	CAMLE	A,MAXFRE
	MOVEM	A,MAXFRE	; MODIFY MAXIMUM
	HLRE	A,TP		; FIND THE DOPE WORD OF THE TP STACK
	MOVNS	A
	ADDI	A,1(TP)		; CLOSE TO DOPE WORD
	CAME	A,TPGROW
	ADDI	A,PDLBUF	; NOW AT REAL DOPE WORD
	HLRZ	B,(A)		; GET LENGTH OF TP-STACK
	MOVEM	B,NOWTP
	CAMLE	B,CTPMX		; SEE IF THIS IS THE BIGGEST TP
	MOVEM	B,CTPMX
	HLRE	B,P		; FIND DOPE WORD OF P-STACK
	MOVNS	B
	ADDI	B,1(P)		; CLOSE TO IT
	CAME	B,PGROW		; SEE IF THE STACK IS BLOWN
	ADDI	B,PDLBUF	; POINTING TO IT
	HLRZ	A,(B)		; GET IN LENGTH
	MOVEM	A,NOWP
	CAMLE	A,CPMX		; SEE IF WE HAVE THE BIGGEST P STACK
	MOVEM	A,CPMX
	POPJ	P,		; EXIT

RBLDM:	JUMPGE	R,CPOPJ
	SKIPGE	M,1(R)		; SKIP IF FUNNY
	JRST	RBLDM1

	HLRS	M
	ADD	M,PURVEC+1
	HLLM	TB,2(M)
	SKIPL	M,1(M)
	JRST	RBLDM1
	PUSH	P,0
	HRRZ	0,1(R)
	ADD	M,0
	POP	P,0
RBLDM1:	SKIPN	SAVM		; SKIP IF FUNNY (M)
	POPJ	P,		; EXIT
	MOVEM	M,SAVM
	MOVEI	M,0
	POPJ	P,
CPOPJ1:
C1POPJ:	AOS	(P)
	POPJ	P,



; THIS ROUTINE MAKES SURE CURRENT FRAME MAKES SENSE
FRMUNG:	MOVEM	D,PSAV(A)
	MOVE	SP,SPSTOR+1
	MOVEM	SP,SPSAV(A)
	MOVEM	TP,TPSAV(A)	; SAVE FOR MARKING
	POPJ	P,


; SUBROUTINE TO REBUILD THE NOW DEFUNCT HASH TABLE

REHASH:	MOVE	D,ASOVEC+1	; GET POINTER TO VECTOR
	MOVEI	E,(D)
	PUSH	P,E		; PUSH A POINTER
	HLRE	A,D		; GET -LENGTH
	MOVMS	A		; AND PLUSIFY
	PUSH	P,A		; PUSH IT ALSO

REH3:	HRRZ	C,(D)		; POINT TO FIRST BUCKKET
	HLRZS	(D)		; MAKE SURE NEW POINTER IS IN RH
	JUMPLE	C,REH1		; BUCKET EMPTY, QUIT

REH2:	MOVEI	E,(C)		; MAKE A COPY OF THE POINTER
	MOVE	A,ITEM(C)	; START HASHING
	TLZ	A,TYPMSK#777777	; KILL MONITORS
	XOR	A,ITEM+1(C)
	MOVE	0,INDIC(C)
	TLZ	0,TYPMSK#777777
	XOR	A,0
	XOR	A,INDIC+1(C)
	TLZ	A,400000	; MAKE SURE FINAL HASH IS +
	IDIV	A,(P)		; DIVIDE BY TOTAL LENGTH
	ADD	B,-1(P)		; POINT TO WINNING BUCKET

	MOVE	C,[002200,,(B)]	; BYTE POINTER TO RH
	CAILE	B,(D)		; IF PAST CURRENT POINT
	MOVE	C,[222200,,(B)]	; USE LH
	LDB	A,C		; GET OLD VALUE
	DPB	E,C		; STORE NEW VALUE
	HRRZ	B,ASOLNT-1(E)	; GET NEXT POINTER
	HRRZM	A,ASOLNT-1(E)	; AND CLOBBER IN NEW NEXT
	SKIPE	A		; SKKIP IF NOTHING PREVIOUSLY IN BUCKET
	HRLM	E,ASOLNT-1(A)	; OTHERWISE CLOBBER
	SKIPE	C,B		; SKIP IF END OF CHAIN
	JRST	REH2
REH1:	AOBJN	D,REH3

	SUB	P,C%22	; FLUSH THE JUNK
	POPJ	P,

;SUBROUTINES TO RETURN WORDS NEEDED BASED ON TYPE OR SAT

NWORDT:	PUSHJ	P,SAT		;GET STORAGE ALLOC TYPE
NWORDS:	CAIG	A,NUMSAT	; TEMPLATE?
	SKIPL	MKTBS(A)	;-ENTRY IN TABLE MEANS 2 NEEDED
	SKIPA	A,C%1		;NEED ONLY 1
	MOVEI	A,2		;NEED 2
	POPJ	P,

.GLOBAL GCRET,PAIRMK,DEFMK,VECTMK,TBMK,TPMK,ARGMK,VECTMK,FRMK,BYTMK,ATOMK,GATOMK
.GLOBAL LOCMK,BYTMK,ABMK,LOCRMK,GCRDMK,DEFQMK,ASMRK,OFFSMK

; DISPATCH TABLE FOR MARK PHASE ("SETZ'D" ENTRIES MUST BE DEFERRED)

DISTBS MKTBS,GCRET,[[S2WORD,PAIRMK],[S2DEFR,DEFMK],[SNWORD,VECTMK],[STBASE,TBMK]
[STPSTK,TPMK],[SARGS,<SETZ ARGMK>],[S2NWORD,VECTMK],[SPSTK,TPMK],[SSTORE,VECTMK]
[SFRAME,<SETZ FRMK>],[SBYTE,<SETZ BYTMK>],[SATOM,ATOMK],[SPVP,VECTMK],[SGATOM,GATOMK]
[SLOCID,<SETZ LOCMK>],[SCHSTR,<SETZ BYTMK>],[SASOC,ASMRK],[SLOCL,PAIRMK],[SABASE,ABMK]
[SLOCA,<SETZ ARGMK>],[SLOCV,VECTMK],[SLOCU,VECTMK],[SLOCS,<SETZ BYTMK>],[SLOCN,ASMRK]
[SLOCR,LOCRMK],[SRDTB,GCRDMK],[SLOCB,<SETZ BYTMK>],[SDEFQ,DEFQMK],[SOFFS,OFFSMK]]

IMPURE

DSTORE:	0			; USED FOR MAPFS AND SEGMENTS
BUFL:	0			; BUFFER PAGE (WORDS)
BUFP:	0			; BUFFER PAGE (PAGES)
NPWRIT:	0			; INDICATION OF PURIFY
RNUMSP:	0			; NUMBER OF MARK/SWEEP GARBAGE
				; COLLECTS TO REAL GARBAGE COLLECT
NUMSWP:	0			; NUMBER MARK SWEEP GARBAGE COLLECTS TO GO
SWAPGC:	0			; FLAG INDICATING WHETHER TO LOAD SWAP
				;	GC OR NOT
TOTCNT:	0			; TOTAL COUNT

PURE

PAT:
PATCH:

BLOCK 400
PATEND:

END