FRE TITLE 'DMSFRE (CMS) VM/370 - RELEASE 6' 00001000
SPACE 2 00002000
*. 00003000
* MODULE NAME: 00010000
* 00011000
* DMSFRE (FREE AND FRET) 00012000
* 00013000
* FUNCTION: 00014000
* 00015000
* MANAGEMENT OF FREE STORAGE. 00016000
* 00017000
* ATTRIBUTES: 00018000
* 00019000
* NUCLEUS RESIDENT, RE-ENTRANT 00020000
* 00021000
* ENTRY POINTS: 00022000
* 00023000
* DMSFREB -- CALLED AS A RESULT OF THE 'DMSFREE' AND 'DMSFRET' 00024000
* MACRO CALLS 00025000
* 00026000
* DMSFREES -- CALLED AS A RESULT OF THE 'SVCFREE' MACRO CALL. 00027000
* 00028000
* DMSFRETS -- CALLED AS A RESULT OF THE 'SVCFRET' MACRO CALL. 00029000
* 00030000
* DMSFREEX -- CALLED AS THE RESULT OF A BALR TO THE ADDRESS IN 00031000
* THE 'NUCON' LOCATION 'AFREE' 00032000
* 00033000
* DMSFRETX -- CALLED AS THE RESULT OF A BALR TO THE ADDRESS IN 00034000
* THE 'NUCON' LOCATION 'AFRET' 00035000
* 00036000
* DMSFRES -- CALLED AS THE RESULT OF EXECUTION OF THE 'DMSFRES' 00037000
* MACRO 00038000
* 00039000
* ENTRY CONDITIONS: 00040000
* 00041000
* DMSFREB -- CODE203 IN NUCON CONTAINS THE HALFWORD CODE 00042000
* COMPUTED BY THE DMSFREE OR DMSFRET MACROS, DEPENDING 00043000
* UPON THE OPTIONS SPECIFIED IN THOSE MACROS. 00044000
* 00045000
* DMSFREES -- R1 POINTS TO A PLIST: 00046000
* DC CL8'SVCFREE' 00047000
* DC A(LENGTH) LENGTH OF REQUESTED BLOCK IN 00048000
* DOUBLEWORDS 00049000
* DC A(0) ADDRESS OF BLOCK, FILLED IN BY 00050000
* THIS ROUTINE 00051000
* 00052000
* DMSFRETS -- R1 POINTS TO A PLIST: 00053000
* DC CL8'SVCFRET' 00054000
* DC A(LENGTH) LENGTH OF BLOCK BEING RELEASED, 00055000
* IN DOUBLEWORDS 00056000
* DC A(ADDRESS) ADDRESS OF BLOCK BEING RELEASED 00057000
* 00058000
* DMSFREEX -- R0 CONTAINS REQUESTED LENGTH 00059000
* 00060000
* DMSFRETX -- R1 CONTAINS THE ADDRESS OF THE BLOCK BEING 00061000
* RELEASED, AND R0 ITS SIZE IN DOUBLEWORDS. 00062000
* 00063000
* DMSFRES -- CODE203 IN NUCON CONTAINS THE HALFWORD CODE 00064000
* COMPUTED BY THE DMSFREE OR DMSFRET MACROS, DEPENDING 00065000
* UPON THE PARTICULAR SERVICE ROUTINE BEING REQUESTED. 00066000
* 00067000
* EXIT CONDITIONS: 00068000
* 00069000
* NORMAL: 00070000
* 00071000
* FOR ALLOCATION, REGISTER 1 IS SET TO THE ADDRESS OF THE 00072000
* ALLOCATED BLOCK. 00073000
* REGISTER 15 IS SET TO THE RETURN CODE, ZERO. 00074000
* 00075000
* ERROR: 00076000
* RC = 1: NO FREE STORAGE AVAILABLE. 00077000
* RC = 2: USER STORAGE POINTERS CLOBBERED. 00078000
* RC = 3: NUCLEUS STORAGE POINTERS CLOBBERED. 00079000
* RC = 4: (FREE) REQUESTED SIZE NOT POSITIVE, OR MIN GREATER 00080000
* THAN MAX FOR VARIABLE REQUEST. 00081000
* RC = 5: (FRET) RETURNED SIZE NOT POSITIVE 00082000
* RC = 6: (FRET) BLOCK WAS IMPROPERLY RETURNED (OVERLAPS TWO 00083000
* AREAS, OR ANOTHER BLOCK, OR OUT OF RANGE) 00084000
* RC = 7: (FRET) RETURNED BLOCK IS NOT DOUBLE-WORD ALIGNED. 00085000
* RC = 8: (DMSFRES) ILLEGAL CODE OR ARGUMENT 00086000
* 00087000
* EXTERNAL REFERENCES: 00088000
* 00089000
* DMSNUCU -- USER NUCON PAGE 00090000
* DMSNUCE -- END OF NUCON 00091000
* TRANSAR -- ADDRESS OF TRANSIENT AREA 00092000
* TRANSEND -- END OF TRANSIENT AREA 00093000
* DMSFRT -- DMSFRE WORK AREA, DESCRIBED BY DMSFRT MACRO 00094000
* 00095000
* CALLS TO OTHER ROUTINES: 00096000
* 00097000
* DMSERR -- TO TYPE OUT ERROR MESSAGES 00098000
* 00099000
* TABLES/WORKAREAS: 00100000
* 00101000
* DMSFRT -- DMSFRE WORK AREA 00102000
* 00103000
* REGISTER USAGE: 00104000
* 00105000
* R2 = SCRATCH REGISTER 00106000
* R3 = CHAIN HEADER POINTER 00107000
* R4 = CURRENT CHAIN ELEMENT POINTER 00108000
* R5 = PREVIOUS CHAIN ELEMENT POINTER 00109000
* R6 = ADDRESS OF BLOCK BEING EXAMINED 00110000
* R7 = SIZE OF BLOCK BEING EXAMINED OR SEARCHED FOR 00111000
* R8 = COUNTING REGISTER 00112000
* R9 = SCRATCH REGISTER 00113000
* R10 = INTERNAL SUBROUTINE RETURN REGISTER 00114000
* R11 = BASE REGISTER 00115000
* R12 = SECOND BASE REGISTER 00116000
* R13 = POINTER TO WORK AREA, DMSFRT 00117000
* 00118000
* OPERATION: 00119000
* 00120000
* DMSFREB -- ALLOCATES OR RELEASES A BLOCK OF STORAGE DEPENDING 00121000
* UPON THE CODE IN NUCON LOCATION 'CODE203'. THE EXACT 00122000
* METHOD OF OPERATION IS DESCRIBED IN THE PLM, IN THE 00123000
* SECTION ON FREE STORAGE MANAGEMENT. 00124000
* 00125000
* DMSFREES -- THE SIZE IS LOADED FROM THE PLIST, AND A DMSFREE 00126000
* MACRO IS EXECUTED. UPON RETURN, THE ADDRESS OF THE 00127000
* ALLOCATED BLOCK IS STORED INTO THE PLIST. 00128000
* 00129000
* DMSFRETS -- THE SIZE AND ADDRESS OF THE BLOCK TO BE RELEASED 00130000
* ARE LOADED FROM THE PLIST, AND A DMSFRET MACRO IS 00131000
* EXECUTED. 00132000
* 00133000
* DMSFREEX -- A DMSFREE MACRO IS EXECUTED. 00134000
* 00135000
* DMSFRETX -- A DMSFRET MACRO IS EXECUTED. 00136000
* 00137000
* DMSFRES -- THE FOLLOWING SERVICE ROUTINES ARE EXECUTED: 00138000
* 00139000
* CKON: TURN ON FLAG WHICH CAUSES 'CHECK' TO BE EXECUTED WITH 00140000
* EACH CALL TO DMSFRE. 00141000
* 00142000
* CKOFF: TURN OFF THIS FLAG. 00143000
* 00144000
* INIT1: FIRST DMSFRE INITIALIZATION ROUTINE. THIS ROUTINE 00145000
* INITIALIZES FREE STORAGE IN A TEMPORARY WAY, SO THAT 00146000
* THE SYSTEM DISK CAN BE LOGGED IN. 00147000
* 00148000
* INIT2: SECOND DMSFRE INITIALIZATION ROUTINE. THIS ROUTINE 00149000
* IS CALLED AFTER THE SIZE OF VIRTUAL MEMORY IS KNOWN, 00150000
* TO PREPARE STORAGE FOR THE USUAL ACTIVITY IN FREE 00151000
* STORAGE ALLOCATION. ANY HIGH-CORE POINTERS ARE CLEARED, 00152000
* THE 'FREETAB' FREE STORAGE TABLE IS ALLOCATED (THIS 00153000
* TABLE CONTAINS ONE BYTE FOR EACH PAGE OF VIRTUAL 00154000
* MEMORY, WHICH INDICATES THE USE OF THAT PAGE), ALL 00155000
* STORAGE KEYS ARE INITIALIZED, AND THE CHAINS ARE 00156000
* CLEANED UP. 00157000
* 00158000
* CHECKS: CAUSE ALL CHAINS TO BE CHECKED FOR VALIDITY. 00159000
* 00160000
* UREC: RECOVERY ROUTINE CALLED BY DMSABN. ALL USER FREE 00161000
* STORAGE BLOCKS ARE RELEASED. 00162000
* 00163000
* CALOC: COMPUTATION ROUTINE CALLED BY DMSABN. THIS ROUTINE 00164000
* COMPUTES THE SIZE OF ALLOCATED STORAGE. 00165000
*. 00166000
MACRO 00173000
&NM CLEANUP &COND,&CHAIN 00174000
&NM REVB &COND,*+12 00175000
OI FREEFLG2,FRF2CL 00176000
AIF ('&CHAIN' NE '').NOC 00177000
OI FLAGS(CHR),FLCLN+FLPA 00178000
MEXIT 00179000
.NOC OI FREE&CHAIN+FLAGS,FLCLN+FLPA 00180000
MEND 00181000
SPACE 5 00182000
MACRO 00183000
&NM REVB &C,&J 00184000
LCLC &CT 00185000
AIF ('&C' EQ '').MEND 00186000
AIF ('&C'(1,1) EQ 'N').N 00187000
&NM BN&C &J 00188000
MEXIT 00189000
.N ANOP 00190000
&CT SETC '&C'(2,8) 00191000
&NM B&CT &J 00192000
.MEND MEND 00193000
EJECT 00194000
MACRO 00195000
&NM DGEN &LIST 00196000
LCLA &I LOOP VARIABLE 00197000
&NM DC 0H'0',AL2(&LIST-&NM) 00198000
.LOOP ANOP 00199000
DC AL2(&SYSLIST(&I+2)-&NM) 00200000
&I SETA &I+1 00201000
AIF (&I+2 LE N'&SYSLIST).LOOP 00202000
MEND 00203000
SPACE 5 00204000
MACRO 00205000
ROUND &TYPE,&R 00206000
.* ROUND SIZE VALUE UP OR DOWN TO 4K MULTIPLE 00207000
AIF ('&TYPE' NE 'UP').D 00208000
LA &R,4096-1(,&R) ADD (PAGE-1) VALUE 00209000
.D N &R,=X'00FFF000' TRUNCATE TO PAGE BOUNDARY 00210000
MEND 00211000
SPACE 3 00212000
MACRO 00213000
CVDB &R,&ERR= CONVERT DOUBLEWORDS TO BYTES 00214000
AR &R,&R MULTIPLY BY 8 00215000
AR &R,&R 00216000
AR &R,&R 00217000
SPACE 00218000
* ERROR RETURN IF RESULT IS NEGATIVE 00219000
RTN NP,&ERR,FINIS 00220000
C &R,=X'00FF0000' COMPARE RESULT WITH MAXIMUM 00221000
BNH *+8 SKIP IF SMALLER 00222000
L &R,=X'00FF0000' LOAD MAXIMUM VALUE 00223000
MEND 00224000
EJECT 00225000
MACRO 00226000
RTN &COND,&CODE,&FINIS 00227000
LCLA &J 00228000
LCLB &CB,&FB 00229000
&CB SETB ('&CODE' NE '0') 00230000
&FB SETB ('&FINIS' NE '') 00231000
&J SETA (1-&CB)*(2*&FB+8)+12*&CB COMPUTE JUMP LENGTH 00232000
REVB &COND,*+&J 00233000
AIF (&CB).NCB1 00234000
SR R15,R15 ZERO RETURN CODE 00235000
AGO .RET 00236000
.NCB1 ANOP 00237000
LA R15,CODE&CODE SET RETURN CODE 00238000
AIF (&CODE LT 20).LC 00239000
CODE&CODE EQU &CODE (DOCUMENTATION) 00240000
.LC ANOP 00241000
AIF (&FB).RET 00242000
LTR R15,R15 SET CONDITION CODE 00243000
.RET ANOP 00244000
AIF (&FB).B 00245000
BR RR RETURN TO CALLER 00246000
MEXIT 00247000
.B B RTN&FINIS 00248000
MEND 00249000
* REGISTER DEFINITIONS 00251000
DMSFRE START 0 00252000
R0 EQU 0 00253000
R1 EQU 1 00254000
R2 EQU 2 00255000
R3 EQU 3 00256000
R4 EQU 4 00257000
R5 EQU 5 00258000
R6 EQU 6 00259000
R7 EQU 7 00260000
R8 EQU 8 00261000
R9 EQU 9 00262000
R10 EQU 10 00263000
R11 EQU 11 00264000
R12 EQU 12 00265000
R13 EQU 13 00266000
R14 EQU 14 00267000
R15 EQU 15 00268000
SPACE 5 00269000
XR2 EQU R2 SCRATCH -- MUST BE PRESERVED BY *00270000
LOW-LEVEL SUBROUTINES 00271000
CHR EQU R3 CHAIN HEADER POINTER 00272000
PTR EQU R4 CURRENT CHAIN ELEMENT POINTER 00273000
PPTR EQU R5 PREVIOUS CHAIN ELEMENT POINTER 00274000
BLR EQU R6 ADDRESS OF BLOCK BEING EXAMINED 00275000
SR EQU R7 SIZE OF BLOCK BE SEARCHED FOR 00276000
CR EQU R8 COUNTING REGISTER 00277000
XR EQU R9 SCRATCH REGISTER -- MUST BE ODD 00278000
RR EQU R10 INTERNAL SUBROUTINE RETURN REG 00279000
BR EQU R11 BASE REGISTER 00280000
BR2 EQU R12 00281000
TR EQU R13 POINTER TO WORK AREA 00282000
SPACE 3 00283000
* NOTE: CR = (XR-1): HIGH BYTE WILL BE CLOBBERED BY MVCL AND CLCL. 00284000
EJECT 00285000
* THE FOLLOWING NAME CHANGES WERE MADE IN GOING FROM CMS/67 TO CMS/370 00286000
SPACE 00287000
* OLD NAME NEW NAME 00288000
* ----------- ----------- 00289000
* SVCFREE DMSFREES 00290000
* SVCFRET DMSFRETS 00291000
* FREE DMSFREEX 00292000
* FRET DMSFRETX 00293000
SPACE 3 00294000
USING DMSFRE,BR,BR2 00295000
USING NUCON,R0 00296000
USING FRDSECT,TR 00297000
SPACE 3 00298000
ENTRY DMSFREB,DMSFREES,DMSFRETS,DMSFREEX,DMSFRETX 00299000
ENTRY DMSFRES DMSFRE SERVICE ROUTINES 00300000
ENTRY FREE,FRET,SVCFREE,SVCFRET ***** REMOVE ***** 00301000
EJECT 00302000
* LIST OF INTERNAL RETURN CODES 00303000
CODE1 EQU 1 NO STORAGE AVAILABLE -- FREE *00304000
REQUEST CANNOT BE SATISFIED 00305000
CODE2 EQU 2 USER STORAGE POINTERS CLOBBERED 00306000
CODE3 EQU 3 NUC STORAGE POINTERS CLOBBERED 00307000
CODE4 EQU 4 FREE: REQUESTED SIZE <= 0 OR *00308000
MIN > MAX FOR VARIABLE REQUEST 00309000
CODE5 EQU 5 FRET: RETURNED SIZE <= 0 00310000
CODE6 EQU 6 FRET: BLOCK WAS IMPROPERLY *00311000
RETURNED (OVERLAPS TWO AREAS OR *00312000
ANOTHER BLOCK, OR OUT OF RANGE) 00313000
CODE7 EQU 7 FRET: RETURNED BLOCK IS NOT *00314000
DOUBLE-WORD ALIGNED 00315000
CODE8 EQU 8 DMSFRES: ILLEGAL CODE OR ARG 00316000
CODE9 EQU 9 ANY: UNEXPECTED INTERNAL ERROR 00317000
SPACE 00318000
* 20 OR HIGHER: UNEXPECTED INTERNAL ERRORS 00319000
INIT1 EQU * 00321000
* FIRST INITIALIZATION ROUTINE 00322000
* PUT ALL STORAGE ON NUCLEUS CHAIN AND ROUTINE. 00323000
* TURN ON AN 'UN-INITIALIZED' FLAG TO INDICATE THAT SECOND INIT 00324000
* ROUTINE HAS NOT YET BEEN CALLED. 00325000
* UNTIL SECOND ROUTINE IS CALLED, NO USER STORAGE MAY BE ALLOCATED. 00326000
* IN THE BEGINNING, THERE IS ONLY ONE LOW-CORE BLOCK ON THE FREE 00327000
* CHAIN. 00328000
L XR,=V(DMSNUCE) ADDR OF BEGINNING OF BLOCK 00329000
ST XR,FREELN+POINTER STORE POINTER IN CHAIN HEADER 00330000
XC POINTER(4,XR),POINTER(XR) ZERO 'NEXT BLOCK' POINTER 00331000
L XR2,=V(TRANSAR) END OF BLOCK 00332000
SR XR2,XR SIZE OF BLOCK 00333000
ST XR2,FREELN+MAX SET MAX FOR CHAIN 00334000
ST XR2,SIZE(,XR) STORE SIZE OF BLOCK 00335000
MVI FREELN+(NUM+3),1 ONE BLOCK IN CHAIN 00336000
MVI FREEFLG2,FRF2NOI INITIALIZE FLAG BYTE 00337000
RTN ,0,FINIS RETURN 00338000
* SECOND INITIALIZATION ROUTINE 00340000
* ALLOCATE BYTE TABLE, DEPENDING ON STORAGE SIZE. 00341000
* SET UP BYTES TO INIDICATE ALLOCATED STORAGE. 00342000
* SET CLEANUP FLAG FOR NUCLEUS LOW-CORE CHAIN 00343000
* TURN OFF 'UN-INITIALIZED' FLAG SET BY FIRST INITIALIZATION ROUTINE. 00344000
* BRANCH TO RETURN, TO ALLOW CLEANUP. 00345000
INIT2 EQU * 00346000
MVC FREELOW1,FREELOWE SAVE CURRENT VALUE OF FREELOWE 00347000
L XR2,FREELOWE SAVE CURRENT VALUE OF FREELOWE 00348000
SPACE 00349000
* WIPE OUT ALL HIGH-CORE NUCLEUS STORAGE. 00350000
XC FREEHN(12),FREEHN CLEAR HIGH CORE POINTERS 00351000
L SR,VMSIZE GET CORE SIZE 00352000
SRA SR,12 NUMBER BYTES NEEDED IN FREETAB 00353000
LA SR,7(,SR) ROUND SR UP TO DOUBLE WORD 00354000
N SR,=X'00FFFFF8' 00355000
LA CHR,FREELN POINT TO LOW-CORE NUCLEUS CHAIN 00356000
BAL RR,SCHFIX ALLOCATE TABLE 00357000
BZ INIT2A GO IT SUCCESSFUL 00358000
SPACE 00359000
* OTHERWISE, ALLOCATE FROM TOP OF CORE STORAGE. 00360000
LR R1,SR SAVE FREETAB SIZE 00361000
ROUND UP,SR ROUND UP TO NUMBER OF PAGES 00362000
BAL RR,GEXT GET EXTEND STORAGE 00363000
LA CHR,FREEHN POINT TO HIGH-CORE NUCLEUS CHAIN 00364000
BAL RR,SFRT PUT ON HIGH NUCLEUS CHAIN 00365000
LR SR,R1 GET SIZE NEEDED 00366000
BAL RR,SCHFIX GO ALLOCATE IT 00367000
RTN NZ,23,FINIS ALLOCATION ERROR IS IMPOSSIBLE 00368000
SPACE 00369000
* WHEN CONTROL REACHES THIS POINT, THE FREETAB TABLE HAS BEEN 00370000
* ALLOCATED, AND ITS ADDRESS IS IN REGISTER BLR. 00371000
INIT2A EQU * 00372000
ST BLR,AFREETAB SAVE ADDRESS IN NUCON 00373000
NI FREEFLG2,X'FF'-FRF2NOI TURN OFF 'NOT INITIALIZED' FLAG 00374000
SPACE 00375000
* WE MUST NOW INITIALIZE THE ASSIGNED CODES AND STORAGE KEYS FOR ALL 00376000
* OF CORE STORAGE. 00377000
SPACE 00378000
* FIRST, WE INITIALIZE EVERYTHING TO NUCLEUS KEY AND SYSTEM CODE. 00379000
SR BLR,BLR BLOCK STARTS AT LOCATION ZERO 00380000
L SR,VMSIZE GET SIZE OF VIRTUAL MEMORY 00381000
LA XR,NUCKEY NUCLEUS KEY 00382000
BAL RR,SETKEYI SET STORAGE KEY 00383000
LA XR,SYSCODE SET SYSTEM CODE 00384000
BAL RR,SETCODEI 00385000
SPACE 00386000
* CHANGE KEY IN USER HALF-PAGE IN NUCON 00387000
L BLR,=V(DMSNUCU) POINT TO USER HALF-PAGE 00388000
LA XR,USERKEY USER STORAGE KEY 00389000
SSK XR,BLR SET STORAGE KEY 00390000
SPACE 00391000
* THE LOW-CORE FREE STORAGE AREA SHOULD HAVE NUCLEUS FREE STORAGE CODE. 00392000
L BLR,=V(DMSNUCE) BEGINNING OF BLOCK 00393000
ROUND DOWN,BLR ROUND DOWN TO PAGE BOUNDARY 00394000
L SR,=V(TRANSAR) END OF BLOCK 00395000
SLR SR,BLR SIZE OF BLOCK IN BYTES 00396000
LA XR,NUCCODE SET NUCLEUS CODE 00397000
BAL RR,SETCODEI 00398000
SPACE 00399000
* THE TRANSIENT AREA IS SET TO TRANSIENT CODE, AND USER STORAGE KEY. 00400000
L BLR,=V(TRANSAR) BEGINNING OF TRANSIENT AREA 00401000
L SR,=V(TRANSEND) END OF TRANSIENT AREA 00402000
SLR SR,BLR SIZE OF TRANSIENT AREA 00403000
LA XR,TRNCODE TRANSIENT AREA CODE 00404000
BAL RR,SETCODEI SET CODE IN FREETAB TABLE 00405000
LA XR,USERKEY USER STORAGE KEY 00406000
BAL RR,SETKEYI SET STORAGE KEY 00407000
SPACE 00408000
* THE USER AREA IS SET TO USER AREA CODE, AND USER STORAGE KEY. 00409000
L BLR,AUSRAREA BEGINNING OF USER AREA 00410000
L SR,FREELOWE END OF USER AREA 00411000
SLR SR,BLR SIZE OF USER AREA 00412000
LA XR,USARCODE USER AREA CODE 00413000
BAL RR,SETCODEI PUT INTO FREETAB 00414000
LA XR,USERKEY USER STORAGE KEY 00415000
BAL RR,SETKEYI SET STORAGE KEY 00416000
SPACE 00417000
* FINALLY, ANY HIGH CORE FREE AREA SHOULD HAVE NUCLEUS FREE STORAGE 00418000
* CODE. ANY SUCH AREA MAY HAVE BEEN ALLOCATE ONLY FOR FREETAB. 00419000
L BLR,FREELOWE BEGINNING OF HIGH CORE FREE AREA 00420000
L SR,FREELOW1 END OF AREA 00421000
SLR SR,BLR SIZE OF AREA 00422000
BZ INIT2B NOTHING TO DO IF ZERO 00423000
LA XR,NUCCODE SET NUCLEUS CODE 00424000
BAL RR,SETCODEI PUT INTO FREETAB 00425000
SPACE 00426000
INIT2B EQU * 00427000
CLEANUP ,LN CLEAN UP LOW CORE NUCLEUS CHAIN 00428000
CLEANUP ,HN CLEAN UP HIGH CORE NUC CHAIN 00429000
RTN ,0,FINIS GO CLEAN UP AND RETURN (RC=0) 00430000
* SVCFREE ENTRY 00432000
USING *,R15 00433000
DMSFREES EQU * 00434000
SVCFREE EQU * ***** REMOVE ***** 00435000
LR R2,R1 SAVE PARAMETER LIST POINTER 00436000
L R0,8(,R1) LOAD BLOCK SIZE INTO R0 00437000
DMSFREE DWORDS=(0),ERR=*,TYPE=USER ALLOCATE BLOCK 00438000
ST R1,12(,R2) STORE ADDRESS IN PARAM LIST 00439000
BR R14 RETURN TO CALLER 00440000
SPACE 5 00441000
* SVCFRET ENTRY 00442000
USING *,R15 00443000
DMSFRETS EQU * 00444000
SVCFRET EQU * ***** REMOVE ***** 00445000
LR R2,R1 SAVE PARAMETER LIST POINTER 00446000
LM R0,R1,8(R1) LOAD LENGTH/ADDR INTO R0/R1 00447000
DMSFRET DWORDS=(0),LOC=(1),ERR=* RETURN BLOCK 00448000
BR R14 00449000
* DMSFREEX IS POINTED TO BY NUCON FIELD AFREE. 00451000
DMSFREEX EQU * 00452000
FREE EQU * ******* REMOVE ******* 00453000
DMSFREE DWORDS=(0),TYPCALL=SVC,TYPE=USER 00454000
BR R14 00455000
SPACE 2 00456000
* DMSFRETX IS POINTED TO BY AFRET 00457000
DMSFRETX EQU * 00458000
FRET EQU * ******* REMOVE ******* 00459000
DMSFRET DWORDS=(0),LOC=(1),TYPCALL=SVC 00460000
BR R14 00461000
* ENTRY POINT FOR SVC 203 CALLS 00463000
USING *,R15 00464000
DMSFREB EQU * 00465000
STM R0,R15,FREESAVE SAVE REGISTERS IN NUCON 00466000
LM BR,BR2,=A(DMSFRE,DMSFRE+4096) SET BASE REGISTERS 00467000
DROP R15 00468000
L TR,=V(DMSFRT) POINT TO WORK AREA 00469000
SPACE 00470000
* NUCON LOCATION CODE203 CONTAINS THE HALFWORD CODE USED IN 00471000
* CONJUNCTION WITH SVC 203. IF THIS VALUE IS NEGATIVE, THEN 00472000
* THIS IS A CONDITIONAL REQUEST. THIS MEANS THAT WE WILL NOT ABEND IF 00473000
* THE REQUEST CANNOT BE SATISFIED. 00474000
* THE ACTUAL ROUTINE CODE IS IN THE SECOND BYTE OF THE ABSOLUTE VALUE 00475000
* OF THE CODE. THIS LEAVES SEVEN FLAGS BITS IN THE FIRST BYTE OF THE 00476000
* CODE, AND THESE BECOME THE FREEFLG1 FLAG BITS. 00477000
LH R14,CODE203 GET SVC 203 CODE VALUE 00478000
LPR R15,R14 GET ABSOLUTE VALUE 00479000
SRL R15,8 GET FLAG BYTE 00480000
STC R15,FREEFLG1 AND STORE IN FLAG BYTE 00481000
LTR R14,R14 WAS ORIGINAL CODE NEGATIVE? 00482000
BP *+8 SKIP IF NOT 00483000
OI FREEFLG1,FRF1C SET 'CONDITIONAL' FLAG 00484000
TM FREEFLG2,FRF2CKE TEXT 'CHECK EACH TIME' FLAG 00485000
BZ *+8 SKIP IF OFF 00486000
OI FREEFLG2,FRF2CKT SET 'CHECK THIS TIME' FLAG 00487000
TM FREEFLG1,FRF1E WAS THIS A 'FREE' CALL? 00488000
BZ FRETUN GO IF A FRET CALL 00489000
SPACE 00490000
* OTHERWISE, IT'S A 'FREE' CALL 00491000
TM FREEFLG1,FRF1N 'NUCLEUS' STORAGE? 00492000
BO NFREE GO IF SO 00493000
B UFREE USER STORAGE IF NOT 00494000
EJECT 00495000
* ENTRY POINT FOR DMSFRES MACRO CALLS -- DMSFRE FREE STORAGE SERVICE 00496000
* ROUTINES. 00497000
USING *,R15 00498000
DMSFRES EQU * 00499000
STM R0,R15,FREESAVE SAVE REGISTERS 00500000
LM BR,BR2,=A(DMSFRE,DMSFRE+4096) 00501000
DROP R15 00502000
L TR,=V(DMSFRT) POINT TO WORK AREA 00503000
MVI FREEFLG1,FRF1C+FRF1M SET FREEFLG1 FOR EXIT LOGIC 00504000
LH R14,CODE203 GET HALFWORD CODE WITH SVC 203 00505000
LPR R14,R14 TAKE ABSOLUTE VALUE 00506000
SRL R14,8 GET LEFTMOST BYTE 00507000
AR R14,R14 MULTIPLY BY 4 00508000
AR R14,R14 00509000
RTN Z,8,FINIS ILLEGAL ARGUMENT IF ZERO 00510000
C R14,FRESTAB COMPARE WITH MAX VALUE 00511000
RTN H,8,FINIS ILLEGAL ARG IF GREATER 00512000
L R14,FRESTAB(R14) GET BRANCH ADDRESS 00513000
BR R14 GO TO IT 00514000
SPACE 5 00515000
* FRESTAB TABLE CONTAINS THE ADDRESSES OF THE VARIOUS DMSFRE 00516000
* FREE STORAGE SERVICE ROUTINES. 00517000
FRESTAB DC A(FRESTABE-FRESTAB) SIZE OF TABLE 00518000
DC A(CKON) 1 00519000
DC A(CKOFF) 2 00520000
DC A(INIT1) 3 00521000
DC A(INIT2) 4 00522000
DC A(CHECKS) 5 00523000
DC A(UREC) 6 00524000
DC A(CALOC) 7 00525000
FRESTABE EQU * 00526000
SPACE 3 00527000
LTORG 00528000
* FRET, USER OR NUCLEUS 00530000
FRETUN EQU * 00531000
SPACE 00532000
* R0 CONTAINS THE NUMBER OF DOUBLE WORDS BEING RETURNED, AND R1 00533000
* CONTAINS THE ADDRESS OF THE BLOCK BEING RETURNED. 00534000
SPACE 00535000
* FIRST, WE CONVERT THE SIZE FROM DOUBLEWORDS TO BYTES. 00536000
CVDB R0,ERR=5 CONVERT DOUBLEWORDS TO BYTES 00537000
LR SR,R0 SR CONTAINS SIZE IN BYTES 00538000
LA R1,0(,R1) CLEAR HIGH-ORDER BYTE P3015 00539000
LR BLR,R1 BLR CONTAINS ADDRESS OF BLOCK 00540000
SPACE 00541000
* CALL FINDCHN SUBROUTINE TO DETERMINE WHICH OF THE FOUR CHAINS THE 00542000
* BLOCK BELONGS ON. FINDCHN ALSO DOES SOME ERROR CHECKING TO SEE IF 00543000
* THE BLOCK IS DOUBLE-WORD ALIGNED AND IT'S ENTIRELY WITHIN ONE AREA 00544000
* (NUCLEUS OR USER, LOW- OR HIGH-CORE). 00545000
BAL RR,FINDCHN FIND CHAIN FOR THE BLOCK 00546000
SPACE 00547000
* CONTROL RETURNS TO THIS POINT WHEN A NUCLEUS FRET RESULTS IN A WHOLE 00548000
* PAGE BEING FREED. THIS POINT IS BRANCHED TO TO PUT THE PAGE(S) ON 00549000
* THE USER CHAIN. 00550000
FRETR EQU * 00551000
BAL RR,SFRT PUT BLOCK ONTO CHAIN 00552000
SPACE 00553000
* SFRT RETURNS (IN BLR AND SR) THE ADDRESS AND SIZE OF THE ENTIRE BLOCK 00554000
* WHICH IS ON THE CHAIN WHICH CONTAINS THE FRETTED BLOCK. (I.E., IF 00555000
* THE FRETTED BLOCK WAS COMBINED WITH ANOTHER BLOCK ALREADY ON THE FREE 00556000
* CHAIN, THEN SFRT RETURNS THE ADDR AND SIZE OF THE ENTIRE BLOCK OF 00557000
* COMBINED STORAGE.) 00558000
* WE CHECK TO SEE WHETHER THIS BLOCK CONTAINS AN EMBEDDED PAGE. 00559000
CL SR,PAGESIZE BLOCKSIZE >= A PAGE? 00560000
BL RETURN NOTHING TO DO IF NOT 00561000
TM FREEFLG2,FRF2NOI SECOND INIT ROUTINE TAKEN PLACE? 00562000
BO RETURN RETURN IF IT HAS NOT 00563000
CL BLR,FREELOWE ADDRESS = ADDR OF LOW EXTEND? 00564000
BNE FRET1 TO FRET1 IF NOT 00565000
SPACE 00566000
* OTHERWISE, WE ARE FRETTING A BLOCK AT LOW EXTEND, SO THAT WE MAY 00567000
* MOVE THE LOW EXTEND POINTER UP. 00568000
ROUND DOWN,SR ROUND DOWN BLOCKSIZE TO PAGE *00569000
SIZE 00570000
BAL RR,SETKEYN SET KEY TO 'UNASSIGNED' 00571000
BAL RR,SETCODEN SET TABLE CODE TO 'UNASSIGNED' 00572000
BAL RR,ALOC REMOVE BLOCK FROM CHAIN 00573000
AR BLR,SR POINT TO END OF BLOCK 00574000
ST BLR,FREELOWE THIS IS NEW LOW EXTEND VALUE 00575000
TM FLAGS(CHR),FLHC THIS HAD BETTER BE HIGH-CORE CHN 00576000
RTN NO,40,CLOB STORAGE CLOBBERED IF NOT 00577000
SPACE 00578000
* IF THIS IS THE NUCLEUS CHAIN, THEN THE HIGH-CORE USER CHAIN MAY 00579000
* CONTAIN PAGES WHICH CAN FURTHER AFFECT FREELOWE (LOW EXTEND). FOR 00580000
* THIS REASON, WE MUST SET CLEANUP FLAG FOR FREEHU IN THIS CASE. 00581000
TM FLAGS(CHR),FLNU HIGH-CORE NUC CHAIN? 00582000
CLEANUP O,HU CLEANUP HIGH-CORE USER CHN IF SO 00583000
RTN ,0,FINIS NORMAL RETURN 00584000
SPACE 2 00585000
* CONTROL COMES HERE IF THE BLOCK IS A PAGE WHOSE ADDRESS IS NOT AT 00586000
* LOW-EXTEND. IF THIS IS A NUCLEUS CHAIN, THEN WE MUST TRANSFER THE 00587000
* PAGE(S) TO THE CORRESPONDING USER CHAIN. 00588000
FRET1 EQU * 00589000
TM FLAGS(CHR),FLNU NUCLEUS CHAIN? 00590000
BZ FRETUP GO IF NOT 00591000
TM FREEFLG2,FRF2NOI SECOND INIT TAKEN PLACE? 00592000
BO FRETUP GO IF NOT 00593000
LR XR,SR SIZE OF BLOCK 00594000
AR XR,BLR XR -> END OF BLOCK 00595000
ROUND UP,BLR BLR -> ADDRESS OF EMBEDDED PAGE 00596000
ROUND DOWN,XR XR -> END OF EMBEDDED PAGE BLOCK 00597000
CLR BLR,XR ARE THE TWO EQUAL? 00598000
RTN NL,0,FINIS IF SO, THEN IT WASN'T REALLY *00599000
A PAGE 00600000
LR SR,XR SR CONTAINS END PAGE ADDRESS 00601000
SR SR,BLR SR = NO BYTES IN PAGE BLOCK 00602000
BAL RR,ALOC REMOVE PAGE BLOCK FROM CHAIN 00603000
LA CHR,BLOCKLEN(,CHR) POINT TO CORRESPONDING USER CHN 00604000
BAL RR,SETKEY SET KEY TO USER KEY 00605000
BAL RR,SETCODE SET TABLE CODE TO USER CODE 00606000
B FRETR RETURN TO CODE ABOVE TO PUT *00607000
BLOCK ONTO USER CHAIN 00608000
SPACE 2 00609000
* COME HERE IF PAGE FOUND ON USER CHAIN (OR ON NUCLEUS CHAIN IF 00610000
* SECOND INITIALIZATION HAS NOT YET TAKEN PLACE) 00611000
FRETUP EQU * 00612000
OI FLAGS(CHR),FLPA SET 'PAGE AVAILABLE' FLAG 00613000
RTN ,0,FINIS AND GIVE NORMAL RETURN 00614000
* UFREE -- USER FREE STORAGE REQUEST. 00616000
* R0 CONTAINS THE SIZE OF THE REQUEST IN DOUBLE WORDS. IF THE 00617000
* REQUEST IS VARIABLE, THEN R1 CONTAINS THE MINIMUM SIZE OF THE 00618000
* REQUEST. 00619000
UFREE EQU * 00620000
SPACE 00621000
* IF THE SECOND INITIALIZATION ROUTINE HAS NOT YET BEEN INVOKED, THEN 00622000
* ALL USER STORAGE REQUESTS BECOME NUCLEUS STORAGE REQUESTS. 00623000
TM FREEFLG2,FRF2NOI NO SECOND INITIALIZATION? 00624000
BNO *+12 SKIP 2 INSTR'S IF THERE WAS ONE 00625000
OI FREEFLG1,FRF1N SET 'NUCLEUS' REQUEST BIT 00626000
B NFREE AND GO TO NUCLEUS FREE ROUTINE 00627000
SPACE 00628000
* WE FIRST CONVERT THE NUMBER IN R0 TO BYTES. 00629000
CVDB R0,ERR=4 CONVERT DOUBLEWORDS TO BYTES 00630000
LR SR,R0 SR CONTAINS SIZE OF REQUEST 00631000
LA CHR,FREELU POINT TO USER LOW-CORE CHAIN 00632000
SPACE 00633000
* IF THE USER SPECIFIED 'AREA=HIGH', THEN LOW-CORE STORAGE MAY NOT 00634000
* BE USED. 00635000
TM FREEFLG1,FRF1L LOW-CORE STORAGE PERMITTED? 00636000
BZ UFREEH GO IF NOT 00637000
BAL RR,SCHFIX ALLOCATE FROM USER LOW-CORE CHN 00638000
BZ RETURN RETURN IF ALLOCATION SUCCESSFUL 00639000
SPACE 00640000
* CONTROL COMES HERE IF NO ALLOCATION CAN BE MADE FROM THE LOW-CORE 00641000
* CHAIN. 00642000
UFREEH EQU * 00643000
LA CHR,FREEHU POINT TO HIGHCORE USER CHAIN 00644000
TM FREEFLG1,FRF1H IS AREA=HIGH PERMITTED? 00645000
BZ UFREEV GO IF NOT 00646000
BAL RR,SCHFIX TRY TO ALLOCATE FROM HIGHCORE 00647000
BZ RETURN RETURN (RC=0) IF SUCCESSFUL 00648000
SPACE 00649000
* THERE IS NO SPACE AVAILABLE ON EITHER HIGH CORE OR LOW CORE CHAIN. 00650000
* WE ATTEMPT TO EXTEND DOWN INTO USER CORE BY ADDING ONE OR MORE 00651000
* PAGES FROM BELOW THE 'LOW EXTEND' AREA TO THE USER HIGH CORE CHAIN. 00652000
ROUND UP,SR ROUND UP SIZE TO PAGE MULTIPLE 00653000
CL SR,PAGESIZE BLOCKSIZE > 1 PAGE? 00654000
CLEANUP H CLEAN UP LATER IF SO 00655000
BAL RR,GEXT GET EXTEND STORAGE 00656000
BNZ UFREEV GO IF NONE AVAILABLE 00657000
BAL RR,SETKEY SET USER STORAGE KEY 00658000
BAL RR,SETCODE SET USER-ASSIGNED TABLE CODE 00659000
BAL RR,SFRT PUT NEW STORAGE ONTO CHAIN 00660000
LR SR,R0 RESTORE R0 = REQUEST SIZE--BYTES 00661000
B UFREEH GO ALLOCATE AGAIN FROM HIGH CHN 00662000
SPACE 2 00663000
* COME HERE IF THERE IS NO HOPE OF ALLOCATING THE REQUEST BLOCKSIZE. 00664000
* AT THIS POINT WE MUST TRY TO SATISFY A VARIABLE REQUEST, IF HE ALLOWS 00665000
* ONE. IF HE DOES, THEN REGISTER 1 CONTAINS THE MINIMUM SIZE WHICH 00666000
* HE WILL ACCEPT. 00667000
UFREEV EQU * 00668000
TM FREEFLG1,FRF1V VARIABLE REQUEST? 00669000
RTN Z,1,FINIS IF NOT, RETURN RC=1 (NO CORE) 00670000
SPACE 00671000
* CONVERT DOUBLE WORD SIZE IN R1 TO BYTES. 00672000
CVDB R1,ERR=4 CONVERT DOUBLEWORDS TO BYTES 00673000
CLR R1,R0 COMPARE WITH MAXIMUM 00674000
RTN H,4,FINIS ILLEGAL ARG IF GREATER 00675000
TM FREEFLG1,FRF1H AREA=HIGH ALLOWED? 00676000
BZ UFREEV1 NO -- NO NEED TO GET EXTEND 00677000
BAL RR,AEXT GET ALL AVAILABLE EXTEND STOR 00678000
BNZ UFREEV1 GO IF NONE AVAILABLE 00679000
LA CHR,FREEHU POINT TO HIGH CORE USER CHN 00680000
BAL RR,SETKEY SET USER CORE KEY 00681000
BAL RR,SETCODE SET USER-ASSIGNED TABLE CODE 00682000
BAL RR,SFRT PUT EXTEND STORAGE ON CHAIN 00683000
CLEANUP , SET CLEANUP FLAG FOR HU CHAIN 00684000
LR SR,R0 RESTORE REAL MAX REQUEST @VM01316 00684100
BAL RR,SCHFIX AND CHECK IT AGAIN... @VM01316 00684200
BZ RETURN RETURN IF SATISFIED @VM01316 00684300
SPACE 2 00685000
* WE NOW SEARCH BOTH USER CHAINS FOR THE LARGEST AVAILABLE BLOCK 00686000
* WHICH IS GREATER THAN THE MINIMUM. 00687000
UFREEV1 EQU * 00688000
LR SR,R1 GET MINIMUM SIZE 00689000
SR BLR,BLR NO BLOCK ALLOCATED YET 00690000
LA CHR,FREELU POINT TO LOW CORE USER CHAIN 00691000
TM FREEFLG1,FRF1L AREA=LOW ALLOWED? 00692000
BZ *+8 SKIP CALL IF NOT 00693000
BAL RR,SCHVAR SEARCH FOR LARGEST BLOCK 00694000
LR XR2,BLR SAVE RESULT FROM LOWCORE SEARCH 00695000
LA CHR,FREEHU POINT TO HIGHCORE CHAIN 00696000
TM FREEFLG1,FRF1H AREA=HIGH ALLOWED? 00697000
BZ *+8 SKIP IF NOT 00698000
BAL RR,SCHVAR SEARCH FOR LARGEST BLOCK 00699000
LTR BLR,BLR WAS ANY BLOCK FOUND EITHER TIME? 00700000
RTN Z,1,FINIS RETURN RC=1 IF NOT (NO CORE) 00701000
CR SR,R1 BLOCKSIZE >= MIN SIZE? 00702000
RTN L,35,FINIS IMPOSSIBLE IF NOT 00703000
CR SR,R0 BLOCKSIZE < MAX SIZE? 00704000
RTN NL,36,FINIS IMPOSSIBLE IF NOT 00705000
CLR BLR,XR2 WAS BLOCK ALLOCATED IN LOWCORE? 00706000
BNE *+8 SKIP IF NOT 00707000
LA CHR,FREELU POINT TO LOW CORE CHAIN IF SO 00708000
BAL RR,ALOC REMOVE THE BLOCK FROM THE CHAIN 00709000
RTN ,0,FINIS RETURN RC=0 -- WE'RE THROUGH 00710000
* NFREE -- NUCLEUS FREE STORAGE REQUEST 00712000
NFREE EQU * 00713000
CVDB R0,ERR=4 CONVERT DOUBLEWORDS TO BYTES 00714000
LR SR,R0 SR = SIZE REQUESTED (IN BYTES) 00715000
LA CHR,FREELN POINT TO LOWCORE NUCLEUS CHAIN 00716000
SPACE 00717000
* THE USER MAY HAVE SPECIFIED AREA=HIGH, IN WHICH CASE AREA=LOW IS NOT 00718000
* PERMITTED. 00719000
TM FREEFLG1,FRF1L AREA=LOW PERMITTED? 00720000
BZ NFREEN GO IF NOT 00721000
SPACE 00722000
* IF THE ATTEMPT TO ALLOCATE THE BLOCK FROM FREELN FAILS, THEN CONTROL 00723000
* WILL LATER RETURN TO THIS POINT WITH CHR POINTING TO THE NUCLEUS 00724000
* HIGH CORE CHAIN. 00725000
* ALSO, CONTROL WILL RETURN HERE TO RE-ATTEMPT AN ALLOCATION FROM 00726000
* THE SAME CHAIN. 00727000
NFREER EQU * 00728000
LR SR,R0 GET REQUESTED SIZE 00729000
BAL RR,SCHFIX ATTEMPT TO ALLOCATE FROM CHAIN 00730000
BZ RETURN RETURN RC=0 IF ALLOCATION *00731000
IS SUCCESSFUL 00732000
LR XR2,CHR SAVE CHAIN PTR TEMPORARILY 00733000
LA CHR,BLOCKLEN(,CHR) POINT TO CORRESPONDING USER CHN 00734000
L SR,PAGESIZE SIZE OF A PAGE 00735000
BAL RR,SCHPAGE ALLOCATE A PAGE FROM USER CHAIN 00736000
LR CHR,XR2 RESTORE CHR 00737000
BNZ NFREEN GO IF NOT SUCCESSFUL 00738000
SPACE 00739000
* CONTROL COMES HERE TO PUT A PAGE BLOCK ON THE CHAIN POINTED TO BY 00740000
* CHR. 00741000
NFREEB EQU * 00742000
BAL RR,SETKEY SET NUC STORAGE KEY FOR BLKP3026 00743000
CL R0,PAGESIZE IS REQUESTED SIZE > 1 PAGE? 00744000
CLEANUP H SET CLEANUP FLAG IF SO 00745000
BAL RR,SETCODE SET NUCLEUS-ASSIGNED CODE 00746000
BAL RR,SFRT PUT BLOCK ONTO NUCLEUS CHAIN 00747000
B NFREER GO RE-ATTEMPT ALLOCATION 00748000
SPACE 00749000
* IF THE ALLOCATION FOR THE GIVEN CHAIN FAILS, THEN CONTROL COMES 00750000
* HERE. THE FIRST TIME CONTROL COMES HERE, WE POINT TO THE HIGHCORE 00751000
* CHAIN AND RETURN TO NFREER TO ATTEMPT ALLOCATION FROM THAT CHAIN. 00752000
* THE NEXT TIME, WE MUST TRY EXTEND STORAGE. 00753000
NFREEN EQU * 00754000
TM FREEFLG1,FRF1H AREA=HIGH ALLOWED? 00755000
BZ NFREEV GO TRY VARIABLE IF NOT 00756000
SPACE 00757000
* CHECK TO SEE IF WE HAVE ALREADY LOOKED AT THE HIGHCORE NUC CHAIN. 00758000
TM FLAGS(CHR),FLHC HIGHCORE CHAIN? 00759000
LA CHR,FREEHN POINT TO HIGHCORE CHAIN 00760000
BNO NFREER GO TRY HIGHCORE CHAIN 00761000
L SR,PAGESIZE PUT PAGESIZE INTO SR 00762000
BAL RR,GEXT GET EXTEND STORAGE 00763000
BZ NFREEB PUT STORAGE ONTO NUC CHAIN, *00764000
IF AVAILABLE 00765000
SPACE 2 00766000
* CONTROL COMES HERE IF THE FIXED REQUEST CANNOT BE SATISFIED. 00767000
* AT THIS POINT, ALL AVAILABLE PAGES ARE ON THE NUCLEUS CHAIN. 00768000
* WE TRY FOR A VARIABLE REQUEST. 00769000
NFREEV EQU * 00770000
TM FREEFLG1,FRF1V VARIABLE REQUEST MADE? 00771000
RTN Z,1,FINIS RETURN RC=1 (NO CORE) IF NOT 00772000
SPACE 00773000
* MIN SIZE ALLOWED IS IN R1 IN DOUBLEWORDS. CONVERT TO BYTES. 00774000
CVDB R1,ERR=4 CONVERT R1 FROM DWORDS TO BYTES 00775000
CR R1,R0 COMPARE WITH MAX REQUEST 00776000
RTN H,4,FINIS ILLEGAL ARG IF LARGER 00777000
LR SR,R1 GET MIN SIZE ALLOWED 00778000
BCTR SR,0 DECREMENT FOR SCHVAR ROUTINE 00779000
SR BLR,BLR NO BLOCK FOUND YET 00780000
LA CHR,FREELN POINT TO LOW-CORE NUC CHAIN 00781000
TM FREEFLG1,FRF1L AREA=LOW ALLOWED? 00782000
BZ *+8 SKIP CALL IF NOT 00783000
SPACE 00784000
* SCHVAR WILL FIND THE LARGEST BLOCK ON THE CHAIN WHOSE SIZE IS 00785000
* LARGER THAN THE VALUE IN REGISTER SR. 00786000
BAL RR,SCHVAR FIND LARGEST BLOCK. 00787000
LR XR2,BLR SAVE RETURNED VALUE TEMPORARILY 00788000
LA CHR,FREEHN POINT TO HIGHCORE BLOCK 00789000
TM FREEFLG1,FRF1H AREA=HIGH ALLOWED? 00790000
BZ *+8 SKIP CALL TO SCHVAR IF NOT 00791000
BAL RR,SCHVAR FIND ANY LARGER BLOCK 00792000
LTR BLR,BLR ANY BLOCK FOUND WHATSOEVER? 00793000
RTN Z,1,FINIS RETURN RC=1 (NO CORE) IF NONE 00794000
CR SR,R1 BLOCK LARGER THAN MIN SIZE? 00795000
RTN L,33,FINIS IMPOSSIBLE IF NOT 00796000
CR SR,R0 BLOCK SMALLER THAN MAX SIZE? 00797000
RTN NL,34,FINIS 00798000
CLR BLR,XR2 WAS BLOCK ALLOCATED FROM *00799000
LOW CORE CHAIN? 00800000
BNE *+8 SKIP IF NOT 00801000
LA CHR,FREELN POINT TO LOWCORE CHAIN 00802000
BAL RR,ALOC ALLOCATE BLOCK FROM CHAIN 00803000
B RETURN RETURN TO CALLER 00804000
AEXT EQU * 00806000
SPACE 00807000
* ALLOCATE ALL AVAILABLE EXTEND STORAGE. 00808000
SPACE 00809000
* NORMAL RETURN: 00810000
* BLR -> BLOCK OF ALL REMAINING EXTEND STORAGE 00811000
* SR CONTAINS THE SIZE OF THIS BLOCK. 00812000
SPACE 00813000
* ERROR RETURN: 00814000
* RC = 1 (NO STORAGE AVAILABLE) 00815000
SPACE 2 00816000
* THE LOWEST POSSIBLE EXTEND AREA ADDRESS IS EQUAL TO THE MAXIMUM 00817000
* OF MAINHIGH, LOCCNT, AND AUSRAREA. 00818000
L BLR,MAINHIGH GET MAINHIGH 00819000
CL BLR,LOCCNT COMPARE WITH LOCCNT 00820000
BH *+8 SKIP IF HIGHER 00821000
L BLR,LOCCNT USE LOCCNT IF HIGHER 00822000
CL BLR,AUSRAREA COMPARE WITH USERAREA ADDR 00823000
BH *+8 SKIP IF HIGHER 00824000
L BLR,AUSRAREA USE IT IF HIGHER 00825000
ROUND UP,BLR ROUND UP TO PAGE BOUNDARY 00826000
CL BLR,FREELOWE LOWER THAN EXISTING LOW EXTEND? 00827000
RTN NL,1 RETURN RC=1 IF NOT (NO CORE) 00828000
L SR,FREELOWE GET OLD LOW EXTEND LOCATION 00829000
SR SR,BLR OBTAIN SIZE OF NEW BLOCK 00830000
ST BLR,FREELOWE STORE NEW LOW EXTEND VALUE 00831000
RTN ,0 RETURN RC=0 TO CALLER 00832000
ALOC EQU * 00834000
SPACE 00835000
* THIS SUBROUTINE ALLOCATES A SPECIFIC BLOCK OF A SPECIFIC SIZE FROM 00836000
* A SPECIFIC CHAIN. 00837000
SPACE 00838000
* AT ENTRY: 00839000
* BLR -> DESIRED BLOCK 00840000
* SR CONTAINS SIZE OF BLOCK 00841000
* CHR -> DESIRED CHAIN HEADER 00842000
SPACE 00843000
* NORMAL RETURN: 00844000
* BLR AND SR ARE UNCHANGED 00845000
* THE BLOCK IS REMOVED FROM THE SPECIFIED CHAIN 00846000
SPACE 00847000
* ERROR RETURN: 00848000
* IF THE BLOCK CANNOT BE ALLOCATED, THEN IT IS ASSUMED THAT 00849000
* THERE IS AN ERROR IN INTERNAL DMSFRE LOGIC, AND THE ROUTINE 00850000
* IS TERMINATED IMMEDIATELY. 00851000
SPACE 3 00852000
* ALOCC ENTRY IS USED TO SAVE TIME IF CURRENT CHAIN ELEMENTS ARE 00853000
* ALREADY KNOWN. 00854000
SPACE 00855000
* ADDITIONAL ENTRY REQUIREMENTS: 00856000
* BLR, SR AND CHR AS ABOVE 00857000
* PTR -> CHAIN ELEMENT CONTAINS DESIRED BLOCK 00858000
* PPTR -> PREVIOUS CHAIN ELEMENT (OR CHAIN HEADER) 00859000
SPACE 3 00860000
* ALOC ENTRY 00861000
L CR,NUM(,CHR) GET NUMBER OF CHAIN ELEMENTS 00862000
LTR CR,CR ANY CHAIN ELEMENTS? 00863000
RTN Z,20,FINIS IMPOSSIBLE IF NONE 00864000
SPACE 00865000
* SET UP TWO REGISTERS TO SAVE TIME IN LOOP 00866000
LA R14,ALOCL FOR LOOP 00867000
LA R15,ALOCF FOR LOOP 00868000
LR PTR,CHR INITIALIZE CHAIN ELEMENT POINTER 00869000
SPACE 00870000
* THE FOLLOWING LOOP SEARCHES FOR THE CHAIN ELEMENT CONTAINING THE 00871000
* DESIRED BLOCK. 00872000
CNOP 0,8 FOR SPEED 00873000
ALOCL EQU * 00874000
LR PPTR,PTR MOVE UP ONE CHAIN ELEMENT 00875000
L PTR,POINTER(,PTR) POINT TO NEXT CHAIN ELEMENT 00876000
CLR PTR,BLR HAVE WE FOUND BLOCK YET? 00877000
BCR 13,R15 (BNH ALOCF) GO IF FOUND 00878000
BCTR CR,R14 (BCT CR,ALOCL) COUNT CHAIN BLOCKS 00879000
RTN ,21,FINIS WE'RE OUT OF THEM -- IMPOSSIBLE 00880000
SPACE 00881000
* COME HERE WHEN THE BLOCK HAS BEEN FOUND. AT THIS POINT, THE 00882000
* REGISTERS ARE SET UP AS FOLLOWS: 00883000
* BLR -> DESIRED BLOCK 00884000
* SR CONTAINS SIZE OF DESIRED BLOCK (IN BYTES) 00885000
* PTR -> CHAINED FREE BLOCK CONTAINING DESIRED BLOCK 00886000
* PPTR -> PREVIOUS BLOCK IN CHAIN 00887000
ALOCF EQU * 00888000
SPACE 00889000
* ALOCC ENTRY. 00890000
* THIS ENTRY POINT IS USED AS AN ALTERNATE ENTRY POINT TO ALOC WHEN 00891000
* THE ABOVE REGISTERS ARE ALREADY SET. 00892000
ALOCC EQU * 00893000
L CR,NUM(,CHR) GET NUMBER OF ELEMENTS IN CHN 00894000
CLR PTR,BLR IS DESIRED BLOCK AT BEGINNING *00895000
OF THIS FREE CHAIN ENTRY? 00896000
BE ALOCT GO IF IT IS 00897000
SPACE 00898000
* OTHERWISE, WE MUST LOP OFF PART OF THE BOTTOM OF THE CHAIN ELEMENT, 00899000
* UP TO THE DESIRED BLOCK. 00900000
* WE DO THAT BY SIMPLY MAKING IT A SEPARATE BLOCK ON THE FREE CHAIN. 00901000
LR R14,BLR R14 -> DESIRED BLOCK 00902000
SR R14,PTR R14 CONTAINS SIZE OF FREE BLOCK *00903000
BELOW DESIRED BLOCK 00904000
L XR,SIZE(,PTR) XR CONTAINS SIZE OF ENTIRE FREE *00905000
ELEMENT CONTAINING DESIRED BLK 00906000
ST R14,SIZE(,PTR) SET SIZE OF NEW LOPPED OFF BLOCK 00907000
SR XR,R14 SIZE REMAINING IN UPPER BLOCK 00908000
ST BLR,POINTER(,PPTR) PUT UPPER BLOCK INTO CHAIN 00909000
ST PTR,POINTER(,BLR) 00910000
ST XR,SIZE(,BLR) STORE SIZE OF UPPER BLOCK 00911000
LA CR,1(,CR) INCREMENT FREE CHAIN ELEMENT *00912000
COUNT 00913000
LR PTR,BLR MAKE UPPER PART THE NEW CURRENT *00914000
BLOCK 00915000
SPACE 2 00916000
* WHEN CONTROL REACHES THIS POINT, THE CURRENT CHAIN ELEMENT (POINTED 00917000
* TO BY PTR) BEGINS AT THE ADDRESS OF THE DESIRED BLOCK. (I.E., 00918000
* PTR = BLR.) 00919000
ALOCT EQU * 00920000
C SR,SIZE(,PTR) COMPARE DESIRED SIZE WITH SIZE *00921000
OF FREE ELEMENT 00922000
BE ALOCE GO IF THEY'RE EQUAL 00923000
SPACE 00924000
* CHECK TO SEE IF THE CHAIN ELEMENT IS LARGE ENOUGH. 00925000
RTN H,22,FINIS NOT LARGE ENOUGH -- IMPOSSIBLE 00926000
SPACE 00927000
* OTHERWISE, THE CHAIN ELEMENT IS LARGER THAN THE DESIRED BLOCK, AND 00928000
* SO A BLOCK MUST BE LOPPED OFF THE TOP OF THE CHAIN ELEMENT. WE 00929000
* SIMPLY MAKE THE TOP PART OF THE BLOCK A SEPARATE CHAIN ELEMENT. 00930000
LR R14,SR R14 CONTAINS SIZE OF DESIRED BLK 00931000
AR R14,PTR R14 -> UPPER BLOCK 00932000
L XR,SIZE(,PTR) XR = SIZE OF ENTIRE FREE ELEMENT 00933000
SR XR,SR SR = SIZE OF UPPER BLOCK 00934000
SPACE 00935000
* WE PLACE THE UPPER BLOCK IN THE CHAIN, REMOVING THE REQUESTED BLOCK. 00936000
ST R14,POINTER(,PPTR) PUT UPPER BLOCK INTO CHAIN 00937000
ST XR,SIZE(,R14) STORE SIZE OF NEW UPPER BLOCK 00938000
MVC POINTER(4,R14),POINTER(PTR) PUT UPPER BLOCK INTO CHAIN 00939000
B ALOCX 00940000
SPACE 2 00941000
* CONTROL COMES HERE IF THE CHAIN ELEMENT IS EXACTLY EQUAL TO THE 00942000
* DESIRED BLOCK. WE SIMPLY REMOVE THIS BLOCK FROM THE CHAIN. 00943000
ALOCE EQU * 00944000
MVC POINTER(4,PPTR),POINTER(PTR) REMOVE FROM CHAIN 00945000
BCTR CR,0 DECREMENT ELEMENT COUNT 00946000
SPACE 00947000
* CONTROL COMES HERE WHEN THE DESIRED BLOCK HAS BEEN REMOVED FROM 00948000
* THE CHAIN, WITH CR CONTAINING THE NEW CHAIN ELEMENT COUNT. 00949000
ALOCX EQU * 00950000
ST CR,NUM(,CHR) STORE ELEMENT COUNT 00951000
RTN ,0 RETURN RC=0 TO CALLER 00952000
FINDCHN EQU * 00954000
SPACE 00955000
* THIS SUBROUTINE IS CALLED BY 'FRET' TO DETERMINE ON WHICH OF THE FOUR 00956000
* CHAINS THE FRETTED BLOCK BELONGS (LOW VS HIGH CORE, USER VS NUCLEUS) 00957000
SPACE 00958000
* INPUT: 00959000
* BLR -> BLOCK 00960000
* SR = SIZE OF BLOCK 00961000
SPACE 00962000
* RESULTS: 00963000
* CHR -> CORRECT CHAIN 00964000
* FREEFLG1 FLAGS ARE SET AS FOLLOWS: 00965000
* FRF1N IF NUCLEUS BLOCK 00966000
* FRF1L IF LOW-CORE BLOCK 00967000
* FRF1H IF HIGH-CORE BLOCK 00968000
SPACE 00969000
* ERROR CHECKING: 00970000
* IF BLOCK DOES NOT BELONG ENTIRELY TO ONE CHAIN, A DIRECT 00971000
* RETURN IS MADE WITH RC=6. 00972000
* IF NOT DOUBLE-WORD ALIGNED, THEN RC=7 00973000
* IF SIZE <= 0 THEN RC=5 00974000
SPACE 2 00975000
LA XR,7 CHECK DOUBLE-WORD ALIGNMENT 00976000
NR XR,BLR 'AND' OUT HIGHORDER BITS 00977000
RTN NZ,7,FINIS RETURN RC=7 IF NOT DOUBLEWORD 00978000
LTR SR,SR CHECK SIZE 00979000
RTN NP,5,FINIS ERROR IF NOT > 0 00980000
C BLR,VMSIZE BLOCK ADDRESS IN MEMORY? P3015 00981000
RTN NL,6,FINIS RETURN CODE 6 IF NOT P3015 00982000
LR R14,BLR R14 -> BLOCK 00983000
ROUND DOWN,R14 ROUND DOWN TO PAGE BOUNDARY 00984000
LR R15,SR R15 = SIZE OF BLOCK 00985000
AR R15,BLR R15 -> END OF BLOCK 00986000
C R15,VMSIZE END OF BLOCK WITHIN MEMORY?P3015 00987000
RTN H,6,FINIS RETURN CODE 6 IF NOT P3015 00988000
ROUND UP,R15 ROUND UP R15 TO PAGE BOUNDARY 00989000
SR R15,R14 LENGTH OF PAGE GROUP CONTAINING *00990000
BLOCK 00991000
SRL R14,12 DIVIDE BY 4096: R14 = PAGE NUM 00992000
SRL R15,12 DIVIDE BY 4096: R15 = NUM PAGES 00993000
SPACE 00994000
* FREETAB CONTAINS ONE BYTE FOR EACH PAGE OF VIRTUAL MEMORY. THAT 00995000
* BYTE INDICATES WHETHER THAT PAGE IS ASSIGNED TO USER FREE/FRET 00996000
* STORAGE, NUCLEUS FREE/FRET STORAGE, OR UNASSIGNED TO FREE/FRET 00997000
* STORAGE. 00998000
* WE CHECK TO SEE IF ALL THE TYPES CORRESPONDING TO THE BLOCK 00999000
* BEING RETURNED ARE THE SAME, EITHER NUCLEUS OR USER. 01000000
AL R14,AFREETAB POINT TO FIRST BYTE IN FREETAB 01001000
SPACE 01002000
* HOWEVER, IF THE SECOND INITIALIZATION HAS NOT YET BEEN INVOKED, THEN 01003000
* FREETAB HAS NOT YET BEEN ALLOCATED. IN THIS CASE, WE SIMPLY POINT 01004000
* R14 TO A DUMMY BYTE CONTAINING THE NUCLEUS CODE. 01005000
TM FREEFLG2,FRF2NOI NO SECOND INITIALIZATION? 01006000
BNO *+8 SKIP IF THERE WAS ONE 01007000
LA R14,=AL1(NUCCODE) POINT TO DUMMY NUCCODE BYTE 01008000
SPACE 01009000
LA CHR,FREELN ASSUME NUCLEUS LOW-CORE CHAIN 01010000
CL BLR,AUSRAREA IS IT HIGH CORE? 01011000
BL *+8 SKIP IF NOT 01012000
LA CHR,FREEHN ASSUME NUCLEUS HIGH-CORE CHAIN 01013000
SPACE 01014000
* WE NOW EXAMINE THE BYTE IN FREETAB. 01015000
CLI 0(R14),MAXCODE GREATER THAN MAXIMUM CODE VALUE? 01016000
RTN H,30,FINIS IMPOSSIBLE IF HIGHER 01017000
CLI 0(R14),0 TEST IF ZERO 01018000
RTN E,31,FINIS IMPOSSIBLE IF SO 01019000
CLI 0(R14),NUCCODE IS IT NUCLEUS CODE? 01020000
BE FINDCHN1 GO IF NUCLEUS PAGE 01021000
CLI 0(R14),USERCODE IS IT USER CODE 01022000
RTN NE,6,FINIS ILLEGAL ARGS IF NOT 01023000
LA CHR,BLOCKLEN(,CHR) POINT TO CORRESPONDING USER *01024000
CHAIN IF SO 01025000
SPACE 01026000
* WHEN CONTROL REACHES THIS POINT, CHR POINTS TO THE CORRECT CHAIN, 01027000
* R14 POINTS TO THE FIRST FREETAB BYTE FOR THE GROUP OF PAGES, 01028000
* AND R15 CONTAINS THE NUMBER OF PAGES. 01029000
* WE FIRST SET THE FREEFLG1 FLAG BITS. 01030000
FINDCHN1 EQU * 01031000
TM FLAGS(CHR),FLNU NUCLEUS CHAIN? 01032000
BZ *+8 SKIP IF NOT 01033000
OI FREEFLG1,FRF1N SET NUCLEUS BIT 01034000
OI FREEFLG1,FRF1L DEFAULT LOW-CORE BIT 01035000
TM FLAGS(CHR),FLHC HIGH-CORE CHAIN? 01036000
BZ *+8 SKIP IF NOT 01037000
XI FREEFLG1,FRF1L+FRF1H SWITCH TO HIGHCORE BIT 01038000
SPACE 01039000
* WE NOW CHECK TO SEE IF ALL THE BYTES IN THE FREETAB TABLE FOR THIS 01040000
* PAGE GROUP ARE EQUAL. 01041000
SPACE 01042000
* HOWEVER, IF THE SECOND INITIALIZATION ROUTINE HAS NOT YET BEEN 01043000
* INVOKED, THEN THERE IS NOTHING MORE TO DO. 01044000
TM FREEFLG2,FRF2NOI NO SECOND INITIALIZATION? 01045000
RTN O,0 NORMAL RETURN IF NONE 01046000
SPACE 01047000
IC XR,0(R14) GET FIRST BYTE FROM TABLE 01048000
SLL XR,24 PUT INTO HIGH BYTE OF REG 01049000
SPACE 01050000
* NOTE: XR IS AN ODD-NUMBERED REGISTER WHICH CONTAINS A ZERO ADDRESS 01051000
* AND A PAD CHARARACTER EQUAL TO THE CHARACTER IN THE TABLE. THE 01052000
* CONTENTS OF REGISTER (XR-1) ARE IRRELEVANT. 01053000
CLCL R14,XR-1 CHECK TO SEE IF BYTES ARE ALL *01054000
THE SAME 01055000
USING FRDSECT,TR 01056000
RTN E,0 RETURN RC=0 IF THEY ARE 01057000
RTN ,6,FINIS OTHERWISE, ILLEGAL ARG 01058000
GEXT EQU * 01060000
SPACE 01061000
* ALLOCATE 'EXTEND' PAGE OF PAGES. 01062000
SPACE 01063000
* AT ENTRY: 01064000
* SR = NUMBER OF BYTES REQUIRED (MUST BE PAGE MULTIPLE) 01065000
SPACE 01066000
* NORMAL RETURN: 01067000
* BLR -> ALLOCATED BLOCK OR EXTEND STORAGE 01068000
* SR IS UNCHANGED (= SIZE OF BLOCK) 01069000
SPACE 01070000
* ERROR RETURN: 01071000
* RC=1 IF REQUEST STORAGE IS NOT AVAILABLE 01072000
SPACE 2 01073000
L BLR,FREELOWE LOAD LOW EXTEND POINTER 01074000
SR BLR,SR TENTATIVE NEW LOW EXTEND VALUE 01075000
SPACE 01076000
* THE NEW LOW EXTEND MUST EXCEED MAINHIGH, LOCCNT, AND AUSRAREA. 01077000
C BLR,MAINHIGH COMPARE WITH END OF GETMAIN AREA 01078000
RTN L,1 ERROR RETURN IF LOWER 01079000
TM BATFLAGS,BATLOAD IS BATCH BEING LOADED ? @VA05381 01079330
BO CKUAREA YES, DON'T CHECK AGAINST LOCCNT @VA05381 01079660
CL BLR,LOCCNT COMPARE WITH LOADER LOCATION *01080000
COUNTER 01081000
RTN L,1 ERROR RETURN IF LOWER 01082000
CKUAREA EQU * @VA05381 01082500
CL BLR,AUSRAREA COMPARE WITH USER PROGRAM ADDR 01083000
RTN L,1 ERROR RETURN IF LOWER 01084000
ST BLR,FREELOWE STORE NEW LOW EXTEND VALUE 01085000
RTN ,0 RETURN RC=0 01086000
SCHFIX EQU * 01088000
SPACE 01089000
* SEARCH THE SPECIFIED FREE CHAIN FOR A BLOCK OF THE DESIRED SIZE, AND 01090000
* ALLOCATE IT AND RETURN ITS ADDRESS. 01091000
SPACE 01092000
* AT ENTRY: 01093000
* SR = SIZE OF DESIRED BLOCK 01094000
* CHR -> CHAIN HEADER BLOCK OF CHAIN TO BE SEARCHED 01095000
SPACE 01096000
* NORMAL RETURN: 01097000
* SEARCHED CHAIN IS ADJUSTED 01098000
* BLR -> ALLOCATED BLOCK 01099000
SPACE 01100000
* ERROR RETURN: 01101000
* RC = 1 (NO STORAGE AVAILABLE) 01102000
* CHAIN IS LEFT UNCHANGED 01103000
SPACE 2 01104000
L CR,NUM(,CHR) GET NUM OF ELEMENTS ON CHAIN 01105000
LTR CR,CR ANY ELEMENTS? 01106000
RTN Z,1 RETURN RC=1 IF NOTHING TO DO 01107000
CL SR,MAX(,CHR) SR EXCEED MAX BLOCK ON CHAIN? 01108000
RTN H,1 IF YES, NO POINT IN EVEN *01109000
CHECKING -- RETURN RC=1 01110000
LR PTR,CHR INITIALIZER CHAIN ELEMENT PTR 01111000
LA R14,SCHFIXL FOR SPEED IN LOOP 01112000
LA R15,SCHFIXF FOR SPEED IN LOOP 01113000
SPACE 01114000
* THE FOLLOWING LOOP SEARCHES FOR THE FIRST FREE ELEMENT IN THE 01115000
* CHAIN WHICH IS LARGE ENOUGH TO ACCOMODATE THE REQUEST. 01116000
CNOP 0,8 FOR SPEED 01117000
SCHFIXL EQU * 01118000
LR PPTR,PTR ADVANCE ONE CHAIN ELEMENT 01119000
L PTR,POINTER(,PTR) 01120000
CL SR,SIZE(,PTR) CHAIN ELEMENT BIG ENOUGH? 01121000
BCR 13,R15 (BNH SCHFIXF) GO IF YES 01122000
BCTR CR,R14 (BCT CR,SCHFIXL) COUNT BLOCKS AND LOOP BACK 01123000
SPACE 01124000
* COME HERE IF WE'VE RUN OUT OF BLOCKS 01125000
* FIRST, RESET MAX TO ONE LESS THAN CURRENT SEARCH VALUE. 01126000
LR XR,SR XR = BLOCK BEING SEARCHED FOR 01127000
BCTR XR,0 DECREMENT BY ONE 01128000
ST XR,MAX(,CHR) STORE AS NEW MAX 01129000
L PTR,POINTER(,PTR) LOAD NEXT POINTER 01130000
LTR PTR,PTR IT HAD BETTER BE ZERO 01131000
RTN Z,1 IF SO, RETURN RC=1 (NO CORE) 01132000
RTN ,55,CLOB CHAIN CLOBBERED IF NOT 01133000
SPACE 2 01134000
* COME HERE IF A CHAIN ELEMENT IS BIG ENOUGH. AT THIS POINT, THE 01135000
* FOLLOWING REGISTERS ARE SET: 01136000
* PTR -> CURRENT FREE CHAIN ELEMENT 01137000
* PPTR -> PREVIOUS FREE CHAIN ELEMENT (OR CHAIN HEADER) 01138000
* CHR -> CHAIN HEADER 01139000
SPACE 01140000
* THE CONDITION IS STILL SET FROM THE LASE 'CL SR,SIZE(,PTR)' 01141000
* INSTRUCTION. 01142000
SCHFIXF EQU * 01143000
BE SCHFIXE GO IF CHAIN ELT IS EXACTLY RIGHT 01144000
SPACE 01145000
* OTHERWISE, WE MUST LOP OFF THE BOTTOM PART OF THE BLOCK AND ALLOCATE 01146000
* THE TOP PART OF THE REQUIRED SIZE. 01147000
L XR,SIZE(,PTR) GET SIZE OF CHAIN ELEMENT 01148000
SR XR,SR COMPUTE SIZE REMAINING IN *01149000
BOTTOM PART 01150000
ST XR,SIZE(,PTR) STORE NEW BLOCK SIZE 01151000
LA BLR,0(XR,PTR) ADDRESS OF ALLOCATED BLOCK 01152000
RTN ,0 RETURN RC=0 01153000
SPACE 2 01154000
* COME HERE IF THE CHAIN ELEMENT IS EXACTLY THE SIZE REQUESTED. 01155000
SCHFIXE EQU * 01156000
MVC 0(4,PPTR),0(PTR) REMOVE CHAIN ELEMENT FROM CHAIN 01157000
L CR,NUM(,CHR) DECREMENT ELEMENT COUNT 01158000
BCTR CR,0 01159000
ST CR,NUM(,CHR) 01160000
LR BLR,PTR POINT TO ALLOCATED BLOCK 01161000
RTN ,0 AND RETURN 01162000
SCHPAGE EQU * 01164000
SPACE 01165000
* SEARCH SPECIFIED CHAIN FOR FULL PAGE(S). WILL RETURN BLOCK ONLY 01166000
* PAGE-ALIGNED AND ONLY A MULTIPLE OF A PAGE. 01167000
SPACE 01168000
* INPUT: 01169000
* CHR -> CHAIN 01170000
* SR = SIZE OF BLOCK (PAGE MULTIPLE) 01171000
SPACE 01172000
* NORMAL RETURN 01173000
* BLR -> BLOCK, REMOVED FROM CHAIN 01174000
SPACE 01175000
* ERROR RETURN 01176000
* BLR = GARBAGE 01177000
* RC = 1 (NO CORE AVAILABLE) 01178000
SPACE 01179000
NI FREEFLG2,X'FF'-FRF2SVP TURN OFF SCHVPGE FLAG 01180000
B SCHPC 01181000
EJECT 01182000
SCHVPGE EQU * 01183000
SPACE 01184000
* SCHVPGE IS LIKE SCHPAGE, EXCEPT THAT IT IS USED FOR VARIABLE 01185000
* REQUESTS, AND RETURNS AN ENTIRE BLOCK OF PAGES WHICH IS GREATER THAN 01186000
* OR EQUAL TO THE DESIRED MINIMUM SIZE. 01187000
SPACE 01188000
* AT ENTRY: 01189000
* SR = MINIMUM SIZE IN BYTES (MULTIPLE OF PAGE SIZE) 01190000
SPACE 01191000
* NORMAL RETURN: 01192000
* SR = ACTUAL SIZE ALLOCATED 01193000
* BLR -> ALLOCATED BLOCK 01194000
SPACE 01195000
* ERROR RETURN 01196000
* RC = 1 (NO STORAGE AVAILABLE) 01197000
SPACE 2 01198000
OI FREEFLG2,FRF2SVP SET SCHVPGE FLAG 01199000
EJECT 01200000
* COMMON BRANCH POINT FOR SCHPAGE AND SCHVPGE. THE FLAG FRF2SVP 01201000
* IN FREEFLG2 IS SET IF AND ONLY IF SCHVPGE WAS THE ENTRY POINT. 01202000
SCHPC EQU * 01203000
TM FLAGS(CHR),FLPA PAGE AVAILABLE ON CHAIN? 01204000
RTN Z,1 JUST RETURN (RC=1) IF NOT 01205000
L CR,NUM(,CHR) GET NUMBER OF BLOCKS 01206000
LTR CR,CR ANY IN THE CHAIN? 01207000
RTN Z,1 THEN THERE'S NO USE LOOKING 01208000
CL SR,MAX(,CHR) DOES ANY BLOCK OF MIN SIZE *01209000
EXIST IN THE CHAIN? 01210000
RTN H,1 RETURN RC=1 IF NOT 01211000
LA R14,SCHPAGL TO SPEED UP LOOP 01212000
LA R15,SCHPAGF TO SPEED UP LOOP 01213000
LR PTR,CHR INITIALIZE CHAIN ELEMENT PTR 01214000
SPACE 01215000
* WE USE THE HIGH BYTE OF REG RR AS A FLAG BYTE TO INDICATE THAT NO 01216000
* BLOCK OF THE REQUIRED MINIMUM SIZE WAS FOUND. (OF COURSE, JUST 01217000
* FINDING A LARGE ENOUGH BLOCK IS NOT ENOUGH. IT MAY BECOME TOO 01218000
* SMALL WHEN WE ALIGN IT TO PAGE BOUNDARIES.) 01219000
O RR,=AL1(X'FF',0,0,0) NO BLOCK FOUND YET 01220000
SPACE 01221000
* THE FOLLOWING LOOP SEARCHES FOR A BLOCK OF THE REQUIRED MIN SIZE. 01222000
CNOP 0,8 FOR SPEED 01223000
SCHPAGL EQU * 01224000
LR PPTR,PTR MOVE UP ONE CHAIN ELEMENT 01225000
L PTR,POINTER(,PTR) 01226000
CL SR,SIZE(,PTR) CHAIN ELEMENT LARGE ENOUGH? 01227000
BCR 13,R15 (BNH SCHPAGF) GO IF BIG ENOUGH 01228000
SPACE 01229000
* A RETURN IS MADE TO SCHPAGLR IF THE BLOCK WHICH IS BIG ENOUGH NOW 01230000
* TURNS OUT TO BE TOO SMALL WHEN IT IS ROUNDED TO PAGE BOUNDARIES. 01231000
SCHPAGLR EQU * 01232000
BCTR CR,R14 (BCT CR,SCHPAGL) COUNT FREE ELEMENTS 01233000
SPACE 01234000
* COME HERE WHEN WE'VE RUN OUT OF BLOCKS. 01235000
LR XR,SR COPY REQUESTED SIZE 01236000
BCTR XR,0 DECREMENT 01237000
LTR RR,RR WAS ANY BLOCK FOUND? 01238000
BNM SCHPAGL1 SKIP RESETTING CODE IF SO 01239000
ST XR,MAX(,CHR) STORE NEW MAX FIELD 01240000
CL SR,PAGESIZE SIZE REQUESTED > 1 PAGE? 01241000
BH *+8 SKIP IF YES 01242000
NI FLAGS(CHR),X'FF'-FLPA TURN OFF 'PAGE AVAILABLE' FLAG 01243000
SPACE 01244000
SCHPAGL1 EQU * 01245000
L PTR,POINTER(,PTR) LOAD NEXT POINTER 01246000
LTR PTR,PTR ANYTHING THERE? 01247000
RTN Z,1 RETURN RC=1 IF NOT 01248000
RTN ,56,CLOB IMPOSSIBLE CONDITION IF SO 01249000
SPACE 01250000
* CONTROL COMES HERE WHEN A BIG ENOUGH BLOCK IS FOUND. WE MUST PAGE 01251000
* ALIGN THE BLOCK AND SEE IF IT'S STILL BIG ENOUGH. 01252000
SCHPAGF EQU * 01253000
LA RR,0(,RR) INDICATE THAT SOME BLOCK WAS FND 01254000
LR BLR,PTR POINTER TO FREE ELEMENT 01255000
ROUND UP,BLR ROUND UP TO PAGE BOUNDARY 01256000
LR XR,PTR POINTER TO FREE ELEMENT 01257000
A XR,SIZE(,PTR) POINTER TO END OF FREE ELEMENT 01258000
SR XR,BLR NUMBER OF BYTES BEYOND PAGE *01259000
BOUNDARY 01260000
CLR SR,XR STILL BIG ENOUGH? 01261000
BH SCHPAGLR RE-ENTER SEARCH LOOP IF NOT 01262000
SPACE 01263000
* CONTROL COMES HERE IF THE BLOCK AT PTR IS INDEED BIG ENOUGH. 01264000
* WE NOW MAKE AN ADJUSTMENT, FOR SCHPGE ONLY, IN CASE THERE ARE 01265000
* MORE PAGES AVAILABLE THAN WE NEED. IN THIS CASE, WE GRAB ONLY THE 01266000
* HIGHEST PAGES. 01267000
SPACE 01268000
* AT THIS POINT, REGISTERS ARE AS FOLLOWS: 01269000
* PTR -> FREE BLOCK 01270000
* BLR = PTR ROUNDED UP TO PAGE BOUNDARY 01271000
* XR = SIZE OF FREE ELEMENT FROM BLR ON UP 01272000
SPACE 01273000
* IN ADDITION, THE CONDITION CODE IS STILL SET FROM 'CLR SR,XR'. 01274000
BE SCHPAGC GO IF REST OF BLOCK = SIZE *01275000
DESIRED -- JUST TAKE IT. 01276000
SPACE 01277000
* OTHERWISE, IT'S TOO BIG. 01278000
LR R14,XR SIZE OF FREE ELT FROM BLR UP 01279000
ROUND DOWN,R14 ROUND DOWN TO PAGE BOUNDARY 01280000
TM FREEFLG2,FRF2SVP SCHVPGE ENTRY? 01281000
BZ *+10 SKIP TWO IF SCHPAGE 01282000
LR SR,R14 SR = ENTIRE PAGE BLOCK SIZE 01283000
B SCHPAGC GO ALLOCATE IT 01284000
SPACE 01285000
* MAYBE JUST THE PAGE BLOCK IS THE RIGHT SIZE. 01286000
CLR R14,SR 01287000
BE SCHPAGC GO IF IT'S JUST THE RIGHT SIZE 01288000
SPACE 01289000
* WE MUST MOVE THE POINTERS UP SO THAT WE ALLOCATE THE HIGHEST PAGES. 01290000
SR R14,SR R14=NUMBER OF PAGES TO ADVANCE 01291000
SR XR,R14 UPDATE XR 01292000
AR BLR,R14 UPDATE BLR 01293000
SPACE 01294000
* AT THIS POINT, WE HAVE: 01295000
* BLR -> BLOCK DESIRED 01296000
* SR = SIZE DESIRED 01297000
* PTR -> FREE CHAIN ELEMENT WHICH MUST BE SUB-DIVIDED 01298000
* PPTR -> PREVIOUS FREE CHAIN ELEMENT 01299000
SPACE 01300000
* WE NOW ENTER THE ALOC SUBROUTINE TO ALLOCATE THE THE SUB-BLOCK. 01301000
SCHPAGC EQU * 01302000
B ALOCC 01303000
SCHVAR EQU * 01305000
SPACE 01306000
* FOR VARIABLE SEARCHES, SEARCH SPECIFIED CHAIN FOR LARGEST BLOCK 01307000
* EXCEEDING A GIVEN MINIMUM SIZE. THIS ROUTINE DOES NOT REMOVE THE 01308000
* BLOCK FROM THE CHAIN. 01309000
SPACE 01310000
* AT ENTRY: 01311000
* SR = MINIMUM SIZE WHICH MUST BE EXCEEDED 01312000
* CHR -> CHAIN HEADER FOR DESIRED CHAIN 01313000
SPACE 01314000
* NORMAL RETURN: 01315000
* RC = 0 01316000
* SR = SIZE OF BLOCK FOUND 01317000
* BLR = ADDRESS OF BLOCK FOUND 01318000
SPACE 01319000
* ERROR RETURN (NO BLOCK OF REQUIRED MINIMUM SIZE) 01320000
* RC = 1 (NO STORAGE AVAILABLE) 01321000
* SR, BLR ARE UNCHANGED 01322000
SPACE 2 01323000
L CR,NUM(,CHR) GET FREE ELEMENT COUNT 01324000
LTR CR,CR ANY ELEMENTS? 01325000
RTN Z,1 RETURN RC=1 TO CALLER IF NOT 01326000
CL SR,MAX(,CHR) DESIRED SIZE >= CHAIN MAX? 01327000
RTN NL,1 RETURN RC=1 TO CALLER IF NOT 01328000
LR PTR,CHR INITIALIZE PTR 01329000
SR XR,XR INDICATE NO BLOCK WAS FOUND 01330000
LA R15,SCHVARF FOR SPEED IN LOOP 01331000
LA R14,SCHVARL FOR SPEED IN LOOP 01332000
SPACE 01333000
* THIS LOOP SEARCHES THE CHAIN FOR A LARGE ENOUGH BLOCK. 01334000
SCHVARL EQU * 01335000
LR PPTR,PTR MOVE POINTERS UP ONE ELEMENT 01336000
L PTR,POINTER(,PTR) 01337000
CL SR,SIZE(,PTR) BLOCK LARGER THAN MIN SIZE? 01338000
BCR 11,R15 (BNL SCHVARF) SKIP IF TOO SMALL 01339000
BCTR XR,0 INDICATE THAT A BLOCK WAS FOUND 01340000
LR BLR,PTR POINT TO THE BLOCK 01341000
L SR,SIZE(,BLR) SET NEW MINIMUM SIZE 01342000
SPACE 01343000
SCHVARF EQU * 01344000
BCTR CR,R14 (BCT CR,SCHVARL) COUNT BLOCKS 01345000
SPACE 01346000
* COME HERE WHEN THE ENTIRE CHAIN HAS BEEN SEARCHED. 01347000
ST SR,MAX(,CHR) SET CORRECT MAXIMUM 01348000
L PTR,POINTER(,PTR) LOOK AT NEXT POINTER 01349000
LTR PTR,PTR ANYTHING THERE? 01350000
RTN NZ,57,CLOB CHAIN CLOBBERED IF SO 01351000
LTR XR,XR ANY BLOCK FOUND? 01352000
RTN M,0 YES, IF XR < 0 01353000
RTN ,1 IF NOT, RETURN RC=1 (NO CORE) 01354000
SETCODE EQU * 01356000
SPACE 01357000
* SET CODES IN FREETAB TO INDICATED VALUE. 01358000
SPACE 01359000
* AT ENTRY: 01360000
* BLR -> PAGE BLOCK WHOSE FREETAB BYTES ARE TO BE CHANGED 01361000
* SR = SIZE OF PAGE BLOCK (PAGE MULTIPLE) 01362000
* CHR -> CHAIN HEADER, WHOSE 'TCODE' FIELD INDICATES VALUE TO 01363000
* WHICH THE FREETAB BYTES FOR THIS BLOCK ARE TO BE SET. 01364000
SPACE 01365000
* NOTE: NORMAL RETURN IS ALWAYS MADE 01366000
SPACE 2 01367000
IC XR,TCODE(,CHR) GET NEW CODE VALUE 01368000
B SETCODC GO TO COMMON CODE 01369000
SPACE 5 01370000
SETCODEN EQU * 01371000
SPACE 01372000
* SAME AS SETCODE, BUT CODE IS SET TO 'UNASSIGNED'. 01373000
LA XR,USARCODE USE USER AREA CODE 01374000
B SETCODC BRANCH TO COMMON CODE 01375000
SPACE 3 01376000
* THE FOLLOWING IS USED BY THE INITIALIZATION ROUTINES -- THE PROPER 01377000
* CODE IS ALREADY IN XR. 01378000
SETCODEI EQU * 01379000
SPACE 5 01380000
* COMMON BRANCH POINT FOR SETCODE AND SETCODEN. 01381000
SETCODC EQU * 01382000
SPACE 01383000
* IF THE SECOND INITIALIZATION ROUTINE HAS NOT YET BEEN INVOKED, THEN 01384000
* THERE IS NOTHING TO DO. 01385000
TM FREEFLG2,FRF2NOI NO SECOND INITIALIZATION? 01386000
RTN O,0 NORMAL RETURN IF NONE 01387000
SPACE 01388000
LR R14,BLR R14 = PAGE BLOCK ADDRESS 01389000
SRL R14,12 DIVIDE BY 4096 TO GET PAGE NUMB 01390000
AL R14,AFREETAB POINT TO FIRST BYTE IN FREETAB *01391000
TO BE MODIFIED 01392000
LR R15,SR SIZE OF PAGE BLOCK IN BYTES 01393000
SRL R15,12 DIVIDE BY 4096 TO NUMBER PAGES 01394000
SLL XR,24 PUT VALUE INTO HIGH ORDER BYTE 01395000
SPACE 01396000
* NOTE: XR IS AN ODD-NUMBERED REGISTER WHICH CONTAINS A ZERO ADDRESS 01397000
* FIELD AND A PAD CHARACTER (IN THE HIGH ORDER BYTE) EQUAL TO THE 01398000
* CHARACTER TO BE PLACED IN THE TABLE. 01399000
* THE CONTENTS OF REGISTER (XR-1) ARE IRRELEVANT. 01400000
MVCL R14,XR-1 FILL IN CHARACTER 01401000
USING FRDSECT,TR 01402000
RTN ,0 NORMAL RETURN 01403000
SETKEY EQU * 01405000
SPACE 01406000
* SET STORAGE KEYS 01407000
SPACE 01408000
* AT ENTRY: 01409000
* BLR -> BLOCK OF STORAGE FOR WHICH STORAGE KEYS ARE TO BE 01410000
* CHANGED (PAGE-ALIGNED) 01411000
* SR = SIZE OF BLOCK (MULTIPLE OF PAGE SIZE) 01412000
* CHR -> CHAIN HEADER, WHOSE 'SKEY' FIELD CONTAINS THE NEW 01413000
* STORAGE KEY VALUE FOR THESE PAGES 01414000
SPACE 01415000
* NOTE: NORMAL RETURN IS ALWAYS MADE 01416000
SPACE 2 01417000
IC XR,SKEY(,CHR) GET STORAGE KEY 01418000
B SETKEYG GO TO COMMON CODE 01419000
SPACE 5 01420000
SETKEYN EQU * 01421000
SPACE 01422000
* SAME AS SETKEY, EXCEPT THAT 'UNASSIGNED' STORAGE KEY IS SET. 01423000
LA XR,USERKEY SET USER KEY 01424000
B SETKEYG GO TO COMMON CODE 01425000
SPACE 3 01426000
SETKEYI EQU * 01427000
SPACE 5 01428000
* COMMON BRANCH POINT FOR SETKEY AND SETKEYN 01429000
SETKEYG EQU * 01430000
LR R14,BLR POINTER TO PAGE BLOCK 01431000
LR R15,SR SIZE OF PAGE BLOCK 01432000
SPACE 01433000
* SSK LOOP 01434000
SETKEYL EQU * 01435000
SSK XR,R14 SET STORAGE KEY OF 1ST HALF OF *01436000
PAGE 01437000
LA R14,2048(,R14) ADVANCE POINTER TO SECOND HALF 01438000
SSK XR,R14 SET STORAGE KEY OF SECOND HALF 01439000
LA R14,2048(,R14) ADVANCE TO NEXT PAGE 01440000
S R15,PAGESIZE SUBTRACT PAGESIZE FROM TOTAL *01441000
SIZE 01442000
BP SETKEYL LOOP IF THERE IS MORE TO DO 01443000
BM *+8 @VA00980 01444100
SETKEYR SR R15,R15 @VA00980 01444200
BR RR @VA00980 01444300
RTN ,24,FINIS IMPOSSIBLE CONDITION IF NEGATIVE 01445000
SFRT EQU * 01447000
SPACE 01448000
* FRET SUBROUTINE -- ADD A BLOCK TO A SPECIFIED CHAIN. 01449000
SPACE 01450000
* AT ENTRY: 01451000
* CHR -> CHAIN HEADER FOR CHAIN TO BE MODIFIED 01452000
* BLR -> BLOCK TO BE ADDED TO CHAIN 01453000
* SR = SIZE OF BLOCK TO BE ADDED TO CHAIN 01454000
SPACE 01455000
* AT RETURN: 01456000
* BLR AND SR ARE SET UP TO INDICATE THE BLOCK ON THE CHAIN 01457000
* WHICH CONTAINS THE BLOCK WHICH WAS RETURNED. THAT IS, 01458000
* IF THE RETURNED BLOCK DID NOT COMBINE WITH ANY OTHER BLOCK, 01459000
* THEN BLR AND SR INDICATE THE RETURNED BLOCK. IF THE RETURNED 01460000
* BLOCK DID COMBINE, THEN BLR AND SR INDICATE THE TOTAL BLOCK 01461000
* ON THE FREE CHAIN. 01462000
* BLR -> BLOCK ON FREE CHAIN CONTAINING RETURNED BLOCK 01463000
* SR = SIZE OF THIS BLOCK 01464000
SPACE 01465000
ST SR,SIZE(,BLR) SET SIZE FIELD OF RETURNED BLOCK 01466000
LR XR,SR XR = SIZE OF RETURNED BLOCK 01467000
AR XR,BLR XR -> END OF RETURNED BLOCK 01468000
LR PTR,CHR INITIALIZE CHAIN POINTER 01469000
LA R15,SFRTL FOR SPEED IN LOOP 01470000
SPACE 01471000
* SEARCH LOOP -- FINDS THE PLACE WHERE THE NEW BLOCK BELONGS. 01472000
CNOP 0,8 FOR SPEED 01473000
SFRTL EQU * 01474000
LR PPTR,PTR MOVE POINTERS AHEAD ONE BLOCK 01475000
L PTR,POINTER(,PTR) 01476000
CLR XR,PTR END OF NEW BLOCK ABOVE OLD BLK? 01477000
BCR 4,R15 (BL SFRTL) YES -- LOOP BACK AND CONTINUE 01478000
SPACE 01479000
* WE DROP THROUGH THE LOOP WHEN WE HAVE FOUND THE POSITION IN 01480000
* THE CHAIN WHERE THE BLOCK BELONGS. 01481000
* WHEN CONTROL COMES TO THIS POINT, THEN REGISTERS ARE AS FOLLOWS: 01482000
SPACE 01483000
* BLR -> NEW BLOCK 01484000
* XR -> END OF NEW BLOCK 01485000
* SR = SIZE OF NEW BLOCK (= XR - BLR) 01486000
SPACE 01487000
* PTR AND PPTR -> CHAIN ELEMENTS SUCH THAT ONE OF THE FOLLOWING 01488000
* IS TRUE: 01489000
SPACE 01490000
* CASE 1. 01491000
* XR = PTR 01492000
* BLR > POINTER(,PTR) + SIZE OF BLOCK BELOW NEW BLOCK 01493000
* IN THIS CASE, THE NEW BLOCK COMBINES WITH THE PTR BLOCK 01494000
* ABOVE IT, BUT LIES ABOVE THE POINTER(,PTR) BLOCK AND 01495000
* DOES NOT COMBINE WITH IT. 01496000
SPACE 01497000
* CASE 2. 01498000
* XR = PTR 01499000
* BLR = POINTER(,PTR) + SIZE OF BLOCK BELOW NEW BLOCK 01500000
* IN THIS CASE, THE NEW BLOCK COMBINES WITH THE PTR BLOCK 01501000
* ABOVE IT AND WITH THE POINTER(,PTR) BLOCK BELOW. 01502000
SPACE 01503000
* CASE 3. 01504000
* XR > PTR 01505000
* BLR = PTR + SIZE(,PTR) 01506000
* IN THIS CASE, THE NEW BLOCK CAN BE COMBINED WITH THE 01507000
* PTR BLOCK BELOW IT. 01508000
SPACE 01509000
* CASE 4. 01510000
* XR > PTR 01511000
* BLR > PTR + SIZE(,PTR) 01512000
* IN THIS CASE, THE NEW BLOCK LIES STRICTLY BETWEEN THE 01513000
* PTR BLOCK AND THE PPTR BLOCK, AND DOES NOT COMBINE WITH 01514000
* ANYTHING. (THIS CASE ALSO ARISES IF PTR = 0 -- THE NEW 01515000
* BLOCK GOES ON THE END OF THE CHAIN.) 01516000
SPACE 01517000
* IN ADDITION, THE CONDITION CODE IS STILL SET FROM THE 01518000
* INSTRUCTION 'CLR XR, PTR' 01519000
SFRTLO EQU * 01520000
L CR,NUM(,CHR) GET NUMBER OF ELEMENTS ON CHAIN 01521000
BE SFRTC123 GO IF CASES 1 OR 2 01522000
SPACE 01523000
* CASES 3 OR 4; ALSO CASES 1 AND 2 AFTER LOADING NEXT LOWER PTR 01524000
SFRTC34 EQU * 01525000
LTR R14,PTR ANY PTR POINTER? 01526000
BZ SFRTC4 CASE 4 IF NOT 01527000
AL R14,SIZE(,PTR) R14 -> END OF PTR BLOCK 01528000
CLR R14,BLR COMBINE BLR AND PTR BLOCKS? 01529000
RTN H,6,FINIS NEW BLOCK OVERLAPS PTR BLOCK 01530000
BL SFRTC4 FINISHED IF BLOCKS ARE NON-CONTIGUOUS @VA08663 01531000
SPACE 01532000
* COME HERE ON CASES 1, 2 OR 3 -- THE BLR BLOCK IS TO BE COMBINED WITH 01533000
* THE PTR BLOCK EITHER FROM ABOVE OR FROM BELOW. 01534000
SFRTC123 EQU * 01535000
AL SR,SIZE(,PTR) SIZE OF COMBINED BLOCKS 01536000
CLR BLR,PTR WHICH BLOCK IS LOWER IN CORE? 01537000
BL *+6 SKIP IF CASES 1 OR 2 01538000
LR BLR,PTR CASE 3 01539000
SPACE 01540000
* AT THIS POINT, BLR POINTS TO COMBINED BLOCK. 01541000
ST SR,SIZE(,BLR) STORE SIZE OF COMBINED BLOCK. 01542000
L PTR,POINTER(,PTR) POINT TO BLOCK FOLLOWING OLD PTR 01543000
BCTR CR,0 DECREMENT COUNT, BECAUSE OF *01544000
COMBINING JUST PERFORMED 01545000
ST PTR,POINTER(,PPTR) 01546000
SPACE 01547000
* NOW EVERYTHING IS SET UP FOR CASE 1 OR 2 AS IF FOR CASE 3 OR 4, WITH 01548000
* BLR NOW POINTING TO THE COMBINED BLOCK, AND PTR POINTING TO WHAT USED 01549000
* TO BE POINTER(,PTR). ALSO, CONDITION CODE FROM LAST CLR INSTRUCTION 01550000
* IS STILL SET. 01551000
BL SFRTC34 GO HANDLE FINISH-UP @VA08663 01552000
SFRTC4 EQU * 01554000
ST BLR,POINTER(,PPTR) PUT NEW BLOCK ONTO CHAIN 01555000
ST PTR,POINTER(,BLR) 01556000
LA CR,1(,CR) INCREMENT COUNT, SINCE WE HAVE *01557000
ADDED A BLOCK 01558000
SPACE 01559000
* AT THIS POINT, ALL THE BLOCKS ARE PROPERLY CHAINED, AND REGISTERS 01560000
* BLR AND SR ARE PROPERLY SET UP FOR EXIT. NOW WE NEED ONLY STORE THE 01561000
* NEW CHAIN HEADER VALUES, AND EXIT. 01562000
ST CR,NUM(,CHR) STORE NUMBER OF BLOCKS 01563000
CL SR,MAX(,CHR) SHOULD MAX BE UPDATED? 01564000
BL *+8 SKIP IF NOT 01565000
ST SR,MAX(,CHR) STORE IF SO 01566000
RTN ,0 NORMAL RETURN (RC=0) 01567000
RTNFINIS EQU * 01569000
RTNCLOB EQU * 01570000
RETURN EQU * 01571000
ST R15,FREESAVE+R15*4 STORE RETURN CODE IN SAVE AREA 01572000
LTR R15,R15 ANY RETURN CODE? 01573000
BNZ ERRORET GO HANDLE IT 01574000
SPACE 01575000
RETURN1 EQU * 01576000
TM FREEFLG1,FRF1E WAS THIS FREE CALL (NOT FRET) 01577000
BZ RETURN2 GO IF IT WAS FRET 01578000
ST BLR,FREESAVE+R1*4 STORE ALLOCATED BLOCK LOCATION 01579000
TM FREEFLG1,FRF1V+FRF1E WAS IT VARIABLE REQUEST? 01580000
BNO RETURN2 SKIP IF NOT 01581000
SRA SR,3 CONVERT SIZE TO DOUBLEWORDS 01582000
ST SR,FREESAVE+R0*4 AND STORE IN SAVE AREA 01583000
SPACE 01584000
RETURN2 EQU * 01585000
TM FREEFLG2,FRF2CL CLEAN-UP FLAG SET? 01586000
BO CLEANUP YES -- GO CLEAN UP 01587000
SPACE 01588000
RETURN3 EQU * 01589000
TM FREEFLG2,FRF2CKT CHECK FLAG SET? 01590000
BO CHECK YES -- GO CHECK 01591000
SPACE 01592000
RETURN4 EQU * 01593000
SPACE 01594000
RETURNE EQU * 01595000
LM R0,R15,FREESAVE RESTORE GENERAL REGISTERS 01596000
BR R14 AND RETURN TO CALLER 01597000
* PUT CONSTANTS AND LITERALS HERE TO KEEP HEAVILY USED PARTS 01599000
* OF ROUTINE IN ONE PAGE. 01600000
PAGESIZE DC A(4096) SIZE OF A PAGE IN BYTES 01601000
SPACE 2 01602000
LTORG 01603000
DS 0H 01604000
SPACE 01605000
* THIS ENDS THE HEAVILY USED PORTION OF DMSFRE. 01606000
SPACE 01607000
CLEANUP EQU * 01609000
SPACE 01610000
* THE CLEANUP ROUTINE IS ENTERED WHEN THE FRF2CL FLAG IS SET IN 01611000
* FREEFLG2. 01612000
* CLEANUP WILL TAKE PLACE FOR ALL CHAINS WHOSE HEADERS HAVE FLCLN FLAG 01613000
* ON IN THE 'FLAGS' BYTE. 01614000
SPACE 01615000
* THERE ARE TWO TYPES OF CLEANUP: 01616000
* 1. FOR NUCLEUS CHAINS, ANY FULL PAGES MUST BE REMOVED AND 01617000
* PLACED ON THE CORRESPONDING USER CHAINS. 01618000
* 2. FOR THE HIGH-CORE USER CHAIN, IT MAY BE POSSIBLE TO 01619000
* REMOVE STORAGE FROM CHAIN AND MOVE UP 'LOW EXTEND' POINTER. 01620000
SPACE 2 01621000
LA XR,4 NUMBER OF CHAINS 01622000
LA CHR,FREELN POINT TO FIRST HEADER BLOCK 01623000
SH CHR,=AL2(BLOCKLEN) AND BACK UP BY LENGTH OF ONE 01624000
BALR R14,0 (LA R14,CLEANUPL) SET R14 FOR SPEED IN LOOP 01625000
SPACE 01626000
CLEANUPL EQU * 01627000
LA CHR,BLOCKLEN(,CHR) POINT TO NEXT CHAIN HEADER BLK 01628000
TM FLAGS(CHR),FLCLN 'CLEANUP' FLAG SET? 01629000
BO CL GO CLEAN UP IF SO 01630000
BCTR XR,R14 (BCT XR,CLEANUPL) COUNT CHAINS 01631000
NI FREEFLG2,X'FF'-FRF2CL TURN OFF MAJOR CLEANUP FLAG 01632000
B RETURN3 AND RE-ENTER RETURN CODE 01633000
SPACE 2 01634000
* COME HERE IF A CHAIN HEADER BLOCK WITH THE CLEANUP FLAG ON IS 01635000
* FOUND. 01636000
CL EQU * 01637000
TM FLAGS(CHR),FLNU NUCLEUS CHAIN? 01638000
BO CLN GO HANDLE IT 01639000
SPACE 01640000
CL1 EQU * 01641000
TM FLAGS(CHR),FLHC HIGH-CORE CHAIN? 01642000
BO CLH GO HANDLE IT 01643000
SPACE 01644000
CL2 EQU * 01645000
NI FLAGS(CHR),X'FF'-FLCLN TURN OFF CLEANUP FLAG 01646000
B CLEANUP AND SEARCH FOR MORE DIRTY CHAINS 01647000
SPACE 01648000
* COME HERE TO CLEAN UP A NUCLEUS CHAIN. IT IS NECESSARY TO REMOVE 01649000
* COMPLETE PAGES FROM THE CHAIN. 01650000
CLN EQU * 01651000
TM FREEFLG2,FRF2NOI 2ND INITIALIZATION TAKEN PLACE? 01652000
BO CL1 NO -- NOTHING TO DO 01653000
L SR,PAGESIZE GET PAGE SIZE 01654000
BAL RR,SCHVPGE FIND ANY PAGES ON CHAIN 01655000
BNZ CL1 FINISHED IF NO FULL PAGES 01656000
TM FLAGS(CHR),FLHC IS THIS A HIGH-CORE CHAIN? 01657000
BZ CLN1 GO IF NOT HIGH CORE 01658000
CL BLR,FREELOWE IS THE BLOCK AT LOW EXTEND? 01659000
BNE CLN1 GO IF NOT 01660000
SPACE 01661000
* OTHERWISE, WE CAN INCREASE THE LOW EXTEND POINTER. 01662000
BAL RR,SETCODEN SET CODE TO UNASSIGNED 01663000
BAL RR,SETKEYN SET KEY TO UNASSIGNED 01664000
AR BLR,SR FIND END OF BLOCK 01665000
ST BLR,FREELOWE STORE NEW LOW EXTEND PTR 01666000
SPACE 01667000
* IT IS NOW POSSIBLE THAT THE HIGH-CORE USER CHAIN MAY NEED CLEANING 01668000
* UP, SINCE LOW EXTEND HAS BEEN CHANGED. 01669000
CLEANUP ,HU 01670000
B CL2 ALL FINISHED WITH THIS CHAIN 01671000
SPACE 01672000
* COME HERE IF THERE IS A PAGE BLOCK TO BE MOVED TO THE 01673000
* CORRESPONDING USER CHAIN. 01674000
CLN1 EQU * 01675000
LA CHR,BLOCKLEN(,CHR) POINT TO CORRESPONDING USER CHN 01676000
BAL RR,SETCODE SET USER CODE IN FREETAB 01677000
BAL RR,SETKEY SET USER STORAGE KEY 01678000
BAL RR,SFRT PUT PAGE BLOCK ON THAT CHAIN 01679000
OI FLAGS(CHR),FLPA SET PAGE AVAILABLE FLAG 01680000
SH CHR,=AL2(BLOCKLEN) POINT BACK TO NUC CHAIN 01681000
B CLN AND LOOK FOR MORE PAGES 01682000
SPACE 01683000
* FOR HIGH-CORE USER CHAIN, WE NEED ONLY SEE IF IT CAN BE 01684000
* DIS-EXTENDED. 01685000
CLH EQU * 01686000
TM FLAGS(CHR),FLPA PAGE AVAILABLE ON CHAIN? 01687000
BZ CL2 NOTHING TO DO IF NOT 01688000
L CR,NUM(,CHR) GET NUMBER OF BLOCKS ON CHAIN 01689000
LTR CR,CR ANY BLOCKS? 01690000
BZ CL2 GO IF NOT 01691000
L SR,PAGESIZE SIZE OF A PAGE 01692000
CL SR,MAX(,CHR) COMPARE WITH MAX SIZE ON CHAIN 01693000
BH CL2 WE'RE ALL THROUGH IF MAX TOO *01694000
SMALL 01695000
LA R14,CLHL FOR SPEED IN LOOP 01696000
LR PTR,CHR INITIALIZE PTR 01697000
SPACE 01698000
* THE FOLLOWING LOOP SIMPLY SEARCHES FOR THE LAST BLOCK IN THE 01699000
* CHAIN. 01700000
CNOP 0,8 FOR SPEED IN LOOP 01701000
CLHL EQU * 01702000
LR PPTR,PTR MOVE POINTERS AHEAD ONE BLOCK 01703000
L PTR,POINTER(,PTR) 01704000
BCTR CR,R14 (BCT CR,CLHL) COUNT BLOCKS 01705000
CLC =F'0',POINTER(PTR) CHECK FOR CLOBBERED CHAIN 01706000
RTN NE,61,CLOB CLOBBERED IF NONZERO 01707000
L SR,SIZE(,PTR) GET SIZE OF LAST BLOCK 01708000
ROUND DOWN,SR ROUND DOWN TO PAGE BOUNDARY 01709000
LTR SR,SR ANYTHING LEFT? 01710000
BZ CL2 WE'RE THROUGH IF NOT 01711000
LR BLR,PTR POINT TO BLOCK 01712000
CL BLR,FREELOWE IS IT A LOW-EXTEND? 01713000
BNE CL2 WE'RE THROUGH IF NOT 01714000
BAL RR,ALOCC ALLOCATE BLOCK 01715000
BAL RR,SETCODEN SET UNASSIGNED CODE 01716000
BAL RR,SETKEYN SET UNASSIGNED STORAGE KEY 01717000
ALR BLR,SR POINT TO END OF BLOCK 01718000
ST BLR,FREELOWE THAT'S THE NEW LOW-EXTEND VALUE 01719000
B CL2 AND WE'RE THROUGH 01720000
CHECK EQU * 01722000
SPACE 01723000
* CHECK TO SEE IF ALL CHAINS ARE CONSISTENT. 01724000
SPACE 01725000
* THIS ROUTINE DOES NOT MAKE ANY CHANGES TO THE CHAINS (NOT EVEN MAX). 01726000
* IT JUST CHECKS TO SEE IF EVERYTHING'S LEGAL. 01727000
SPACE 01728000
* IT WILL BE ENTERED IF THE 'FRF2CKT' FLAG IN FREEFLG2 IS SET. 01729000
SPACE 2 01730000
* THE FOLLOWING FLAG INDICATES THAT THE CHECK ROUTINE IS BEING 01731000
* EXECUTED. 01732000
OI FREEFLG2,FRF2CKX SET 'IN CHECK' FLAG 01733000
L XR,FREELOWE GET CURRENT LOW EXTEND VALUE 01734000
C XR,VMSIZE GREATER THAN SIZE OF STORAGE? 01735000
RTN H,84,CHKP CLOBBERED IF IT IS 01736000
C XR,AUSRAREA BELOW USER PROGRAM AREA? 01737000
RTN L,85,CHKP CLOBBERED IF IT IS 01738000
L SR,VMSIZE GET SIZE OF STORAGE 01739000
SRA SR,12 SR = SIZE OF FREETAB IN BYTES 01740000
L BLR,AFREETAB BLR -> FREETABL 01741000
LA R14,256 01742000
SPACE 01743000
* THE FOLLOWING LOOP CHECKS ALL THE BYTES IN FREETAB TO SEE IF THEY 01744000
* ARE WITHIN LEGAL RANGE. NOTE, FOR THE PURPOSES OF THE TRT USED 01745000
* IN THE LOOP, THAT XR2 = R2, SO THAT NOTHING IMPORTANT IS BEING 01746000
* CLOBBERED IN REGISTER 2. 01747000
CHECKF EQU * 01748000
LTR R15,SR ANY BYTES LEFT TO CHECK? 01749000
BZ CHECKF1 ALL THROUGH CHECKING IF NOT 01750000
CLR R15,R14 MORE THAN 256 BYTES LEFT? 01751000
BL *+6 SKIP IF NOT 01752000
LR R15,R14 USE 256 PER TRT, IF SO 01753000
SR SR,R15 SUBTRACT THIS NUMBER FROM TOTAL 01754000
BCTR R15,0 DECREMENT COUNT FOR EX 01755000
EX R15,CHECKFI DO THE TRT ON FREETAB 01756000
RTN NZ,86,CHKP ERROR IF NOT ALL ZERO 01757000
* FUNCTION VALUES 01758000
LA BLR,256(,BLR) INCREMENT POINTER INTO FREETAB 01759000
B CHECKF LOOP BACK FOR NEXT 256 BYTES 01760000
SPACE 01761000
CHECKFI TRT 0(0,BLR),CHECKFT LENGTH FIELD FILLED IN BY EX 01762000
SPACE 01763000
* THE FOLLOWING TRANSLATE TABLE SHOULD REALLY BE 256 BYTES LONG. 01764000
* HOWEVER, SINCE THE TABLE IS FOLLOWED BY EXECUTABLE CODE, THERE WILL 01765000
* NOT BE VERY MANY NON-ZERO BYTES IN THE STORAGE FOLLOWING IT. AS A 01766000
* RESULT, IT WILL BE SUFFICIENT FOR OUR PURPOSES. 01767000
CHECKFT DC AL1(1),(5)AL1(0) 01768000
DS 0H 01769000
EJECT 01770000
* WE NOW BEGIN THE MAIN WORK OF CHECKING ALL CHAINS FOR 01771000
* CONSISTENCY. 01772000
CHECKF1 EQU * 01773000
LA CHR,FREELN POINT TO LOW NUCLEUS CHAIN 01774000
B CHECKB GO ENTER OUTER LOOP AND CHECK IT 01775000
SPACE 01776000
* COME HERE EACH TIME A NEW CHAIN IS TO BE STARTED. 01777000
CHECKA EQU * 01778000
LR XR,CHR SAVE OLD CHAIN POINTER 01779000
LA CHR,BLOCKLEN(,CHR) ADVANCE TO NEXT CHAIN POINTER 01780000
TM FLAGS(XR),FLHC HAVE WE EXAMINED HIGH-CORE YET? 01781000
BZ CHECKB GO HANDLE NEXT CHAIN IF NOT 01782000
TM FLAGS(XR),FLNU WAS IT HIGH-CORE USER CHAIN? 01783000
BO CHECKB GO HANDLE HIGH USER CHAIN IF NOT 01784000
SPACE 01785000
* WE HAVE CHECKED ALL FOUR CHAINS 01786000
SPACE 01787000
* THE FOLLOWING TURNS OFF THE 'CHECK IN USE' AND THE 'ENTER CHECK 01788000
* THIS TIME' FLAGS 01789000
NI FREEFLG2,X'FF'-FRF2CKT-FRF2CKX TURN OFF FLAGS 01790000
SPACE 01791000
* IF THERE HAS BEEN AN ERROR, WE GO TO THE ERROR HANDLING CODE. 01792000
* OTHERWISE, WE JUST RETURN. 01793000
CLC =F'0',FREESAVE+4*R15 HAS THERE BEEN AN ERROR 01794000
BE RETURN4 JUST RETURN IF NOT 01795000
B ERCHK GO FINISH UP IF THERE HAS 01796000
SPACE 2 01797000
* COME HERE TO BEGIN PROCESSING A NEW CHAIN 01798000
* FIRST, CHECK TO SEE IF ANY HIGH BYTES HAVE BEEN CLOBBERED. 01799000
CHECKB EQU * 01800000
CLI POINTER(CHR),0 HIGH BYTE OF POINTER CLOBBERED? 01801000
RTN NE,82,CHK CLOBBERED IF NONZERO 01802000
CLI MAX(CHR),0 HIGH BYTE OF MAX CLOBBERED? 01803000
RTN NE,83,CHK CLOBBERED IF NONZERO 01804000
L CR,NUM(,CHR) NUMBER OF ELEMENTS IN CHAIN 01805000
LA CR,1(,CR) INCREMENT BY 1 FOR LOOP LOGIC 01806000
LR PTR,CHR INITIALIZE PTR 01807000
B CHECKLE ENTER LOOP AT THE END 01808000
SPACE 01809000
* THIS IS THE RETURN BRANCH POINT IN THE LOOP 01810000
CHECKL EQU * 01811000
LR PPTR,PTR MOVE UP POINTERS ONE BLOCK 01812000
L PTR,POINTER(,PTR) 01813000
LTR PTR,PTR DOES POINTER = 0? 01814000
RTN Z,70,CHK CHAIN CLOBBERED IF SO 01815000
LR BLR,PTR BLR -> CURRENT BLOCK 01816000
SPACE 01817000
* CHECK FOR DOUBLE WORD ALIGNED BLOCK. 01818000
L XR,=AL1(255,0,0,7) 01819000
NR XR,PTR ZERO OUT HIGHORDER BITS 01820000
RTN NZ,71,CHK IF NONZERO, THEN NOT ALIGNED 01821000
SPACE 01822000
* CHECK FOR DOUBLEWORD ALIGNED SIZE 01823000
L SR,SIZE(,PTR) GET SIZE OF BLOCK 01824000
L XR,=AL1(255,0,0,7) 01825000
NR XR,SR ZERO OUT HIGHORDER BITS 01826000
RTN NZ,72,CHK IF NONZERO, THEN NOT ALIGNED 01827000
SPACE 01828000
CLR PPTR,CHR IS THIS THE FIRST BLOCK ON THE *01829000
CHAIN? 01830000
BE CHECKLA YES -- SKIP NEXT TEST 01831000
LA XR,0(SR,BLR) XR -> END OF BLOCK 01832000
CLR XR,PPTR SEE IF BLOCKS ARE IN CORRECT *01833000
ORDER 01834000
RTN NL,73,CHK BLOCKS OVERLAP OR NOT CHAINED *01835000
IN ORDER 01836000
SPACE 01837000
CHECKLA EQU * 01838000
SPACE 01839000
* CHECK TO SEE IF BLOCKSIZE IS GREATER THAN MAX FOR THIS CHAIN. 01840000
CL SR,MAX(,CHR) COMPARE WITH MAX 01841000
RTN H,74,CHK CLOBBERED IF SIZE > MAX 01842000
SPACE 01843000
* WE CALL FINDCHN TO PERFORM THE CHECK TO SEE IF THE FREETAB TABLE IS 01844000
* CORRECT. THIS ROUTINE WILL ALSO CHECK TO MAKE SURE THAT THE BLOCK 01845000
* DOES NOT OVERLAP STORAGE ASSIGNED TO ANOTHER CHAIN. 01846000
LR XR2,CHR SAVE CHAIN POINTER 01847000
BAL RR,FINDCHN FIND CORRECT CHAIN POINTER 01848000
RTN NZ,75,CHK ERROR RETURN -> CLOBBERED 01849000
CLR XR2,CHR DID WE END UP WITH SAME CHAIN? 01850000
RTN NE,76,CHK BLOCK ON WRONG CHAIN 01851000
SPACE 01852000
* IF THE BLOCK CONTAINS A FULL PAGE, WE CHECK TO SEE IF: 01853000
* 1. THE 'PAGE AVAILABLE' (FLPA) FLAG IS ON IN THE FLAGS BYTE. 01854000
* 2. IF FREELOWE CAN BE DIS-EXTENDED. 01855000
* 3. IF THE CHAIN IS A NUCLEUS CHAIN (IN WHICH CASE, A FULL PAGE 01856000
* IS ILLEGAL) 01857000
CL SR,PAGESIZE COMPARE BLOCK SIZE WITH PAGESIZE 01858000
BL CHECKLB NOTHING TO DO IF SMALLER 01859000
LA XR,0(SR,BLR) XR -> END OF BLOCK 01860000
ROUND UP,BLR BLR -> BEGINNING OF EMBEDDED PGE 01861000
ROUND DOWN,XR XR -> END OF EMBEDDED PAGE BLOCK 01862000
CLR BLR,XR ARE THE TWO EQUAL? 01863000
BNL CHECKLB THEN THERE IS NO EMBEDDED PAGE 01864000
TM FLAGS(CHR),FLPA PAGE AVAILABLE FLAG ON? 01865000
RTN Z,77,CHK CHAIN CLOBBERED IF NOT 01866000
CL BLR,FREELOWE BLOCK AT LOW-EXTEND? 01867000
RTN E,78,CHK THAT SHOULDN'T HAVE HAPPENED 01868000
SPACE 01869000
* A FULL PAGE CANNOT APPEAR ON A NUCLEUS CHAIN, UNLESS THE SECOND 01870000
* INITIALIZATION HAS NOT YET TAKEN PLACE. 01871000
TM FLAGS(CHR),FLNU NUCLEUS CHAIN? 01872000
BZ CHECKLB OK IF NOT 01873000
TM FREEFLG2,FRF2NOI SECOND INIT TAKEN PLACE? 01874000
RTN NO,79,CHK CHAIN CLOBBERED IF IT HAS 01875000
SPACE 01876000
* WE CHECK THE VALIDITY OF THE FREELOWE POINTER. IF THIS IS A HIGH 01877000
* CORE CHAIN, THEN THIS BLOCK SHOULD LIE ABOVE FREELOWE, THE LOW 01878000
* EXTEND POINTER. 01879000
CHECKLB EQU * 01880000
LR BLR,PTR RESTORE BLR 01881000
CL BLR,FREELOWE COMPARE WITH LOW EXTEND 01882000
BNL CHECKLC IF HIGH OR EQUAL, THEN IT'S OK 01883000
TM FLAGS(CHR),FLHC IS THIS A HIGH-CORE CHAIN? 01884000
RTN O,80,CHK FREELOWE CLOBBERED IF SO 01885000
SPACE 01886000
CHECKLC EQU * 01887000
SPACE 01888000
* COME HERE AT END OF CHECKING EACH CHAIN. 01889000
CHECKLE EQU * 01890000
BCT CR,CHECKL COUNT BLOCKS ON CHAIN 01891000
CLC =F'0',POINTER(PTR) LAST POINTER = 0? 01892000
RTN NE,81,CHK COUNT IS WRONG IF NOT 01893000
B CHECKA 01894000
* THE CKON SERVICE ROUTINE TURNS ON A FLAG, SO THAT FROM THIS POINT 01896000
* ON A 'CHECK' WILL TAKE PLACE WITH EACH CALL TO DMSFRE. 01897000
CKON EQU * 01898000
OI FREEFLG2,FRF2CKE+FRF2CKT TURN ON FLAGS 01899000
RTN ,0,FINIS RETURN TO CALLER 01900000
SPACE 3 01901000
* THE CKOFF SERVICE ROUTINE TURNS OFF THIS FLAG. 01902000
CKOFF EQU * 01903000
NI FREEFLG2,X'FF'-FRF2CKE 01904000
RTN ,0,FINIS RETURN TO CALLER 01905000
SPACE 3 01906000
* THE CHECK SERVICE ROUTINE CAUSES A 'CHECK' TO BE PERFORMED. THIS 01907000
* WILL INVOLVE A COMPLETE CHECK OF ALL FREE CHAINS FOR IRREGULARITIES. 01908000
CHECKS EQU * 01909000
OI FREEFLG2,FRF2CKT SIGNAL A CHECK 01910000
RTN ,0,FINIS RETURN TO CALLER 01911000
* USER FREE STORAGE RECOVERY SERVICE ROUTINE. 01913000
* THIS ROUTINE IS CALLED BY THE DMSABN ABEND RECOVERY ROUTINE. IT 01914000
* RELEASES ALL STORAGE ALLOCATED AS 'USER' STORAGE. 01915000
UREC EQU * 01916000
XC FREELU(12),FREELU ZERO OUT LOWCORE POINTERS 01917000
XC FREEHU(12),FREEHU ZERO OUT HIGHCORE POINTERS 01918000
L R1,AFREETAB POINT TO FREE STORAGE BYTE TABLE 01919000
SR XR2,XR2 POINT TO CURRENT PAGE (PAGE 0) 01920000
L R0,AUSRAREA BEGINNING OF HIGH CORE 01921000
SRA R0,12 NUMBER OF PAGES IN LOW CORE 01922000
LA CHR,FREELU POINT TO LOW-CORE USER CHAIN 01923000
SPACE 01924000
* THE FOLLOWING LOOP SEARCHES THROUGH THE FREETAB TABLE, LOOKING FOR 01925000
* BYTES CORRESPONDING TO USER PAGES. THESE PAGES ARE PUT BACK ONTO 01926000
* THE USER FREE STORAGE CHAIN. 01927000
URECL EQU * 01928000
CLI 0(R1),USERCODE IS THIS A USER PAGE? 01929000
BNE URECLE SKIP IT IF NOT 01930000
LR BLR,XR2 BLR -> CURRENT PAGE 01931000
L SR,PAGESIZE LOAD BLOCKSIZE REG WITH PAGESIZE 01932000
SPACE 01933000
* WE LOOP THRU FREETAB TO FIND THE FIRST NON-USER BYTE. 01934000
URECG EQU * 01935000
CLI 1(R1),USERCODE IS THE NEXT ONE FOR USER? 01936000
BNE URECF GO IF NOT 01937000
LA R1,1(,R1) OTHERWISE, INCREMENT REGS 01938000
A XR2,PAGESIZE 01939000
A SR,PAGESIZE 01940000
BCT R0,URECG AND GO TRY AGAIN 01941000
SPACE 01942000
* AT THIS POINT, WE CALL SFRT TO PUT THE BLOCK ONTO THE FREE CHAIN. 01943000
URECF EQU * 01944000
BAL RR,SFRT 01945000
OI FLAGS(CHR),FLPA SET 'PAGE AVAILABLE' FLAG 01946000
SPACE 01947000
URECLE EQU * 01948000
LA R1,1(,R1) INCREMENT FREETAB POINTER 01949000
A XR2,PAGESIZE INCREMENT PAGE POINTER 01950000
BCT R0,URECL COUNT PAGES 01951000
SPACE 01952000
* WHEN WE REACH THIS POINT FOR THE FIRST TIME, WE WILL HAVE CHECKED 01953000
* ONLY THE LOW-CORE PAGES. SO WE NOW SET THINGS UP TO CHECK THE 01954000
* HIGH CORE PAGES. 01955000
C XR2,AUSRAREA ARE WE AT BEGINNING OF USER AREA 01956000
BNE URECB WE'RE ALL THROUGH IF NOT 01957000
SPACE 01958000
* OTHERWISE, WE COMPUTE THE NUMBER OF PAGES IN HIGH CORE. 01959000
L R0,VMSIZE SIZE OF VIRTUAL MEMORY 01960000
S R0,AUSRAREA SIZE OF HIGH CORE 01961000
SRA R0,12 AND CONVERT TO NUMBER OF PAGES 01962000
LA CHR,FREEHU POINT TO HIGH-CORE USER CHAIN 01963000
B URECL GO BACK AND RE-ENTER LOOP 01964000
SPACE 01965000
* COME HERE WHEN WE'RE ALL THROUGH 01966000
URECB EQU * 01967000
C XR2,VMSIZE XR2 -> END OF CORE? 01968000
RTN NE,41,FINIS IMPOSSIBLE IF NOT 01969000
CLEANUP ,HU CLEAN UP HIGH-CORE USER CHAIN 01970000
OI FREEFLG2,FRF2CKT FORCE A CHECK OF ALL CHAINS 01971000
RTN ,0,FINIS RETURN TO CALLER 01972000
* CALOC SERVICE ROUTINE. 01974000
* THIS ROUTINE IS CALLED BY DMSABN, THE ABEND RECOVERY ROUTINE. 01975000
* THIS ROUTINE COMPUTES THE TOTAL AMOUNT OF FREE STORAGE WHICH IS 01976000
* NOT ON THE FREE CHAIN. THE FIGURE DOES NOT INCLUDE SPACE OCCUPIED 01977000
* BY THE SYSTEM DISK FILE DIRECTORY (SSTAT), NOR DOES IT INCLUDE 01978000
* THE FREETAB TABLE. 01979000
CALOC EQU * 01980000
SPACE 01981000
* FIRST, WE COMPUTE THE SIZE OF ALL PAGES ALLOCATED TO FREE STORAGE. 01982000
SPACE 01983000
* LOW CORE RUNS FROM NUCEND TO SSTAT. 01984000
* NOTE THAT SSTAT IS LOCATED IN THE HIGHEST PART OF WHAT WAS 01985000
* ORIGINALLY THE LOW-CORE FREE STORAGE REGION (FROM NUCEND TO TRANSAR) 01986000
L SR,ASSTAT POINT TO SSTAT 01987000
S SR,=V(DMSNUCE) GET SIZE OF LOWCORE REGION 01988000
SPACE 01989000
* HIGH CORE RUNS FROM FREELOWE TO FREELOW1 (THE LATTER WAS SET BY 01990000
* INIT2 AS THE ORIGINAL VALUE OF FREELOWE) 01991000
A SR,FREELOW1 ADD FREELOW1 01992000
S SR,FREELOWE NET SIZE OF HIGH CORE REGION 01993000
SPACE 01994000
* WE NOW LOOP THROUGH ALL FOUR CHAINS, AND SUBTRACT THE SIZE OF EACH 01995000
* BLOCK ON THE FREE CHAIN FROM SR. 01996000
LA XR,4 NUMBER OF CHAINS 01997000
LA CHR,FREELN POINT TO LOW-CORE NUCLEUS CHAIN 01998000
SH CHR,=AL2(BLOCKLEN) BACK UP BY ONE BLOCK LENGTH 01999000
SPACE 02000000
* COME HERE TO EXAMINE THE NEXT CHAIN 02001000
CALOCC EQU * 02002000
LA CHR,BLOCKLEN(,CHR) POINT TO NEXT CHAIN HEADER 02003000
L CR,NUM(,CHR) GET NUMBER OF BLOCKS ON CHAIN 02004000
LTR CR,CR ARE THERE ANY? 02005000
BZ CALOCE NOTHING TO DO IF NOT 02006000
LR PTR,CHR POINT TO CHAIN HEADER 02007000
SPACE 02008000
* POINT TO EACH BLOCK, AND SUBTRACT ITS SIZE FROM SR. 02009000
CALOCB EQU * 02010000
L PTR,POINTER(,PTR) POINT TO NEXT CHAIN ELEMENT 02011000
S SR,SIZE(,PTR) SUBTRACT ITS SIZE FROM SR 02012000
BCT CR,CALOCB COUNT BLOCKS 02013000
SPACE 02014000
* COME HERE AT THE END OF EACH CHAIN 02015000
CALOCE EQU * 02016000
BCT XR,CALOCC COUNT CHAINS 02017000
SPACE 02018000
* WE NOW SUBTRACT FROM SR THE SIZE OF FREETAB. 02019000
L XR,VMSIZE SIZE OF MEMORY 02020000
SRA XR,12 NUMBER OF PAGES = SIZE OF *02021000
FREETAB 02022000
SR SR,XR SUBTRACT RESULT FROM SR 02023000
SRA SR,3 CONVERT TO DOUBLE WORDS 02024000
ST SR,FREESAVE+R0*4 STORE IN RETURNED REG 0 02025000
RTN ,0,FINIS RETURN TO CALLER 02026000
* COME HERE UPON ANY ERROR RETURN FROM OTHER THAN THE 'CHECK' 02028000
* ROUTINE. 02029000
ERRORET EQU * 02030000
TM FREEFLG2,FRF2CKX ARE WE IN 'CHECK' ROUTINE? P3015 02031000
BO RTNCHK CLOBBERED CHAIN IF SO P3015 02032000
SPACE 02033000
* FIRST, WE COMPUTE THE ADDRESS OF THE CALLER. 02034000
L R14,FREESAVE+4*R14 GET VALUE OF R14 AT ENTRY 02035000
TM FREEFLG1,FRF1B WAS THIS A 'TYPCALL=BALR' CALL? 02036000
BO ERRET1 WE HAVE OUR ANSWER IF SO 02037000
L XR,CURRSAVE GET ADDRESS OF CURRENT SAVE AREA 02038000
USING SSAVE,XR 02039000
L R14,CALLER GET ADDRESS OF SVC CALLER 02040000
DROP XR 02041000
SPACE 02042000
ERRET1 EQU * 02043000
ST R14,ACALL SAVE ADDRESS OF ACALL 02044000
CH R15,=H'20' IS ERROR CODE > 20? 02045000
BNL ERRX GO DIRECTLY TO 'ERRX' IF SO 02046000
SR XR,XR 02047000
IC XR,ERRTAB(R15) GET JUMP CODE FOR THIS ERROR 02048000
B *+4(XR) JUMP BASED ON ERROR CODE 02049000
B ERRX 0 9 < RC < 20 -- CAN'T HAPPEN 02050000
B ERRCORE 4 RC = 1 -- NO CORE AVAILABLE 02051000
B ERREERR 8 RC = 4 -- DMSFREE ARGUMENT ERROR 02052000
B ERRTERR 12 RC = 5, 6 OR 7 -- DMSFRET ARG ER 02053000
SPACE 02054000
ERRTAB DC AL1(0,4,0,0,8,12,12,12),13AL1(0) 02055000
DS 0H 02056000
EJECT 02057000
ERRX EQU * 02058000
LR XR,R15 XR <- IMPOSSIBLE ERROR CODE 02059000
DMSERR NUM=167,LET=T,TYPCALL=BALR,DISP=SIO, *02060000
TEXT='FREE STORAGE MANAGEMENT ERROR, INTERNAL ERROR CODE*02061000
.....', *02062000
SUB=(DEC,(XR)) 02063000
B CHECK 02064000
SPACE 2 02065000
ERRCORE EQU * 02066000
TM FREEFLG1,FRF1M MESSAGES SUPPRESSED 02067000
BZ CHKCLN SKIP MSG, CHECK CLEANUP @VA02373 02068300
DMSERR NUM=159,LET=T,TYPCALL=BALR,DISP=SIO, *02069000
SUB=(HEXA,ACALL), *02070000
TEXT='INSUFFICIENT STORAGE AVAILABLE TO SATISFY DMSFREE *02071000
REQUEST FROM ......' 02072000
CHKCLN TM FREEFLG2,FRF2CL CLEANUP REQUIRED? @VA02373 02073200
BZ CHECK SEE IF ANYTHING IS MESSED UP @VA02373 02073400
OI FREEFLG2,FRF2CKT CHECK AFTERWARD @VA02373 02073600
B CLEANUP PUT PAGES ON RIGHT QUEUES @VA02373 02073800
SPACE 2 02074000
ERREERR EQU * 02075000
TM FREEFLG1,FRF1M MESSAGES SUPPRESSED? 02076000
BZ CHECK DON'T TYPE MESSAGE IF SO 02077000
DMSERR NUM=160,LET=T,TYPCALL=BALR,DISP=SIO, *02078000
SUB=(HEXA,ACALL), *02079000
TEXT='INVALID DMSFREE CALL FROM ......' @V305066 02080000
B CHECK 02081000
SPACE 2 02082000
ERRTERR EQU * 02083000
TM FREEFLG1,FRF1M MESSAGES SUPPRESSED? 02084000
BZ CHECK DON'T TYPE MESSAGE IF SO 02085000
LR XR,R15 GET ACTUAL RETURN CODE 02086000
DMSERR NUM=161,LET=T,TYPCALL=BALR,MF=(E,'SYS'),DISP=SIO, *02087000
SUB=(HEXA,ACALL,DEC,(XR)), *02088000
TEXT='INVALID DMSFRET CALL FROM ......, ERROR NUMBER ...*02089000
..' @V305066 02090000
B CHECK 02091000
EJECT 02092000
* CONTROL COMES HERE WHEN A CRITICAL POINTER IS FOUND BY THE 'CHECK' 02093000
* ROUTINE TO BE MEANINGLESS OR DESTROYED. 02094000
RTNCHKP EQU * 02095000
LR XR,R15 GET INTERNAL RETURN CODE 02096000
DMSERR NUM=162,LET=T,TYPCALL=BALR,DISP=SIO,HALT=YES, *02097000
TEXT='VITAL FREE STORAGE POINTERS DESTROYED (INTERNAL ER*02098000
ROR CODE ....), RE-IPL CMS', *02099000
SUB=(DEC,(XR)) 02100000
SPACE 02101000
* WE CONTINUE OPERATION IN CASE HE TURNS OFF THE WAIT STATE BIT AFTER 02102000
* REPAIRING THE POINTERS. 02103000
B CHECK 02104000
EJECT 02105000
* CONTROL COMES HERE WHEN THE 'CHECK' ROUTINE FINDS THAT ONE OF THE 02106000
* CHAINS IS CLOBBERED. 02107000
RTNCHK EQU * 02108000
LR XR,R15 GET INTERNAL ERROR CODE 02109000
LA R0,=CL4'LOW' POINT TO WORD 'LOW' 02110000
TM FLAGS(CHR),FLHC IS THIS THE HIGHCORE CHAIN? 02111000
BZ *+8 SKIP IF NOT 02112000
LA R0,=CL4'HIGH' IF SO, THEN POINT TO WORD 'HIGH' 02113000
TM FLAGS(CHR),FLNU IS THIS A NUCLEUS CHAIN? 02114000
BO RTNCHKN GO IF IT IS 02115000
SPACE 2 02116000
* MESSAGE: DMSFRE163T LOW/HIGH CORE USER CHAIN HAS BEEN DESTROYED. 02117000
DMSERR NUM=163,LET=T,MF=(E,'SYS'),TYPCALL=BALR,DISP=SIO, *02118000
TEXTA=RTNCHKT1, *02119000
SUB=(CHARA,(R0),CHARA,=CL7'USER',DEC,(XR),CHARA, P3071*02120000
=CL10' ') 02121000
SPACE 02122000
* HEADER INFORMATION MESSAGE 02123000
DMSERR NUM=165,LET=T,MF=(E,'SYS'),TYPCALL=BALR,DISP=SIO, *02124000
TEXTA=RTNCHKT2,SUB=(HEX,(CHR),HEX4A,(CHR)) 02125000
XC 0(12,CHR),0(CHR) ZERO OUT HEADER BLOCK 02126000
RTN ,2,CHKC USER STORAGE POINTERS CLOBBERED 02127000
SPACE 5 02128000
* NUCLEUS STORAGE POINTERS HAVE BEEN CLOBBERED. 02129000
RTNCHKN EQU * 02130000
DMSERR NUM=164,LET=T,MF=(E,'SYS'),TYPCALL=BALR,DISP=SIO, *02131000
TEXTA=RTNCHKT1, *02132000
SUB=(CHARA,(R0),CHARA,=CL7'NUCLEUS',DEC,(XR), P3071*02133000
CHARA,=C'RE-IPL CMS') 02134000
DMSERR NUM=165,LET=T,MF=(E,'SYS'),TYPCALL=BALR, *02135000
DISP=SIO,TEXTA=RTNCHKT2, *02136000
SUB=(HEX,(CHR),HEX4A,(CHR)) 02137000
XC 0(12,CHR),0(CHR) ZERO OUT HEADER POINTER 02138000
LPSW =A(X'20000',RTNCHKN1) LOAD DISABLED WAIT STATE TO DIE 02139000
SPACE 3 02140000
* WE CONTINUE OPERATION, IN CASE HE TURNS OFF THE WAIT STATE BIT. 02141000
RTNCHKN1 EQU * 02142000
RTN ,3,CHKC NUCLEUS STORAGE POINTERS CLOBBED 02143000
SPACE 2 02144000
* TEXT FOR THE TWO ERROR MESSAGES. 02145000
RTNCHKT1 DC AL1(RTNCHKL1) 02146000
DC C'....-CORE ....... STORAGE POINTERS DESTROYED (INTERNAL*02147000
ERROR CODE ....) ..........' 02148000
RTNCHKL1 EQU *-RTNCHKT1-1 02149000
SPACE 02150000
RTNCHKT2 DC AL1(RTNCHKL2) 02151000
DC C'CHAIN HEADER AT ......: ..............................*02152000
.....' 02153000
RTNCHKL2 EQU *-RTNCHKT2-1 02154000
DS 0H 02155000
SPACE 5 02156000
* COME HERE AFTER THE MESSAGE IS TYPED OUT. WE ZERO OUT THE CHAIN 02157000
* HEADER BLOCK FOR THE CLOBBERED CHAIN. 02158000
RTNCHKC EQU * 02159000
ST R15,FREESAVE+4*R15 SAVE 2/3 RETURN CODE 02160000
B CHECK GO TO CHECK AGAIN 02161000
EJECT 02162000
* COME HERE AFTER THE CHECK ROUTINE HAS COMPLETED, IF ANY ERROR HAS 02163000
* BEEN DETECTED SINCE DMSFRE WAS ENTERED. 02164000
ERCHK EQU * 02165000
CLC =F'20',FREESAVE+4*R15 ERROR CODE STILL > 20? 02166000
BNL ERCHK1 GO IF NOT 02167000
SPACE 02168000
* THAT MEANS THAT WE GOT AN UNEXPECTED ERROR, BUT ALL THE CHAINS 02169000
* ARE OK. WE TYPE OUT A SPECIAL ERROR MESSAGE FOR THIS. 02170000
DMSERR NUM=166,LET=T,DISP=SIO,TYPCALL=BALR,HALT=YES, *02171000
SUB=(DECA,FREESAVE+4*R15), *02172000
TEXT='UNEXPECTED ERROR IN FREE STORAGE MANAGEMENT ROUTIN*02173000
E (INTERNAL ERROR CODE ....). RE-IPL CMS' 02174000
SPACE 02175000
* CONTINUE PROCESSING IN CASE THE USER TURNS OFF THE WAIT STATE BIT. 02176000
MVC FREESAVE+4*R15(4),=A(CODE9) SET RETURN CODE TO 9 02177000
SPACE 2 02178000
ERCHK1 EQU * 02179000
TM FREEFLG1,FRF1C WAS THIS A CONDITIONAL CALL? 02180000
BO RETURNE JUST RETURN TO CALLER IF SO 02181000
TM FREEFLG1,FRF1B WAS 'TYPCALL=BALR' CODED? 02182000
BO ERCHK1B GO HANDLE THAT IF SO 02183000
SPACE 02184000
* FOR TYPCALL=SVC CALLS, WE SIMPLY SET THE ABEND CODE IN SVCSECT SO 02185000
* THAT DMSITS WILL ABEND BEFORE RETURNING TO THE CALLER. 02186000
L XR,ASVCSECT POINT TO SVCSECT 02187000
USING SVCSECT,XR 02188000
MVC SVCAB,=X'00F7' SET ABEND CODE TO 0F7 02189000
B RETURN AND JUST RETURN 02190000
SPACE 02191000
* FOR TYPCALL=BALR CALLS TO DMSFRE, WE ABEND BY PASSING CONTROL TO 02192000
* DMSABNGO. 02193000
ERCHK1B EQU * 02194000
L XR,=V(DMSABW) POINT TO DMSABN WORKSPACE 02195000
USING ABWSECT,XR 02196000
MVC ABNPSW(4),=A(X'0F8') SET ABEND CODE TO 0F8 02197000
MVC ABNPSW+4(4),FREESAVE+4*R14 PUT RETURN ADDR INTO PSW 02198000
MVC ABNREGS(4*16),FREESAVE COPY ABEND REGISTERS 02199000
LA R0,X'0F8' PUT ABEND CODE INTO REG 0 02200000
L R15,=V(DMSABNGO) POINT TO ABEND ROUTINE 02201000
BALR R14,R15 AND BRANCH TO IT 02202000
DC 4H'0' DMSABNGO SHOULDN'T RETURN 02203000
LTORG 02205000
DMSFRT 02207000
NUCON 02209000
DMSABW 02210000
SVCSAVE 02211000
SVCSECT 02212000
END 02213000