* $Source: /commtar/monoBANK/RTS/tKsecstack.a,v $ * $Revision: 1.7 $ $Date: 88/07/06 10:15:22 $ $Author: stt $ PUNCH ' ALIAS #ADAMSEC,#ADACSEC,#ADARSEC,#ADAASEC' #ADASSTK ADASTART 'Secondary Stack routines',CICS=NO SPACE * * The secondary stack consists of a linked list of * "secondary stack segments." Each segment contains * an area of allocatable storage followed by a "memory * control block" (MCB). Graphically (with low address * at the top of the picture): * * +--------------------+ <-+ <---- start of segment * | | | * | actual stack data | | * | | | * | | | * | | | * | | | * +-> +--------------------+ | * | | MBASE o-----+ * | +--------------------+ * +-----o MTOP | * +--------------------+ * | MNEXT o--------> to MCB for previously allocated * +--------------------+ stack segment ("next" segment) * | MPREV (unused) | * +--------------------+ * * The Ada global area contains pointers to the MCB for the * current stack segment and the current "top of stack" within * that segment. A new object will be allocated in the current * segment at the top of the stack, if it will fit; if not, * a new segment will be allocated. * * The secondary stack is managed using a "mark/release" * allocation policy; a "mark" is a two word descriptor * that contains the address of the MCB for a stack segment * and an address within that segment. When a "release" is * done, all segments between the current segment and the * marked segment are released (if any) and the pointers * in the global area are updated. * * Each stack segment has its size rounded up to be a * multiple of the page size, and the requested storage * is page aligned. This should ensure that the secondary * stack does not fragment storage for MVS. * * The functions provided by this module are: * * Mark: create a mark for the current stack position. * * Release: release storage back to the specified mark. * * Allocate: allocate a new object on the stack. * * Copy: allocate a new object on the stack at a specified * mark and initialize it; then free any unused stack * space between the original end of the stack and the * newly allocated object. * * The Mark/Release/Allocate routines attempt to work without * saving registers, which they can do if no stack segment * boundaries are crossed; otherwise, the register save area * at the front of the global area is used. * SPACE ENTRY #ADAMSEC #ADAMSEC DS 0H * * Mark the secondary stack, by copying the two pointers * in the global area to the mark pointer to by PR1. * USING GBL,RGLBL map the global area MVC 0(8,PR1),GBLSSSEG copy mark information BR RRET return DROP SPACE ENTRY #ADARSEC #ADARSEC DS 0H * * Release the stack space back to the mark pointed to * by PR1. * USING #ADARSEC,R11 establish addressability USING GBL,RGLBL map the global area USING MARK,PR1 map the mark TM MARKTOP+3,X'07' MCB in mark on doubleword? BNZ MARKERR if not, raise error CLC GBLSSTOP,MARKTOP is mark in current segment? BNE RELSEGS if not, must release segments MVC GBLSSSEG,MARKSEG if so, just set new pointer BR RRET and return RELSEGS DS 0H * * The mark is not in the current segment, so we will have * to release some segments. For this we need registers, so * save into the global save area. * STM R14,R8,12(R13) save the registers LR PR3,PR1 copy mark address to PR3 L R2,GBLSSTOP R2 -> current segment's MCB LA R7,FREESEGS point to release routine BALR R8,R7 call the routine * * The necessary segments have been released. Now copy the * mark's information to the global area and return. * MVC GBLSSSEG(8),MARK copy the mark to global LM R14,R8,12(R13) restore the registers BR RRET return DROP SPACE ENTRY #ADAASEC #ADAASEC DS 0H * * Allocate an object on the secondary stack. The length * of the object is in PR1; return its address in RVAL. * USING #ADAASEC,R11 establish addressability USING GBL,RGLBL map the global area L RVAL,GBLSSSEG get current stack pointer ALR RVAL,PR1 add length of object BC 3,NEWSEG if overflow, need new segment CL RVAL,GBLSSTOP will object fit this segment? BH NEWSEG if not, need new segment * * Object will fit into this segment. * LR R11,RVAL hold on to new stack ptr DROP R11 addressability is gone L RVAL,GBLSSSEG get address for object ST R11,GBLSSSEG save new stack ptr BR RRET return NEWSEG DS 0H USING #ADAASEC,R11 if we get here, base is OK * * The object won't fit in the current stack segment, so * allocate a new one. We will need some registers, so * they will be saved in the global save area. * STM R14,R8,12(R13) save a few registers LA R7,ALLOCATE point to allocate routine BALR R8,R7 call it * * R1 now points to the new stack segment (and therefore the * newly allocated object. * LR RVAL,R1 copy for return AR R1,PR1 compute new stack top ST R1,GBLSSSEG save in global area LM R14,R8,12(R13) restore registers BR RRET return DROP SPACE ENTRY #ADACSEC #ADACSEC DS 0H * * Allocate an object on the secondary stack and initialize * it. At entry: * PR1 = size of object in bytes * PR2 -> source used to initialize the new object * PR3 -> mark, indicating where to try to put the * object. * * This code is a bit tricky because the "source" (from which * the new object is initialized) may be further down the * secondary stack than where we want to put the object. So * what we have to do is allocate the object (which may * require a new stack chunk), initialize it, and then free * any stack chunks beyond the original mark. * USING #ADACSEC,R11 establish addressability USING GBL,RGLBL map the global area USING MARK,PR3 map the mark TM MARKTOP+3,X'07' MCB in mark on doublework? BNZ MARKERR if not, raise error STM R14,R8,12(R13) save regs in global save area L R3,GBLSSTOP get MCB addr for current top MVC GBLSSSEG(8),MARK make mark current L R15,MARKSEG get stack pointer from mark LR R0,R15 save in R0 ALR R15,PR1 add length of new object BC 3,CNEWSEG if overflow, need new segment CL R15,MARKTOP will object fit this segment? BNH COPY if so, do the copy * * The object won't fit in the current segment, so we must * get a new one. * CNEWSEG DS 0H LA R7,ALLOCATE point to allocate routine BALR R8,R7 call it * * R1 points to the new stack top (and therefore the new * object). * LR R0,R1 copy new stack top to R0 COPY DS 0H LR RVAL,R0 return object's address LR R1,PR1 copy length to R1 LR R14,PR2 point R14 to source LR R15,R1 source/target length the same MVCL R0,R14 copy source to target ST R0,GBLSSSEG save new stack pointer * * The object is now allocated and initialized. Next we must * free any "dangling" secondary stack segments. * LR R2,R3 MCB addr for 1st dangling seg LA R7,FREESEGS point to the free routine BALR R8,R7 call it LM R14,R8,12(R13) restore regs BR RRET return DROP ALLOCATE DS 0H * * This routine allocates a new stack segment. Linkage is * via BALR R8,R7. On entry PR1 contains the length of the * object requiring stack space; the amount is adjusted up by * the length of the MCB and then to the next multiple of * a page size (4096). This amount of storage is requested * via FREEMAIN. The address of the storage area is returned * in R1. R2 and R15 are used as scratch; the address of the * MCB for the new segment is in R15. * * The new MCB is initialized and chained to the old, and the * new segment is made current in the global area. * PAGESIZE EQU 4096 allocation boundary PAGESHFT EQU 12 bits needed for roundup USING GBL,RGLBL map global area USING ALLOCATE,R7 establish addressability LR R0,PR1 copy length to R0 AL R0,=A(MEMCTLSZ+PAGESIZE-1) add to object size * length of MCB and * (PAGESIZE-1) for roundup BC 3,STOERR if overflow, error SRL R0,PAGESHFT clear out... SLL R0,PAGESHFT ...to round LR R2,R0 save length for later * * Check if OK to use Txn Storage * L R15,=V(##CIOK) BALR R14,R15 OK to use Txn Storage? L R15,=V(##CIGM) BNZ USETXN L R15,=V(##GETM) Nope, must use PAA USETXN DS 0H BALR R14,R15 call the routine LTR R15,R15 was storage available? BZ STOERR if not, storage_error AR R15,R1 add length and base address S R15,=A(MEMCTLSZ) adjust for MCB USING MBASE,R15 map the new MCB ST R1,MBASE store base address of segment ST R15,MTOP store MCB address XC MPREV,MPREV clear "previous" pointer L R2,GBLSSTOP get old MCB address ST R2,MNEXT save in new MCB DROP R15 done with new MCB USING MBASE,R2 map old MCB ST R15,MPREV save forward pointer ST R15,GBLSSTOP make new segment current BR R8 return to caller DROP FREESEGS DS 0H * * This routine frees stack segments back to the requested one. * Linkage is via BALR R8,R7. On entry R2 points to the MCB for * the current (and therefore first to be freed) segment, and * PR3 points to the mark to free back to. R15 is zapped. * USING FREESEGS,R7 establish addressability USING GBL,RGLBL map global area USING MBASE,R2 map MCB for current segment USING MARK,PR3 map the mark CL R2,MARKTOP are we at the "stop" segment? BNE FREETHIS if not, free this segment XC MPREV,MPREV if so, clear forward pointer.. BR R8 .. and return FREETHIS DS 0H L R1,MBASE get base address into R1 LR R0,R2 copy "top" address to R0 SLR R0,R1 compute length BC 14,MCBERR if zero or negative, error AL R0,=A(MEMCTLSZ) add in MCB length BC 3,MCBERR if overflow, error L R2,MNEXT get address of next segment * * Check if are using Txn Storage * L R15,=V(##CIOK) BALR R14,R15 Using Txn Storage? L R15,=V(##CIFM) BNZ FRETXN L R15,=V(##FREEM) Nope, must be using PAA FRETXN DS 0H BALR R14,R15 call free routine BR R7 repeat loop DROP SPACE * * Here are all of the error routines. Basically all they do * is raise an appropriate exception, but the job is complicated * by the fact the this code was not entered using standard Ada * linkage, and we want the exception to be raised in the calling * code, not here. We also need somewhere to store the exception * descriptor; one word at GBLWORK is used. Each routine is * carefully tailored to its callers; use caution changing * this code. * SPACE MARKERR DS 0H * * The mark is always validity checked BEFORE any registers * are touched, so none have to be restored. * USING GBL,RGLBL map global area BALR R11,0 load a base register USING *,R11 establish addressability L R4,=A(MARKEXN) point to exception name ST R4,GBLWORK save in global area OI GBLWORK,X'80' indicate EBCDIC descriptor LA R4,GBLWORK point to exception descriptor B GBLERRH raise the exception MARKEXN DC C'Secondary_Stack_Mark_Contains_Bad_MCB_Address' DC X'00' exception name terminator DROP SPACE STOERR DS 0H * * Registers 14-8 have been saved into the global save area * when this routine is called, so they must be restored. * USING GBL,RGLBL map the global area LM R14,R8,12(R13) restore registers B GBLERRS raise storage_error DROP SPACE MCBERR DS 0H * * Registers 14-7 are saved before this error occurs and * must therefore be restored. * BALR R11,0 load base register USING *,R11 establish addressability USING GBL,RGLBL map the global area LM R14,R8,12(R13) restore registers L R4,=A(MCBEXN) point to exception name ST R4,GBLWORK save in global area OI GBLWORK,X'80' indicate EBCDIC descriptor LA R4,GBLWORK point to exception descriptor B GBLERRH raise the exception MCBEXN DC C'Invalid_MCB_Found_In_Secondary_Stack_Release' DC X'00' exception name terminator DROP * SPACE ADAMCTL ADAMARK ADAGLOBL END * $Cprt start$ * * Copyright (C) 1988 by Intermetrics, Inc. * * This material may be used duplicated or disclosed by or for the * U.S. Government pursuant to the copyright license under DAR clause * 7-104.9(a) (May 1981). * * This project was spnsored by the STARS Foundation * Naval Research Laboratory, Washington DC * * $Cprt end$