* $Source: /commtar/monoBANK/RTS/tKtskasm.a,v $ * $Revision: 1.19 $ $Date: 88/07/06 20:46:58 $ $Author: stt $ PUNCH ' ALIAS TSK$SCUR,TSK$CURT,TSK$SWST,TSK$CLTA' PUNCH ' ALIAS TSK$LSWP,TSK$INNW' PUNCH ' ALIAS TSK$RASE,TSK$GEPS,TSK$PRAB,TSK$GMPR' PUNCH ' ALIAS TSK$GLK,TSK$RSTL,ADAGLOB' PUNCH ' ALIAS CIC$SPRO' SPACE TSKASM ADASTART 'Tasking assembler support routines' ********************************************************************* * * * This module contains code for a number of assembler * * routines that were coded for UTS and then MVS. * * I have eliminated. * * * * Most of these routines do not need to use the stack * * frame and therefore don't use the usual Ada linkage * * macros. * * * * Also, ADAGLOB is in this CSECT. * * * ********************************************************************* EXTRN GETMEM,#CIGETM,##CIOK EXTRN FREEMEM,#CIFREEM EXTRN #HOOKUDA EXTRN CIC$DELA SPACE * * Equates used to access register in the stack frame RSA * RSARET EQU 0 R14 return address to caller RSAUDA EQU 4 R15 address of UDA for this rtn RSASBC EQU 8 R0 static link RSASCA EQU 12 R1 subprogram communication area RSACODE EQU 16 R2 code base register RSAFP EQU 20 R3 offset of from pointer in RSA RSAPR1 EQU 24 R4 parameter 1 RSAPR2 EQU 28 R5 parameter 2 RSAPR3 EQU 32 R6 parameter 3 SPACE * * Equates used to access UDA fields * UDAPRIO EQU 22 priority (halfword) UDAEPI EQU 40 address of epilogue * * Miscellaneous equates * PRIMSSIZ EQU 2048 size of primary stack of task AMAINUDA EQU 0 offset in ADA#MAIN of UDA SPACE ENTRY TSK$SCUR TSK$SCUR DS 0H ********************************************************************* * * * procedure Set_Current_TCB( * * New_TCB: TCBPtr); * * * * --| change "current TCB" in global area to a new task * * * ********************************************************************* USING GBL,RGLBL map the global area ST PR1,GBLRTCB set running TCB BR RRET return DROP SPACE ENTRY TSK$CURT TSK$CURT DS 0H ********************************************************************* * * * function Current_TCB return TCBPtr; * * * * --| return the currently running TCB pointer * * * ********************************************************************* USING GBL,RGLBL map the global area L RVAL,GBLRTCB get the running TCB BR RRET return DROP SPACE ENTRY TSK$SWST TSK$SWST DS 0H ********************************************************************* * * * procedure Swap_Stack( * * From: out Stack_State; * * To: in Stack_State); * * * * --| Save the current stack state in "From" and * * --| transfer control to "To". * * * ********************************************************************* STM R14,REGSAVE,0(RSCA) save all register LR RCODE,RUDAPRI set up base register USING TSK$SWST,RCODE establish addressability USING GBL,RGLBL map the task global area USING STKSTATE,PR1 map the "from" state ST RSCA,STKST#FP save old frame pointer L RUDAPRI,=V(RTS#STOF) point to trace countrol rtn BALR RRET,RUDAPRI test tracing and turn off * if RVAL=0, tracing was on MVC STKST#GS(12),GBLSTSEG save stack info from global DROP PR1 done with "from" parameter USING STKSTATE,PR2 map the "to" state MVC GBLSTSEG(12),STKST#GS set up new stack info LTR RVAL,RVAL was tracing on? BNZ NOTRAC1 if not, leave off L RUDAPRI,=V(RTS#STON) Point to trace control rtn BALR RRET,RUDAPRI turn on tracing NOTRAC1 DS 0H L RFP,STKST#FP get new frame pointer * * We are NOW on the new stack frame. * Update ACDPROCP to reflect new task * L RVAL,GBLEIPLR point to CICS data area USING DFHEISTG,RVAL map the area MVC ACDPROCP,STKST#PR update ACDPROCP * LM R14,REGSAVE,0(RFP) restore registers from the * NEW stack frame BR RRET return (to a different caller) DROP SPACE ENTRY TSK$LSWP TSK$LSWP DS 0H ********************************************************************* * * * procedure Last_Swap_Stack( * * To: in Stack_State); * * * * --| Free the space used by the current stack state and * * --| transfer control to "To". * * * ********************************************************************* LR RCODE,RUDAPRI set up base register USING TSK$LSWP,RCODE establish addressability USING GBL,RGLBL map the task global area LR R9,PR1 USING STKSTATE,R9 map the "to" state L PR1,GBLSTSEG prepare params for freeing USING MEMCTL,PR1 L PR2,MBASE primary stack seg LA PR1,MEMCTLSZ(PR1) DROP PR1 SLR PR1,PR2 L RUDAPRI,=V(RTS#STOF) point to trace countrol rtn BALR RRET,RUDAPRI test tracing and turn off * if RVAL=0, tracing was on MVC GBLSTSEG(12),STKST#GS set up new stack info LTR RVAL,RVAL was tracing on? BNZ NOTRAC2 if not, leave off L RUDAPRI,=V(RTS#STON) Point to trace control rtn BALR RRET,RUDAPRI turn on tracing NOTRAC2 DS 0H L RFP,STKST#FP get new frame pointer * * We are NOW on the new stack frame. * * Free primary stack **** ONLY FIRST CHUNK SO FAR **** * L R15,=V(##CIOK) using Txn storage? BALR R14,R15 L R15,=V(#CIFREEM) BNZ FREETXN L R15,=V(FREEMEM) nope, must be PAA FREETXN DS 0H LA RSCA,12(RGLBL) set up SCA BALR R14,R15 call appropriate free routine * * Free secondary stack **** TBD ***** * * Update ACDPROCP to reflect new task * (this must be done after call on ##CIOK) * L RVAL,GBLEIPLR point to CICS data area USING DFHEISTG,RVAL map the area MVC ACDPROCP,STKST#PR update ACDPROCP * LM R14,REGSAVE,0(RFP) restore registers from the * NEW stack frame BR RRET return (to a different caller) DROP SPACE ENTRY TSK$INNW TSK$INNW DS 0H ********************************************************************* * * * procedure Init_New_Stack( * * New_State: out Stack_State; * * New_TCB: TCB_Ptr; * * Task_Envelope: System.Address); * * * * --| Allocate stacks, * * --| Set up register save area so Swap_Stack will result * * --| in call on Task_Envelope with New_TCB as parameter * * * ********************************************************************* USING *,RCODE USING GBL,RGLBL map the task global area STM R14,REGSAVE,0(RSCA) Save regs LR RFP,RSCA point to frame LR RCODE,RUDAPRI point to code LR R9,PR1 save PR1 = New_State (Stk st) USING STKSTATE,R9 * Allocate primary stack LH PR1,=AL2(PRIMSSIZ) get size of stk to be alloc'd LA RSCA,12(RGLBL) do SCA setup ICM R15,B'1111',STKST#PR Ok to use Txn storage? L R15,=V(#CIGETM) BNZ PRIMALC L R15,=V(GETMEM) nope, use PAA allocator PRIMALC DS 0H BALR R14,R15 go ahead and call it * On return, PR2 contains size allocated * PR3 contains address of allocated space LTR R7,PR2 check if returned siz non-zero BE STKOVFL couldn't allocate space ST PR3,STKST#FP save frame ptr in stk state ALR R7,PR3 top = chunk.base + chunk.size S R7,=A(MEMCTLSZ) back up over chunk header USING MEMCTL,R7 ST R7,MTOP ST PR3,MBASE chunk.base = base ST R7,STKST#PS save end primary stk in stk st XC MNEXT,MNEXT no next (prev) chunk XC MPREV,MPREV DROP R7 L R8,=A(##DUMSTK) get dummy secondary stack ST R8,STKST#SP save base of sec stk in stk_st ST R8,STKST#SS ditto for end of sec stack LR R7,PR3 r7 now points to new frame LM PR2,PR3,RSAPR2(RFP) restore PR2, PR3 ST PR3,RSARET(R7) Set up return addresses ST PR3,RSAUDA(R7) ST R7,RSASCA(R7) Point to frame XC RSAFP(4,7),RSAFP(R7) FP=0, indicate top of task ST PR2,RSAPR1(R7) Fill in parm to task_envelope LM R14,REGSAVE,0(RFP) Restore Regs BR RRET return (to a different caller) SPACE STKOVFL LM R14,REGSAVE,0(RFP) Restore Regs B GBLERRS raise storage error DROP SPACE ENTRY TSK$CLTA TSK$CLTA DS 0H ********************************************************************* * * * procedure Call_Task( * * Task_UDA: SYSTEM.Address; --| UDA/code of task body * * Task_SBC: SYSTEM.Address; --| Static link * * Task_TCB: TCBPtr); --| Parm to task body (TCB) * * * ********************************************************************* LR RUDAPRI,PR1 get address of UDA/code LR RSBC,PR2 set up static link LR PR1,PR3 make TCB the 1st parameter BR RUDAPRI go to the routine SPACE ENTRY TSK$RASE TSK$RASE DS 0H ********************************************************************* * * * procedure Raise_Exception( * * Exception_To_Raise: ExceptionInfo); * * * * --| raise an exception from Ada * * * ********************************************************************* USING GBL,RGLBL map the task global area B GBLERRH go raise exception routine DROP SPACE ENTRY TSK$GEPS TSK$GEPS DS 0H ********************************************************************* * * * function Get_EPS_Frame return Integer; * * --| get frame pointer of caller's caller * * * ********************************************************************* USING TSK$GEPS,RUDAPRI establish a base register L RVAL,RSAFP(,RFP) get caller's caller's frame CLC RSAUDA(4,RVAL),=V(#HOOKUDA) UDA for hook routine? BNER RRET if not, all set L RVAL,RSAFP(,RVAL) if so, skip debugger frame BR RRET return DROP RUDAPRI SPACE ********************************************************************* * * * procedure Propagate_Abort( * * RSA_Ptr : System.Address; --| passed to End_Rendez * * EPS_Frame : System.Address; --| EPS frame to look for * * End_Rendez : System.Address); --| gets control at end * * * * --| This routine unwinds the stack from the current * * --| frame back to the specified EPS frame and then * * --| calls the routine passed in as End_Rendez (which * * --| will be Abort_End_Rendezvous). * * * * This routine DOES use standard linkage, since it needs * * to look like an ordinary Ada routine. * * * ********************************************************************* TSK$PRAB ADAENTRY 0,PRABEXIT LR R0,PR2 copy EPS frame to R0 * * The static link register slot in the RSA is used to * preserve this value as we unwind stack frames. * LR R10,PR3 save code address in R10 LR R11,PR1 save parm in R11 BALR RRET,0 make R14 point to UNWIND DROP UNWIND DS 0H USING *,RRET establish addressability L RUDAPRI,RSAUDA(RFP) get UDA/code address CR R0,RFP are we at the desired frame? BE CALLRTN if so, call routine ST R0,RSASBC(,RFP) save in RSA for propagation L R1,RSASCA(,RFP) handle stack chunk crossing ST RRET,RSARET(,R1) return back to UNWIND L R2,UDAEPI(,RUDAPRI) get address of epilogue BR R2 go there * * After epilogue executes control will return to UNWIND. * The reason that the SCA register from the RSA is used as * the base when storing the return address is to handle stack * chunk crossings; when we cross a stack chunk, RSARET in * the active frame will point to #PSTKCLN, which MUST run * to fix up the stack. By using the SCA frame pointer we * are sure that we are changing the return address in the * "real" stack frame passed by the caller. * CALLRTN DS 0H * * We come here when we find the frame of interest. * L RRET,UDAEPI(RUDAPRI) when Abort_End_Rendez returns LR PR1,R11 set up parameter LR RUDAPRI,R10 address of routine BR RUDAPRI call it SPACE PRABEXIT ADARTN DROP ADAPSTAK STKLOCAL EQU * ADAPSTKE ADAEND TSKASM CSECT SPACE ENTRY TSK$GMPR TSK$GMPR DS 0H ********************************************************************* * * * function Get_Main_Priority return System.Priority; * * --| return priority of main procedure * * * * NOTE: Is this meaningful in MVS? It seems that what * * we really want is the dispatching priority of the * * main task. * * * ********************************************************************* USING TSK$GMPR,RUDAPRI establish addressability L RVAL,=V(ADA#MAIN) get address of ADA#MAIN L RVAL,AMAINUDA(,RVAL) get address of UDA for main LH RVAL,UDAPRIO(,RVAL) get priority from UDA BR RRET return DROP SPACE ENTRY TSK$GLK TSK$GLK DS 0H ********************************************************************* * * * function Get_Ents_Static_Link return system.address * * --| Get static link of caller's caller * * --| (which should be an EPS). * * * ********************************************************************* USING TSK$GLK,RUDAPRI L RVAL,RSAFP(,RFP) get caller's caller's frame CLC RSAUDA(4,RVAL),=V(#HOOKUDA) UDA for hook routine? BNE GLKOK nope, we have the right frame L RVAL,RSAFP(RVAL) yep, go to enclosing frame GLKOK L RVAL,RSASBC(RVAL) get static link BR RRET return DROP SPACE ENTRY TSK$RSTL TSK$RSTL DS 0H ********************************************************************* * * * procedure Restore_Static_Link( * * The_Link: System.Address); * * --| Restore static link of caller's caller * * * ********************************************************************* USING TSK$RSTL,RUDAPRI establish a base register L RVAL,RSAFP(,RFP) get caller's caller's frame CLC RSAUDA(4,RVAL),=V(#HOOKUDA) UDA for hook routine? BNE NOTHOOK if not, all set L RVAL,RSAFP(,RVAL) if so, skip debugger frame NOTHOOK DS 0H ST PR1,RSASBC(,RVAL) set static link BR RRET return DROP RUDAPRI SPACE ENTRY ADAGLOB ADAGLOB DS 0H ********************************************************************* * * * function Get_Current_Global return System.Address; * * --| return the address of the task global area * * * ********************************************************************* LR RVAL,RGLBL copy global area address BR R14 return SPACE SPACE DROP ******************************************************************** * * * procedure Asm_Set_Proc_Info( * * State : Task_State_Info; * * Proc : Processor_Info * * ); --| Fill in proc-info field in task-state record. * * * ******************************************************************** ENTRY CIC$SPRO CIC$SPRO DS 0H USING STKSTATE,PR1 map task state ST PR2,STKST#PR fill in proc-info BR R14 and return DROP SPACE LTORG * ##DUMSTK CSECT DC A(##DUMSTK) base DC A(##DUMSTK) top DC A(0) next DC A(0) prev SPACE * MEMCTL ADAMCTL ADAGLOBL ADAUDA SPACE STKSTATE DSECT STKST#FP DS A primary stack frame pointer STKST#PS DS A primary stack MCB address STKST#SP DS A secondary stack frame pointer STKST#SS DS A secondary stack MCB address STKST#PR DS A proc-info for task ORG STKST#PS STKST#GS DS XL12 global area stack info ORG 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$