%routine ACTIVE MEM(%record (PARMF) %name P)
!***********************************************************************
!*    CONTROLS THE ALLOCATION OF ACTIVE MEMORY                         *
!*    ACTIVITY 0  INITIALISE                                           *
!*    ACTIVITY 1  GET AMT FOR SPECIFIED DISC ADDRESSS                  *
!*    ACTIVITY 2  RETURN AMT FOR DITTO                                 *
!*    ACTIVITY 3  COMPLETE RETURN OF AMT AFTER TRANSFER COMPLETED      *
!*    ACTIVITY 4  ORGANISE TIMEOUT OF ACTIVE MEM                       *
!*    ACTIVITY 5 CHECK IF DISC ADDRESS IS STILL ACTIVE                 *
!***********************************************************************
%routinespec COLLECT DD GARBAGE
%routinespec APPENDAMTA(%integer NEWSPACE,REALAD)
%routinespec APPENDAMTDD(%integer NEWSPACE,REALAD)
%routinespec DDASLALLOC(%integer FROM,TO)
%routinespec DEALLOCAMT
%routinespec DEALLOCDD(%integer DDX,LEN)
%integer HASH,DDX,GARB,AMTX,SRCE,ID,DA,LEN,MASK,REALAD,FREEMAX,I,J,K,CN
%integer DACT,LIM
      %if MONLEVEL&12=12 %thenstart
      %integer IT,IC
      %finish
%record (PROCF) %name PROC
%record (PARMF) Q
%ownshortintegerarray AMTHASH(0:511)=0(512)
%record (AMTF) %name AMT
      %if XA=YES %thenstart
      %ownintegerarrayname AMTAPT,AMTDDPT
      %finishelsestart
      %ownshortintegerarrayname AMTAPT,AMTDDPT
      %finish
%owninteger AMTASIZE,AMTASL,AMTANEXT=0
%owninteger AMTDDSIZE,AMTDDNEXT=0
%ownintegerarray DDASL(1:MAXBLOCK)=0(MAXBLOCK)
%switch ACT(0:6)
      %if MONLEVEL&2#0 %and KMON&1<<8#0 %then PKMONREC("ACTIVEMEM:",P)
      SRCE=P_SRCE
      ID=P_P1
      %if MULTIOCP=YES %thenstart
         *BALR_1,0; *USING_1
         *SR_0,0; *LR_2,0; *BCTR_2,0
         *CS_2,0,STORESEMA
         *BC_8,<SSEMAGOT>
         *DROP_1
         SEMALOOP(STORESEMA,0)
SSEMAGOT:
      %finish
      DACT=P_DEST&X'F'
      ->ACT(DACT)
ACT(0):                                 ! INITIALISE
      %if MULTIOCP=YES %start; STORESEMA=-1; %finish
      REALAD=NEW EPAGE
      LIM=MAXAMTAK//64
      I=(LIM+1)*64;                     ! PT SIZE WORST CASE
      %if XA=YES %start
         SEGTAB(AMTASEG)=REALAD!X'80'!LIM; ! COMMON BIT SET
      %else
         SEGTAB(AMTASEG)=LIM<<28!REALAD
      %finish
!
! SET UP PUBLIC SEGMENT 'AMTASEG' FOR AMTA RECORD ARRAY WITH
! PAGE TABLE FOR IT AT BEGINNING OF FIRST EPAGE OF ITSELF
!
      AMTAPT==ARRAY(AMTASEG<<SSHIFT,PTF)
      APPENDAMTA(PAGESIZE-I,REALAD)
      REALAD=NEW EPAGE
      LIM=MAXAMTDDK//64
      I=(LIM+1)*64
!
! PUBLIC SEGMENT 'AMTDDSEG' FOR AMTDD ARRAY WITH
! PAGE TABLE FOR IT AT BEGINNING OF FIRST EPAGE OF ITSELF
!
      %if XA=YES %start
         SEGTAB(AMTDDSEG)=LIM!X'80'!REALAD
      %else
         SEGTAB(AMTDDSEG)=LIM<<28!REALAD
      %finish
      AMTDDPT==ARRAY(AMTDDSEG<<SSHIFT,PTF)
      APPENDAMTDD(PAGESIZE-I,REALAD)
      %return
ACT(1):                                 ! GET AMTX
      DA=P_P2
      LEN=P_P3&(MAXBLOCK-1)+1
      MASK=P_P3;                        ! "NEW" EPAGE BIT MASK (TOP BITS)
      *SR_0,0; *L_1,DA; *LA_2,509; *DR_0,2; *ST_0,HASH
      AMTX=AMTHASH(HASH)
      %while AMTX#0 %cycle;             ! SCAN DOWN LIST
         AMT==AMTA(AMTX)
         %if AMT_DA=DA %thenstart;      ! THIS DA ALREADY IN TABLE
            %if AMT_LEN#LEN %thenstart
               %if AMT_USERS#0 %then AMTX=-3 %and ->RETURN
               %if AMT_LEN<LEN %then AMTX=0 %and ->RETURN; ! EXTEND ?
               %cycle I=AMT_DDP+LEN,1,AMT_DDP+AMT_LEN-1
                                        ! RETURN IF STILL IN USE
                  %if AMTDD(I)&STXMASK#STXMASK %then AMTX=0 %and ->RETURN
               %repeat
               DEALLOCDD(AMT_DDP+LEN,AMT_LEN-LEN)
               AMT_LEN=LEN
            %finish
            %if AMT_USERS=0 %and AMT_OUTS>0 %start
               %cycle I=AMT_DDP,1,AMT_DDP+LEN-1
                  %if AMTDD(I)&NEWEPBIT#0 %then AMTX=-4 %and ->RETURN
               %repeat
            %finish
            AMT_USERS=AMT_USERS+1;      ! USERS
            ->RETURN
         %finish
         AMTX=AMT_LINK
      %repeat
      %if AMTASL=0 %thenstart;          ! NO AMT CELLS FREE
                                        ! TRY TO APPEND EPAGE TO AMTA
         AMTX=-1
         %if AMTANEXT>=MAXAMTAK %then ->RETURN; ! ALREADY MAX SIZE
         REALAD=NEW EPAGE
         %if REALAD<=0 %then ->RETURN;  ! NO FREE EPAGE
         APPENDAMTA(PAGESIZE,REALAD)
      %finish
                                        ! ALLOCATE NEW SPACE
      GARB=0;                           ! NOT GARBAGE COLLECTED YET
      %cycle
         %if DDASL(LEN)#0 %thenstart
            DDX=DDASL(LEN)
            DDASL(LEN)=AMTDD(DDX)
            ->SETAMT
         %finish
                                        ! TAKE SPACE FROM A BIGGER HOLE
         I=LEN+1
         %while I<=MAXBLOCK %cycle
            DDX=DDASL(I)
            %if DDX#0 %thenstart
               DDASL(I)=AMTDD(DDX)
               AMTDD(DDX+LEN)=DDASL(I-LEN)
               DDASL(I-LEN)=DDX+LEN
               ->SETAMT
            %finish
            I=I+1
         %repeat
                                        ! NO HOLES BIG ENOUGH
         %if GARB#0 %then AMTX=-2 %and ->RETURN; ! STILL NOT ENOUGH SPACE
         COLLECT DD GARBAGE
                                        ! TRY TO APPEND EPAGE TO AMTDD
         %if FREEMAX<32 %and AMTDDNEXT<MAXAMTDDK %start
            REALAD=NEW EPAGE
            %if REALAD>0 %then APPENDAMTDD(PAGESIZE,REALAD)
         %finish
      %repeat
SETAMT:                                 ! PUSHDOWN NEW AMT CELL
      AMTX=AMTASL
      AMT==AMTA(AMTX)
      AMTASL=AMT_LINK
      AMT_DA=DA
      AMT_DDP=DDX
      AMT_USERS=1
      AMT_LEN=LEN
      AMT_OUTS=0
      AMT_LINK=AMTHASH(HASH)
      AMTHASH(HASH)=AMTX
      %cycle I=DDX,1,DDX+LEN-1
         AMTDD(I)<-MASK>>31<<15!STXMASK
      %repeat
RETURN:
      P_P1=ID
      P_P2=AMTX
      %if MULTIOCP=YES %start; STORESEMA=-1; %finish
      %if SRCE>0 %then P_DEST=SRCE %and P_SRCE=X'80001' %and PON(P)
      %return
ACT(2):                                 ! RETURN AMTX IN P_P2
                                        ! P_P3=0 FILE KEPT #0 DESTROY
%begin
%integerarray CLEARS(0:MAXBLOCK)
      AMTX=P_P2
      AMT==AMTA(AMTX)
      %if AMT_DA=X'FF000000' %or AMT_DA=0 %then OPMESS("RETURNED AMT??")
      CN=0;                             ! NO CLEARS AS YET
      %if P_P3=0 %thenstart;            ! FILE BEING KEPT
         %cycle I=AMT_DDP,1,AMT_DDP+AMT_LEN-1; ! CHECK "NEW" EPAGE BIT
                                        ! "NEW" SECTIONS NEVER SHARED
            %if AMTDD(I)&NEWEPBIT#0 %thenstart
               CLEARS(CN)=AMTX<<16!(I-AMT_DDP)
               CN=CN+1
               AMT_OUTS=AMT_OUTS+1
            %finish
         %repeat
      %finish
      AMT_USERS=AMT_USERS-1
!
! NOW IF THERE WERE ANY CLEARS SET THEM OFF. THIS IS DONE LATER
! SO THAT THE STORE SEMA CAN BE FREE ON DUALS. IMPORTANT AS IT MAY
! BE NECESSARY TO EXTEND THE PARM ASL IF VERY LARGE NO OF CLEARS
! ARE REQUIRED
!
      P_P6=CN;                          ! SO L-C CAN ACCOUNT FOR CLEARS
      %if CN>0 %start
         DCLEARS=DCLEARS+CN
         %if MULTIOCP=YES %start; STORESEMA=-1; %finish
         Q_DEST=X'40004';               ! ZERO PAGE
         Q_SRCE=X'80080002'
         %cycle I=0,1,CN-1
            Q_P1=CLEARS(I)
            PON(Q);                     ! PON to limit call depth & so
         %repeat;                       ! avoid possible LC stack o'flow
      %finish
%end
      %if CN>0 %thenreturn;             ! SEMA ALREADY RELEASED
                                        ! IF THERE WERE NO CLEARS THEN
                                        ! DROP THROUGH INTO ACT 3
ACT(3):                                 ! RETURN AMTX AFTER TRANFERS END
      AMTX=P_P2
      AMT==AMTA(AMTX)
      %unless AMT_USERS=0 %AND AMT_OUTS=0 %and AMT_DA#X'FF000000' %start
         %if MULTIOCP=YES %start; STORESEMA=-1; %finish
         %return;                       ! AWAIT TRANSFERS
      %finish
      DEALLOCDD(AMT_DDP,AMT_LEN)
      DEALLOCAMT
      %if MULTIOCP=YES %start; STORESEMA=-1; %finish
      %return
ACT(4):                                 ! ENTERED EVERY 10 SECS
      %if MULTIOCP=YES %start; STORESEMA=-1; %finish
                                        ! CODE WAS HERE TO ADJUST RESIDENCES
                                        ! BETWEEN MIN&MAX ACCORDING TO
                                        ! DRUM SATURATION. HARDLY SEEMS WORTH
                                        ! KEEPING THIS TO SAVE AMT SPACE
      RESIDENCES=MAXRESIDENCES
!
! EXAMINE PROCESS LIST EVERY 10 SECS. ALL PROCESSES THAT HAVE
! BEEN INACTIVE FOR MORE THAN 2 MINS ARE TOLD TO DEACTIVATE
! THEIR ACTIVE MEMORY FREEING DRUM & TABLESPACE
!
      P_SRCE=X'80000'
      K=(RESIDENCES-MINRESIDENCES+2)>>1; ! HOW LONG CAN HE HANG ON TO DRUM
                                        ! MAX 7 MIN 1 IN 20 SEC TICKS
      I=1; J=0
      %until J=COM_USERS %or I>MAXPROCS %cycle
         PROC==PROCA(I)
         %if PROC_USER#"" %thenstart
            %if PROC_STATUS&AMTLOST=0 %and K<PROC_ACTIVE<=200 %start
               P_DEST=(I+LOCSN3)<<16;   ! ASYNCH ACT 0
               P_P1=2;                  ! RELEASE ACTIVE MEMORY
               PON(P)
               %exit
            %finish
            J=J+1
         %finish
         I=I+1
      %repeat
      %return
ACT(5):                                 ! CHECK DISC ADDRESS ACTIVE
ACT(6):                                 ! TRAP ! VALIDATE BULKMOVE
      DA=P_P1
      *SR_0,0; *L_1,DA; *LA_2,509; *DR_0,2; *ST_0,HASH
      AMTX=AMTHASH(HASH)
      P_DEST=0
      %while AMTX#0 %cycle
         AMT==AMTA(AMTX)
         %if AMT_DA=DA %thenstart
            %if AMT_OUTS#0 %or (MULTIOCP=YES %and AMT_USERS=0) %then %c
               P_DEST=1 %andexit
                                        ! HAVE BEATEN PONNED DEALOCATE
                                        ! IN MULTIOCP CASE
            P_DEST=-1;                  ! REPORT BACK TO DIRECTOR
            %exit
         %finish
         AMTX=AMT_LINK
      %repeat
      %if MULTIOCP=YES %start; STORESEMA=-1; %finish
      %if DACT=6 %and P_DEST#0 %start;  ! TRAP SPRING
         OPMESS("ACTIVE BM--CALL PDS")
         OPMESS("DA=".STRHEX(DA))
         I=(P_SRCE>>16-LOCSN0)&(MAXPROCS-1)
         OPMESS("USER=".PROCA(I)_USER)
      %finish
      %return
%routine COLLECT DD GARBAGE
!***********************************************************************
!*    GARBAGE COLLECT AMTDD TO COUNTERACT FRAGMENTATION                *
!*    IN DUALS HALT OTHER OCP OR SEMA WILL TIMEOUT !                   *
!***********************************************************************
%integer I
                                        ! CLEAR ALL FREE HOLES TO ZERO
      %if MULTIOCP=YES %and COM_NOCPS>1 %then HALT OTHER OCP
      %cycle I=1,1,MAXBLOCK
         %while DDASL(I)#0 %cycle
            J=DDASL(I)
            DDASL(I)=AMTDD(J)
            AMTDD(J)=0
         %repeat
      %repeat
      FREEMAX=0
      I=AMTDDSIZE+1
ALLOC:%while I>1 %cycle
         I=I-1
         %if AMTDD(I)=0 %thenstart
            DDX=I
            %while I>1 %cycle
               I=I-1
               %if AMTDD(I)#0 %then DDASLALLOC(I+1,DDX) %and ->ALLOC
            %repeat
            DDASLALLOC(1,DDX)
            %exit
         %finish
      %repeat
      GARB=1
      %if MULTIOCP=YES %and COM_NOCPS>1 %then RESTART OTHER OCP(0)
%end
%routine APPENDAMTA(%integer NEWSPACE,REALAD)
!***********************************************************************
!*    APPEND A NEW EPAGE AT "REALAD" TO THE AMT TABLE. ADD THE LAST    *
!*    NEWSPACE BYTES TO THE TABLE. NEWSPACE=EPAGESIZE FOR ALL EPAGES   *
!*    EXCEPT THE FIRST WHICH HOLDS THE PAGETABLE ALSO.                 *
!*    SETTING UP THE FIRST PAGE MUST BE DONE WITHOUT USING THE         *
!*    MAPPED PAGETABLE ARRAY UNTIL THE ZERO ENTRY IS IN PLACE          *
!***********************************************************************
%integer FIRSTNEW,I,J,PTE
      %if XA=YES %then PTE=REALAD %else PTE=REALAD>>12<<4
      %if AMTANEXT=0 %start;            ! FIRST PT ENTRY
         I=RTV(REALAD);                 ! SET A GLOBAL MAPPING
         %if XA=YES %then INTEGER(I)=PTE %else SHORTINTEGER(I)=PTE
         %for J=1,1,MAXAMTAK//4 %cycle
            AMTAPT(J)=-1
         %repeat
      %finishelse AMTAPT(AMTANEXT)=PTE
      AMTANEXT=AMTANEXT+1
      FIRSTNEW=AMTASIZE+1
      AMTASIZE=AMTASIZE+NEWSPACE//AMTFLEN; ! MIGHT WASTE THE ODD RECORD
      %cycle I=FIRSTNEW,1,AMTASIZE-1
         AMTA(I)_LINK=I+1
      %repeat
      AMTA(AMTASIZE)_LINK=AMTASL
      AMTASL=FIRSTNEW
%end
%routine APPENDAMTDD(%integer NEWSPACE,REALAD)
!***********************************************************************
!*    APPEND A NEW EPAGE TO AMTDD. PARAMETERS AS FOR APPENDAMTA        *
!***********************************************************************
%integer FIRSTNEW,I,J,PTE
      %if XA=YES %then PTE=REALAD %else PTE=REALAD>>12<<4
      %if AMTDDNEXT=0 %start;           ! FIRST PT ENTRY
         I=RTV(REALAD);                 ! SET A GLOBAL MAPPING
         %if XA=YES %then INTEGER(I)=PTE %else SHORTINTEGER(I)=PTE
         %for J=1,1,MAXAMTDDK//4 %cycle
            AMTDDPT(J)=-1
         %repeat
      %finishelse AMTAPT(AMTDDNEXT)=PTE
      AMTDDNEXT=AMTDDNEXT+1
      FIRSTNEW=AMTDDSIZE+1
      AMTDDSIZE=AMTDDSIZE+NEWSPACE//DDFLEN
      FREEMAX=0
      DDASLALLOC(FIRSTNEW,AMTDDSIZE)
%end
%routine DDASLALLOC(%integer FROM,TO)
!***********************************************************************
!*    CHOP UP AMTDD (FROM:TO) INTO AS MANY MAXIMUM SIZED BLOCKS        *
!*    AS POSSIBLE AND A LEFTOVER                                       *
!***********************************************************************
%integer LEN
      %cycle
         LEN=TO-FROM+1
         %if LEN>=MAXBLOCK %thenstart
            AMTDD(FROM)=DDASL(MAXBLOCK)
            DDASL(MAXBLOCK)=FROM
            FREEMAX=FREEMAX+1
            FROM=FROM+MAXBLOCK
         %finishelsestart
            %if FROM<=TO %then AMTDD(FROM)=DDASL(LEN) %and DDASL(LEN)=FROM
            %return
         %finish
      %repeat
%end
%routine DEALLOCAMT
!***********************************************************************
!*    DEALLOCATE AMT ENTRY AND RETURN TO FREE LIST. RESETTING THE HASH *
!*    CHAIN IS THE ONLY PROBLEM                                        *
!***********************************************************************
%integer HASH,DA
%record (AMTF) %name AMT
%shortintegername PTR
      AMT==AMTA(AMTX)
      DA=AMT_DA
      AMT_DA=X'FF000000'
      *SR_0,0; *L_1,DA; *LA_2,509; *DR_0,2; *ST_0,HASH
      PTR==AMTHASH(HASH)
      PTR==AMTA(PTR)_LINK %while PTR#AMTX
      PTR=AMT_LINK;                     ! RESET CHAIN OMITTING THIS ENTRY
      AMT_LINK=AMTASL;                  ! RETURN CELL
      AMTASL=AMTX
%end
%routine DEALLOCDD(%integer DDX,LEN)
!***********************************************************************
!*    DEALLOCATE A SECTION OF AMTDD. DIFFICULT IN DUALS AS STORE       *
!*    SEMA IS NEEDED TO CLEAR BACKLINKS                                *
!***********************************************************************
%integer I,J,DTX
      %cycle I=DDX,1,DDX+LEN-1
         J=AMTDD(I)&STXMASK
         AMTDD(I)=0
         %if J#STXMASK %then STORE(J)_FLAGS=0
      %repeat
      I=DDASL(LEN)
      AMTDD(DDX)=I
      DDASL(LEN)=DDX
%end
%end
%endoffile