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