* $Source: /commtar/monoBANK/RTS/tKalstksg.a,v $ * $Revision: 1.7 $ $Date: 88/07/01 09:01:02 $ $Author: stt $ PUNCH ' ALIAS #ALSTKSG,#PSTKCLN,RTS$STON,RTS$STOF' PUNCH ' ALIAS RTS#STON,RTS#STOF' #PSTACKR ADASTART 'Allocate another extent on the primary stack', X CICS=NO SPACE 1 ENTRY #PSTKCLN Stack Cleanup Entry SPACE 1 * This routine is called by the prologue of an Ada procedure, * when it is determined that insufficient space remains * in the current primary stack segment, and a new segment * must be allocated. (The call to this routine is made through * the global area). * * This routine ALSO gets control whenever tracing has been * requested (by, say, the APHID debugger). Tracing works by * setting the "primary stack top" field in the task global * area (GBLSTSEG) to zero, so that all procedure calls think * they need to get a new stack chunk. The model for this routine * is as follows; "P" is the procedure that the user really wants * to call. * * procedure Hook is * begin * if More_Stack_Needed then * Allocate_Stack_Space; * end if; * if Tracing then * Hook_Enter (Call_Frame, UDA); -- call the trace routine * -- for a procedure call * end if; * Copy_Call_Frame_Header_To_New_Frame; * P; -- call the procedure; * if Tracing then * Hook_Exit (Call_Frame, UDA, 0); -- call the trace routine * -- for procedure return * end if; * Copy_Call_Frame_Header_To_Old_Frame; * exception * when others => * if Tracing then * Hook_Exit (Call_Frame, UDA, Exception_Descriptor); * -- Call trace routine for procedure return * end if; * Copy_Call_Frame_Header_To_Old_Frame; * end Hook; EJECT * * Newly acquired stack chunks are chained to the existing stack * chunks, so that hopefully we can reuse the stack space later. * If the required size of a new chunk is larger than the size * of the next existing chunk, the ENTIRE chain of chunks (out * from the current chunk) is freed before allocating the new * chunk. The idea is that there may be contiguous chunks that, * while individually too small for this request, would together * be big enough, so we should free them and try to re-acquire. * * The long-term effect of this is to make the primary stack * consist of a few large chunks, rather than many smaller chunks. * * Chunks are allocated in page size units (4096 bytes); the old * "minimum chunk size" and "fudge" concepts have been removed. * * At entry to this routine, * * R1 -> current stack position + desired size (beyond end of segment) * R3 -> current stack position. NOTE that registers 14-? * have been saved, starting at this location, and that there * is room to store registers 14-9 (and this routine does so). * R11 -> #ALSTKSG * R13 -> Global Area * R14 -> Return address from newly invoked procedure * R15 -> Beginning of Prologue of newly invoked procedure * The procedure's UDA is located 24 bytes beyond R15. * The second and third words in that UDA are used . * by this routine. These words are: * UDAFHSZ Frame Header Size, = # of bytes that * must be copied to the top of the new * stack segment * UDACFSZ Total size of call frame * EJECT PAGESIZE EQU 4096 size of a page PAGESHFT EQU 12 number of bits to shift for rounding * * This is the dummied-up UDA for "Hook." Note that the prologue * code is NOT ever executed! * #HOOKUDA ADAENTRY HOOKXMAP,HOOKEXIT DROP SPACE ENTRY #ALSTKSG #ALSTKSG DS 0H USING #ALSTKSG,R11 code addressability USING GBL,RGLBL access to task global area STM R4,REGSAVE,24(R3) Save registers that might not * have been saved in prologue LR R7,RUDAPRI save P's UDA prefix address in R7 USING UDAPROLG,R7 map the UDA L R6,UDACFSZ get call frame size L R8,GBLSTSEG get address of stack end (MCB) LTR R9,R8 copy to R9 and test BNZ ALLOC if non-zero, we are not tracing, * so it must be that we need a new * stack chunk. TRACING DS 0H * * Entered for tracing. Restore true stack and see if call * frame will fit in the current chunk. * ICM R9,B'1111',GBLTRUES get true stack end BNZ TRUEOK better not be zero, so... EX R0,* ...if it is, die horribly * (clean this up someday...) TRUEOK DS 0H ST R9,GBLSTSEG restore true stack end - this * also turns off tracing * * Registers at this point: * * R3 -> call frame header for "P" * R6 = Size needed for call frame * R7 -> UDA prologue for "P" * R8 = "trace flag" (0 means tracing) * R9 -> end of stack chunk (MCB for chunk) * * When tracing we need room on the stack for both the * called procedure's call frame AND for the call frame * header. Make sure we have that. * LR R1,R3 copy call frame header ptr AL R1,UDAFHSZ bump past call frame header LR R6,R1 copy to R6 AL R6,UDACFSZ add in call frame size BC 3,STOERR if overflow, raise Storage_Error CR R6,R9 room in current chunk? BNH ENOUGH if so then no need to allocate * * No luck. Get the amount we need in R6. * L R6,UDAFHSZ get call frame header size AL R6,UDACFSZ add in length of call frame EJECT ALLOC DS 0H * * There isn't enough room in the current chunk for the * call frame, so we need to get another chunk. The * minimum size we need is in R6. * LR R5,R6 save requested amount temporarily USING MEMCTL,R9 map the MCB AL R6,=A(MEMCTLSZ+PAGESIZE-1) add to frame size the * length of the MCB and * (PAGESIZE-1) for roundup BC 3,STOERR if overflow, raise storage_error SRL R6,PAGESHFT clear out low order stuff... SLL R6,PAGESHFT ...to round to page size * * R6 now contains the minimum desired chunk size. See if * another chunk exists, and if it does, if it is big * enough to use. * ICM R4,B'1111',MNEXT See if a "next" chunk already there BZ GETNEW If not, go allocate a new one DROP R9 USING MEMCTL,R4 map MCB for the next chunk L R1,MBASE Get the base address of the chunk. * If there is enough space in this chunk * then R1 now points to where the new * call frames will go. LA R5,MEMCTLSZ(,R4) point past last byte SR R5,R1 subtract base address, giving size CR R5,R6 is the chunk big enough? BL FREEALL if not, free all "next" chunks * * The current "next" chunk is large enough, so we can just * reuse it. * ST R4,GBLSTSEG make new chunk active in global area B ENOUGH use it. EJECT * * The current "next" chunk is too small, so we will free * the remainder of the stack before allocating the new chunk. * While in this loop, R4 points to the MCB for the chunk we * are freeing. * FREEALL DS 0H LTR R5,R4 have we freed the last chunk? BZ GETNEW if so, get the new one L R1,MBASE Base of chunk we are freeing LA R0,MEMCTLSZ(R1,R5) point R0 past last byte SR R0,R1 compute the size of the chunk L R4,MNEXT get pointer to MCB for next chunk * * <<< UNRESOLVED >>> * To support tasking we will need to figure out whether * we are freeing PAA space or CICS dynamic space. For * now we assume the latter. * L R15,=V(##CIFM) point to free routine BALR R14,R15 free the storage B FREEALL repeat DROP R4 EJECT * * At this point any old chunks have been freed and we are * ready to allocate a new chunk. The size desired is in R6. * GETNEW DS 0H LR R0,R6 copy size wanted to R0 L R15,=V(##CIOK) OK to use Txn storage? BALR R14,R15 L R15,=V(##CIGM) BNZ GETNEW2 L R15,=V(##GETM) Nope, must use PAA GETNEW2 DS 0H BALR R14,R15 call it LTR R1,R1 did we get the storage? BNZ GOTOK Branch if allocated OK STOERR DS 0H L R14,4(,R3) RAISE Storage_Error B GBLERRS (with WhereRaised = procedure Entry) * * Storage was obtained OK. Now set up the MCB and chain it to * the current MCB. * * R15 = amount allocated * R1 -> storage * GOTOK DS 0H AR R15,R1 R15 -> Top of gotten area S R15,=A(MEMCTLSZ) subtract MCB size USING MEMCTL,R15 map the MCB for the new chunk ST R15,MTOP store the MCB self-pointer ST R1,MBASE store the base address * R9 still contains the MCB address for current chunk ST R9,MPREV save back pointer in new chunk XC MNEXT,MNEXT clear the forward pointer ST R15,GBLSTSEG make the new chunk current DROP R15 USING MEMCTL,R9 map the MCB for the old chunk ST R15,MNEXT store forward pointer to new chunk DROP R9 EJECT ENOUGH DS 0H * * At this point we have enough space for the call * frame(s); register use is thus: * * R1 -> where to build call frame(s) * R3 -> call frame header for "P" * R7 -> UDA prologue for "P" * R8 = "trace flag" (0 means tracing) * R9 -> end of ORIGINAL stack chunk * * If we are tracing then we must set up a call frame * for "hook" and then call the hook_enter routine. * MVC 4(4,R3),=A(#HOOKUDA) insert hook UDA address in CFH LTR R8,R8 are we tracing? BNZ MOVEM if not, set up to call "P" * * Call the hook_enter routine with the frame pointer * and UDA pointer. * WXTRN #HENTER ICM RUDAPRI,B'1111',=A(#HENTER) point to hook enter routine BZ AFTERTRC if routine isn't there, skip it LR PR1,RFP load frame pointer into 1st parm LR PR2,R7 load UDA pointer into 2nd parm LR PR3,R1 save frame pointer in case of * an unhandled exception in trace TRCENTER DS 0H BALR RRET,RUDAPRI call it XREGION1 DS 0H * * Turn tracing back on before calling P. Be careful about * our base register (R11) - it has almost certainly been * trashed. * DROP R11 base is no good USING *,R14 use return address for now L R11,=A(#ALSTKSG) restore base DROP R14 USING #ALSTKSG,R11 back to usual base AFTERTRC DS 0H MVC GBLTRUES,GBLSTSEG copy true stack end to save area ST R8,GBLSTSEG zero out stack end in global area * to turn on tracing * * Now move the first UDAFHSZ bytes from the old stack frame * to the new stack frame. Use an MVCL, with regs R4-5 and R14-15. * MOVEM DS 0H LR R4,R1 -> New stack segment LR R14,R3 -> Old stack segment L R5,UDAFHSZ # bytes to move LR R15,R5 MVCL R4,R14 Move them * * Now insert the address of the stack cleanup routine in the * return address of this procedure, in the new stack frame only. * Also restore the remaining registers to the approriate values * LA R14,#PSTKCLN -> Cleanup routine LR R15,R7 -> P's UDA prologue L R0,8(,R1) restore original R0 LM R4,R6,24(R1) restore original R4-R6 STM R14,R9,0(R1) make save area consistent with regs * * Now ready to return to the prologue that invoked us, with * R3 -> base of new primary stack. * CALLP DS 0H LR R3,R1 set stack pointer - base of new stk AL R1,UDACFSZ this matches UDA prologue code * * Now return to the prologue that invoked us, this time * with R3 -> base of new primary stack. To match what UTS does, * return 18 bytes into the routine. Registers 7-9 are saved as * this routine needs them for communication with the cleanup routine. * RETURN DS 0H B 18(,R15) skip most of the prologue DROP , SPACE DS 0F DBLMASK DC X'FFFFFFF8' EJECT * * Stack Clean Up. * * Come here on return from the procedure that caused allocation of * the primary stack segment or when returning during tracing. * * When control arrives here, the registers have just been * loaded from the save area (Procedure Epilog) and they contain: * * R13 -> Ada Global Area * R14 -> #PSTKCLN * R15 -> Start of called procedure * R1 -> Call frame actually used to call procedure * R3 -> Original call frame header (possibly in different stack seg) * R4-R6 = parameters (possibly different than when P was called) * R7 -> UDA prologue for P * R8 = trace flag (0 means tracing) * R9 -> original stack frame end * R10 = return value (if any) * SPACE 1 USING GBL,RGLBL address global area USING UDAPROLG,R7 address P's UDA prologue #PSTKCLN DS 0H LR R11,R14 Establish addressability USING #PSTKCLN,R11 STM PR1,PR3,24(RFP) save back possible out parameters LA R4,52(,RFP) point past registers in CFH L R5,UDAFHSZ get size of call frame header S R5,=F'52' remove length of register save area LA R14,52(,R1) point past regs in used CFH LR R15,R5 copy length of remainder of CFH MVCL R4,R14 copy back any remaining parameters SR R4,R4 clear R4 (to indicate no exception) LR R0,RVAL save return value LA R2,HOOKEXN load base register to match * what happens in exception handlers DROP R11 ditch old base * * The call frame header supplied by the caller has been updated * to reflect changes made by P (to out parameters). The only * field that is not correct now is the UDA pointer (which * points to the fake UDA for hook, rather than to P's UDA). * * Registers here: * * R0 = function return value (must be passed back to caller) * R1 -> CFH used by P (and to be used to call hook_exit) * R2 -> HOOKEXN (base register for next chunk of code) * R3 -> original call frame header * R4 = zero (no exception propagated out of P) * R7 -> P's UDA * R8 = trace flag * R9 -> end of original stack chunk * EJECT HOOKEXN DS 0H * * This is the exception handler for any exceptions that * propagate out of P. We also fall thru to here on normal * return from P. In other words, no matter HOW P terminates, * this code gets control. * USING HOOKEXN,R2 set up addressability LR PR3,R4 copy (possible) exception descriptor * to PR3 for passage to hook_exit LTR R8,R8 are we tracing? BNZ NOXTRACE if not, don't do exit trace MVC GBLSTSEG,GBLTRUES copy true stack end to global * area to turn off tracing WXTRN #HEXIT ICM RUDAPRI,B'1111',=A(#HEXIT) point to hook exit routine BZ NOXTRACE if routine isn't there, skip it LR PR1,RFP 1st parameter is frame pointer LR PR2,R7 2nd parameter is UDA pointer * 3rd parameter is exception descriptor * or zero, and has already been set. BALR RRET,RUDAPRI call exit trace routine NOXTRACE DS 0H * * If we crossed a stack chunk boundary we handle that now. * L R4,GBLSTSEG R4 -> top of current stack CLR R4,R9 same as when we started? BE NOCHUNK if so, no adjustment needed * * Stack chunk boundary was crossed. Back up to the * previously used chunk. * USING MEMCTL,R4 which also is addr(memory ctl blk) MVC GBLSTSEG(4),MPREV Set Stack top in global DROP R4 NOCHUNK DS 0H * * Prepare to exit. If no exception was raised in P then * we return to the caller; if an exception WAS raised, * we reraise it. * LTR R8,R8 are we tracing? BNZ CHECKX if not, leave tracing off **** TM AGGFLAG1,AGGHOOKA is tracing STILL active? **** BNO CHECKX if not, don't turn it back on MVC GBLTRUES,GBLSTSEG copy true stack end to save area SR R8,R8 re-zero R8 ST R8,GBLSTSEG zero out stack end in global area * to turn on tracing CHECKX DS 0H LTR R6,R6 was an exception raised? BNZ RERAISE if so, reraise it * * No exception - return to caller * LR R10,R0 restore return value HOOKEXIT DS 0H hook's epilogue ST R7,4(,RFP) restore P's UDA pointer in CFH LM R14,REGSAVE,0(RFP) Restore registers BR RRET and return to calling procedure RERAISE DS 0H LR R4,R6 restore exception descriptor BAL R14,GBLRERR reraise the exception EJECT * * This is the exception handler to catch any exceptions * that propagate out of the trace enter routine. If the * exception is "Debugger_Quit" we re-raise it. (Note: * this is checked for in a fairly bogus manner...) * PUSH USING DROP ENTERX DS 0H USING ENTERX,R2 addressability USING GBL,RGLBL likewise for global area LR R1,R6 restore frame pointer for P L R11,=A(#ALSTKSG) restore main base register DROP R2 drop temporary addressability USING #ALSTKSG,R11 reuse main L R5,0(,R4) get address of the exception name CLC DBGQUIT(DBGQUITL),0(R5) is it Debugger_Quit? BNE AFTERTRC if not, go back and call P BAL R14,GBLRERR if so, re-raise DBGQUIT DC X'44656275676765725F5175697400' * D e b u g g e r _ Q u i t DBGQUITL EQU *-DBGQUIT POP USING EJECT * * This is the exception map for "Hook" * HOOKXMAP DS 0F DC A(TRCENTER) DC F'0' DC A(XREGION1) DC A(ENTERX) DC A(#PSTKCLN) DC A(HOOKEXN) DC A(HOOKXMAP) DC F'0' LTORG DROP EJECT * * These are the routines for turning tracing on and off * from an Ada program. * ENTRY RTS$STON USING GBL,RGLBL map global area RTS$STON DS 0H USING *,R15 STM R14,R0,0(R1) save a few registers ICM RVAL,B'1111',GBLSTSEG get the current stack end BZR RRET if tracing already on, return ST RVAL,GBLTRUES save true stack end XC GBLSTSEG,GBLSTSEG zero out global area value L R14,GBLGFLG get current flag word SETON DS 0H L R0,HOOKFLAG get "hook on" flag OR R0,R14 OR in the existing bits CS R14,R0,GBLGFLG update the flags BNE SETON if update fails, try again * * Once the global flag has been turned on, return. * LM R14,R0,0(R1) restore registers BR RRET return (with tracing on) DROP SPACE 2 ENTRY RTS$STOF USING GBL,RGLBL map global area RTS$STOF DS 0H USING *,R15 STM R14,R0,0(R1) save a few registers ICM RVAL,B'1111',GBLSTSEG get current stack end BNZ ISOFF if already off, leave it off MVC GBLSTSEG,GBLTRUES restore true stack end ISOFF DS 0H * * Make sure that the tracing flag is turned off in * the global global area. * L R14,GBLGFLG get current flag word SETOFF DS 0H SR R0,R0 clear R15 BCTR R0,0 subtract one to get all ones X R0,HOOKFLAG turn off tracing flag NR R0,R14 AND with existing bits to turn * off the tracing flag CS R14,R0,GBLGFLG update the flags BNE SETOFF if update fails, try again LM R14,R0,0(R1) restore registers BR RRET return (with tracing off) EJECT * * These are the routines for turning tracing on and off * from within the assembler RTS code. The difference * between this code and the previous routines is that the * global flag is not touched. * ENTRY RTS#STON RTS#STON DS 0H USING *,R15 code addressability USING GBL,RGLBL map global area ICM RVAL,B'1111',GBLSTSEG get the current stack end BZR RRET if tracing already on, return ST RVAL,GBLTRUES save true stack end XC GBLSTSEG,GBLSTSEG zero out global area value BR RRET return (with tracing on) DROP SPACE 2 ENTRY RTS#STOF RTS#STOF DS 0H USING *,R15 code addressability USING GBL,RGLBL map global area ICM RVAL,B'1111',GBLSTSEG get current stack end BNZR RRET if already off, leave off MVC GBLSTSEG,GBLTRUES restore true stack end BR RRET return (with tracing off) EJECT LTORG HOOKFLAG DC AL1(GBLSHOOK),AL3(0) EJECT ADAGLOBL ADAGFLG ADAUDA MEMCTL ADAMCTL ADAPSTAK STKLOCAL EQU * ADACFH ADAPSTKE ADAEND 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$