Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-05 - 43,50337/16/sa.mac
There are 3 other files named sa.mac in the archive. Click here to see a list.
00100		SUBTTL	SIMULA RUNTIME SYSTEM, STORAGE ALLOCATION
00200	
00300	; Author:	Lars Enderin, Reidar Karlsson
00400	; Version:	4 (11,65,72,175,215,265,273,276)
00500	; Purpose:	To manage storage for objects (RTS dynamic data).
00600	
00700		SEARCH	SIMMAC,SIMMCR,SIMRPA
00800		SALL
00900	
01000	;	The SA module contains the following procedures:
01100	
01200	intern	.SAAB  ;  Allocate block instance record
01300			; (without display record).
01400	intern	.SAAR  ;  Allocate a non-block record (array, text, ac stack etc).
01500	intern	.SACL  ;  Give a log message and close GCP.TMP
01600	intern	.SADB  ;  Allocate a block record with
01700			;  an attached display  record.
01800	intern	.SADE  ;  Deallocate record. Not implemented in the first RTS
01900			;  version.
02000	intern	.SAGC  ;  Garbage collector.
02100	intern	.SAGI  ;  Garbage collector initialization
02200	intern	.SAIN  ;  Initialize ref and array variables in a block.
02300	intern	.SANP  ;  Determine and allocate new storage pool area.
02400	
02500	Comment;
02600	
02700	The routines described  implement  a  particular  storage  allocation
02800	scheme,  which  may  be changed as experience is gained. Essentially,
02900	storage is allocated in a contiguous pool, starting at  YSABOT(XLOW).
03000	All  blocks  are  allocated from YSABOT upwards. YSATOP(XLOW) at each
03100	instant shows the next free location.  When  YSATOP  reaches  YSALIM,
03200	.SAGC  is  called  to get more core, and if necessary, reclaim unused
03300	storage.  YSALIM is adjusted to leave room for a maximal  acs  object
03400	(of  size  2+QNAC*2 words), ensuring that the accumulators can always
03500	be saved before garbage collection is performed.
03600	[175]  Statistics  of  page  faults  between   and   during   garbage
03700	collections  are  collected  and  used  in  SANP to determine virtual
03800	memory size for paging jobs.  YSANWA and  YSANWC  are  used  to  save
03900	paging data. ;
04000	
04100		RTITLE	SA
04200		TWOSEG
04300		RELOC	400K
04400		MACINIT
04500		ERRMAC	SA
04600	
04700						edit(65)
04800		IFNDEF	QZERO,<QZERO==0>	;[65] Do not zero new core (should be zero)
04900	
05000	
05100		IFE QDEBUG,< DEFINE ASSERT(B)=<>
05200		>
05300	
05400		EXTERN	.JBREL, .JBFF, .JBHRL
05500	
05600		ASSERT<
05700		INTERN	SAGCLE,SAGCOD,SAGCOO
05800		EXTERN	SAPDCO,SAPDOI,SAPDTO
05900		EXTERN	.OCINC, .OCIN7, .OCIND
06000	
06100		OPDEF	FREEBUFF	[PUSHJ	XPDP,.OCINC]	;Frees a buffer area
06200		OPDEF	GETBUFF		[PUSHJ	XPDP,.OCIN7]	;Finds a free buffer
06300		OPDEF	LINKBUFF	[PUSHJ	XPDP,.OCIND]	;Links a buffer ring
06400	
06500		edit(273)	;[273]
06600		DEFINE CLAIMBUFF	<
06700					LF	X0,ZBHLEN(X1)
06800					MOVN	X0,X0
06900					SF	X0,ZBHLEN(X1)
07000					>
07100			>
07200	
07300		DEFINE	ZDNCASE(z,w)<
07400		LF	XTYP,ZDNTYP(XCUR)
07500		IFN QDEBUG,<
07600		JUMPL XTYP,.+2
07700		CAILE XTYP,QZDNTM
07800		 GOTO @.+2
07900		>
08000		GOTO	@.+1(XTYP)
08100		DEFINE X(A)<IRP A,<EXP w''A''z>>
08200		TYPZDN
08300		>
08400	
08500	
08600	
08700		;Constants used in .SAGC and .SANP
08800		; All floating point constants are stored in right half
08900		; as immediate constants
09000	
09100	
09200		RH=	-^D18		;To shift a floating point assembly
09300					; constant to the right half
09400		QSAF0=	0.0_RH	;F0 floating	initial value of F^ (YSAFES)
09500		QSAR0=	0.0_RH	;R0  "		initial value of R^ (YSARES)
09600		QSAB0=	0.0_RH	;B0  "		initial value of B^ (YSABES)
09700		IFN QSASTE,<
09800		QSAPMI= ^D256	;Min free pool area
09900		>
10000		IFE QSASTE,<
10100		QSALMI= ^D512	;Min low seg area change (treshold value) that
10200				; causes a core request after garbage collection
10300		>
10400	
10500		QSALF=	0.0_RH	;LF floating	exponential smoothing const. for F^
10600		QSALR=	0.0_RH	;LR   "		exponential smoothing const. for R^
10700		QSALB=	0.0_RH	;LB   "		exponential smoothing const. for B^
10800	
10900	
11000		QSAL1F=	1.0_RH	;L1F	floating	QSALF + 1.0
11100		QSAL1R=	1.0_RH	;L1R	  "		QSALR + 1.0
11200		QSAL1B=	1.0_RH	;L1B	  "		QSALB + 1.0
11300	
11400	;=========== N O T E  !!!!!!!!!!!!!!  ========================================
11500	;======== QSAL? and QSAL1? MUST be CHANGED at the SAME time ==================
11600	;==============================================================================
11700	
11800		QCHGCP=17	;GCP.TMP channel number
11900		.IOBIN=14	;GCP.TMP data mode (binary)
12000		QPROTE=0	;1: a fixed pool is allocated
12100				;0: the dynamic allocation formula is used
12200	
12300	
12400	IFN <%ZDNTYP-^D17>,<CFAIL ZDNTYP field must end in bit 17..>
     
00100		SUBTTL	.SAAB   (allocate block record)
00200	
00300	; Purpose:	To allocate a block record without a display record.
00400	
00500	; Input:	Prototype address in XSAC.
00600	
00700	; Output:	Address of the new block in XRAC.
00800	
00900	; Function:	Take the length from ZPRBLE(XSAC).  If  YSATOP+length
01000	;		>  YSALIM,  call  .SAGC  with  the  difference in X0.
01100	;		Place  the  current  value  of  YSATOP  in  XRAC  and
01200	;		increase YSATOP by  the  length.    Set  ZBIZPR=XSAC,
01300	;		which  should  be preserved (not destroyed by .SAGC).
01400	;		Return.
01500	
01600	.SAAB:	PROC
01700		SAVE	<X0,XSAC>
01800		LOWADR
01900		LF	,ZPRBLE(XSAC)
02000		ADD	YSATOP(XLOW)
02100		SUB	YSALIM(XLOW)
02200		IF	;Not enough space
02300			JUMPLE	FALSE
02400		THEN	;Collect garbage to get more
02500			EXEC	.SAGC
02600		FI
02700		L	XRAC,YSATOP(XLOW)
02800		LF	,ZPRBLE(XSAC)
02900		ADDM	YSATOP(XLOW)
03000		REPEAT 0,<
03100		SETZM	ZBI%S(XRAC)
03200		IF	;More than one variable
03300			CAIG	ZBI%S+1
03400			GOTO	FALSE
03500		THEN
03600			STACK	XTAC
03700			LI	ZBI%S+1(XRAC)
03800			HRLI	ZBI%S(XRAC)
03900			L	XTAC,YSATOP(XLOW)
04000			BLT	-1(XTAC)
04100			UNSTK	XTAC
04200		FI
04300		>
04400		MOVSI	QZBI
04500		WSF	,ZDNTYP(XRAC)
04600		WSF	XSAC,ZBIZPR(XRAC)
04700		EXEC	.SAIN	;Initialize  any  ref  and/or array variable
04800		RETURN
04900		EPROC
     
00100		SUBTTL	.SAAR   (allocate non-block record)
00200	
00300	; Purpose:	Allocate a dynamic record of given length and type and return
00400	;		its address.
00500	
00600	; Input:	XTAC= XWD record type,record length
00700	
00800	; Output:	New record address in XTAC.
00900	
01000	; Function:	If YSATOP + length >  YSALIM,  call  .SAGC.   Set  XTAC  to  the
01100	;		current  value  of  YSATOP,  and  increase YSATOP with the given
01200	;		length.  Initialize data area with YSANIN value (if not  =  -1).
01300	;		Reset YSANIN to zero.  Store record type in ZDNTYP field, length
01400	;		in second word (which is the most common place), then return.
01500	
01600	.SAAR:	PROC
01700		LOWADR
01800		LI	(XTAC)			;Length
01900		ADD	YSATOP(XLOW)
02000		SUB	YSALIM(XLOW)
02100		IF
02200			JUMPLE	FALSE
02300		THEN
02400			EXEC	.SAGC
02500		FI
02600		HLLZM	XTAC,@YSATOP(XLOW)	;Type
02700		LI	(XTAC)			;Length,
02800		L	XTAC,YSATOP(XLOW)
02900		ST	1(XTAC)			;put it in second word
03000		ADD	XTAC
03100		ST	YSATOP(XLOW)
03200		IF	;Initialization required
03300			AOSN	YSANIN(XLOW)
03400			GOTO	FALSE
03500		THEN
03600			STACK	XSAC
03700			IF
03800				SOSN	XSAC,YSANIN(XLOW)
03900				GOTO	FALSE
04000			THEN
04100				ST	XSAC,2(XTAC)
04200				LI	XSAC,3(XTAC)
04300				HRLI	XSAC,2(XTAC)
04400				EXCH	XSAC
04500				CAILE	XSAC,3(XTAC)	;If more than one data word,
04600				 BLT	-1(XSAC)	;initialize the rest
04700			FI
04800			UNSTK	XSAC
04900		FI
05000		SETOM	YSANIN(XLOW)
05100		RETURN
05200		EPROC
     
00100		SUBTTL	.SACL	(close  GCP.TMP)
00200	
00300		COMMENT;
00400	
00500	Purpose:	Give a GC log message.
00600			Output the final GC parameter values
00700			and close GCP.TMP in debug version.
00800	
00900	Entry:		.SACL
01000	
01100	Normal exit:	RETURN
01200	
01300	Call format:	EXEC	.SACL
01400	
01500	Used  subroutines:	SANPDU, SAGCOD
01600				FREEBUFF
01700	
01800		;
01900	
02000	
02100	
02200	
02300	.SACL:
02400		PROC
02500		edit(175)	;[175] save X3 too!
02600		SAVE	<X0,X1,X2,X3>
02700	
02800		LOWADR(X16)
02900	
03000		IF	;GC was ever called
03100			SKIPN	X1,YSAGCN(XLOW)
03200			GOTO	FALSE
03300		THEN	;Log number of GC's, GC time
03400			OUTSTR	[ASCIZ	/	
03500	/]
03600			IFN QDEBUG,<
03700			L	X0,YSASW(XLOW)
03800				SETONA	SWGCT2
03900			>
04000			EXEC	SAGCOD
04100				edit(265)	;[265]
04200			OUTSTR	[ASCIZ	/ garbage collection(s) in /]
04300			L	X1,YSAGCT(XLOW)
04400			EXEC	SAGCOD
04500			OUTSTR	[ASCIZ	/ ms
04600	/]
04700	
04800		FI
04850	REPEAT 0,<;[276] Misleading, don't output
04900	edit(175)
05000	;[175] type page fault statistics
05200		L	X3,[%VMSPF]
05300		GETTAB	X3,
05400		SETZ	X3,
05500		HLRZ	X3,X3
05600		SUB	X3,YSANWA(XLOW)
05700		HRLZ	X3,X3
05800		ADDB	X3,YSANWC(XLOW)	;Cumul. NIW count between GC:s in left half
05900		IF	SKIPN	X3
06000			GOTO	FALSE
06100		THEN
06200			edit(265)	;[265]
06300			OUTSTR	[ASCIZ"[Page faults between/during G.C.'s]=["]
06400			HLRZ	X1,X3	;NIW faults between
06500			EXEC	SAGCOD
06600			LI	X1,"/"
06700			OUTCHR	X1
06800			HRRZ	X1,X3	;NIW faults during GC:s
06900			EXEC	SAGCOD
07000			OUTSTR	[ASCIZ/]
07100	/]
07200		FI	>;[276]
07300	
07400		IFN QDEBUG,<
07500			;If log output on GCP.TMP
07600			;Update TIM and set TAU
07700	
07800		IF
07900			L	X0,YSASW(XLOW)
08000			IFONA	SAGCPE
08100			GOTO	FALSE
08200		THEN
08300	
08400		SETZ	X0,
08500		RUNTIM	X0,
08600		L	X1,YSATIM(XLOW)
08700		SUB	X0,X1
08800		FLTR	X0,X0
08900		ST	X0,YSATAU(XLOW)
09000	
09100			;Set YSATIM to -1 to indicate last dump record and dump
09200	
09300		SETOM	YSATIM(XLOW)
09400		EXEC	SANPDU
09500	
09600			;Close GCP.TMP and release buffer
09700	
09800		CLOSE	QCHGCP,
09900		L	X1,YSABH(XLOW)
10000		FREEBUF
10100	
10200	
10300		FI
10400		>
10500	
10600		RETURN
10700	
10800		EPROC
     
00100		SUBTTL	.SADB   (allocate block record with display)
00200	
00300	; Purpose:	To allocate a block record with an attached display  record  and
00400	;		fill some fields with information.
00500	
00600	; Input:	Block type in XSAC left half, prototype  address  in  the  right
00700	;		half.
00800	
00900	; Output:	XRAC = address of the new block instance.
01000	
01100	; Function:	If the length of the  display  record  (ZPCDLE(XSAC))  plus  the
01200	;		length  of  the block (ZPRBLE) plus YSATOP > YSALIM, call .SAGC.
01300	;		The display record is allocated, and the ZDNTYP, ZDRLEN,  ZDRZAC
01400	;		fields are set.  ZDRZAC is copied from YCSZAC.
01500	
01600	;		XRAC is set to the block instance address, ZDNTYP and ZBIZPR are
01700	;		copied  from the input parameter (XSAC), ZDNZAC is set if YCSZAC
01800	;		is non-zero.  YCSZAC  is  reset.   ZDRZBI:-XCB,  ZDRARE:=YOBJRT.
01900	;		Store new ZBI address at ZPREBL in the display.   Initialize the
02000	;		block to zeros,  except for REF variables,  the  value  of a REF
02100	;		PROCEDURE and ARRAY variables, which are initialized to NONE.
02200	
02300	.SADB:	PROC
02400		SAVE	<X0,XSAC,XTAC>
02500		LOWADR
02600		LF	XRAC,ZPCDLE(XSAC)
02700		LF	,ZPRBLE(XSAC)
02800		ADDI	(XRAC)
02900		ADD	YSATOP(XLOW)
03000		SUB	YSALIM(XLOW)
03100		IF	JUMPLE	FALSE
03200		THEN	EXEC	.SAGC
03300		FI
03400		L	XTAC,YSATOP(XLOW)
03500		MOVSI	QZDR
03600		WSF	,ZDNTYP(XTAC)
03700		SF	XRAC,ZDRLEN(XTAC)
03800		L	YCSZAC(XLOW)
03900		IF	;Any ac's saved
04000			JUMPE	FALSE
04100		THEN	;Mark the block
04200			SF	,ZDRZAC(XTAC)
04300			SETONA	ZDNACS(XSAC)
04400		FI
04500		SETZM	YCSZAC(XLOW)
04600		ADDI	XRAC,(XTAC)		;ZBI address
04700		repeat 0,<
04800		SETZM	2(XTAC)
04900		LI	3(XTAC)
05000		IF	CAIL	-1(XRAC)
05100			GOTO	FALSE
05200		THEN	HRLI	2(XTAC)
05300			BLT	-2(XRAC)
05400		FI
05500		>
05600		HRRZM	XSAC,OFFSET(ZBIZPR)(XRAC)
05700		HLLZM	XSAC,OFFSET(ZDNTYP)(XRAC)
05800		LFE	XTAC,ZPREBL(XSAC)	;Innermost display level
05900		ADDI	XTAC,(XRAC)
06000		ST	XRAC,(XTAC)
06100		SF	XCB,ZDRZBI(XRAC)	;Dynamic link
06200		HRRZ	YOBJRT(XLOW)
06300		SF	,ZDRARE(XRAC)		;Return address
06400		LF	XSAC,ZPRBLE(XSAC)	;Block length
06500		ADD	XSAC,XRAC
06600		ST	XSAC,YSATOP(XLOW)
06700		REPEAT	0,<
06800		SETZM	ZBI%S(XRAC)
06900		IF	;More than one variable
07000			CAIG	XSAC,ZBI%S+1(XRAC)
07100			GOTO	FALSE
07200		THEN
07300			LI	ZBI%S+1(XRAC)
07400			HRLI	ZBI%S(XRAC)
07500			BLT	-1(XSAC)
07600		FI
07700		>
07800		LF	XSAC,ZBIZPR(XRAC)	;Get prototype for special initialization
07900		LF	,ZPCTYP(XSAC)		;Check for type procedure
08000		IF	;Ref procedure
08100			CAIE	QREF
08200			GOTO	FALSE
08300		THEN
08400			LI	NONE
08500			ST	ZBI%S(XRAC)
08600		FI
08700		EXEC	.SAIN	;Initialize any ref and/or array variable
08800		RETURN
08900		EPROC
     
00100		SUBTTL	.SADE   (Deallocate record)
00200	
00300	; Purpose:	To return a record to the free pool.
00400	
00500	; Input:	YSARES(XLOW)= address of record to deallocate.
00600	
00700	
00800	.SADE:	RFAIL	.SADE SHOULD NOT BE CALLED
00900		RETURN
     
00100		SUBTTL	.SAGC   (garbage collector)
00200	
00300	
00400	; Purpose:	To provide space for a new piece of data.
00500	
00600	; Input:	The  amount  of  storage  required  is  specified  in  X0.    If
00700	;		YSAREL(XLOW)  is  different  from zero, the pool should be moved
00800	;		upwards by that amount.
00900	
01000	; Function:	The garbage collector works in 4 phases.
01100	;	Phase 1:
01200	;		Start from XCB and internal run time record pointers  and  chain
01300	;		all referenceable records by their ZDNLNK fields.
01400	
01500	;		Search record references in records on the chain,  chaining  all
01600	;		found records to the end of the chain.
01700	
01800	;	Phase 2:
01900	;		When all referenceable records have been found, step through the
02000	;		storage  pool  from  the  start and compute new record addresses
02100	;		(assuming that the records should be moved towards the bottom of
02200	;		the  pool).  If YSAREL is non-zero, add it to all new addresses.
02300	;		The new addresses are saved in the ZDNLNK fields of the records.
02400	;		The unreferenceable records have ZDNLNK=0.
02500	;		[273] Do not relocate blocks below address given in YSAFRZ(XLOW).
02600	;		When all new addresses are determined,  the  minimum  amount  of
02700	;		core  is requested to make it  possible  to  continue  execution
02800	;		after the garbage collection. If not enough core is available  a
02900	;		run time error is generated.
03000	
03100	;	Phase 3:
03200	;		Step through the pool again and replace (update)  all  reference
03300	;		quantities in the system.
03400	
03500	;	Phase 4:
03600	;		Step through the pool a third time and move the records to their
03700	;		new  positions as given by their ZDNLNK fields.
03800	;		Determine a new garbage collector limit and if  QSASTE=1  a  new
03900	;		optimal step size. If QSASTE=0 a pool  up  to  the  new  garbage
04000	;		collector limit is allocated, and if QSASTE=1 a free  pool  step
04100	;		is allocated. If the CORMAX limit is exceeded, the CORMAX  value
04200	;		is taken as the new garbage collector limit.
04300	;		If CORMAX > high segment start, use that as limit.
     
00100		;REGISTER ASSIGNMENTS AND OPDEFS
00200	
00300	XSW=	X1	;Switches the return jump in SAGCNP
00400	XTYP=	X1	;Dyn. rec. type or formal param. type
00500	XLO=	X1	;Used as XLOW
00600	
00700	XST=	X2	;Store instruction to update pointers by  XCT XST
00800	XBEG=	X2	;First dyn. rec. in pool that must be moved
00900	
01000	XPT=	X3	;New pointer value
01100	XKND=	X3	;Formal parameter kind
01200	
01300	XAD=	X4	;The address to be loaded into XST before    XCT XST
01400			; or address of first occupied word in the new pool
01500	
01600	XTOP=	X5	;End of old pool = YSATOP(XLOW)
01700	
01800	XCUR=	X6	;Current dyn. rec.
01900	
02000	XIND=	X7	;Index register
02100	XSTOP=	X7	;LOOP LIMIT
02200	XSAV=	X7	;Save register
02300	
02400	XEND=	X10	;End of ZDNLNK chain in PHASE1
02500	XTOT=	X10	;Total length of adjacent not referenced rec.
02600	XFROM=	X10	;Source address at word by word move
02700	XFROTO=	X10	;BLT ac with source address in left half
02800			;and target address in right
02900	
03000	XZPR=	X11	;ZBIZPR
03100	XZEV=	X11	;ZEV pointer
03200	
03300	XLEN=	X12	;Length of current rec.
03400	
03500	XLNK=	X13	;ZDNLNK
03600	
03700	XBOT=	X14	;Bottom of the old pool  YSABOT(XLOW)
03800	
03900	XNEXT=	XCB	;Address to routine NEXT
04000			; (i.e. SAGCN1 in PHASE1 and SAGCN3 in PHASE3)
04100	
04200	
04300	
04400	
04500	
04600	OPDEF	NEXT	[JRST	(XNEXT)]	;Find next dyn. rec.
04700	OPDEF	NPOINT	[JSP	XSW,SAGCNP]	;Check new pointer
04800	OPDEF	NZEV	[JSP	X0,NEWZEV]	;Compute new zev pointer
04900	OPDEF	LENGTH	[JSP	X0,SAGCLE]	;XLEN := length of current rec.
05000	OPDEF	GOBACK	[JSP	X16,(X16)]	;Coroutine return
05100	OPDEF	OP	[HRLI]			;Load operation in left half
05200	
05300	
05400	DEFINE	INPOOL <CAIL XPT,(XBOT)		;;Skip next if pointer in pool
05600			CAIL	XPT,(XTOP)	>
05700	
05800	
05900	DEFINE	NPNT(F)	<	;;Handle the pointer in the field F
06000				IFE<%'F - ^D17>,<OP	XST,(HRLM  XPT,)> ;;Left half
06100				LI	XAD,OFFSET(F)(XCUR)
06200				LF	XPT,F(XCUR)
06300				NPOINT
06400				IFE<%'F - ^D17>,<OP	XST,(HRRM  XPT,)> ;;Right half
06500									  ;;as default
06600			>
06700	
06800	
06900	OPDEF	OUTOCT		[PUSHJ	17,SAGCOO]	;Output octal number
07000	OPDEF	OUTDEC		[PUSHJ	17,SAGCOD]	;Output decimal number
07100	
     
00100		SUBTTL	SAGCCH	(Garbage collector coroutine)
00200	
00300		Comment;
00400	
00500	Purpose:	Used  in  Phase  1  to  chain  a new dyn. rec. to the
00600			ZDNLNK chain if it is not referenced  before.  Update
00700			XEND to point to the latest chained rec.
00800	
00900	Entry:		SAGCCH
01000	
01100	Input arguments: XPT points to the new record
01200	
01300	Normal exit:	GOBACK	(JSP	X16,(X16))
01400	
01500	Call format:	GOTO	(XSW)	where XSW contains the PC value
01600					saved by the previous GOBACK.
01700	
01800	
01900		;
02000	
02100	
02200	
02300	
02400	SAGCCH:	LF	XLNK,ZDNLNK(XPT)
02500		IF	;Not referenced before
02600			JUMPN	XLNK,FALSE
02700			CAIN	XPT,(XEND)
02800			GOTO	FALSE
02900		THEN			;Chain the new rec. and update XEND
03000			SF	XPT,ZDNLNK(XEND)
03100			LI	XEND,(XPT)
03200			IFN	QDEBUG,<	;Log chained records if SWGCTE on
03300					LOWADR(X1)
03400					IF
03500						L	X0,YSASW(XLOW)
03600						IFOFFA	SWGCTE
03700						GOTO	FALSE
03800					THEN
03900						RTEXT
04000						L	X1,XPT
04100						OUTOCT
04200					FI
04300					>
04400		FI
04500		GOBACK		;to SAGCSP or SAGCGP
04600		GOTO	SAGCCH	;Entry for next coroutine call on SAGCCH
04700				; Saved by GOBACK in X16
     
00100		SUBTTL	SAGCDR	(Garbage collector subroutine)
00200	
00300		Comment;
00400	
00500	Purpose:	Search for dynamic pointers in a display record.
00600			The routine is used for ZBP, ZPB and ZCL records.
00700	
00800	Entry:		SAGCDR
00900	
01000	Input arguments:
01050			XCUR points to the ZBI record
01100			immediately following the display record.
01200			XZPR points to its prototype.
01300	
01400	Normal exit:	GOTO ZBI.
01500	
01600	Call format:	GOTO SAGCDR
01700	
01800		;
01900	
02000	
02100	
02200	
02300	SAGCDR:	IF	;NOT Terminated AND NOT keepdisplay
02400			L	X0,(XCUR)
02500			IFOFFA	ZDNTER
02600			GOTO	TRUE
02700			IFOFFA	ZDNKDP
02800			GOTO	FALSE
02900		THEN	;Display record is referenced
03000			L	XSTOP,XCUR
03100			LF	XLEN,ZPCDLE(XZPR)
03200			SUBI	XCUR,(XLEN)
03300	
03400		;If ZDNLNK = 0 (i.e. in PHASE1),
03500		; then mark this ZDR rec. as referenced
03600	
03700			LF	XLNK,ZDNLNK(XCUR)
03800			IF
03900				JUMPN	XLNK,FALSE
04000			THEN	;Put -1 in ZDNLNK to mark as referenced
04100				HLLOS	OFFSET(ZDNLNK)(XCUR)
04200			FI
04300	
04400	
04500			LI	XAD,OFFSET(ZDRZAC)(XCUR)
04600			OP	XST,(HRLM XPT,)
04700			LOOP
04800				;Search for pointers into the pool in the left half
04900				; of words in the display record area
05000				; i.e. ZDRZAC, ZTSZBI and ZDRZBI fields
05100	
05200				HLRZ	XPT,(XAD)
05300				SKIPE	XPT
05400				NPOINT
05500			AS
05600				AOJ	XAD,
05700				CAIGE	XAD,(XSTOP)
05800				GOTO	TRUE
05900			SA
06000			LI	XAD,OFFSET(ZDRZAC)(XCUR)
06100			OP	XST,(HRRM	XPT,)
06200			LOOP
06300				;Search for pointers into the pool in the right half
06400				; of words in the display record area
06500				; i.e. display vector elements (ZDRZPB)
06600				; and ZTSZAC fields
06700	
06800				HRRZ	XPT,(XAD)
06900				SKIPE	XPT
07000				NPOINT
07100			AS
07200				AOJ	XAD,
07300				CAIGE	XAD,(XSTOP)
07400				GOTO	TRUE
07500			SA
07600			L	XCUR,XSTOP	;Restore XCUR
07700		FI
07800		BRANCH	ZBI.
     
00100		SUBTTL	SAGCFP	(Garbage collector subroutine)
00200	
00300		Comment;
00400	
00500	Purpose:	Check formal parameter locations for ZBP, ZCL and ZPB rec.
00600	
00700	Entry:		SAGCFP
00800	
00900	Input arguments:	XCUR points to current dyn. rec. and
01000				XZPR points to its prototype rec.
01100	
01200	Normal exit:	RETURN
01300	
01400	Call format:	EXEC	SAGCFP
01500	
01600		;
01700	
01800	
01900	
02000	
02100	SAGCFP:	HLLZ	XIND,OFFSET(ZPCNRP)(XZPR) ;number of param's in left half
02200		TLNN	XIND,-1
02300		RETURN				;No parameters
02400	
02500		MOVNS	XIND			;Number of param's negated in left half
02600		HRRI	XIND,OFFSET(ZPCZFP)(XZPR) ;XIND points to first formal
02700						; parameter descriptor
02800		LOOP
02900			;Find the ZDVZBI,ZDSZBI,ZDLZBI,ZDAZAR,ZRVZBI,ZDPZBI and
03000			; ZFLZBI pointers (i.e. the right half of the first word
03100			; in the formal location)
03200	
03300		    LF	X0,ZFPMOD(XIND)
03400		    LF	XTYP,ZTDTYP(XIND)
03500		    LF	XKND,ZPDKND(XIND)
03600		    IF
03700			CAIN	X0,QVALUE	; Not VALUE mode
03900			CAIN	XKND,QARRAY	; OR kind ARRAY
04000			GOTO	TRUE
04100			CAIN	XTYP,QREF	; OR type REF
04200			GOTO	TRUE
04300			CAIE	XTYP,QTEXT	; OR TEXT
04400			GOTO	FALSE
04500		    THEN ;We have an address in RH
04600			LF	XAD,ZFPOFS(XIND)
04700			ADDI	XAD,(XCUR)	;XAD = formal location address
04800			HRRZ	XPT,(XAD)
04900			NPOINT
05000	
05100		;Special code for procedures (not switches) not called by name
05200	
05300			LF	XTYP,ZTDTYP(XIND)
05400			LF	XKND,ZPDKND(XIND)
05500			IF	;Procedure not called by name
05600				CAIE	XKND,QPROCEDURE
05700				GOTO	FALSE
05800				IFNEQF	XIND,ZFPMOD,QNAME
05900				CAIN	XTYP,QLABEL
06000				GOTO	FALSE
06100			THEN	;Procedure not called by name and no switch
06200				LF	XPT,ZDPEBI(XAD)
06300				LI	XAD,OFFSET(ZDPEBI)(XAD)
06400				NPOINT		;ZDPEBI
06500			FI
06600			IFEQF	XIND,ZTDTYP,QREF
06700			ADDI	XIND,1		;Allow for qualification
06800		    FI
06900		AS
07000			AOBJN	XIND,TRUE	;more parameters
07100		SA
07200		RETURN
     
00100		SUBTTL	SAGCGP	(Garbage collector subroutine)
00200	
00300	Comment;
00400	
00500	Purpose:	Find global dynamic record pointers
00600			i.e. pointers in the static area declared in SIMRPA.MAC
00700	
00800	Entry:		SAGCGP
00900	
01000	Normal exit:	RETURN
01100	
01200	Call format:	EXEC	SAGCGP
01300	
01400		;
01500	
01600	
01700	
01800	
01900	SAGCGP:	LOWADR(XIND)
02000	
02100		;Start the chain with the outermost block
02200		; which is fixed, allocated in generated code
02300	
02400		L	XCUR,YOCXCB(XLOW)	;Outermost block address
02500		LI	XEND,(XCUR)		;End of chain
02600		LI	XNEXT,.+2		;Return address for SAGCSP
02700		GOTO	SAGCSP			;Search outermost block
02800	
02900						;Make XNEXT point to first record
03000		LI	XNEXT,(XCUR)		;in the chain
03100		LOWADR(XIND)
03200	
03300		OP	XST,(HRRM  XPT,(XLOW))	;Set the store inst. in XST
03400						; to be indexed with XLOW
03500		LI	XAD,XCB+YSASAV
03600		L	XPT,XCB+YSASAV(XLOW)
03700		NPOINT				;XCB
03800		LI	XAD,YTXZTV
03900		HRRZ	XPT,YTXZTV(XLOW)
04000		NPOINT				;YTXZTV
04100	
04200		LI	XAD,YOBJAD
04300		LI	XCUR,(XAD)
04400		ADDI	XCUR,(XLOW)		;XCUR = YOBJAD + (XLOW)
04500		HRLI	XAD,-<QOBJAD + QNGP>
04600		LOOP
04700			HRRZ	XPT,(XCUR)
04800			NPOINT			;YOBJAD[0:QOBJAD-1] and
04900						; YCSZAC,YSYSIN,YSYSOU,...
05000			ADDI	XCUR,1
05100		AS
05200			AOBJN	XAD,TRUE
05300		SA
05400	
05500	
05600		;Channel table right half
05700	
05800		LI	XAD,YIOCHT
05900		LI	XCUR,(XAD)
06000		ADDI	XCUR,(XLOW)		;XCUR = YIOCHT + (XLOW)
06100		HRLI	XAD,-20
06200		LOOP
06300			HRRZ	XPT,(XCUR)
06400			NPOINT			;YIOCHT [0:17] right half
06500			ADDI	XCUR,1
06600		AS
06700			AOBJN	XAD,TRUE
06800		SA
06900	
07000	
07100		;Channel table left half
07200	
07300		OP	XST,(HRLM  XPT,(XLOW))	;Pointer in left half
07400						; indexed with XLOW
07500		LI	XAD,YIOCHT
07600		LI	XCUR,(XAD)
07700		ADDI	XCUR,(XLOW)		;XCUR = YIOCHT + (XLOW)
07800		HRLI	XAD,-20
07900		LOOP
08000			HLRZ	XPT,(XCUR)
08100			NPOINT			;YIOCHT [0:17] left half
08200			ADDI	XCUR,1
08300		AS
08400			AOBJN	XAD,TRUE
08500		SA
08600	
08700		OP	XST,(HRRM  XPT,)	;Set default store instr. in XST
08800	
08900		RETURN
     
09100		SUBTTL	SAGCLE	(Garbage collector coroutine)
09200	
09300		Comment;
09400	
09500	Purpose:	To determine the length of a dynamic record
09600	
09700	Entry:		SAGCLE
09800	
09900	Input arguments:	XCUR points to the record
10000	
10100	Normal exit:	GOTO	@X0
10200	
10300	Output arguments:	XLEN contains the length
10400	
10500	Call format:	LENGTH		(JSP	X0,SAGCLE)
10600	
10700		;
10800	
10900	
11000	
11100	
11200	SAGCLE:	edit(273)
11300		ZDNCASE(,.)	;[273]
11400	
11500	.ZDN:	RFAIL	Bad ptr in XCUR (SAGCLE)
11600	.ZBI:
11700	.ZBP:
11800	.ZPB:
11900	.ZCL:	LF	XZPR,ZBIZPR(XCUR)
12000		LF	XLEN,ZPRBLE(XZPR)
12100		GOTO	@X0
12200	
12300	.ZTT:	LI	XLEN,ZTT%S
12400		GOTO	@X0
12500	
12600	.ZAC:	LF	XLEN,ZACNAC(XCUR)
12700		ADDI	XLEN,2+OFFSET(ZACSVA)
12800		GOTO	@X0
12900	
13000	.ZTE:
13100	.ZAR:
13200	.ZER:
13300	.ZDR:
13400	.ZYS:
13500	.ZXB:	LF	XLEN,ZYSLG(XCUR)
13600		GOTO	@X0
     
00100		SUBTTL	SAGCN1,SAGCN3	(Garbage collector subroutines)
00200	
00300		Comment;
00400	
00500	Purpose:	SAGCN1:	To find next record in the ZDNLNK chain
00600	
00700			SAGCN3:	To find next record in pool and to update
00800				internal pointers in the new record
00900	
01000	Entries:	SAGCN1,SAGCN3
01100	
01200	Input arg.:	SAGCN1:	XCUR points to the rec just handled, and XEND points
01300				to the last rec in the chain to be handled.
01400			SAGCN3:	XCUR points to the rec just handled and XLEN
01500				contains the length of this rec. XTOP points to the
01600				first free location in the pool. The ZDNLNK field
01700				of a referenced record contains the new address.
01800	
01900	Normal exits:	GOTO	SAGCSP
02000	
02100			SAGCN1:	GOTO	PHASE2		at end of chain
02200	
02300			SAGCN3:	GOTO	PHASE4		at end of pool
02400	
02500	Call format:	NEXT	(GOTO	(XNEXT) where XNEXT = SAGCN1 in PHASE1
02600				and XNEXT = SAGCN3 in PHASE3)
02700	
02800		;
02900	
03000	
03100	
03200	
03300	SAGCN1:		;Find next rec. in chain
03400		CAIN	XCUR,(XEND)
03500		GOTO	PHASE2		;Last rec. is already handled
03600		LF	XCUR,ZDNLNK(XCUR)
03700		GOTO	SAGCSP		;Handle next in chain
03800	
03900	
04000	
04100	
04200	SAGCN3:		;Find next rec in the pool
04300		LOOP
04400			ADDI	XCUR,(XLEN)	;XCUR points to the next
04500						; rec. in pool
04600			CAIL	XCUR,(XTOP)
04700			GOTO	PHASE4		;End of pool
04800		AS
04900			LF	XLNK,ZDNLNK(XCUR)
05000			JUMPN	XLNK,FALSE	;Referenced rec.
05100			LENGTH
05200			GOTO	TRUE		;Not referenced rec.
05300		SA
05400	
05500		;Update internal pointers in the new record
05600		;i.e. add the difference  new address [ZDNLNK(XCUR)]
05700		; - old address [XCUR]  to the internal pointer location
05800	
05900		edit(273)
06000		ZDNCASE(..)	;[273]
06100	
06200		edit(265)	;[265]
06300	ZDN..:	RFAIL	Bad ptr in XCUR (SAGCN3)
06400	
06500	ZAR..:	LF	XLNK,ZDNLNK(XCUR)
06600		SUBI	XLNK,(XCUR)
06700		ADDM	XLNK,OFFSET(ZARBAD)(XCUR)		;ZARBAD
06800		GOTO	SAGCSP
06900	
07000	ZER..:	LF	XSTOP,ZERLEN(XCUR)
07100		ADDI	XSTOP,(XCUR)		;XSTOP points to the first
07200						; word of the next record
07300		LF	XLNK,ZDNLNK(XCUR)
07400		SUBI	XLNK,(XCUR)		;XLNK contains the relocation
07500						; constant for all internal pointers
07600						; in this ZER rec.
07700		LF	XPT,ZERZEV(XCUR)
07800		IF	;Any free chain in this ZER rec.?
07900			JUMPE	XPT,FALSE
08000		THEN
08100			;Update the free chain
08200			LI	XZEV,(XPT)
08300			ADD	XPT,XLNK
08400			SF	XPT,ZERZEV(XCUR)
08500			WHILE		;Not end of free chain
08600				LFE	XPT,ZEVZCH(XZEV)
08700				JUMPL	XPT,FALSE	;-1 = End of chain
08800				IFN QDEBUG,<	CAIL	XPT,(XCUR)
08900					CAIL	XPT,(XSTOP)
09000					RFAIL	ZEVZCH points out of ZER rec.>
09100			DO
09200				LI	XAD,(XZEV)
09300				LI	XZEV,(XPT)
09400				ADD	XPT,XLNK
09500				SF	XPT,ZEVZCH(XAD)
09600			OD
09700		FI
09800	
09900		;Step through all ZEV nodes in the ZER rec. and update the link
10000		; Pointers in used ZEV nodes (i.e. ZEV nodes with ZEVZCH = 0)
10100		;The ZEVZER pointer is updated at the beginning of PHASE4 since this
10200		; field is used to find the relocation factor in NEWZEV.
10300	
10400		LI	XZEV,ZER%S(XCUR)
10500		LOOP
10600			LF	XPT,ZEVZCH(XZEV)
10700			IF
10800				JUMPN	XPT,FALSE
10900			THEN
11000				IFN QDEBUG,<
11100					LOWADR(X1)
11200					IF
11300						L	X0,YSASW(XLOW)
11400						IFOFFA	SWGCTE
11500						GOTO	FALSE
11600					THEN		;Log the internal ZEV update
11700						STACK	X2
11800						RTEXT	(ZEV-ZBL -ZLL -ZRL at )
11900						L	X1,XZEV
12000						OUTOCT
12100						UNSTK	X2
12200					FI
12300				>
12400	
12500				;Update ZEV-ZBL,-ZLL,-ZRL
12600				LF	XPT,ZEVZBL(XZEV)
12700				NZEV
12800				SF	XPT,ZEVZBL(XZEV)	;ZEVZBL
12900	
13000				LF	XPT,ZEVZLL(XZEV)
13100				NZEV
13200				SF	XPT,ZEVZLL(XZEV)	;ZEVZLL
13300	
13400				LF	XPT,ZEVZRL(XZEV)
13500				NZEV
13600				SF	XPT,ZEVZRL(XZEV)	;ZEVZRL
13700			FI
13800			STEP	XZEV,ZEV
13900		AS
14000			CAIGE	XZEV,1-ZEV%S(XSTOP)
14100			GOTO	TRUE
14200		SA
14300		GOTO	SAGCSP
14400	
14500	NEWZEV:		;Enter with the old ZEV pointer value in XPT
14600			; Its new value is computed into XPT
14700		INPOOL
14800		GOTO	@X0
14900		LF	XAD,ZEVZER(XPT)
15000		LF	XLNK,ZDNLNK(XAD)	;New ZER rec. address
15100		SUB	XLNK,XAD		;New - old ZER rec. address
15200	
15300		IFN QDEBUG,<
15400			STACK	X0
15500			LOWADR(X1)
15600			IF
15700				L	X0,YSASW(XLOW)
15800				IFOFFA	SWGCTE
15900				GOTO	FALSE
16000			THEN		;Log the ZEV pointer update
16100				STACK	X2
16200				RTEXT	(	)
16300				L	X1,XPT
16400				OUTOCT
16500				TEXT	(	)
16600				L	X1,XPT
16700				ADD	X1,XLNK
16800				OUTOCT
16900				UNSTK	X2
17000			FI
17100			UNSTK	X0
17200		>
17300	
17400		ADD	XPT,XLNK		;Update pointer value
17500		GOTO	@X0			;Return (NEWZEV called by JSP X0,NEWZEV)
17600	
17700	
17800	ZPB..:
17900	ZCL..:		;Update ZEV pointers in Simulation and Process block
18000		LF	XZPR,ZBIZPR(XCUR)
18100		LOOP			;Search for ZCPGCI \= 0 in prefix chain
18200			LF	XTYP,ZCPGCI(XZPR)
18300		AS
18400			JUMPN	XTYP,FALSE
18500			LF	X0,ZCPZCP(XZPR)
18600			JUMPE	X0,FALSE
18700			L	XZPR,X0
18800			GOTO	TRUE
18900		SA
19000		IF
19100			CAIE	XTYP,QSUSI
19200			GOTO	FALSE
19300		THEN
19400			;Simulation block
19500	
19600			IFN QDEBUG,<
19700				LOWADR(X1)
19800				IF
19900					L	X0,YSASW(XLOW)
20000					IFOFFA	SWGCTE
20100					GOTO	FALSE
20200				THEN		;Log the Simulation block update
20300					STACK	X2
20400					RTEXT	(ZSU-FT -LT at )
20500					L	X1,XCUR
20600					OUTOCT
20700					UNSTK	X2
20800				FI
20900			>
21000	
21100			LF	XPT,ZSUFT(XCUR)
21200			NZEV
21300			SF	XPT,ZSUFT(XCUR)	;ZSUFT
21400	
21500			LF	XPT,ZSULT(XCUR)
21600			NZEV
21700			SF	XPT,ZSULT(XCUR)	;ZSULT
21800	
21900		ELSE
22000			IF
22100				CAIE	XTYP,QSUPS
22200				GOTO	FALSE
22300			THEN
22400				;Process block
22500	
22600				IFN QDEBUG,<
22700					LOWADR(X1)
22800					IF
22900						L	X0,YSASW(XLOW)
23000						IFOFFA	SWGCTE
23100						GOTO	FALSE
23200					THEN		;Log the Process block update
23300						STACK	X2
23400						RTEXT	(ZPSZEV at )
23500						L	X1,XCUR
23600						OUTOCT
23700						UNSTK	X2
23800					FI
23900					>
24000	
24100				LF	XPT,ZPSZEV(XCUR)
24200				NZEV
24300				SF	XPT,ZPSZEV(XCUR)	;ZPSZEV
24400			FI
24500		FI
24600	
24700	ZBI..:				;These rec. types have no
24800	ZBP..:				; internal pointers
24900	ZTT..:
25000	ZTE..:
25100	ZAC..:
25200	ZDR..:
25300	ZYS..:
25400	ZXB..:	GOTO	SAGCSP
     
00100		SUBTTL	SAGCNP	(Garbage collector subroutine)
00200	
00300		Comment;
00400	
00500	Purpose:	Check if the new pointer in XPT points into the pool.
00600			If not return at once to SAGCGP or SAGCSP else go to
00700			SAGCCH (PHASE1) or SAGCUP (PHASE3)
00800			(i.e. the current address in X16)
00900	
01000	Entry:		SAGCNP
01100	
01200	Input arguments:	XPT contains the pointer value
01300				XAD contains the pointer address
01400				XSW contains the return address
01500	
01600	Normal exit:	GOTO	(XSW)
01700			where XSW has been exchanged with X16 if the new pointer
01800			points into the pool and will cause a jump to SAGCCH (PHASE1)
01900			and SAGCUP (PHASE3). X16 will then contain the return
02000			address from where SAGCNP was called
02100	
02200	CALL FORMAT:	NPOINT		(JSP	XSW,SAGCNP)
02300	
02400		;
02500	
02600	
02700	
02800	
02900	SAGCNP:	INPOOL
03000		GOTO	(XSW)
03100		EXCH 	XSW,X16
03200		GOTO	(XSW)
     
00100		SUBTTL	SAGCOO, SAGCOD	(Garbage collector subroutines)
00200	
00300		Comment;
00400	
00500	Purpose:	To output an octal or a decimal number
00600	
00700	Entry:		SAGCOO		Output octal number
00800			SAGCOD		Output decimal number
00900	
01000	
01100	Input arguments:	X1 (right half) contains the number
01200				X0 contains the switch word YSASW(XLOW)
01300				In production version the number is output on TTY
01400				In test version the number is output on TTY if
01500					SWGCT2 in X0 is on and on Sysout if SWGCT3
01600					in X0 is on.
01700	
01800	Normal exit:	RETURN
01900	
02000	Call format:	EXEC	SAGCOO
02100			EXEC	SAGCOD
02200	
02300	
02400		;
02500	
02600	SAGCOO:
02700		PROC
02800		SAVE	<X3>
02900		SETZ	X3,
03000		LOOP
03100			LSHC	X1,-3
03200			AOJ	X3,
03300		AS
03400			JUMPN	X1,TRUE
03500		SA
03600		LOOP
03700			SETZ	X1,
03800			LSHC	X1,3
03900			ADDI	X1,"0"
04000			IFN QDEBUG,<
04100			IFONA	SWGCT2
04200			>
04300			OUTCHR	X1
04400			IFN QDEBUG,<
04500			IF
04600				IFOFFA	SWGCT3
04700				GOTO	FALSE
04800			THEN
04900				EXEC	SAPDCO,<X1>
05000			FI
05100			>
05200		AS
05300			SOJG	X3,TRUE
05400		SA
05500		RETURN
05600		EPROC
05700	
05800	
05900	
06000	SAGCOD:
06100		PROC
06200		SAVE	<X3,X4>
06300		IF
06400			JUMPL	X1,FALSE
06500		THEN
06600			SETZ	X4,
06700			LOOP
06800				IDIVI	X1,^D10
06900				LSHC	X2,-4
07000				AOJ	X4,
07100			AS
07200				JUMPN	X1,TRUE
07300			SA
07400			LOOP
07500				SETZ	X2,
07600				LSHC	X2,4
07700				ADDI	X2,"0"
07800				IFN QDEBUG,<
07900				IFONA	SWGCT2
08000				>
08100				OUTCHR	X2
08200				IFN QDEBUG,<
08300				IF
08400					IFOFFA	SWGCT3
08500					GOTO	FALSE
08600				THEN
08700					EXEC	SAPDCO,<X2>
08800				FI
08900				>
09000			AS
09100				SOJG	X4,TRUE
09200			SA
09300		IFN QDEBUG,<
09400		ELSE
09500			TEXT	(negative?)
09600		>
09700		FI
09800		RETURN
09900		EPROC
     
00100		SUBTTL	SAGCSP	(Garbage collector subroutine)
00200	
00300	Comment;
00400	
00500	Purpose:	Find all pointers in a dynamic record that point to
00600			other dynamic records and call SAGCNP (NPOINT)
00700			for each pointer found
00800	
00900	Entry:		SAGCSP
01000	
01100	Input arguments:	XCUR points to the record to be handled
01200	
01300	Normal exit:	NEXT	(GOTO	(XNEXT)	where XNEXT points to SAGCN1
01400				in PHASE1 and to SAGCN3 in PHASE3)
01500	
01600	Output arg.:	XLEN contains the record length.
01700			XZPR points to the prototype record if present
01800	
01900	Call format:	GOTO	SAGCSP
02000	
02100		;
02200	
02300	
02400	
02500	
02600	SAGCSP:	edit(273)
02700		ZDNCASE(.)	;[273]
02800	
02900		edit(265)	;[265]
03000	ZDN.:	RFAIL	Bad ptr in XCUR (SAGCSP)
03100	
03200	ZBI.:		;Block instance record
03300			;Common to ZBI, ZBP, ZPB and ZCL records
03400		LF	XZPR,ZBIZPR(XCUR)
03500		LF	XLEN,ZPRBLE(XZPR)
03600	
03700			;Find the offset of the first MAP entry
03800		LF	XIND,ZBIBNM(XCUR)
03900		IFE<ZMP%S - 4>,<ASH	XIND,2>		; * 4	( = * ZMP%S)
04000		IFN<ZMP%S - 4>,<IMULI	XIND,ZMP%S>	; * ZMP%S
04100	
04200		LOOP
04300			;Loop on the prefix chain if ZCL or ZPB record
04400	
04500			;Find the first variable MAP address
04600			; (I.E. ZPRMAP + ZMP%S*ZBIBNM)
04700	
04800		    LF	XAD,ZPRMAP(XZPR)
04900		    IF	;Any map?
05000			JUMPE	XAD,FALSE
05100		    THEN
05200			ADDI	XIND,(XAD)		;XIND = first map address
05300			LOOP
05400				;Check the map for the ZBI block and its
05500				; enclosing blocks
05600				WLF	XAD,ZMPNRV(XIND)	;Number of REF and
05700								; ARRAY variables
05800				IF	;Any REF or ARRAY var.
05900								edit(215)
06000					JUMPGE	XAD,FALSE	;[215]
06100				THEN
06200					ADDI	XAD,(XCUR)	;Start address
06300								; in right half
06400					LOOP
06500						;Find all REF and ARRAY var. pointers
06600						L	XPT,(XAD)
06700						NPOINT
06800					AS
06900						AOBJN	XAD,TRUE
07000					SA
07100				FI
07200				WLF	XAD,ZMPNTX(XIND)	;Number of words for
07300								; TEXT var.
07400				IF	;Any TEXT var.
07500					JUMPGE	XAD,FALSE	;[215]
07600				THEN
07700					ADDI	XAD,(XCUR)	;Start address
07800								; in right half
07900					LOOP
08000						;Find all TEXT rec. pointers
08100						LF	XPT,ZTVZTE(XAD)
08200						NPOINT		;ZTVZTE
08300					AS
08400						AOBJP	XAD,FALSE
08500						AOBJN	XAD,TRUE
08600					SA
08700				FI
08800				LF	XIND,ZMPZMP(XIND)	;Next outer map
08900			AS
09000				JUMPN	XIND,TRUE		; If not the outermost
09100			SA
09200		    FI
09300		AS
09400	
09500		    LF	XTYP,ZDNTYP(XCUR)
09600		    IF	;ZCL or ZPB
09700			CAIE	XTYP,QZCL
09800			CAIN	XTYP,QZPB
09900			GOTO	FALSE
10000		    THEN	;Check variable maps in prefix chain
10100			NEXT
10200		    FI
10300		    SETZ	XIND,		;BNM=0 in the prefix chain
10400		    LF	XZPR,ZCPZCP(XZPR)
10500		    JUMPN	XZPR,TRUE
10600	        SA
10700		NEXT
10800	
10900	
11000	ZBP.:		;PROCEDURE
11100		LF	XZPR,ZBIZPR(XCUR)
11200	
11300			;Check for function procedure type REF or TEXT
11400	
11500		LF	XTYP,ZPCTYP(XZPR)
11600		IF
11700			CAIN	XTYP,QREF
11800			GOTO	TRUE
11900			CAIE	XTYP,QTEXT
12000			GOTO	FALSE
12100		THEN
12200			LI	XAD,ZBI%S(XCUR)
12300			HRRZ	XPT,(XAD)
12400			NPOINT			;Function value location
12500		FI
12600	
12700		EXEC	SAGCFP		;Check formal parameters
12800		BRANCH	SAGCDR		;Handle the display rec.
12900					; and then return to ZBI.
13000	
13100	ZCL.:
13200	ZPB.:		;Class and prefixed block
13300		LF	XZPR,ZBIZPR(XCUR)
13400		LOOP				;Search for spec. GC index in prefix chain
13500			LF	XTYP,ZCPGCI(XZPR)
13600		AS
13700			JUMPN	XTYP,FALSE
13800			LF	X0,ZCPZCP(XZPR)
13900			JUMPE	X0,FALSE
14000			L	XZPR,X0
14100			GOTO	TRUE
14200		SA
14300		LF	XZPR,ZBIZPR(XCUR)
14400	
14500		IFN QDEBUG,<	SKIPL	XTYP
14600			CAILE	XTYP,QIOFI
14700			RFAIL	Wrong ZCPGCI in SAGCSP	>
14800		GOTO	@SYSTCL(XTYP)
14900	
15000	SYSTCL:	SYSCLASS	;Generate jump table
15100	
15200	CLPB.:		;Not a  system class
15300		LOOP
15400			;Check formal parameters for the class and its
15500			; enclosing classes
15600			EXEC	SAGCFP
15700			LF	XZPR,ZCPZCP(XZPR)
15800		AS
15900			JUMPN	XZPR,TRUE
16000		SA
16100		LF 	XZPR,ZBIZPR(XCUR)
16200		BRANCH	SAGCDR		;Handle the display rec.
16300					; and then return to ZBI.
16400	
16500	SUSI.:		;Simulation class
16600	
16700	
16800		NPNT(ZSUZPS)			;ZSUZPS
16900	
17000	
17100	
17200			;In PHASE1
17300			; Simulation blocks are chained in a special backward chain
17400			;	with last ref. in YSAZSU(XLOW) and linked in
17500			;	ZSULNK field
17600			; ZSUZER records are chained in the usual way but not updated
17700			;	during PHASE3
17800			; In PHASE4 the chain mentioned above is followed
17900			;	and ZER pointers in the sequencing set are updated
18000			;	(i.e. ZSUZER and ZERZER and ZEVZER pointers)
18100	
18200		IF
18300			CAIE	XNEXT,SAGCN1
18400			GOTO	FALSE
18500		THEN
18600			LOWADR(XLO)
18700			L	X0,YSAZSU(XLOW)
18800			SF	X0,ZSULNK(XCUR)
18900			ST	XCUR,YSAZSU(XLOW)
19000					;Chain but don't update ZSUZER
19100			NPNT(ZSUZER)			;ZSUZER
19200		FI
19300		GOTO	CLPB.
19400	
19500	
19600	SUPS.:		;Process class
19700	SSLG.:		;Linkage class
19800		NPNT(ZLGSUC)			;ZLGSUC
19900		NPNT(ZLGPRE)			;ZLGPRE
20000		GOTO	CLPB.
20100	
20200	
20300	IOFI.:		;File object
20400		;ZFISPC is handled as parameter (741121 LE)
20500		LI	XAD,OFFSET(ZFIIMG)(XCUR)
20600		LF	XPT,ZTVZTE(XAD)
20700		NPOINT				;TEXT rec. pointer in ZFIIMG
20800	
20900		IF
21000			IFOFF	ZFISFD(XCUR)
21100			GOTO	FALSE
21200		THEN
21300			NPNT(ZFIARG)		;ZFIARG
21400		FI
21500	
21600		IF
21700			IFOFF	ZFIDE(XCUR)
21800			GOTO	FALSE
21900		THEN
22000			NPNT(ZFIFIL)		;ZFIFIL
22100		FI
22200	
22300		GOTO	CLPB.
22400	
22500	
22600	
22700	
22800	ZTT.:		;Temporary TEXT variable
22900		LI	XLEN,ZTT%S
23000		NPNT(ZTTZTE)			;ZTTZTE
23100		NEXT
23200	
23300	
23400	ZAR.:		;ARRAY record
23500		LF	XLEN,ZARLEN(XCUR)
23600		LF	XTYP,ZARTYP(XCUR)
23700		IF		;REF or TEXT ARRAY
23800			CAIN	XTYP,QREF
23900			GOTO	TRUE
24000			CAIE	XTYP,QTEXT
24100			GOTO	FALSE
24200		THEN
24300			;Find the address of the first element
24400			; (i.e. XCUR + 3N + 3 where N = number of subscripts)
24500			LF	XIND,ZARSUB(XCUR)	;N
24600			LI	XAD,(XIND)		;N
24700			ASH	XAD,1			;2N
24800			ADDI	XAD,3(XIND)		;2N + N + 3 = 3N + 3
24900			ADD	XAD,XCUR		;XCUR+3N+3
25000	
25100		;Set XSTOP to the address of the first word after the ZAR rec.
25200			LI	XSTOP,(XLEN)
25300			ADDI	XSTOP,(XCUR)
25400	
25500			LOOP
25600				;Step through all elements
25700				HRRZ	XPT,(XAD)
25800				NPOINT			;ZTVZTE or REF pointer
25900				ADDI	XAD,1
26000				CAIN	XTYP,QTEXT
26100				ADDI	XAD,1		;2 words for a TEXT ARR. element
26200			AS
26300				CAIGE	XAD,(XSTOP)
26400				GOTO	TRUE
26500			SA
26600		FI
26700		NEXT
26800	
26900	
27000	ZAC.:		;Accumulator stack record
27100		LF	XLEN,ZACNAC(XCUR)
27200		LI	XAD,OFFSET(ZACSVA)(XCUR)
27300		LF	XIND,ZACZAM(XCUR)
27400		HLLZ	X0,(XIND)		;X0 = relocation flags in left half
27500						; for real ac's
27600		WHILE
27700			SOJL	XLEN,FALSE
27800		DO
27900			ROT	X0,1
28000			IF
28100				TRNN	X0,1
28200				GOTO	FALSE
28300	
28400			THEN
28500				;Right half must be relocated
28600				HRRZ	XPT,(XAD)
28700				NPOINT
28800			FI
28900			ADDI	XAD,1
29000			CAIN	XAD,QNAC+OFFSET(ZACSVA)(XCUR)
29100			HRLZ	X0,(XIND)		;X0 = relocation flags in
29200							; left half for pseudo ac's
29300		OD
29400		LF	XLEN,ZACNAC(XCUR)
29500		ADDI	XLEN,2+OFFSET(ZACSVA)
29600		NEXT
29700	
29800	
29900	ZER.:		;Event notice record
30000		LF	XLEN,ZERLEN(XCUR)
30100	
30200	
30300			;Chain but don't update ZERZER
30400	
30500		IF
30600			CAIE	XNEXT,SAGCN1
30700			GOTO	FALSE
30800		THEN
30900			NPNT(ZERZER)			;ZERZER only in PHASE1
31000		FI
31100	
31200		LI	XAD,OFFSET(ZERZV1)(XCUR)	;XAD points to the first
31300							; event notice
31400		LI	XSTOP,(XLEN)
31500		ADDI	XSTOP,(XCUR)		;XSTOP points to the next rec. in pool
31600		LOOP
31700			;Find all ZEVZPS in used ZEV nodes
31800			IF	;ZEV in use? (i.e. ZEVZCH = 0)
31900				LF	X0,ZEVZCH(XAD)
32000				JUMPN	X0,FALSE
32100			THEN
32200				LF	XPT,ZEVZPS(XAD)
32300				NPOINT			;ZEVZPS
32400			FI
32500			STEP	XAD,ZEV
32600		AS
32700			CAIGE	XAD,1-ZEV%S(XSTOP)
32800			GOTO	TRUE
32900		SA
33000		NEXT
33100	
33200	
33300	ZDR.:		;Display record
33400		IFN QDEBUG,<	IF		;PHASE1?
33500				CAIE	XNEXT,SAGCN1
33600				GOTO	FALSE
33700			THEN		;ZDR should not be referenced
33800				RFAIL	XCUR points to ZDR rec. in SAGCSP PHASE1
33900			FI	>
34000	ZTE.:		;TEXT record
34100	ZYS.:		;System record (no relocation of contents)
34200		LF	XLEN,ZYSLG(XCUR)
34300		NEXT
34400	
34500	
34600	ZXB.:		;Extended lookup block
34700		LF	XLEN,ZXBLG(XCUR)
34800		LF	XPT,ZXBP2(XCUR)
34900		IF
35000			;SFD pointer in ZXBP2 if left half = 0
35100	
35200			TLNE	XPT,-1
35300			GOTO	FALSE
35400		THEN
35500			LI	XAD,OFFSET(ZXBP2)(XCUR)
35600			NPOINT
35700		FI
35800		NEXT
35900	
     
00100		SUBTTL	SAGCUP	(Garbage collector coroutine)
00200	
00300		Comment;
00400	
00500	Purpose:	Update a new pointer by executing the instruction in
00600			XST	with the new value in XPT
00700	
00800	Entry:		SAGCUP
00900	
01000	Input arguments:	XPT points to the old rec. with the new value in
01100					its ZDNLNK field
01200				XST contains the instruction to store XPT at the
01300					pointer address
01400	
01500	Normal exit:	GOBACK		(JSP	X16,(X16))
01600	
01700	Call format:	GOTO	(XSW)
01800	
01900		;
02000	
02100	
02200	
02300	
02400	SAGCUP:
02500			IFN	QDEBUG,<
02600				LOWADR(X1)
02700				IF
02800					L	X0,YSASW(XLOW)
02900					IFOFFA	SWGCTE
03000					GOTO	FALSE
03100				THEN
03200						;Log the update phase
03300					STACK	X2
03400					RTEXT
03500					HRRZ	X1,XAD
03600					OUTOCT
03700					TEXT	(	)
03800					L	X1,XPT
03900					OUTOCT
04000					TEXT	(	)
04100					LF	X1,ZDNLNK(XPT)
04200					OUTOCT
04300					UNSTK	X2
04400				FI
04500				>
04600		LF	XPT,ZDNLNK(XPT)	;New pointer value
04700		HRRI	XST,(XAD)	;Set the address field in XST
04800		XCT	XST		;Store the new address in the pointer field
04900		GOBACK
05000		GOTO	SAGCUP		;Entry for next call on SAGCUP
     
00100		SUBTTL	.SAGC	(Garbage collector)
00200	
00300	.SAGC:
00400		PROC
00500	
00600		IFN QSASTE,<
00700	
00800	;	If allocation in steps then
00900	;	If X0 = 0 a garbage collection should be forced
01000	;	(.SAGC called from SIMDDT or with YSAREL GT 0)
01100	;	If X0 NE 0 then check if a new step can be allocated
01200	;	without exceeding the garbage collection limit.
01300	;		.JBREL + X0 + YSASTE LT YSABOT +YSAL
01400	;	If so call SANP1 for a CORE request with lowseg size in X2
01500	;	If not do a garbage collection (call SAGC1).
01600	
01700		LOWADR(X16)
01800		edit(265)	;[265]
01900		STD	X1,YSASAV+X1(XLOW)
02000		JUMPE	X0,.SAGC1
02100		L	X1,.JBREL
02200		ADD	X1,X0
02300		ADD	X1,YSASTE(XLOW)
02400		L	X2,X1
02500		SUB	X1,YSAL(XLOW)
02600		CAML	X1,YSABOT(XLOW)
02700		 GOTO	.SAGC1
02800		XEC	SANP1
02900		LD	X1,YSASAV+X1(XLOW)
03000		RET
03100	
03200	.SAGC1:		;Garbage collector main entry
03300	
03400		>	;END IFN QSASTE,
03500		IFE QSASTE,<LOWADR X16>
03600	
03700		edit(265)	;[265] Save X0,X3-X15 (X1,X2 already saved)
03800		ST	X0,YSASAV+X0(XLOW)
03900		LI	YSASAV+X3(XLOW)
04000		HRLI	X3
04100		BLT	YSASAV+X15(XLOW)
04200	
04300	
04400		IFON	SWNOGC(XLOW)
04500		 SAERR	0,Garbage collection not possible
04600	
04700		SETON	SWNOGC(XLOW)	;Indicate GC started
04800	
04900		IFN QDEBUG,<
05000		IF	L	X0,YSASW(XLOW)
05100			IFOFFA	SWGCTE
05200			GOTO	FALSE
05300		THEN	;Start log output
05400			RTEXT(GARBAGE COLLECTION STARTED)
05500		FI
05600		>
05700	
05800		STACK	YDSCSW(XLOW)	;Save ^C-REENTER switch
05900		SKIPN	YDSCSW(XLOW)
06000		 CDEFER			;Defer call on SIMDDT
06100	
06200		IF	;Pool to be expanded at the top
06300			SKIPE	YSAREL(XLOW)
06400			GOTO	FALSE
06500		THEN	L	X0,YSALIM(XLOW)
06600			SUB	X0,YSATOP(XLOW)	;Let X0(saved) be the minimum amount
06700			ADDM	X0,X0+YSASAV(XLOW); of free pool area needed
06800		FI
06900	
07000			;Update parameters for calculation of new garbage collection
07100			; limit and step size
07200	
07300	edit(175)	;[175]
07400		EXTERN	.JBPFH
07500		IF	;Page fault handler is in core
07600			SKIPN	.JBPFH
07700			GOTO	FALSE
07800		THEN
07900			L	X1,[%VMSPF]
08000			GETTAB	X1,
08100			SETZ	X1,
08200			HLRZ	X1,X1
08300			L	X0,X1
08400			SUB	X1,YSANWA(XLOW)	;NIW faults between gc:s
08500			ST	X1,YSANWB(XLOW)
08600			HRLZ	X1,X1
08700			ADDM	X1,YSANWC(XLOW)	;Accumulate between gc:s
08800			ST	X0,YSANWA(XLOW)
08900		FI
09000		AOS	YSAGCN(XLOW)		;Increment GC counter
09100		SETZ	X0,
09200		RUNTIM	X0,
09300		L	X1,YSATIM(XLOW)
09400		ST	X0,YSATIM(XLOW)		;Update TIM
09500		SUB	X0,X1
09600		FLTR	X0,X0
09700		ST	X0,YSATAU(XLOW)		;TAU:=run time before GC
09800		L	X1,YSAFES(XLOW)
09900		ST	X1,YSAFLA(XLOW)		;Save last F^
10000		L	X2,YSAL(XLOW)
10100		FLTR	X2,X2
10200		FSBR	X2,X1			;L-F^
10300		IF
10400			JUMPE	X0,FALSE	;R unchanged if TAU = 0
10500			JUMPLE	X2,FALSE	; or if L-F^ <= 0
10600		THEN
10700			FDVR	X2,X0			;/TAU
10800			ST	X2,YSAR(XLOW)		;R:=(L-F^)/TAU
10900		FI
11000	
11100			;Set XTOP and XBOT
11200	
11300		L	XTOP,YSATOP(XLOW)	;Top of pool
11400		L	XBOT,YSABOT(XLOW)	;Bottom of pool
11500	
11600		IFN QDEBUG,<
11700	
11800			;In debug version a buffer ring for GCP.TMP is needed
11900			; (see .SAGI). In this case .SAGC is called with
12000			; an empty pool
12100	
12200		IF
12300			CAME	XTOP,XBOT
12400			GOTO	FALSE
12500		THEN
12600			;Here in debug version to get buff for GCP.TMP
12700			;Just ask for more core and set new pool limit
12800	
12900			L	X0,YSAREL(XLOW)
13000			ADDI	X0,(XBOT)
13100			ST	X0,YSABOT(XLOW)
13200			ST	X0,YSATOP(XLOW)
13300			L	X0,.JBREL
13400			ADD	X0,YSAREL(XLOW)
13500			L	XFROTO,.JBREL
13600			CORE	X0,
13700			 SAERR	1,CORE failed
13800			edit(65)
13900		IFN QZERO,<;[65]
14000			SETZM	(XFROTO)	;Zero new core just for sure
14100			HRL	XFROTO,XFROTO
14200			ADDI	XFROTO,1
14300			BLT	XFROTO,@.JBREL
14400		>
14500	
14600			L	X0,.JBREL
14700			HRRM	X0,.JBFF
14800			SUBI	X0,QSALIM
14900			ST	X0,YSALIM(XLOW)
15000			BRANCH	SAGCEX		;Exit at once without any updating
15100		FI
15200		>
     
00100		SUBTTL	SAGC (Garbage collector) PHASE 1
00200	
00300	PHASE1:		;Chain all referenced dynamic records
00400			; SAGCGP and SAGCSP communicate with the coroutine
00500			; SAGCCH via SAGCNP
00600	
00700		IFN QDEBUG,<
00800				L	 X0,YSASW(XLOW)
00900				IF
01000					IFOFFA	SWGCTE
01100					GOTO	FALSE
01200				THEN	;Title in log output
01300					RRTEXT	(Chain record at)
01400				FI>
01500	
01600		LI	X16,SAGCCH	;X16 should contain the address of the routine
01700					; to be called when a new pointer is found with
01800					; a value pointing into the pool, and that is
01900					; SAGCCH during PHASE1.
02000	
02100		EXEC	SAGCGP		;Start with global pointers
02200		LI	XCUR,(XNEXT)	;Go on with pointers in records in the chain
02300					; Start of chain saved in XNEXT (SAGCGP)
02400		LI	XNEXT,SAGCN1	;NEXT will call SAGCN1 in PHASE1
02500		JUMPE	XCUR,PHASE2	;No chain to search
02600		BRANCH	SAGCSP		;Start searching for pointers in all chained
02700					; records, and chain new referenced records.
     
00100		SUBTTL	SAGC (Garbage collector) PHASE 2
00200	
00300	PHASE2:		;Return here from SAGCN1 when there are no more records in the
00400			; chain
00500	
00600		HLLOS	OFFSET(ZDNLNK)(XEND)	;Set -1 in ZDNLNK to mark
00700						; that the last rec in the chain
00800						; is referenced
00900	
01000		;Step through the pool and compute new addresses for all referenced
01100		; records, and store the new addresses in their ZDNLNK field.
01200		; Collect adjacent unreferenced records to one ZYS record
01300		; with the total length in ZYSLG
01400	
01500	
01600		LOWADR	(X16)
01700	
01800		IFN QDEBUG,<
01900				L	X0,YSASW(XLOW)
02000				IF
02100					IFOFFA	SWGCTE
02200					GOTO	FALSE
02300				THEN
02400					;Title in the log output
02500					RRTEXT	(Rec. at	to	length)
02600				FI>
02700	
02800		L	XAD,YSAREL(XLOW)	;The quantity to be added to YSABOT
02900						; if the pool must be moved upwards
03000		ADDI	XAD,(XBOT)
03100		ST	XAD,YSABOT(XLOW)	;New start address of the pool
03200		LI	XCUR,(XBOT)		;Start at the bottom
03300		LOOP	;Thru the pool
03400			LENGTH			;XLEN := length of rec. at XCUR
03500			LF	XLNK,ZDNLNK(XCUR)
03600			IF	;Not referenced
03700				JUMPN	XLNK,FALSE
03800			THEN	;Make a ZYS rec. of unreferenced neighbours
03900				LI	XPT,(XCUR)
04000				LI	XTOT,(XLEN)
04100				SETF	QZYS,ZDNTYP(XPT)
04200				WHILE
04300					ADDI	XCUR,(XLEN)
04400					CAIL	XCUR,(XTOP)
04500					GOTO	FALSE
04600				DO
04700					LENGTH
04800					LF	XLNK,ZDNLNK(XCUR)
04900					JUMPN	XLNK,FALSE
05000					ADDI	XTOT,(XLEN)
05100				OD
05200				SF	XTOT,ZYSLG(XPT)
05300				edit(273)	;[273] Do not relocate below YSAFRZ
05400				CAMG	XCUR,YSAFRZ(XLOW)
05500				 ADDI	XAD,(XTOT)
05600			ELSE
05700				IFN QDEBUG,<
05800					IF
05900						L	X0,YSASW(XLOW)
06000						IFOFFA	SWGCTE
06100						GOTO	FALSE
06200					THEN
06300						;Log output
06400						RTEXT
06500						L	X1,XCUR
06600						OUTOCT
06700						TEXT	(	)
06800						L	X1,XAD
06900						OUTOCT
07000						TEXT	(	)
07100						L	X1,XLEN
07200						OUTOCT
07300					FI
07400					>
07500	
07600				SF	XAD,ZDNLNK(XCUR) ;Store new address
07700				ADDI	XAD,(XLEN)	;XAD:=new address for next rec.
07800				ADDI	XCUR,(XLEN)
07900			FI
08000		AS
08100			CAIGE	XCUR,(XTOP)
08200			GOTO	TRUE	;Check next rec. in pool
08300		SA
     
00100		;Now XAD = the new YSATOP
00200		; IF XAD + X0(saved) + QSALIM > .JBREL,
00300		; ask for more core and update YSALIM(XLOW)
00400	
00500	
00600		ST	XAD,YSATOP(XLOW)
00700	
00800	IFN QSADEA,<	;Update YSADEA (the deallocation pointer)
00900			; If YSADEA points to a referenced rec. get its new
01000			; address else set YSADEA to the new YSATOP value
01100	
01200			L	XPT,YSADEA(XLOW)
01300			LF	XPT,ZDNLNK(XPT)
01400			SKIPN	XPT
01500			 L	XPT,XAD
01600			ST	XPT,YSADEA(XLOW)
01700		>
01800	
01900		ADD	XAD,X0+YSASAV(XLOW)
02000		ADDI	XAD,QSALIM
02100		IF	;More core needed
02200			CAMG	XAD,.JBREL
02300			GOTO	FALSE
02400		THEN
02500		    L	XFROTO,.JBREL
02600		    IF
02700			CORE	XAD,
02800			GOTO	FALSE
02900		    THEN
03000			L	XAD,.JBREL
03100			HRRM	XAD,.JBFF
03200	
03300				edit(65)
03400			IFN QZERO,<;[65]
03500			SETZM	(XFROTO)	;Zero new core just for sure
03600			HRL	XFROTO,XFROTO
03700			ADDI	XFROTO,1
03800			BLT	XFROTO,(XAD)
03900			>
04000	
04100			SUBI	XAD,QSALIM
04200			ST	XAD,YSALIM(XLOW)
04300		    ELSE
04400			;Restore XTOP and XCB for SIMDDT
04500	
04600			ST	XTOP,YSATOP(XLOW)
04700			L	XCB,XCB+YSASAV(XLOW)
04800			 SAERR	1,Cannot get enough core for object pool
04900		    FI
05000		FI
     
00100		SUBTTL	SAGC (Garbage collector) PHASE 3
00200	
00300	PHASE3:
00400			;Update all dynamic pointers in referenced records
00500			; SAGCGP and SAGCSP communicate with the coroutine
00600			; SAGCUP via SAGCNP
00700			;All internal pointers (except ZEVZER) are also updated
00800			; via the NEXT routine SAGCN3
00900	
01000		IFN QDEBUG,<
01100				L	X0,YSASW(XLOW)
01200				IF
01300					IFOFFA	SWGCTE
01400					GOTO	FALSE
01500				THEN
01600					;Title in log output
01700					RRTEXT	(Pointer	old val	new val)
01800				FI>
01900	
02000		LI	X16,SAGCUP
02100		OP	XST,(HRRM  XPT,);Set the default store inst. in XST
02200		EXEC	SAGCGP		;Start with global pointers
02300		LI	XCUR,(XBOT)	;Go on with pointers in the pool
02400		LI	XNEXT,SAGCN3	;NEXT will jump to SAGCN3
02500		GOTO	SAGCSP		;Step through the pool
     
00100		SUBTTL	SAGC (Garbage collector) PHASE 4
00200	
00300	PHASE4:
00400			;Return here from SAGCN3 when the last record in the pool
00500			; has been handled
00600	
00700	
00800			;Update sequencing set chains and ZEVZER in all ZER records
00900	
01000		LOWADR(X16)
01100		L	XCUR,YSAZSU(XLOW)
01200		SETZM	YSAZSU(XLOW)
01300		WHILE	;More SIMULATION blocks on chain
01400			JUMPE	XCUR,FALSE
01500		DO
01600			LF	XPT,ZSUZER(XCUR)
01700			LI	XAD,OFFSET(ZSUZER)(XCUR)
01800			WHILE
01900				;ZER rec found
02000				JUMPE	XPT,FALSE
02100			DO
02200				;Update all internal pointers in this ZER and
02300				; the ZER chain. ZDNLNK contains the new address.
02400	
02500				LF	XLNK,ZDNLNK(XPT)
02600				HRRM	XLNK,(XAD)	;Update ZER chain
02700							; (ZSUZER or ZERZER)
02800				IFN QDEBUG,<
02900					L	X0,YSASW(XLOW)
03000					IF
03100						IFOFFA	SWGCTE
03200						GOTO	FALSE
03300					THEN
03400						;Log the update of ZSUZER and ZERZER
03500						RTEXT	(ZER-pointer at )
03600						L	X1,XAD
03700						OUTOCT
03800						RTEXT	(	)
03900						L	X1,XPT
04000						OUTOCT
04100						TEXT	(	)
04200						L	X1,XLNK
04300						OUTOCT
04400					FI
04500				>
04600				;Step through the ZER rec and update all ZEVZER
04700				LI	XZEV,OFFSET(ZERZV1)(XPT)
04800				LF	XSTOP,ZERLEN(XPT)
04900				ADDI	XSTOP,(XPT)
05000				LOOP
05100					IFN QDEBUG,<
05200						L	X0,YSASW(XLOW)
05300						IF
05400							IFOFFA	SWGCTE
05500							GOTO	FALSE
05600						THEN
05700							;Log the ZEVZER update
05800							RTEXT
05900							LI	X1,OFFSET(ZEVZER)(XZEV)
06000							OUTOCT
06100							TEXT	(	)
06200							LF	X1,ZEVZER(XZEV)
06300							OUTOCT
06400							TEXT	(	)
06500							L	X1,XLNK
06600							OUTOCT
06700						FI
06800					>
06900					SF	XLNK,ZEVZER(XZEV)
07000				AS
07100								;Next ZEV in ZER rec.
07200					STEP	XZEV,ZEV
07300					CAIGE	XZEV,1-ZEV%S(XSTOP)
07400					GOTO	TRUE
07500				SA
07600				LI	XAD,OFFSET(ZERZER)(XPT)	;Next ZER rec. in chain
07700				LF	XPT,ZERZER(XPT)
07800			OD
07900			LF	X0,ZSULNK(XCUR)
08000			ZF	ZSULNK(XCUR)
08100			L	XCUR,X0		;Next SIMULATION block in chain
08200		OD
     
00100	;Step through the pool a third time and move all referenced
00200	; records to the new address and clear their ZDNLNK field
00300	
00400		SETZB	XBEG,XSAV
00500		LI	XCUR,(XBOT)
00600		LOOP
00700			;Find the first rec. to be moved towards the bottom of
00800			; the pool
00900			LF	XLNK,ZDNLNK(XCUR)
01000			JUMPE	XLNK,L2		;Unreferenced
01100	
01200				;Find first referenced rec.
01300				;  in pool that has to be moved
01400	
01500			IF	;Not found yet
01600				JUMPN	XBEG,FALSE
01700			THEN
01800				IF
01900					CAIE	XLNK,(XCUR)
02000					GOTO	FALSE
02100				THEN
02200					ZF	ZDNLNK(XCUR)
02300					GOTO	L2	;Ref. rec. at top of pool
02400							; need not be moved
02500				FI
02600				LI	XBEG,(XCUR)	;XBEG points to the first rec.
02700							; in the pool that must be moved
02800			FI
02900			CAIG	XLNK,(XCUR)
03000			GOTO	FALSE			;The first rec. to be moved
03100							; towards the bottom is found
03300			LI	XSAV,(XCUR)		;Save the latest referenced rec.
03400	L2():!		LENGTH
03500			ADDI	XCUR,(XLEN)
03600		AS
03700			CAIGE	XCUR,(XTOP)
03800			GOTO	TRUE			;Handle next rec.
03900			IFN QDEBUG,<	CAIE	XCUR,(XTOP)
04000				RFAIL	No match XCUR-XTOP at end of pool>
04100	
04200		SA
     
00100		LI	XPT,(XCUR)	;XPT points to the first rec. to be
00200					; moved towards the bottom
00300		JUMPE	XSAV,L3		;No records are to be moved towards the top
00400		LI	XCUR,(XSAV)	;XCUR points to the rec. with the highest
00500					; address that must be moved towards the top
00600		LENGTH
00700		LF	XAD,ZDNLNK(XCUR)
00800		ADDI	XAD,(XLEN)	;XAD points to the first word in the new rec.
00900					; area of the first rec. moved towards
01000					; the bottom
01100	
01200					edit(72)
01300		LI	XCUR,(XBEG)	;[72] Generate backward chain in records to be
01400					;[72] moved towards the top
01500		SETZ	XFROM,0		;[72] End of chain
01600		LOOP
01700			;All rec's to be moved towards the top are moved with a BLT or
01800			; if the old and the new area overlap with a word by word
01900			; transfer starting with the last word in the rec.
02000	
02100			LF	XLNK,ZDNLNK(XCUR)
02200			LENGTH
02300	
02400			;Check if the referenced rec. with the highest address
02500			; overlaps with its new area,
02600			; i.e. the rec. whose ZDNLNK points to an address (XLEN) less
02700			; than (XAD), where XAD points to the first occupied word
02800			; in the new pool
02900	
03000	
03100			IF
03200				JUMPE	XLNK,FALSE
03300				SF	XFROM,ZDNLNK(XCUR)	;[72] Insert back chain
03400				LI	XFROM,(XCUR)		;[72] Save new chain addr
03500				LI	X0,(XLNK)
03600				ADDI	X0,(XLEN)
03700				CAIE	X0,(XAD)
03800				GOTO	FALSE
03900			THEN
04000	L4():!			;[72]
04100				;Next rec. to be moved is found
04200				LI	XFROM,(XCUR)
04300				ADDI	XFROM,(XLEN)
04400				LF	XBEG,ZDNLNK(XCUR)	;[72] Next record addr
04500				ZF	ZDNLNK(XCUR)		;[72] Clear link field
04600				IF	;Overlap
04700					CAIG	XFROM,(XLNK)
04800					GOTO	FALSE
04900				THEN	;Move word by word
05000					IFN QDEBUG,<
05100						LOWADR(X1)
05200						IF
05300							L	X0,YSASW(XLOW)
05400							IFOFFA	SWGCTE
05500							GOTO	FALSE
05600						THEN
05700							;Log upward overlap move
05800							STACK	X2
05900							RTEXT	(Rec at )
06000							L	X1,XCUR
06100							OUTOCT
06200							TEXT( overlap moved to )
06300							L	X1,XLNK
06400							OUTOCT
06500							TEXT	( length )
06600							L	X1,XLEN
06700							OUTOCT
06800							UNSTK	X2
06900						FI
07000						>
07100	
07200								;[72]
07300					LOOP
07400						;Move one word at a time
07500						SUBI	XAD,1
07600						SUBI	XFROM,1
07700						L	X0,(XFROM)
07800						ST	X0,(XAD)
07900					AS
08000						CAIN	XFROM,(XCUR)
08100						GOTO	FALSE	;The first word in the
08200							; old area is moved -> the whole
08300							; rec. is moved, and XAD points
08400							; to the first occupied word in
08500							; the new pool
08600						GOTO	TRUE	;Move the next word
08700					SA
08800				ELSE	;No overlap, use BLT
08900								;[72]
09000					LI	XAD,(XLNK)
09100					LI	XFROTO,(XLNK)
09200					HRLI	XFROTO,(XCUR)
09300					ADDI	XLNK,-1(XLEN)
09400	
09500	
09600				IFN QDEBUG,<
09700					LOWADR(X1)
09800					IF
09900						L	X0,YSASW(XLOW)
10000						IFOFFA	SWGCTE
10100						GOTO	FALSE
10200					THEN
10300						;Log upward BLT move
10400						STACK	X2
10500						RTEXT	(Rec at )
10600						HLRZ	X1,XFROTO
10700						OUTOCT
10800						TEXT	( BLT to )
10900						HRRZ	X1,XFROTO
11000						OUTOCT
11100						TEXT	( length )
11200						L	X1,XLEN
11300						OUTOCT
11400						UNSTK	X2
11500					FI
11600					>
11700	
11800	
11900					BLT	XFROTO,(XLNK)
12000				FI
12100				edit(72)
12200				;[72]  Next record to be moved has address XBEG
12300				;Calculate the address to which it should be moved
12400				JUMPE	XBEG,L3		;No more records are to be moved
12500				LI	XCUR,(XBEG)	;Next record address
12600				LENGTH
12700				LI	XLNK,(XAD)	;XAD points to the first occupied
12800							;word in the new pool
12900				SUBI	XLNK,(XLEN)	;New record address after the move
13000				GOTO	L4
13100			FI		;[72] END
13200				;Search for next rec. to be moved
13300			ADDI	XCUR,(XLEN)
13400			IFN QDEBUG,<	CAIL	XCUR,(XTOP)
13500				RFAIL	XCUR points out of the pool >
13600				;[72]
13700		AS
13800			GOTO	TRUE
13900		SA
     
00100	L3():!		;Move the remaining ref. rec. towards the bottom with a BLT
00200			; for each rec.
00300	
00400		LI	XCUR,(XPT)
00500		WHILE
00600			;Records left
00700			CAIL	XCUR,(XTOP)
00800			GOTO	FALSE		;All records in the old pool are checked
00900						; and moved to the new pool if
01000						; referenced
01100		DO
01200			LF	XLNK,ZDNLNK(XCUR)
01300			LENGTH
01400			IF	;Referenced
01500				JUMPE	XLNK,FALSE
01600			THEN
01700				;Move a referenced record and clear ZDNLNK
01800				ZF	ZDNLNK(XCUR)
01900				LI	XFROTO,(XLNK)
02000				HRLI	XFROTO,(XCUR)
02100				ADDI	XLNK,-1(XLEN)
02200	
02300	
02400				IFN QDEBUG,<
02500					LOWADR(X1)
02600					IF
02700						L	X0,YSASW(XLOW)
02800						IFOFFA	SWGCTE
02900						GOTO	FALSE
03000					THEN
03100						;Log downward BLT move
03200						RTEXT	(Rec at )
03300						HLRZ	X1,XFROTO
03400						OUTOCT
03500						TEXT	( BLT to )
03600						HRRZ	X1,XFROTO
03700						OUTOCT
03800						TEXT	( length )
03900						L	X1,XLEN
04000						OUTOCT
04100					FI
04200					>
04300	
04400				BLT	XFROTO,(XLNK)
04500			FI
04600			ADDI	XCUR,(XLEN)	;Check next record
04700		OD
     
00100		IFN QDEBUG,<	CAIE	XCUR,(XTOP)
00200			RFAIL	No match XCUR-XTOP at end of SAGC>
00300	
00400		LOWADR(X16)
00500		;Clear freed area at the top
00600		L	XFROTO,YSATOP(XLOW)
00700		IF
00800			CAIL	XFROTO,(XTOP)
00900			GOTO	FALSE
01000		THEN
01100			SETZM	(XFROTO)
01200			IF	;More than one word freed
01300				CAIL	XFROTO,-1(XTOP)
01400				GOTO	FALSE
01500			THEN
01600				HRLI	XFROTO,(XFROTO)
01700				ADDI	XFROTO,1
01800				BLT	XFROTO,-1(XTOP)
01900			FI
02000		FI
02100	
02200		;Clear freed area at the bottom
02300		LI	XFROTO,(XBOT)
02400		L	XSTOP,YSABOT(XLOW)
02500		IF
02600			;At least one word freed
02700			CAIL	XFROTO,(XSTOP)
02800			GOTO	FALSE
02900		THEN
03000			SETZM	(XFROTO)
03100			IF	;More than one word freed
03200				CAIL	XFROTO,-1(XSTOP)
03300				GOTO	FALSE
03400			THEN
03500				HRLI	XFROTO,(XFROTO)
03600				ADDI	XFROTO,1
03700				BLT	XFROTO,-1(XSTOP)
03800			FI
03900		FI
04000	
04100	
04200		;Update YSATIM and set X6 to garbage collection runtime
04300		; and output on TTY in debug version
04400	
04500		SETZ	X6,
04600		RUNTIM	X6,
04700		L	X1,YSATIM(XLOW)
04800		ST	X6,YSATIM(XLOW)
04900		SUBB	X6,X1		;X6 := X1 := TAUGC  (fixed)
05000		IFN QDEBUG,<
05100		IF
05200			L	X0,YSASW(XLOW)
05300			IFOFFA	SWGCT4
05400			GOTO	FALSE
05500		THEN
05600			;Log the g.c. time
05700			RTEXT( RUNTIME:  )
05800			OUTDEC
05900		FI
06000		>
06100		ADDM	X6,YSAGCT(XLOW)	;Accumulate GC time
06200	
06300		EXEC	.SANP		;Determine free storage pool area
06400					; and allocate a first step
06500					; (or if QSASTE=0 the whole pool)
06600	
06700		IFN QDEBUG,<
06800		IF
06900			L	X0,YSASW(XLOW)
07000			IFOFFA	SWGCT4
07100			GOTO	FALSE
07200		THEN
07300			;Log the new low segment limit
07400			L	X1,.JBREL
07500			RTEXT(LOW SEGMENT LIMIT:  )
07600			EXEC	SAGCOO
07700			RTEXT
07800		FI
07900		>
     
00100	;** EXIT **
00200	
00300	SAGCEX:
00400		LOWADR	(X16)
00500		UNSTK	YDSCSW(XLOW)		;Restore ^C-REENTER switch
00600		SETOFF	SWNOGC(XLOW)		;Indicate GC finished
00700		SETZM	YSAREL(XLOW)
00800	
00900	
01000	IFN QDEBUG,<
01100		;Output the last line on Sysout if Sysout used for dump and log output
01200		IFON	SWGCT3(XLOW)
01300		EXEC	SAPDOI
01400	>
01500	
01600		;Restore ac's
01700	
01800		MOVSI	X16,YSASAV(XLOW)		; YSASAV(XLOW),, 0
01900		BLT	XLOW,X15
02000		LOWADR (X16)
02100	
02200		RETURN
02300	
02400		EPROC
     
00100		SUBTTL	.SAGI	(Garbage collector initializations)
00200	
00300		Comment;
00400	
00500	Purpose:	Open in append mode GCP.TMP in debug version
00600			and initialize garbage collection parameters
00700	
00800	Entry:		.SAGI
00900	
01000	Input arguments:
01050			YSABOT(XLOW) should be initialized to
01100			needed low seg. area excluding the storage pool.
01200			YRUNTM(XLOW) should be set to execution start time.
01300	
01400	Normal exit:	RETURN
01500	
01600	Call format:	EXEC	.SAGI
01700	
01800	Used subroutines:	SANP1, SANP2, GETBUFF, LINKBUFF
01900	
02000	
02100		;
02200	
02300	
02400	
02500	
02600	.SAGI:	PROC
02700		SAVE	<X0,X1,X2,X3,X6,X7>
02800	
02900		LOWADR(X16)
03000		IFN QDEBUG,<
03100		SETOFF	SAGCPE(XLOW)
03200		LI	X6,QBUFS	;Buffer size
03300		LI	X7,2		;Number of buffers
03400		GETBUFF
03500		ST	X1,YSABH(XLOW)
03600		LI	X2,1(X1)	;Buffer header address returned by GETBUFF
03700		HRL	X2,X2
03800		LI	X0,.IOBIN	;Mode
03900		MOVSI	X1,'DSK'
04000		IF
04100			OPEN	QCHGCP,X0
04200			GOTO	FALSE
04300		THEN
04400			L	X1,YSABH(XLOW)
04500			LINKBUFF
04600			LF	X0,ZBHBUP(X1)
04700			HRLI	X0,4400
04800			SF	X0,ZBHBUP(X1)
04900			LI	X0,200
05000			SF	X0,ZBHCNT(X1)
05100			PJOB	X1,		;Job number in X1
05200			;Convert to sixbit in X0 left half
05300	
05400			IDIVI	X1,^D100
05500			IDIVI	X2,^D10
05600			LSH	X1,^D12
05700			LSH	X2,6
05800			ADD	X1,X2
05900			ADD	X1,X3
06000			HRL	X0,X1
06100			TLO	X0,202020
06200	
06300			HRRI	X0,'GCP'
06400			MOVSI	X1,'TMP'
06500			SETZB	X2,X3
06600			IF
06700				LOOKUP	QCHGCP,X0
06800				GOTO	FALSE
06900			THEN
07000	L1():!			SETZ	X3,
07100				IF
07200					ENTER	QCHGCP,X0
07300					GOTO	FALSE
07400				THEN
07500					L	X1,YSABH(XLOW)
07600					CLAIMBUFF
07700					USETI	QCHGCP,-1	;End of file
07800					IF
07900						OUT	QCHGCP,	;Initial OUT
08000						GOTO	FALSE
08100					THEN
08200						SETON	SAGCPE(XLOW)
08300						OUTSTR	[ASCIZ	/Err 1:st OUT GCP/]
08400					FI
08500				ELSE
08600	L2():!				SETON	SAGCPE(XLOW)
08700					OUTSTR	[ASCIZ	/ENTER error GCP.TMP/]
08800				FI
08900			ELSE
09000					;Create a file if not already present
09100	
09200				ENTER	QCHGCP,X0
09300				GOTO	L2
09400				CLOSE	QCHGCP,
09500				LOOKUP	QCHGCP,X0
09600				SKIPA
09700				GOTO	L1
09800				SETON	SAGCPE(XLOW)
09900				OUTSTR	[ASCIZ	/LOOKUP error GCP.TMP/]
10000			FI
10100		ELSE
10200			SETON	SAGCPE(XLOW)
10300			OUTSTR	[ASCIZ	/OPEN error GCP.TMP/]
10400		FI
10500	
10600		;Initialize for dump output on Sysout
10700	
10800		L	X1,YSATOP(XLOW)
10900		ST	X1,YSAIMP(XLOW)		;Local image pointer
11000		HRLZI	X0,^D72
11100		ST	X0,YSAILC(XLOW)		;ZTVLNG,,ZTVCP
11200		HRLZI	X0,QZTE
11300		ST	X0,(X1)			;ZDN word for a text record
11400						; placed at the bottom of the pool
11500		LI	X0,^D17
11600		ADDM	X0,YSATOP(XLOW)
11700		ADDM	X0,YSABOT(XLOW)		;Let Image be outside the pool
11800		HRLI	X0,^D72
11900		ST	X0,1(X1)		;ZTECLN,,ZTELEN
12000		LI	X0,OFFSET(ZTECHR)(X1)
12100		HRLI	X0,440700		;POINT 7,ZTECHR,
12200		ST	X0,YSAIBP(XLOW)		;Local image byte pointer
12300	
12400		SETON	SWGCT2(XLOW)		;Default is log and dump output
12500						;  on TTY
12600		>
12700	
12800	
12900		;Initialize garbage collection parameters for garbage collection
13000		; limit and step size calculations.
13100	
13200	
13300		SETZM	YSAGCN(XLOW)	;Number of gc:s
13400		SETZM	YSAGCT(XLOW)	;Accumulated GC time
13500	edit(175)	;[175]
13600		L	X1,[%VMSPF]
13700		GETTAB	X1,
13800		SETZ	X1,
13900		HLRZ	X1,X1
14000		ST	X1,YSANWA(XLOW)
14100		L	YRUNTM(XLOW)
14200		ST	YSATIM(XLOW)	;TIM := execution start time
14300		MOVSI	QSAF0
14400		ST	YSAFES(XLOW)	;F^ := F0
14500		MOVSI	QSAR0
14600		ST	YSARES(XLOW)	;R^ := R0
14700		MOVSI	QSAB0
14800		ST	YSABES(XLOW)	;B^ := B0
14900	
15000		IFN QSASTE,<
15100		L	X2,YSABOT(XLOW)
15200		ADDI	X2,QSALIM+QSAPMI
15300		EXEC	SANP1
15400		L	X2,.JBREL
15500		ADDI	X2,QPOLMI
15600		SUB	X2,YSABOT(XLOW)
15700		ST	X2,YSAL(XLOW)	;L := first garb.coll. limit
15800		LI	X2,QSAPMI
15900		ST	X2,YSASTE(XLOW)	;Initialize step size
16000		>
16100	
16200		IFE QSASTE,<
16300		L	X1,.JBREL
16400		SUB	X1,YSABOT(XLOW)
16500		ST	X1,YSAL(XLOW)	;L:=free pool area
16600		>
16700	
16800	
16900		RETURN
17000		EPROC
     
00100		SUBTTL	.SAIN	(initialize ref and array)
00200	
00300	; Purpose:	To initialize any ref and/or array variables in a block.
00400	
00500	; Input:	Prototype address in XSAC, block address in XRAC.
00600	
00700	; Function:	If ZPRMAP(XSAC) =/= 0 and ZMPNRV of the map =/= 0,
00800	;		set the variables to NONE.
00900	
01000	.SAIN:	PROC
01100		SAVE	XSAC
01200		LF	XSAC,ZPRMAP(XSAC)
01300		IF	;Any MAP
01400			JUMPE	XSAC,FALSE
01500		THEN
01600			WLF	XSAC,ZMPNRV(XSAC)
01700			IF	;Any REF or ARRAY variable
01800				JUMPE	XSAC,FALSE
01900			THEN
02000				ADDI	XSAC,(XRAC)
02100				LI	NONE
02200				LOOP
02300					ST	(XSAC)
02400				AS
02500					AOBJN	XSAC,TRUE
02600				SA
02700			FI
02800		FI
02900		RETURN
03000		EPROC
     
00100		SUBTTL	.SANP	(New pool)
00200	
00300		Comment;
00400	
00500	Purpose:	To determine a new g.c. limit  and
00600			 IFN QSASTE,< a new optimal step size and>
00700			make a core request for low. seg area needed
00800	
00900	Function:	New g.c. limit  (L) :=
01000			IFN QSASTE,<:= F^ [ 1 + SQRT( 2B^ R^ ( 1 + A/F^ )]>
01100			IFE QSASTE,<:= F^ [ 1 + SQRT( 1B^ R^ ( 1 + A/F^ )]>
01200	
01300			L := Min (L,CORMAX limit)
01400	
01500			where
01600			F^ = YSAFES =	active memory
01700			R^ = YSARES =	allocation rate
01800			B^ = YSABES =	garbage collection cost
01900			A  = YSAA   =	accounting dependent parameter
02000	
02100			IFN QSASTE,<
02200	
02300			New step size  YSASTE :=
02400	
02500				     K     4A/W - U*U
02600			SQRT ( R^ * --- [ ------------ + (X+U) ] )
02700				     2        X + U
02800	
02900	
03000			where expressed in pages and seconds:
03100	
03200			R^ = YSARES = allocation rate   [pages/sec.]
03300			K  = time for a CORE UUO  approx.= 0.004  [sec.]
03400			X  = C0 + C1	[pages]
03500			C0 = YSATOP + YSAHSZ   [pages]
03600			C1 = YSABOT + YSAL + YSAHSZ   [pages]
03700			A, W and U are constants that can be evaluated from the
03800			 accounting  algorithm written on the form:
03900	
04000				TIME * [ A + W(M+U)*M]
04100	
04200			where M is the total number of 512 word pages allocated
04300			 to the job.
04400	
04500			>	END IFN QSASTE,
04600	
04700	
04800		========= N O T E  !!!!!!!!!!!!!!!!!!   =====================
04900		 the calculation of A = YSAA should be changed in the code
05000		 as soon as the accounting algorithm is changed to
05100		 minimize the cost of SIMULA program executions.
05200	
05300		 if QSASTE = 1 the calculation of the step size
05400		 must also be changed.
05500		=============================================================
05600	
05700	
05800	Entries:	.SANP, SANP1, SANP2
05900			.SANP is the main entry after each gc
06000			SANP1 is the entry point to set the storage pool
06100				to the initial value and allocate core
06200			SANP2 is the entry to set the pool to the initial
06300				value if enough core already allocated
06400	
06500	Input arguments: At entry to SANP1 X0 should contain the low segment
06600			 area needed
06700	
06800	Normal exit:	RETURN
06900	
07000	Call format:	EXEC	.SANP
07100			EXEC	SANP1
07200			EXEC	SANP2
07300	
07400	Used local subroutines:	SANPSQ, SANPDU
07500	
07600		;
07700	
07800	
07900	
08000	
08100		DEFINE	NEWEST(P,XREG)	<
08200	
08300		;;Compute a new estimate by exponential smoothing of parameter P
08400		;; into register XREG and store the result in YSA'P'ES(XLOW)
08500		;; it is assumed that X0 contains the observed value of P
08600	
08700	 	;; P^ := (P + LP * P^)/(1 + LP) = (P + LP*P^)/L1P
08800		;; where
08900		;; P^ = YSA'P'ES
09000		;; LP = QSAL'P
09100		;; L1P= QSAL1'P = QSAL'P + 1
09200	
09300		L	XREG,YSA'P'ES(XLOW)
09400		FMPRI	XREG,QSAL'P
09500		FADR	XREG,X0
09600		FDVRI	XREG,QSAL1'P
09700		ST	XREG,YSA'P'ES(XLOW)
09800		>
09900	
     
00100		SUBTTL	SANPSQ
00200	
00300		Comment;
00400	
00500	Purpose:	Floating point single precision square root function
00600	
00700	Function:	The square root of the arg. in X1 is calculated.
00800			The arg. is written in the form
00900			arg. = frac * (2**2b)
01000			where 0 < frac < 1
01100			Sqrt(arg.) is then calculated as
01200			Sqrt(frac) * (2**b)
01300			Sqrt(frac) is calculated by a linear approximation, the nature
01400			of which depends on whether 1/4 < frac < 1/2 or 1/2 < frac < 1
01500			followed by two iterations of Newton's method.
01600	
01700	Entry:		SANPSQ
01800	
01900	Input arguments: X1  contains the input arguments
02000	
02100	Normal exit:	RETURN
02200	
02300	Output arguments: X0 contains the result
02400	
02500	Call format:	EXEC	SANPSQ
02600	
02700		;
02800	
02900	
03000	
03100	
03200	SANPSQ:	PROC
03300					;X0:=SQRT(X1)
03400		SETZ	X0
03500		JUMPE	X1,L9		;X1 = 0
03700		LSHC	X0,^D9		;Get exp. to X0
03800		SUBI	X0,201		;Get true exp. -1
03900		ROT	X0,-1		;Divide by 2 and
04000					; if true exp. even the sign bit in X0
04100					; will be set
04200		HRRM	X0,X3		;And store for FSC instr.
04300		LSH	X1,-^D9		;Restore fraction in X1
04400		IF 	;True exp is odd
04500			JUMPL	X0,FALSE
04600		THEN
04900			FSC	X1,177		;Halve and scale fraction
05000			ST	X1,X4		;Now .25 <= X1 <  .5
05100			FMPRI	X1,200640	;Compute approx1
05200			FADRI	X1,177465
05300		ELSE	;Even true exp
05600			FSC	X1,200		;Scale fraction
05700			ST	X1,X4		;Now .5 <= X1 < 1
05800			FMPRI	X1,200450	;Compute approx1
05900			FADRI	X1,177660
06000		FI
06200		L	X0,X4		;1:st iteration of Newton
06300		FDV	X0,X1		;frac/approx1
06400		FAD	X1,X0		;approx1 + frac/approx1
06500		FSC	X1,-1		;Halve
06600		L	X0,X4		;2:nd iteration of Newton
06700		FDV	X0,X1		;frac/approx2
06800		FADR	X0,X1		;approx2 + frac/approx2
06900		FSC	X0,(X3)		;Halve and scale
07000	L9():!	RETURN			;Result in X0
07100	
07200	
07300		EPROC
     
00100		SUBTTL	SANPDU
00200	
00300		Comment;
00400	
00500	Purpose:	To dump GC parameter values on GCP.TMP
00600	
00700	Function:	If debug version and if SAGCPE is off (i.e. GCP.TMP
00800			is ready to receive output data) the GC parameters are
00900			moved with a BLT to the out buffer and written on the
01000			file GCP.TMP when the buffer is filled.
01100	
01200	Entry:		SANPDU
01300	
01400	Normal exit:	RETURN
01500	
01600	Call format:	EXEC	SANPDU
01700	
01800		;
01900	
02000	
02100	
02200		IFN QDEBUG,<
02300	SANPDU:	PROC
02400		SETLOW(X16)
02500		IFON	SAGCPE(XLOW)
02600		RETURN
02700	
02800		WHILE
02900			L	X1,YSABH(XLOW)
03000			LF	X2,ZBHCNT(X1)		;Byte counter
03100			SUBI	X2,YSAEND-YSASTA
03200			JUMPGE	X2,FALSE
03300		DO
03400			IF
03500				OUT	QCHGCP,
03600				GOTO	FALSE
03700			THEN
03800				SETON	SAGCPE(XLOW)
03900				OUTSTR	[ASCIZ	/OUT error GCP.TMP/]
04000				RETURN
04100			FI
04200		OD
04300		SF	X2,ZBHCNT(X1)	;Byte counter
04400		LF	X2,ZBHBUP(X1)	;Byte pointer
04500		LI	X3,1(X2)	;First free data word in buffer
04600		HRRI	X2,YSAEND-YSASTA(X2) ;Next pointer value
04700		SF	X2,ZBHBUP(X1)
04800		HRLI	X3,YSASTA(XLOW)
04900		BLT	X3,(X2)
05000		RETURN
05100	
05200		EPROC
05300		>
     
00100		SUBTTL	SANP1
00200	
00300		Comment;
00400	
00500	Purpose:	To make a core request for the low seg area needed
00600			in version with step allocation (QSASTE=1)
00700	
00800	Function:	After the core request, if QZERO is non-zero
00900			the new core is zeroed.
01000			A new limit for the object pool is determined
01100	
01200	Entry:		SANP1
01300	
01400	Input arguments:	X2 contains the number of words needed in low segment
01500	
01600	Output arguments:	X2 contains maximum number of 1K core blocks
01700				available to the user
01800	
01900	Normal exit:	RETURN
02000	
02100	Error exit:	SAERR 1,Cannot get enough core for object pool
02200	
02300	Call format:	EXEC	SANP1
02400	
02500		;
02600	
02700	
02800	
02900		IFN QSASTE,<
03000	
03100	SANP1:	PROC
03200		SETLOW(X16)
03300	IFN QZERO,<L	X1,.JBREL>
03400		IF
03500			CORE	X2,
03600			GOTO	FALSE
03700		THEN
03800		ELSE
03900			;CORE failed, COREMAX in X2 (Kwords)
04000	
04100	edit(175)	;[175]
04200			IF	;Virtual core limits are found
04300				L	X1,[-1,,.GTCVL]
04400				GETTAB	X1,
04500				GOTO	FALSE
04600			THEN	;NOTE!! Not quite correct!!
04700				LSH	X1,-1	;Get phys guideline Kwords
04800				ANDI	X1,3777	;Delete rubbish from GETTAB
04900				CAMG	X1,X2
05000				 SUBI	X2,1	;Going virtual:subtract space
05100						; of PFH
05200			IFN QZERO,<
05300			ELSE
05400				L	X1,.JBREL
05500			>
05600			FI
05700			LSH	X2,^D10		;Pages to words
05800			SUB	X2,YSAHSZ(XLOW)
05900			edit(276)	;Do not go beyond hiseg start
06000			CAILE	X2,377777	;[276]
06100			 LI	X2,377777	;[276]
06200	
06300			CAMG	X2,.JBREL
06400			 L	X2,.JBREL	;If more core already allocated in ph2
06500						; (The truncated P if COREMAX = an odd
06600						; number of pages)
06700	
06800			CORE	X2,
06900			SAERR	1,Cannot get enough core for object pool
07000		FI
07100	
07200			edit(65)
07300		IFN QZERO,<;[65]
07400			;Zero new core
07500		IF	;Expanded
07600			CAML	X1,.JBREL
07700			GOTO	FALSE
07800		THEN
07900			SETZM	(X1)
08000			HRL	X1,X1
08100			ADDI	X1,1
08200			BLT	X1,@.JBREL
08300		FI
08400		>
08500	
08600	
08700			;Set new limit for object pool
08800		L	X1,.JBREL
08900		HRRM	X1,.JBFF
09000		SUBI	X1,QSALIM
09100		ST	X1,YSALIM(XLOW)
09200	
09300		RETURN
09400	
09500		EPROC
09600	
09700		>	;END IFN QSASTE,
     
00100		SUBTTL	.SANP	(New pool)
00200	.SANP:
00300		PROC
00400		LOWADR(X16)
00500		L	XCB,XCB+YSASAV(XLOW)	;Restore XCB for SIMDDT
00600						; if error occurs
00700	Comment;  Check  if  .SAGC called just to move the pool upwards, then
00800	        the upper limit is increased with the amount in  YSAREL(XLOW)
00900	        and  this garbage collection is not considered to determine a
01000		new dynamic pool area.;
01100		edit(175)
01200	;[175]	X6 holds TAUGC (time for this gc) on entry.
01300	
01400		IF	;Pool is to be moved upwards
01500			SKIPN	YSAREL(XLOW)
01600			GOTO	FALSE
01700		THEN
01800			FIX	X0,YSATAU(XLOW)	;Set YSATIM to look as if no
01900			SUBM	X0,YSATIM(XLOW) ; garb. coll. had occurred
02000			IFN QSASTE,<
02100			L	X2,YSATOP(XLOW)
02200			ADDI	X2,QSALIM+QSAPMI
02300			CAMLE	X2,.JBREL
02400			 BRANCH	SANP1
02500			RETURN
02600			>
02700	
02800			IFE QSASTE,<
02900			L	X0,.JBREL
03000			ADD	X0,YSAREL(XLOW)
03100			BRANCH	SANP1		;Make a core request and return
03200			>
03300	
03400		FI
03500	;[175]
03600	TSWAP=^D20	;Time for page swap in ms
03700		IF
03800			SKIPN	.JBPFH		;Page fault handler present
03900			 GOTO	FALSE
04000			L	X1,[%VMSPF] 	;Get system page
04100			GETTAB	X1,		; fault counts
04200			 GOTO	FALSE
04300			HLRZ	X1,X1		; Not In Working set
04400			L	X0,X1
04500			SUB	X1,YSANWA(XLOW)	;ng := this count
04600						; - count at SAGC start
04700			ST	X0,YSANWA(XLOW)	;Save current count
04800			ADDM	X1,YSANWC(XLOW)	;Accumulated count in GC
04900			JUMPE	X1,FALSE
05000		THEN	;Use virtual core algorithm
05100			;Determine overheads from gc parameters
05200			L	X0,YSANWB(XLOW) ;NIW count since last gc (nb)
05300			ADD	X1,X1		; (2 * ng
05400			ADD	X1,X0		; + nb
05500			IMULI	X1,TSWAP	; * tswap)
05600			SUB	X1,X6		; - taugc
05700			LI	X2,2K		; Add 2K if negative,
05800			SKIPL	X1
05900			 MOVN	X2,X2		; Subtract if positive
06000			ADDB	X2,YSAL(XLOW)	; New YSAL value
06100			edit(276)
06200			L	X1,X2		;[276]
06300			ADD	X2,YSABOT(XLOW) ;[276]
06400			IF	;[276] YSAL would be too big for low seg
06500				CAIG	X2,377777-QSALIM
06600				GOTO	FALSE
06700			THEN	;Make it just small enough
06800				LI	X1,377777-QSALIM
06900				SUB	X1,YSABOT(XLOW)
07000				ST	X1,YSAL(XLOW)
07100			FI	;[276]
07200			L	X2,YSATOP(XLOW)
07300			ADD	X2,X0+YSASAV(XLOW)
07400			CAMG	X2,X1
07500			 L	X2,X1
07600			BRANCH	CHECK
07700		FI
07800	
07900	
08000		;Compute all parameters needed for the calculation of a new
08100		; g.c. limit and a new step size.
08200	
08300	
08400		;F^
08500		; X0 := F = active memory in pool = YSATOP - YSABOT + X0(saved)
08600	
08700		L	X0,YSATOP(XLOW)
08800		ADD	X0,X0+YSASAV(XLOW)
08900	
09000	
09100		IFN QPROTE,<;Assemble this code if a fixed pool should be allocated
09200			ADDI	X0,1000		;Add at least 1P free pool area
09300			;Expand pool only if necessary
09400			IFN QSASTE,<
09500			L	X2,X0
09600			CAMLE	X2,YSALIM(XLOW)
09700			 EXEC	SANP1	;Ask for more core
09800			RETURN		;Pool area unchanged
09900			>
10000	
10100			IFE QSASTE,<
10200			CAMLE	X0,YSALIM(XLOW)
10300			GOTO	SANP1	;Ask for more core and return
10400			>
10500	
10600		>
10700	
10800		SUB	X0,YSABOT(XLOW)
10900		FLTR	X0,X0
11000		NEWEST	(F,X3)		;X3 := F^
11100	
11200	
11300	
11400		;R^
11500		; X0 := R = YSAR
11600	
11700		L	X0,YSAR(XLOW)
11800		NEWEST	(R,X5)		;X5 := R^
11900	
12000		;B^
12100		; X0 := B = TAUGC/F^ = X6/X3
12200	
12300		IF
12400			JUMPE	X6,FALSE	;B^ unchanged if TAUGC = 0
12500		THEN
12600			FLTR	X0,X6
12700			FDVR	X0,X3
12800			NEWEST	(B,X6)		;X6 := B^
12900		ELSE
13000			L	X6,YSABES(XLOW)
13100		FI
13200	
13300		;A
13400		;================== N O T E   !!!!!!!!!!!!!!  ========================;
13500		;== This code should be changed if the accounting algorithm is changed;
13600		;=====================================================================;
13700		COMMENT;
13800	
13900		A(L+Q) = K(L+Q)/K'(L+Q) - L
14000	
14100		where
14200		L = mean storage pool area = (YSAL + YSABOT +YSATOP)/2
14300		Q = memory in high segment + low segment area - L
14400		  = YSAHSZ  +  YSABOT
14500	
14600		K(r) is the cpu time dependent part of the accounting algorithm
14700			with R = L+Q = number of active pages in core
14800	
14900	!!!!!!! Presently used K(R) = (1.1 + 0.005 R (R + 20)/50)
15000	
15100		where
15200	
15300		K'(R) =  0.0002(R + 10)
15400	
15500		A = ( 1.1 + 0.0001( (L+Q+10)**2 - 100 ))) / 0.0002(L+Q+10) - L
15600	
15700		  = 5450/(L+Q+10) + 5 + (Q-L)/2  pages
15800	
15900		where A, L and Q are expressed in number of pages
16000	
16100		Expressed in words we will get:
16200	
16300		A = (5450/((L+Q)/512 +10) + 5 + (Q-L)/(2*512) ) * 512
16400	
16500		  = 14.3E8/(Q+L+5120) + 2560 + (Q-L)/2   words
16600	
16700		;
16800	
16900		L	X0,YSAHSZ(XLOW)	;Q
17000		ADD	X0,YSABOT(XLOW)
17100		L	X2,X0
17200		L	X1,YSAL(XLOW)	;YSAL + YSATOP -YSABOT
17300		ADD	X1,YSATOP(XLOW)
17400		SUB	X1,YSABOT(XLOW)
17500		ASH	X1,-1		; / 2
17600		ST	X1,YSASTE(XLOW)	; =: L
17700		ADD	X0,X1		; (R:=) L + Q
17800		ADDI	X0,^D5120	; + 5120
17900		FLTR	X0,X0
18000		MOVSI	X1,14.3E8_-^D18
18100		FDVR	X1,X0
18200		FADRI	X1,(2560.0)
18300		SUB	X2,YSASTE(XLOW)
18400		ASH	X2,-1
18500		FLTR	X2,X2
18600		FADR	X1,X2
18700		ST	X1,YSAA(XLOW)		;X1 := A
18800	
18900		;=====================================================================;
19000	
19100	
19200		;L
19300		; IFN QSASTE,<
19400		; L := F^ ( 1 + SQRT( 2*B^ R^ (1 + A/F^))
19500		; L := X3 ( 1 + SQRT( 2*X6 X5 (1 +X1/X3))
19600		; >
19700	
19800		; IFE QSASTE,<
19900		; L := F^ ( 1 + SQRT( 1*B^ R^ (1 + A/F^))
20000		; L := X3 ( 1 + SQRT( 1*X6 X5 (1 +X1/X3))
20100		; >
20200	
20300	
20400		FDVR	X1,X3
20500		FADRI	X1,(1.0)
20600		FMPR	X1,X5
20700		FMPR	X1,X6
20800	
20900		IFN QSASTE,<
21000		FMPRI	X1,(2.0)
21100		>
21200	
21300		IF
21400			JUMPLE	X1,FALSE	;Neg or zero arg to SQRT
21500		THEN
21600			EXEC	SANPSQ		;X0 := SQRT(X1)
21700			FADRI	X0,(1.0)
21800			FMPR	X0,X3		;X0 := L
21900			FIX	X0,X0
22000	edit(175)	;[175]
22100			L	X1,[-1,,.GTCVL]
22200			GETTAB	X1,
22300			 LI	X1,400
22400			LSH	X1,^D9
22500			LI	X1,QPOLMI(X1)
22600			SUB	X1,YSAHSZ(XLOW)
22700			CAML	X1,X0
22800		;!Preceding line may skip to ELSE branch; put nothing here!
22900		ELSE
23000			FIX	X0,X3
23100			ADDI	X0,QPOLMI	;Add at least QPOLMI free pool
23200	;[175]
23300			CAML	X1,X0
23400			 L	X0,X1	; To avoid going too much virtual
23500		FI
23600	
23700		IFN	QDEBUG,<FIX	X0,X3		;******TEMPORARY DURING TEST
23800				ADDI	X0,20000>
23900		IFN QSASTE,<
24000		edit(276)	;[276]
24100		 MOVN	X1,YSABOT(XLOW)
24200		CAILE	X0,377777-QSALIM(X1)
24300		 LI	X0,377777-QSALIM(X1)
24400		ST	X0,YSAL(XLOW)	;Set limit for next garb.coll.
24500		>
24600	
24700		IFN QSASTE,<
24800	;=============================================================================
24900	;	N O T E  !!!!!!!!!!!!!!!!! Code to compute an optimal step size
25000	;	should be changed if the accounting algorithm is changed
25100	;=============================================================================
25200	Comment;
25300	
25400			New step size  YSASTE :=
25500	
25600				     K     4A/W - U*U
25700			SQRT ( R^ * --- [ ------------ + (X+U) ] )
25800				     2        X + U
25900	
26000	
26100			where expressed in pages and seconds:
26200	
26300			R^ = YSARES = allocation rate   [pages/sec.]
26400			K  = time for a CORE UUO  approx.= 0.004  [sec.]
26500			X  = C0 + C1	[pages]
26600			C0 = YSATOP + YSAHSZ   [pages]
26700			C1 = YSABOT + YSAL + YSAHSZ   [pages]
26800			A, W and U are constants that can be evaluated from the
26900			 accounting  algorithm written on the form:
27000	
27100				TIME * [ A + W(M+U)*M]
27200	
27300			where M is the total number of 512 word pages allocated
27400			 to the job.
27500	
27600	
27700		Currently at our installation we have:
27800	
27900		TIME * [ 1.1 + 0.0001(M+20)*M ]
28000	
28100		thus
28200		A = 1.1    [1/sec.]
28300		W = 0.0001   [1/sec. * 1/pages*pages]
28400		U = 20       [pages]
28500	
28600	
28700		Expressed in words and milliseconds we will get:
28800	
28900	
29000		A = 1.1 * 10^-3	[1/ms.]
29100		W = 0.0001 * 10^-3 * 512^2	[1/ms. * 1/words^2]
29200		U = 20 * 512 		[words]
29300	
29400	Step size := SQRT( R * 2 [( 1.143E10 / (X + 10240)) +X+10240])
29500	
29600		;
29700	
29800		L	X1,YSAL(XLOW)
29900		ADD	X1,YSABOT(XLOW)
30000		ADD	X1,YSATOP(XLOW)
30100		ADD	X1,YSAHSZ(XLOW)
30200		ADD	X1,YSAHSZ(XLOW)
30300		FLTR	X1,X1
30400		MOVSI	X2,1.143E10_-^D18
30500		L	X3,X1
30600		FADRI	X3,(10240.0)
30700		FDVR	X2,X3
30800		FADR	X3,X2
30900		L	X1,X3
31000		FMPR	X1,YSARES(XLOW)
31100		FMPRI	X1,(2.0)
31200		EXEC	SANPSQ
31300		FIX	X0,X0
31400		CAIGE	X0,QSAPMI
31500		 LI	X0,QSAPMI
31600		ST	X0,YSASTE(XLOW)
31700	
31800	;===========================================================================
31900	
32000	
32100		L	X2,YSATOP(XLOW)
32200		ADD	X2,X0+YSASAV(XLOW)	;Min low seg to continue exec
32300		ADD	X2,YSASTE(XLOW)		;Add a step free pool
32400	;[175]
32500	CHECK:
32600		EXEC	SANP1
32700	
32800			;If YSAL (g.c. limit) greater than allowed by CORMAX
32900			; limit, set YSAL to the maximal value obtained by the
33000			; return argument from the CORE UUO (X2=CORMAX
33100			; in number of K words).
33200	
33300		LSH	X2,^D10
33400		SUB	X2,YSAHSZ(XLOW)
33500		SUB	X2,YSABOT(XLOW)
33600		CAMGE	X2,YSAL(XLOW)
33700		 ST	X2,YSAL(XLOW)
33800		>
33900	
34000		IFE QSASTE,<
34100	
34200		ADD	X0,YSABOT(XLOW)
34300	
34400	
34500	
34600	
34700	SANP1:		;Entry at storage pool initialization
34800		L	X1,.JBREL
34900		SUB	X1,X0
35000		MOVM	X1,X1
35100		IF
35200			CAIG	X1,QSALMI
35300			GOTO	FALSE
35400		THEN
35500			;The low seg. area needed has changed more than QSALMI
35600			; Make a core request for Min(X0,CORMAX - highseg.)
35700	
35800			IF
35900				L	X2,.JBREL
36000				CORE	X0,
36100				GOTO	FALSE
36200			THEN
36300			ELSE
36400				;CORE failed, CORMAX in X0 (in K words)
36500				LSH	X0,^D10		;Convert CORMAX to words
36600				SUB	X0,YSAHSZ(XLOW)	;Set X0 to CORMAX - high seg length
36700							; and try again
36800				CAMG	X0,.JBREL
36900				L	X0,.JBREL	;Get the truncated P
37000							; if CORMAX odd
37100				IF
37200					CORE	X0,
37300					GOTO	FALSE
37400				THEN
37500				ELSE
37600					L	XCB,XCB+YSASAV(XLOW)	;Restore XCB
37700					SAERR	1,Cannot get enough core for object pool
37800				FI
37900			FI
38000			IFN QZERO,<;[65]
38100			IF
38200				;Zero new core if expanded
38300				CAML	X2,.JBREL
38400				GOTO	FALSE
38500			THEN
38600				SETZM	(X2)
38700				HRL	X2,X2
38800				ADDI	X2,1
38900				BLT	X2,@.JBREL	;Just for sure
39000			FI
39100			>
39200		FI
39300	
39400			;Set .JBFF, YSALIM and YSAL and dump GC parameters if
39500			; debug version
39600	
39700	SANP2:			;Entry at storage pool initialization if enough
39800				; core already allocated
39900		L	X1,.JBREL
40000		HRRM	X1,.JBFF
40100		SUBI	X1,QSALIM
40200		ST	X1,YSALIM(XLOW)
40300		SUB	X1,YSABOT(XLOW)
40400		ST	X1,YSAL(XLOW)
40500		>	;END IFE QSASTE
40600	
40700		IFN QDEBUG,<
40800			EXEC	SANPDU
40900		>
41000	
41100		RETURN
41200	
41300		EPROC
     
00100		IFN QDEBUG,<			;Reserve patch area
00200	SAPATCH:	BLOCK	100
00300				>
     
00100		SUBTTL	LITERALS
00200	
00300		LIT
00400		END