/* --- Copyright University of Sussex 1994. All rights reserved. ---------- * File: S.axpvms/src/amisc.s * Purpose: Miscellaneous Assembler routines * Author: John Gibson, Sep 12 1994 */ .title "amisc.o" ;;; must be the object file name #_< #_INCLUDE 'asm.ph' vars _call_stack_lim, _plog_trail_sp, _plog_trail_lim ; section $-Sys; constant procedure (Call_overflow, User_overflow, Callstack_reset, Conspair, Plog$-Area_overflow, Async_raise_signal) ; endsection; >_# ASM_CODE_PSECT ;;;--------------------------------------------------------------------------- ;;; do checks .align quad DEF_C_LAB (_checkplogall) ldl rt3, _SVB_OFFS(_plog_trail_sp)(rsvb) ldl rt4, _SVB_OFFS(_plog_trail_lim)(rsvb) ldl rt0, _SVB_OFFS(_call_stack_lim)(rsvb) cmpule rt4, rt3, rt4 ;;; rt4=1 if trail overflow ldl rt1, _SVB_OFFS(_userlim)(rsvb) cmpult sp, rt0, rt0 ;;; rt0=1 if callstack overflow ldl rt2, _SVB_OFFS(_trap)(rsvb) ;;; rt2 = 1 if trap cmpult rusp, rt1, rt1 ;;; rt1=1 if userstack overflow or rt2, rt4, rt3 ;;; rt3=1 if trap or trail overflow or rt0, rt1, rt1 ;;; rt1=1 if call/user overflow or rt1, rt3, rt3 ;;; rt3=1 if any blbs rt3, 1$ ;;; br if so ret (rret) ;;; else return 1$: blbc rt4, checkall_failed ;;; br if no trail overflow ldl rpb, _SVB_OFFS(weakref[prologvar_key] Sys$-Plog$-Area_overflow)(rsvb) ldl rt0, _PD_EXECUTE(rpb) jmp (rt0) ;;; chain Area_overflow .align quad DEF_C_LAB (_checkall) ldl rt0, _SVB_OFFS(_call_stack_lim)(rsvb) ldl rt1, _SVB_OFFS(_userlim)(rsvb) cmpult sp, rt0, rt0 ;;; rt0=1 if callstack overflow cmpult rusp, rt1, rt1 ;;; rt1=1 if userstack overflow ldl rt2, _SVB_OFFS(_trap)(rsvb) ;;; rt2 = 1 if trap or rt0, rt1, rt1 ;;; rt1=1 if call/user overflow or rt1, rt2, rt3 ;;; rt3=1 if stack overflow or trap blbs rt3, checkall_failed ;;; br if so ret (rret) ;;; else return ;;; one or more checks failed .align quad checkall_failed: ldl rt3, _SVB_OFFS(_disable)(rsvb) blbc rt1, 2$ ;;; br if stack checks okay ;;; stack check failed and rt3, #2, rt1 ;;; stack checks disabled? bne rt1, 1$ ;;; br if so to check trap ldl rt2, _SVB_OFFS(Sys$-User_overflow)(rsvb) ldl rpb, _SVB_OFFS(Sys$-Call_overflow)(rsvb) cmovlbc rt0, rt2, rpb ;;; set User_overflow if not call over ldl rt0, _PD_EXECUTE(rpb) jmp (rt0) ;;; chain overflow procedure ;;; check for trap when stack checks disabled 1$: blbc rt2, 3$ ;;; return if no trap ;;; trap pending 2$: blbs rt3, 3$ ;;; return if disabled ldl rpb, _SVB_OFFS(Sys$-Async_raise_signal)(rsvb) ldl rt0, _PD_EXECUTE(rpb) jmp (rt0) ;;; chain Async_raise_signal 3$: ret (rret) .align quad DEF_C_LAB (_checkinterrupt) ldl rt0, _SVB_OFFS(_trap)(rsvb) blbs rt0, C_LAB(_checkall) ;;; br if trap pending ret (rret) ;;; else return ;;; --- CALLING ARBITRARY OBJECTS ---------------------------------------- ;;; applying a poplog object in ARG_REG_0 = rt0 ;;; normal checking entry .align quad DEF_C_LAB (_popenter) ldl rt2, _SVB_OFFS(procedure_key)(rsvb) blbs rt0, 1$ ;;; br if object simple ldl rt1, _KEY(rt0) ;;; key in rt1 ldl rt3, _PD_EXECUTE(rt0) cmpeq rt1, rt2, rt2 blbc rt2, 2$ ;;; br if non-procedure structure mov rt0, rpb jmp (rt3) ;;; execute procedure ;;; applying a simple object. set appropriate key in rt1 .align quad 1$: and rt0, #2, rt2 ;;; test integer tag ldl rt1, _SVB_OFFS(integer_key)(rsvb) ;;; assume integer bne rt2, 2$ ;;; br if so ldl rt1, _SVB_OFFS(weakref decimal_key)(rsvb) ;;; else decimal ;;; applying a structure -- run key apply procedure .align quad 2$: ldl rt1, _K_APPLY(rt1) ;;; K_APPLY ref from key lda rusp, -4(rusp) ldl rpb, _RF_CONT(rt1) ;;; apply procedure in ref cont stl rt0, (rusp) ;;; stack object ldl rt1, _PD_EXECUTE(rpb) ;;; execute address jmp (rt1) ;;; run it ;;; applying an object in ARG_REG_0 = rt0 in update mode .align quad DEF_C_LAB (_popuenter) ldl rt2, _SVB_OFFS(procedure_key)(rsvb) blbs rt0, 2$ ;;; br if object simple ldl rt1, _KEY(rt0) ;;; key in rt1 ldl rpb, _PD_UPDATER(rt0) ;;; assume can load updater in pb cmpeq rt1, rt2, rt2 ;;; has procedure key? blbs rt2, up_ex_pb ;;; br if so to execute updater ;;; applying non procedure as updater ;;; -- run key apply procedure updater (key in rt1) 1$: ldl rt1, _K_APPLY(rt1) ;;; K_APPLY ref from key lda rusp, -4(rusp) ldl rt1, _RF_CONT(rt1) ;;; apply procedure in ref cont stl rt0, (rusp) ;;; stack object ldl rpb, _PD_UPDATER(rt1) ;;; get updater cmpeq rpb, rfalse, rt1 ;;; false? blbs rt1, up_err ;;; br if so ldl rt1, _PD_EXECUTE(rpb) ;;; get updater's execute address jmp (rt1) ;;; run it ;;; applying a simple object as updater. set appropriate key in rt1 2$: and rt0, #2, rt2 ;;; test integer tag ldl rt1, _SVB_OFFS(integer_key)(rsvb) ;;; assume integer bne rt2, 1$ ;;; br if so ldl rt1, _SVB_OFFS(weakref decimal_key)(rsvb) ;;; else decimal br 1$ ;;; updater was false up_err_stack: lda rusp, -4(rusp) stl rt0, (rusp) ;;; stack object up_err: ldl rt1, _SVB_OFFS(Sys$-Exec_nonpd)(rsvb) ldl rpb, _PD_UPDATER(rt1) ldl rt1, _PD_EXECUTE(rpb) jmp (rt1) ;;; run Exec_nonpd updater ;;; call updater of object in rt0 -- no-checking entry .align quad DEF_C_LAB (_popuncenter) ldl rpb, _PD_UPDATER(rt0) ;;; get updater up_ex_pb: cmpeq rpb, rfalse, rt1 ;;; false? blbs rt1, up_err_stack ;;; br if so ldl rt1, _PD_EXECUTE(rpb) ;;; get updater's execute address jmp (rt1) ;;; run it ;;; --- CHAINING ROUTINES --------------------------------------------------- ;;; Unwind the current stack frame, by jumping into the procedure's ;;; exit code. This subroutine is called immediately after executing ;;; an M_UNWIND_SF operation, so that the (unwanted) return address ;;; into the procedure being unwound has been replaced in rret by this ;;; subroutine's return address. ;;; The procedure's exit code finishes with 'ret (rret)', and we ;;; replace the return address into the NEXT caller with the return ;;; from this subroutine, but saving the former in rchain, from ;;; whence it can be restored with an M_CALL_WITH_RETURN operation. ;;; Alpha version also saves PB on stack (UNWIND_FRAME_SAVES_PB ;;; set true by genproc.p) .align quad DEF_C_LAB (_unwind_frame) stl rpb, -4(rusp) ;;; save rpb on stack ldl rpb, _SF_OWNER(sp) ;;; ensure pb set for current pdr lda rusp, -4(rusp) ldl rt1, _PD_FRAME_LEN_l(rpb) ;;; get word with frame len ldl rt0, _PD_EXIT(rpb) ;;; address of pdr's exit code extbl rt1, #_PD_FRAME_LEN_b, rt1 ;;; frame length in words s4addl rt1, sp, rt1 ;;; sp for next caller ldl rchain, _SF_RETURN_ADDR(rt1) ;;; save its return in chain reg stl rret, _SF_RETURN_ADDR(rt1) ;;; and replace with my return jmp (rt0) ;;; go to current's exit code ;;; Routines to chain a procedure, either directly or out of the ;;; current caller. These are executed as a result of displacing a ;;; stack frame return address with their address and then returning. ;;; In the case of _syschain and _sysncchain, the displaced return is ;;; saved in rchain. .align quad DEF_C_LAB (_syschain_caller) bsr rret, C_LAB(_unwind_frame) ;;; pop frame for caller lda rusp, 4(rusp) ;;; erase saved rpb DEF_C_LAB (_syschain) mov rchain, rret ;;; reinstate return address from chain reg ldl rt0, (rusp) ;;; object to chain on user stack lda rusp, 4(rusp) br C_LAB(_popenter) ;;; check and run it ;;; The same, but with no check for procedure .align quad DEF_C_LAB (_sysncchain_caller) bsr rret, C_LAB(_unwind_frame) ;;; pop frame for caller lda rusp, 4(rusp) ;;; erase saved rpb DEF_C_LAB (_sysncchain) mov rchain, rret ;;; reinstate return address from chain reg ldl rpb, (rusp) ;;; procedure to chain on user stack lda rusp, 4(rusp) ldl rt0, _PD_EXECUTE(rpb) jmp (rt0) ;;; run it ;;;--------------------------------------------------------------------------- ;;; erase 1 word from the call stack and chain Callstack_reset ;;; (used by Callstack_reset in cleaning up) DEF_C_LAB (_erase_sp_1) lda sp, 4(sp) ;;; chop off a word ldl rpb, _SVB_OFFS(Sys$-Callstack_reset)(rsvb) ldl rt0, _PD_EXECUTE(rpb) jmp (rt0) ;;; try again ;;;--------------------------------------------------------------------------- ;;; _nextframe(________sframe) -> ___________nextframe ;;; get next stack frame from ________sframe .align quad DEF_C_LAB (_nextframe) ldl rt0, (rusp) ;;; ________sframe ldl rt1, _SF_OWNER(rt0) ;;; owner procedure ldl rt1, _PD_FRAME_LEN_l(rt1) ;;; get word with frame len extbl rt1, #_PD_FRAME_LEN_b, rt1 ;;; frame length in words s4addl rt1, rt0, rt1 ;;; ________sframe + frame offs = ___________nextframe stl rt1, (rusp) ;;; return it ret (rret) ;;;--------------------------------------------------------------------------- ;;; fast routines for subscrs and its updater ;;; _subss(_________subscript, ______string) -> ____byte .align quad DEF_C_LAB (_subss) ldl rt1, 4(rusp) ;;; _________subscript ldl rt0, (rusp) ;;; ______string sra rt1, #2, rt1 ;;; _________subscript -> sysint lda rt0, _V_BYTES-1(rt0) ;;; adjust addr for base 1 subscript addl rt0, rt1, rt0 ;;; ptr to byte ldq_u rt1, (rt0) ;;; quadword containing it lda rusp, 4(rusp) extbl rt1, rt0, rt1 ;;; get the byte s4addl rt1, #3, rt1 ;;; convert to popint stl rt1, (rusp) ;;; return it ret (rret) ;;; ____byte -> _subss(_________subscript, ______string) ;;; _u_subss(____byte, _________subscript, ______string) .align quad DEF_C_LAB (-> _subss) DEF_C_LAB (_u_subss) ldl rt1, 4(rusp) ;;; _________subscript ldl rt0, (rusp) ;;; ______string sra rt1, #2, rt1 ;;; _________subscript -> sysint lda rt0, _V_BYTES-1(rt0) ;;; adjust addr for base 1 subscript addl rt0, rt1, rt0 ;;; ptr to byte ldq_u rt1, (rt0) ;;; quadword containing it ldl rt2, 8(rusp) ;;; ____byte lda rusp, 12(rusp) ;;; remove args sra rt2, #2, rt2 ;;; ____byte -> sysint mskbl rt1, rt0, rt1 ;;; clear byte position in quadword insbl rt2, rt0, rt2 ;;; shift new byte to position or rt1, rt2, rt1 ;;; or in new byte stq_u rt1, (rt0) ;;; store the updated quadword ret (rret) ;;; --- PREDICATES ---------------------------------------------------------- ;;; _not(____item) -> ____bool .align quad DEF_C_LAB (_not) ldl rt0, (rusp) lda rt1, _TRUEOFFS(rfalse) cmpeq rt0, rfalse, rt0 cmovlbc rt0, rfalse, rt1 stl rt1, (rusp) ret (rret) ;;; _isinteger(____item) -> ____bool .align quad DEF_C_LAB (_isinteger) ldl rt0, (rusp) lda rt1, _TRUEOFFS(rfalse) and rt0, #2, rt0 cmoveq rt0, rfalse, rt1 stl rt1, (rusp) ret (rret) #_< define lconstant macro TST_ROUTINE S cmov_op; lvars cmov_op, S; [ ldl \t rt0, (rusp) \n \t lda \t rt1, _TRUEOFFS(rfalse) \n \t ^cmov_op \t rt0, rfalse, rt1 \n \t stl \t rt1, (rusp) \n \t ret \t (rret) \n ].dl enddefine; >_# ;;; _iscompound(____item) -> ____bool .align quad DEF_C_LAB (_iscompound) TST_ROUTINE cmovlbs ;;; _issimple(____item) -> ____bool .align quad DEF_C_LAB (_issimple) TST_ROUTINE cmovlbc ;;; _zero(_____int) -> ____bool .align quad DEF_C_LAB (_zero) TST_ROUTINE cmovne ;;; _neg(_____int) -> ____bool .align quad DEF_C_LAB (_neg) TST_ROUTINE cmovge #_< define lconstant macro CMP_ROUTINE S cmp_op S cmov_op; lvars cmp_op, cmov_op, S; [ ldl \t rt0, _4(rusp) \n \t ldl \t rt1, (rusp) \n \t lda \t rusp, _4(rusp) \n \t lda \t rt2, _TRUEOFFS(rfalse) \n \t ^cmp_op \t rt0, rt1, rt0 \n \t ^cmov_op \t rt0, rfalse, rt2 \n \t stl \t rt2, (rusp) \n \t ret \t (rret) \n ].dl enddefine; >_# ;;; ______int1 _bitst ______int2 -> ____bool (bit test) .align quad DEF_C_LAB 4 (_bitst) CMP_ROUTINE and cmoveq ;;; ______int1 _gr ______int2 -> ____bool (unsigned greater than) .align quad DEF_C_LAB 6 (_gr) CMP_ROUTINE cmpule cmovlbs ;;; ______int1 _greq ______int2 -> ____bool (unsigned greater than or equal) .align quad DEF_C_LAB 6 (_greq) CMP_ROUTINE cmpult cmovlbs ;;; ______int1 _lt ______int2 -> ____bool (unsigned less than) .align quad DEF_C_LAB 6 (_lt) CMP_ROUTINE cmpult cmovlbc ;;; ______int1 _lteq ______int2 -> ____bool (unsigned less than or equal) .align quad DEF_C_LAB 6 (_lteq) CMP_ROUTINE cmpule cmovlbc ;;; ______int1 _sgr ______int2 -> ____bool (signed greater than) .align quad DEF_C_LAB 6 (_sgr) CMP_ROUTINE cmple cmovlbs ;;; ______int1 _sgreq ______int2 -> ____bool (signed greater than or equal) .align quad DEF_C_LAB 6 (_sgreq) CMP_ROUTINE cmplt cmovlbs ;;; ______int1 _slt ______int2 -> ____bool (signed less than) .align quad DEF_C_LAB 6 (_slt) CMP_ROUTINE cmplt cmovlbc ;;; ______int1 _slteq ______int2 -> ____bool (signed less than or equal) .align quad DEF_C_LAB 6 (_slteq) CMP_ROUTINE cmple cmovlbc ;;; _____item1 _eq _____item2 -> ____bool .align quad DEF_C_LAB 7 (_eq) CMP_ROUTINE cmpeq cmovlbc ;;; _____item1 _neq _____item2 -> ____bool .align quad DEF_C_LAB 7 (_neq) CMP_ROUTINE cmpeq cmovlbs ;;;--------------------------------------------------------------------------- ;;; _haskey(____item, ___key) -> ____bool .align quad DEF_C_LAB (_haskey) ldl rt0, 4(rusp) ;;; ____item ldl rt1, (rusp) ;;; ___key lda rusp, 4(rusp) blbs rt0, 1$ ;;; false if simple ldl rt2, _KEY(rt0) ;;; else get key lda rt3, _TRUEOFFS(rfalse) xor rt2, rt1, rt0 ;;; zero if keys equal 1$: cmovne rt0, rfalse, rt3 stl rt3, (rusp) ret (rret) ;;; _datakey(____item) -> ___key ;;; get the key of any pop object .align quad DEF_C_LAB (_datakey) ldl rt0, (rusp) ;;; ____item blbs rt0, 1$ ;;; br if simple ldl rt0, _KEY(rt0) ;;; else get key stl rt0, (rusp) ret (rret) 1$: and rt0, #2, rt0 ;;; integer? beq rt0, 2$ ;;; br if not ldl rt0, _SVB_OFFS(integer_key)(rsvb) stl rt0, (rusp) ret (rret) 2$: ldl rt0, _SVB_OFFS(weakref decimal_key)(rsvb) stl rt0, (rusp) ret (rret) ;;;--------------------------------------------------------------------------- ;;; _conspair(_________frontitem, ________backitem) -> ____pair ;;; optimise subroutine for "conspair" .align quad DEF_C_LAB (_conspair) ldl rt0, _SVB_OFFS(Sys$- _free_pairs)(rsvb) ;;; get free pair list ldl rt2, (rusp) ;;; ________backitem blbs rt0, 1$ ;;; none left if simple ldl rt1, _P_BACK(rt0) ldl rt3, 4(rusp) ;;; _________frontitem lda rusp, 4(rusp) ;;; pop stack stl rt1, _SVB_OFFS(Sys$- _free_pairs)(rsvb) ;;; remove pair from _free_pairs stl rt2, _P_BACK(rt0) ;;; assign items into pair stl rt3, _P_FRONT(rt0) stl rt0, (rusp) ;;; return ____pair ret (rret) ;;; no pairs left, chain Conspair 1$: ldl rpb, _SVB_OFFS(Sys$-Conspair)(rsvb) ldl rt0, _PD_EXECUTE(rpb) jmp (rt0) .end