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