; =====> SSTACK.ASM ;*************************************** ;* TIPC Scheme '84 Runtime Support * ;* Interpreter -- Stack Operations * ;* * ;* (C) Copyright 1984,1985 by Texas * ;* Instruments Incorporated. * ;* All rights reserved. * ;* * ;* Date Written: 2 May 1984 * ;* Last Modification: 22 October 1985 * ;*************************************** ;* Modification History: ;* 06 Mar 86 - Recoded the C_push and C_pop routines to attemp to ;* (JCJ) improve their performance and memory utilization. ;* include scheme.equ include sinterp.mac include sinterp.arg include stackf.equ ; define stack frame format XGROUP group PROGX DGROUP group data data segment word public 'DATA' assume DS:DGROUP public stk_in,stk_out stk_in dd 0 ; number of bytes moved into the stack stk_out dd 0 ; number of bytes moved out of the stack m_%exec db "%EXECUTE",0 m_stk_un db "[VM INTERNAL ERROR] Stack underflow",LF,0 m_stk_ov db LF,"[VM ERROR encountered!] Recursion too deep: Stack " db "overflow",LF,0 clos_ptr dw 0 ; register number containing closure pointer m_APPLY dw APPLY_ARG_LIMIT_ERROR m_AP1 db "APPLY",0 ; text for "apply" function name m_AP_adr dw m_AP1 ; address of above text m_one dw 1 ; a constant "one" (1) data ends PGROUP group prog prog segment byte public 'PROG' assume CS:PGROUP stk_int proc near ; Entry points defined in "sinterp.asm" extrn next:near ; Top of interpreter extrn next_PC:near ; Reload ES,SI at top of interpreter extrn next_SP:near ; All of the above, with "mov SP,BP" first extrn src_err:near ; "source operand error" message display extrn sch_err:near ; Link to Scheme Debugger extrn printf_c:near ; Error message print routine extrn %allocbl:far ; Far linkage to "alloc_block" ;************************************************************************ ;* AL * ;* Push register onto stack PUSH reg * ;* * ;* Purpose: Interpreter support to cause the contents of one of the * ;* VM's general registers to be pushed onto the VM's * ;* runtime stack * ;************************************************************************ public spush spush: lods byte ptr ES:[SI] ; load number of register to push spush1: mov DI,TOS ; load top of stack pointer cmp DI,STKSIZE-PTRSIZE ; test for overflow jge spush2 ; jump if overflow will occur add DI,PTRSIZE ; decrement stack top pointer mov TOS,DI ; update TOS pointer in memory mov BX,AX ; copy register number mov AL,byte ptr reg0_pag+[BX] ; load page number from register mov S_stack+[DI].car_page,AL ; and move to the stack mov AX,reg0_dis+[BX] ; same for displacement mov word ptr S_stack+[DI].car,AX jmp next ; process stack overflow-- copy contents to heap spush2: pushm ; preserve "important" regs across call call stk_ovfl ; handle overflow situation popm ; restore "important" registers jmp spush1 ; re-try push ;************************************************************************ ;* AL * ;* Pop register from stack POP reg * ;* * ;* Purpose: Interpreter support to cause the contents of one of the * ;* VM's general registers to be replaced by popping the * ;* value off the top of the VM's runtime stack * ;* * ;* Note: There's no need to check for stack underflow on a simple * ;* POP, because the stack is broken into segments only at stack * ;* frame boundaries. Underflow can occur only when stack space * ;* for a stack frame is released (i.e., during an EXIT). * ;************************************************************************ public spop spop: lods byte ptr ES:[SI] ; load number of register to pop mov DI,TOS ; load top of stack pointer mov BX,AX ; copy register number mov AL,S_stack+[DI].car_page ; move page no. from stack mov byte ptr reg0_pag+[BX],AL ; and update in register mov AX,word ptr S_stack+[DI].car ; same for displacement mov reg0_dis+[BX],AX sub DI,PTRSIZE ; decrement TOS pointer mov TOS,DI ; update TOS pointer in memory jmp next ;************************************************************************ ;* AL * ;* Drop-- remove top elements from stack DROP n * ;* * ;* Purpose: Interpreter support to cause the top "n" elements of the * ;* VM's runtime stack to be discarded. "n" is determined * ;* from the operand of the DROP instruction * ;* * ;* Note: There's no need to check for stack underflow on a DROP * ;* because the stack is broken into segments only at stack * ;* frame boundaries. Underflow can occur only when stack space * ;* for a stack frame is released (i.e., during an EXIT). * ;************************************************************************ public sdrop sdrop: lods byte ptr ES:[SI] ; load number of elements to drop mov DX,AX ; multiply by 3 (size of element) shl AX,1 add AX,DX sub TOS,AX ; update TOS pointer in memory jmp next ; return to interpreter ;************************************************************************ ;* AL AH * ;* Local from local stack frame LDLOCAL dest,entry * ;************************************************************************ public ld_local ld_local: lods word ptr ES:[SI] ; load dest reg, entry number operands mov BL,AL ; copy destination register number mov DI,BX ; into DI (clear high order byte) mov BL,AH ; copy the entry number (clear high byte) mov AX,BX ; BX <- entry * 3 sal AX,1 add BX,AX add BX,FP ; BX <- FP + (entry * 3) mov AL,S_stack+[BX].sf_dat_p ; move page number of entry to mov byte ptr reg0_pag+[DI],AL ; destination register mov AX,word ptr S_stack+[BX].sf_dat_d ; move displacement of mov reg0_dis+[DI],AX ; entry to destination register jmp next ;************************************************************************ ;* AL AH * ;* Store into local stack frame STLOCAL src,entry * ;************************************************************************ public st_local st_local: lods word ptr ES:[SI] ; load dest reg, entry number operands mov BL,AL ; copy destination register number mov DI,BX ; into DI (clear high order byte) mov BL,AH ; copy the entry number (clear high byte) mov AX,BX ; BX <- entry * 3 sal AX,1 add BX,AX add BX,FP ; BX <- FP + (entry * 3) ; cmp BX,TOS ; store out of range? ; jgt st_err ; if so, record error mov AL,byte ptr reg0_pag+[DI] ; move page number of entry from mov S_stack+[BX].sf_dat_p,AL ; destination register mov AX,reg0_dis+[DI] ; move displacement of entry from mov word ptr S_stack+[BX].sf_dat_d,AX ; destination register jmp next ;************************************************************************ ;* AL AL AH * ;* Load from higher lexical level LDLEX dest,entry,lvl * ;************************************************************************ public ld_lex ld_lex: lods byte ptr ES:[SI] ; load destination register operand push AX ; and save it lods word ptr ES:[SI] ; load lexical level and entry number save ; save current location pointer mov BL,AH ; clear high order byte of the lexical mov CX,BX ; level number delta and move to CX mov BL,AL ; align, and save entry number push BX call delta_lv ; get pointer to parent's stack frame pop AX ; get entry number mov BX,AX ; BX <- entry number * 3 shl AX,1 add BX,AX pop DI ; get destination register number mov AL,ES:[SI].sf_dat_p+[BX] ; copy lexical entry from stack mov byte ptr reg0_pag+[DI],AL ; frame to destination register mov AX,ES:[SI].sf_dat_d+[BX] mov reg0_dis+[DI],AX jmp next_PC ; return to the interpreter ;************************************************************************ ;* AL AL AH * ;* Store into higher lexical level STLEX src,entry,lvl * ;************************************************************************ public st_lex st_lex: lods byte ptr ES:[SI] ; load source register operand push AX ; and save it lods word ptr ES:[SI] ; load lexical level and entry number save ; save current location pointer mov BL,AH ; clear high order byte of the lexical mov CX,BX ; level number delta and move to CX mov BL,AL ; align, and save entry number push BX call delta_lv ; get pointer to parent's stack frame pop AX ; get entry number mov BX,AX ; BX <- entry number * 3 shl AX,1 add BX,AX pop DI ; get source register number mov AL,byte ptr reg0_pag+[DI] ; copy contents of register into mov ES:[SI].sf_dat_p+[BX],AL ; lexical entry of stack mov AX,reg0_dis+[DI] mov ES:[SI].sf_dat_d+[BX],AX jmp next_PC ; return to the interpreter ;************************************************************************ ;* AX AL AH * ;* Call local routine CALL lbl,delta-lvl,delta-heap* ;************************************************************************ public call_lcl call_lcl: mov AX,offset PGROUP:next_PC ; For a "CALL", make a tail push AX ; recursive call to following routine cl_l_sub: lods word ptr ES:[SI] ; load branch displacement mov DX,AX ; and save in register DX lods word ptr ES:[SI] ; load delta-level,delta-heap numbers inc AL ; increment releative lexical level mov BL,AL ; isolate delta-lvl and save it push BX mov BL,AH ; isolate delta-heap and save it, too push BX add DX,SI ; compute branch destination address mov [BP].save_SI,DX ; store updated location counter call new_SF ; allocate new stack frame on top of stack mov SI,BX ; save pointer to new stack frame pop CX ; restore the delta-heap argument call delta_hp ; determine new heap env pointer mov S_stack+[SI].sf_hpage,BL ; store new heap env pointer into mov word ptr S_stack+[SI].sf_hdisp,DI ; new stack frame pop CX ; restore the delta-lvl argument push SI ; save new stack frame pointer call delta_lv ; get static link pop SI ; retrieve new stack frame pointer mov word ptr S_stack+[SI].sf_sdisp,BX ; update static link mov FP,SI ; update current frame pointer ret ; return to interpreter, or call/cc support ;************************************************************************ ;* AX AL AH * ;* Call local routine tail recursively CALL-TR lbl,delta-lvl,delta-heap* ;************************************************************************ public call_ltr call_ltr: mov AX,offset PGROUP:next_PC ; For a "CALL-TR", make a tail push AX ; recursive call to following routine cl_lt_sb: lods word ptr ES:[SI] ; load branch displacement mov DX,AX ; and save in register DX lods word ptr ES:[SI] ; load delta-level,delta-heap numbers inc AL ; increment releative lexical level mov BL,AL ; isolate delta-lvl and save it push BX mov BL,AH ; isolate delta-heap and save it, too mov CX,BX add DX,SI ; compute branch destination address mov [BP].save_SI,DX ; store updated location counter mov AX,FP ; load pointer to current stack frame mov SI,AX add AX,SF_OVHD-PTRSIZE mov TOS,AX ; drop any local var's off top of stack call delta_hp ; determine new heap env pointer mov S_stack+[SI].sf_hpage,BL ; store new heap env pointer into mov word ptr S_stack+[SI].sf_hdisp,DI ; new stack frame mov S_stack+[SI].sf_cl_pg,NIL_PAGE*2 ; nil out closure pointer mov word ptr S_stack+[SI].sf_cl_ds,NIL_DISP ; entry in stack frame pop CX ; restore the delta-lvl argument push SI ; save pointer to stack frame call delta_lv ; get static link pop SI ; retrieve pointer to stack frame mov word ptr S_stack+[SI].sf_sdisp,BX ; update static link ret ; return to interpreter, or call/cc support ;************************************************************************ ;* AL AH * ;* Call closed procedure CALL-CLOSURE ftn,#args * ;* * ;* Purpose: Scheme interpreter support for procedure calls to fully * ;* closed functions * ;************************************************************************ public call_clo call_clo: mov AX, offset PGROUP:next_PC ; For a "CALL-CLOSURE" make a tail push AX ; recursive call to the following routine lods word ptr ES:[SI] ; fetch ftn reg, number of args passed cl_c_sub: mov BL,AH ; isolate the number of arguments push BX ; passed and save it mov BL,AL ; copy the procedure object register mov DI,reg0_pag+[BX] ; load page number of closure pointer cmp byte ptr ptype+[DI],CLOSTYPE*2 je call_cok ; if a regular closure, jump jmp call_cnt ; otherwise, a continuation (probably) ; Procedure call to a closed procedure call_cok: push BX ; save number of procedure pointer reg call new_SF ; allocate a new stack frame pop SI ; restore reg number with closure pointer ; Load the pointer to the closure object from the operand register call_xxx: mov clos_ptr,SI ; save number of register containing closure mov DI,reg0_pag+[SI] mov SI,reg0_dis+[SI] LoadPage ES,DI ;;; mov ES,pagetabl+[DI] ; Put the closure pointer into the newly allocated stack frame mov AX,DI ; copy closure's page number to AL mov S_stack+[BX].sf_cl_pg,AL ; then copy into stack frame mov word ptr S_stack+[BX].sf_cl_ds,SI ; put disp into frame, too ; Copy the pointer to the procedure's heap environment from the closure ; object to the new stack frame mov AL,ES:[SI].clo_hpag mov S_stack+[BX].sf_hpage,AL mov AX,ES:[SI].clo_hdis mov word ptr S_stack+[BX].sf_hdisp,AX ; Dummy up the Static Link in the new Stack Frame mov word ptr S_stack+[BX].sf_sdisp,0 ; Update the current frame pointer to point to new stack frame mov FP,BX ; Obtain the entry point address from the closure object mov AX,ES:[SI].clo_cb_d ; define the code base register mov CB_dis,AX add AX,ES:[SI].clo_edis ; add the entry point offset mov [BP].save_SI,AX ; and set up for load into location pointer xor AX,AX mov AL,ES:[SI].clo_cb_p mov byte ptr CB_pag,AL mov DI,AX ; obtain the code block page's paragraph LoadCode AX,DI ;;; mov AX,pagetabl+[DI] ; address and update in memory mov [BP].save_ES,AX ; Determine if the closed function is a mulambda pop CX ; get number of args passed mov AX,ES:[SI].clo_narg ; load number of args expected shl AX,1 ; sign extend the number of sar AX,1 ; arguments expected jl call_mu ; if #args negative, then a mulambda (jump) cmp AX,CX ; verify args passed/expected agree je call_crt ; if so, jump ; ***Error-- wrong number of arguments passed to a closed function*** cl_wrng: mov AX,clos_ptr ; load number of register w/ closure pointer add AX,offset reg0 pushm ; push count of args passed, closure ptr cl_wrng1: C_call wrong_ar,,Load_ES ; print error message and fixup VM regs restore ; load address of next instruction jmp sch_err ; link to Scheme error routine call_crt: ret ; return to interpreter, or call/cc support ; Funtion being called is a mulambda-- cons arguments into a list call_mu: mov SI,CX ; compute the address of the last sal SI,1 ; register which contains an argument sal SI,1 ; to be passed to the mulambda add SI,offset reg0 lea DI,[SI]+size C_ptr ; load address of register page last arg mov [DI].C_page,NIL_PAGE*2 ; put a value of "nil" into the mov [DI].C_disp,NIL_DISP ; register for end of list mov ES,[BP].C_ES ; set up ES for calls to "cons" mov DX,CX ; save number of arguments passed add CX,AX ; adjust number of arguments passed inc CX ; by number required je mu_ret ; if #passed = #required, jump jl mu_wrng ; if too few passed, jump mu_loop: push DI ; push addr of "cdr" register push SI ; push addr of "car" register push SI ; push addr of dest reg (result of cons) C_call cons, ; cons together ptrs in regs "n" and "n+1" add SP,WORDINCR ; drop one copy of SI from the 8088's stack pop SI ; restore value of SI pop DI ; restore value of DI restore ; restore registers destroyed by the call mov [DI].C_page,UN_PAGE*2 ; set register "n+1" to "***unbound***" mov [DI].C_disp,UN_DISP mov DI,SI ; update pointers for next iteration sub SI,size C_ptr loop mu_loop ; repeat for all arguments passed mu_ret: ret ; return to interpreter, or call/cc support ; Too few required arguments-- inform user mu_wrng: mov CX,DX ; restore count of args passed jmp cl_wrng ; print "wrong number of args" message ; Function call is invoking a continuation-- unless we've got an error call_cnt: cmp ptype+[DI],CONTTYPE*2 je cl_cn_ok ; ***Error-- thing being called isn't a procedure object-- note*** ; Note: at this point, the number of arguments passed has been pushed ; onto the runtime stack add BX,offset reg0 ; compute address of "functional" register push BX ; and push as argument C_call not_proc,,Load_ES ; call: not_procedural_object(obj, #args); restore ; load address of next instruction jmp sch_err ; link to Scheme debugger ; Oh, wow! we've got a continuation to envoke (or is that invoke?) ; ; Note: the contents of the stack is restored by making the VM's ; previous stack segment register point to the continuation ; object and signaling an underflow condition. This restores ; the stack, BASE, TOS, PREV_pag, and PREV_dis. The ; remainder of this code fetches the values of CB_pag, ; CB_dis, FP, and LP from the continuation object. ; cl_cn_ok: push BX ; save pointer to continuation object mov AL,byte ptr reg0_pag+[BX] ; copy continuation pointer into mov byte ptr PREV_pag,AL ; PREV_reg mov AX,reg0_dis+[BX] mov PREV_dis,AX call stk_unfl ; signal a stack underflow condition pop DI ; retrieve ptr to reg with continuation ptr. mov SI,reg0_pag+[DI] ; make ES:[SI] point to the continuation LoadPage ES,SI ;;; mov ES,pagetabl+[SI] ; object mov SI,reg0_dis+[DI] xor BX,BX mov BL,ES:[SI].con_cb_p mov byte ptr CB_pag,BL LoadCode AX,BX ;;; mov AX,pagetabl+[BX] ; obtain the code block's paragraph address mov [BP].save_ES,AX mov AX,ES:[SI].con_cb_d ; restore code base pointer mov CB_dis,AX add AX,ES:[SI].con_ret ; restore return address displacement mov [BP].save_SI,AX mov AX,ES:[SI].con_ddis ; restore FP from dynamic link sub AX,BASE ; adjust for current stack buffer base mov FP,AX mov AL,ES:[SI].con_fl_p ; restore fluid environment (FNV_reg) mov byte ptr FNV_pag,AL mov AX,ES:[SI].con_fl_d mov FNV_dis,AX mov AL,ES:[SI].con_gl_p ; restore global environment (GNV_reg) mov byte ptr GNV_pag,AL mov AX,ES:[SI].con_gl_d mov GNV_dis,AX pop AX ; get number of arguments passed cmp AX,1 ; one argument passed? jne cl_cn_er ; if so, good! we can continue (fall thru) cl_cn_rt: ret ; return to interpreter, or call/cc support ; ***error-- wrong number of arguments passed to a continuation*** cl_cn_er: add DI,offset reg0 ; load address of continuation's register pushm ; push continuation ptr, args passed jmp cl_wrng1 ; process error condition ;************************************************************************ ;* AL AH * ;* Call closed proc tail recursively CALL-CLOSURE-TR ftn,#args * ;* * ;* Purpose: Scheme interpreter support for procedure calls to fully * ;* closed functions tail recursively * ;************************************************************************ public call_ctr call_ctr: mov AX,offset PGROUP:next_PC ; For "CALL-CLOSURE-TR" make tail push AX ; recursive call to the following routine lods word ptr ES:[SI] ; fetch ftn reg, number of args passed cl_ct_sb: mov BL,AH ; isolate the number of arguments push BX ; passed and save it mov BL,AL ; copy the procedure object register mov DI,reg0_pag+[BX] ; load page number of procedure object cmp ptype+[DI],CLOSTYPE*2 ; is it a closure data object? je call_cko ; if a regular closure, jump jmp call_cnt ; otherwise, a continuation (probably) ; Procedure call (tail recursive) to a closed procedure call_cko: mov SI,BX ; copy reg number with closure pointer mov AX,FP ; use current stack frame for this call mov BX,AX ; drop any local vars from top of stack add AX,SF_OVHD-PTRSIZE mov TOS,AX ; update TOS pointer jmp call_xxx ; continue processing as non-tr call ;************************************************************************ ;* Call/cc local CALL/CC lbl,delta-lvl,delta-heap* ;* * ;* Purpose: Interpreter support for a local call with current * ;* continuation * ;* * ;* Description: * ;* 1. The local CALL support is called to create a new * ;* stack frame and to establish the VM's registers * ;* for the branch to the called routine. * ;* 2. A stack overflow condition is signaled to cause * ;* the contents of the stack to be saved on the heap * ;* in a continuation object format. * ;* 3. Fields in the continuation object are updated to * ;* cause control to return to the correct place when * ;* the continuation is invoked. * ;* 4. Control returns to the Scheme interpreter. * ;************************************************************************ public call_cc call_cc: call cl_l_sub ; call CALL's alternate entry point call_cc1: call stk_ovfl ; signal stack overflow mov BX,PREV_pag ; move pointer to continuation into R1 mov DI,PREV_dis mov reg1_pag,BX mov reg1_dis,DI LoadPage ES,BX ;;; mov ES,pagetabl+[BX] mov SI,FP ; create a pointer to the current stack add SI,offset S_stack ; frame (the new one) mov AL,[SI].sf_cb_pag ; copy the value of the VM's code base mov ES:[DI].con_cb_p,AL ; into the continuation object mov AX,[SI].sf_cb_dis mov ES:[DI].con_cb_d,AX mov AX,[SI].sf_ret ; copy the return address displacement mov ES:[DI].con_ret,AX ; into the continuation object mov AX,[SI].sf_ddisp ; copy the dynamic link into the mov ES:[DI].con_ddis,AX ; continuation object jmp next_PC ; return to the interpreter ;************************************************************************ ;* Call/cc tail recursively CALL/CC-TR lbl,delta-lvl,delta-heap* ;* * ;* Purpose: Interpreter support for a tail recursive local call with * ;* current continuation * ;* * ;* Description: * ;* 1. The local CALL-TR support is called to update the * ;* current stack frame and to establish the VM's * ;* registers for the branch to the called routine. * ;* 2. Control transfers to the CALL/CC support to create * ;* the continuation object. * ;************************************************************************ public cl_cctr cl_cctr: mov AX,offset PGROUP:call_cc1 ; define return address push AX jmp cl_lt_sb ; tail recursive call to CALL-TR's ; secondary entry point ;************************************************************************ ;* AL * ;* Call/cc with of procedure object CALL/CC-CLOSURE ftn * ;* * ;* Purpose: Interpreter support for a call with current continuation * ;* of a fully closed function * ;* * ;************************************************************************ public clcc_c clcc_c: lods byte ptr ES:[SI] ; load register number pointing to closure mov AH,1 ; indicate one argument being passed push AX ; and save "operands" mov AX,FP ; save current stack frame pointer add AX,BASE push AX mov AX,TOS ; update FP to where it will be after add AX,PTRSIZE ; the new stack frame is built mov FP,AX call stk_ovfl ; signal stack overflow to create ; continuation data object mov BX,PREV_pag ; load pointer to continuation mov DI,PREV_dis LoadPage ES,BX ;;; mov ES,pagetabl+[BX] mov AL,byte ptr CB_pag ; copy the value of the VM's code base mov ES:[DI].con_cb_p,AL ; into the continuation object mov AX,CB_dis mov ES:[DI].con_cb_d,AX sub SI,AX mov ES:[DI].con_ret,SI ; place return addr in continuation object add SI,AX pop AX ; define dynamic link in continuation mov ES:[DI].con_ddis,AX ; object sub AX,BASE ; put FP back to where it should be mov FP,AX ; Note: FP's now negative (TOS is 0) ; Perform the Call-Closure-Tail-Recursive mov AL,byte ptr PREV_pag ; save the pointer to the new mov byte ptr tm2_page,AL ; continuation mov AX,PREV_dis mov tm2_disp,AX pop AX ; recover "operands" to call-closure call cl_c_sub ; call CALL-CLOSURE mov AL,byte ptr tm2_page ; move continuation pointer into mov byte ptr reg1_pag,AL ; VM register R1 mov AX,tm2_disp mov reg1_dis,AX jmp next_PC ; return to interpreter ;************************************************************************ ;* AL * ;* Call/cc with of procedure object CALL/CC-CLOSURE-TR ftn * ;* * ;* Purpose: Interpreter support for a tail recursive call with current * ;* continuation of a fully closed function * ;* * ;* Description: * ;* 1. The CALL/CC-CLOSURE argument is fetched. * ;* 2. The current continuation is formed using the * ;* caller's return address (since there's no way to * ;* return here from the tail recursive call). * ;* The pointer to the continuation is placed into * ;* VM register 1. * ;* 3. The CALL-CLOSURE-TR code is called to complete the * ;* call sequence. * ;************************************************************************ public clcc_ctr clcc_ctr: lods byte ptr ES:[SI] ; load register number pointing to closure mov AH,1 ; indicate one argument being passed push AX ; and save "operands" call stk_ovfl ; signal stack overflow to create ; continuation data object mov BX,PREV_pag ; load pointer to continuation mov DI,PREV_dis LoadPage ES,BX ;;; mov ES,pagetabl+[BX] mov SI,FP ; create a pointer to the current stack add SI,offset S_stack ; frame (the new one) mov AL,[SI].sf_cb_pag ; copy the value of the VM's code base mov ES:[DI].con_cb_p,AL ; into the continuation object mov AX,[SI].sf_cb_dis mov ES:[DI].con_cb_d,AX mov AX,[SI].sf_ret ; copy the return address displacement mov ES:[DI].con_ret,AX ; into the continuation object mov AX,[SI].sf_ddisp ; copy the dynamic link into the mov ES:[DI].con_ddis,AX ; continuation object ; Perform the Call-Closure-Tail-Recursive mov AL,byte ptr PREV_pag ; save the pointer to the new mov byte ptr tm2_page,AL ; continuation mov AX,PREV_dis mov tm2_disp,AX pop AX ; recover "operands" to call-closure-tr call cl_ct_sb ; call CALL-CLOSURE-TR mov AL,byte ptr tm2_page ; move continuation pointer into mov byte ptr reg1_pag,AL ; VM register R1 mov AX,tm2_disp mov reg1_dis,AX jmp next_PC ; return to interpreter ;************************************************************************ ;* AL AH * ;* Apply closure APPLY-CLOSURE ftn,args * ;* * ;* Purpose: Interpreter support for the "apply" primitive. The * ;* argument list (in register "args") are to be passed * ;* to the closure pointed to by the "ftn" register. * ;* * ;* Note: The argument registers may be anything that the compiler * ;* decides on, so the "ftn" pointer could be destroyed * ;* in the process of loading the arguments of the argument * ;* list ("args") into the VM general registers R1-Rn. * ;* So that the ftn pointer is not lost during this process,* ;* this pointer is pushed onto the 8088 stack before the * ;* call to process the arguments, and it is restored into * ;* the last available register to complete the call * ;* sequence. * ;* * ;* Garbage collection will not occur during the argument loading * ;* process (arguments are copied, but no cons-ing occurs), * ;* so it's safe to save the "ftn" pointer on the 8088 * ;* stack temporarily. * ;************************************************************************ last_pag equ reg0_pag + (NUM_REGS - 1) * size C_ptr last_dis equ reg0_dis + (NUM_REGS - 1) * size C_ptr public apply apply: lods word ptr ES:[SI] ; load apply's arguments mov BL,AL ; copy closure pointer register number push reg0_pag+[BX] ; save value of register containing push reg0_dis+[BX] ; the closure pointer save ; save registers across call call aply_arg ; expand arguments into R1-Rn restore ; restore saved registers pop last_dis ; put "ftn" pointer into last VM register pop last_pag mov AH,CL ; copy the argument count to AH, AL<="Rlast" mov AL,(NUM_REGS - 1) * size C_ptr call cl_c_sub ; process the call jmp next_PC ; return to the interpreter ;************************************************************************ ;* AL AH * ;* Apply closure, tail recursively APPLY-CLOSURE-TR ftn,args * ;* * ;* Purpose: Interpreter support for the "apply" primitive. The * ;* argument list (in register "args") are to be passed * ;* to the closure pointed to by the "ftn" register. * ;* * ;* Note: See notes in "APPLY-CLOSURE" support, above. * ;************************************************************************ public apply_tr apply_tr: lods word ptr ES:[SI] ; load apply-tr's arguments mov BL,AL ; copy closure pointer register number push reg0_pag+[BX] ; save value of register containing push reg0_dis+[BX] ; the closure pointer save ; save registers across call call aply_arg ; expand arguments into R1-Rn restore ; restore saved registers pop last_dis ; put "ftn" pointer into last VM register pop last_pag mov AH,CL ; copy the argument count to AH, AL<="Rlast" mov AL,(NUM_REGS - 1) * size C_ptr call cl_ct_sb ; process the call, tail recursively jmp next_PC ; return to the interpreter ;************************************************************************ ;* Execute code block EXECUTE CODE * ;* * ;* Purpose: Interpreter support for the "execute" primitive operation. * ;* * ;* Description: The execute primitive causes a code block to be * ;* executed in a new environment. This is accomplished * ;* by executing a procedure call to the code block with * ;* no static environment information available. The * ;* new stack frame has a nil heap environment pointer, and * ;* the static link is set to point to itself to prevent * ;* access to any higher lexical levels. When the code * ;* block exits, control will return to the place where the * ;* execute instruction was executed. * ;************************************************************************ public execute execute: lods byte ptr ES:[SI] ; fetch register number with code pointer mov BX,AX execute1 label far mov DI,reg0_pag+[BX] cmp byte ptr ptype+[DI],CODETYPE*2 ; pointer to code block? jne load_ex1 ; if not, we've got to load before execute push BX ; save the code pointer's register number call new_SF ; create a new stack frame for the "call" mov word ptr S_stack+[BX].sf_sdisp,0 ; make "nil" static link mov AL,byte ptr GNV_pag ; default environment to global env mov S_stack+[BX].sf_hpage,AL mov AX,GNV_dis mov word ptr S_stack+[BX].sf_hdisp,AX mov FP,BX pop BX ; retrieve the code pointer's reg number mov SI,reg0_dis+[BX] ; define the code base register mov CB_dis,SI mov BL,byte ptr reg0_pag+[BX] mov byte ptr CB_pag,BL LoadCode ES,BX ;;; mov ES,pagetabl+[BX] ; load the code base page's para address save ; and save it off add SI,ES:[SI].cod_entr ; adjust location ptr for entry offset jmp next ; return to the interpreter load_ex1: jmp far ptr load_ex ; long jump to loader ; ; Object to be executed is not a code block, so we've got to create ; one for a compiled program before executing it. The format of an ; object program is: ; ; (tag #-constants #-codebytes (constant ...) (codebyte ...)) ; ; ***Error-- Invalid Object Module Format*** bad_obj2 label far mov AX,offset m_%exec ; load addr of "%EXECUTE" restore ; load number of register containing add BX,offset reg0 ; the "code" pointer and compute its addr mov CX,1 ; load argument count = 1 pushm ; push arguments to set_src_err C_call set_src_ ; call: set_src_err("%EXECUTE", 1, code) restore ; load next instruction's location jmp sch_err ; link to Scheme debugger ;************************************************************************ ;* Exit from current procedure EXIT * ;* * ;* Description: The internal registers of the VM are reset from * ;* information stored in the current frame pointer to * ;* restore the environment at the point where the current * ;* procedure was called (i.e., control returns to the * ;* calling routine). * ;************************************************************************ public s_exit s_exit: mov AX,FP ; load the current frame pointer mov BX,AX add BX,offset S_stack ; compute address of current stack frame sub AX,PTRSIZE ; reset the current TOS to previous mov TOS,AX ; value [FP - sizeof(pointer)] xor AX,AX ; clear AX mov AL,[BX].sf_cb_pag ; load CB's page number mov byte ptr CB_pag,AL mov DI,AX ; save code block's page number LoadCode ES,DI ;;; mov ES,pagetabl+[DI] ; set paragraph address of page containing save ; calling routine's code block mov AX,[BX].sf_cb_dis ; update the current code base (CB) mov CB_dis,AX add AX,[BX].sf_ret ; load return address' location pointer mov SI,AX ; and add in starting offset of code block mov AX,[BX].sf_ddisp ; compute pointer to caller's stack frame cmp AX,BASE ; is new FP outside stack buffer? jae s_exit_1 ; if in bounds, jump pushm ; save new FP, new location pointer call stk_unfl ; process stack underflow popm ; restore saved new FP, new location pointer s_exit_1: sub AX,BASE ; FP <- dynamic link - Base mov FP,AX jmp next ; return to interpreter stk_int endp ;************************************************************************ ;* AL AL AH * ;* Create Closure CR-CLOSE dest,label,nargs * ;* * ;* Purpose: Scheme interpreter support for the creation of closure * ;* objects. * ;************************************************************************ public cr_close cr_close: lods byte ptr ES:[SI] ; load destination register number mov DI,AX ; and save it for now lods word ptr ES:[SI] ; load address of entry label mov CX,AX ; and save it, too lods byte ptr ES:[SI] ; load number of arguments and cbw ; convert it to a fullword integer shl AX,1 ; clear high order bit of immediate value shr AX,1 add CX,SI ; add in current location pointer sub CX,CB_dis ; and adjust for code block offset save ; save nargs, entry point, location pointer mov DX,CLOSTYPE ; load tag=closure mov AX,CLO_OVHD-PTRSIZE ; load size of closure object pushm ; push arguments C_call alloc_bl,,Load_ES ; call: alloc_block(®, type, size) mov SP,BP ; drop arguments off TIPC's stack mov BX,tmp_page ; load pointer to closure object mov DI,tmp_disp LoadPage ES,BX ;;; mov ES,pagetabl+[BX] mov SI,[BP].save_DI ; copy contents of destination register xchg BL,byte ptr reg0_pag+[SI] ; into the information operand of mov ES:[DI].clo_ipag,BL ; the newly allocated closure object. mov AX,DI ; Make the destination register point xchg AX,reg0_dis+[SI] ; to the closure object. mov ES:[DI].clo_idis,AX mov AL,SPECFIX*2 ; set tags for constant fields mov ES:[DI].clo_etag,AL ; entry point tag=fixnum mov ES:[DI].clo_atag,AL ; nargs tag=fixnum mov AL,byte ptr CB_pag ; copy in pointer to current code base mov ES:[DI].clo_cb_p,AL mov AX,CB_dis mov ES:[DI].clo_cb_d,AX restore ; define entry point offset mov ES:[DI].clo_edis,CX restore ; define number of arguments mov ES:[DI].clo_narg,AX mov SI,FP ; load pointer to current stack frame mov AL,S_stack+[SI].sf_hpage ; define heap environment mov ES:[DI].clo_hpag,AL mov AX,word ptr S_stack+[SI].sf_hdisp mov ES:[DI].clo_hdis,AX jmp next_PC ; return to interpreter ;************************************************************************ ;* Local support - stack overflow handler * ;* * ;* Purpose: To move part of Scheme's runtime stack to the heap when * ;* stack overflow occurs. * ;* * ;* Description: The contents of the stack which precede the current * ;* stack frame are moved to the heap (in a continuation * ;* object) and the current stack frame is moved to the * ;* top of the stack buffer. * ;* * ;* Input Parameters: * ;* TIPC register SI - the value to be placed in the * ;* "return address displacement" field of the * ;* continuation (needed only for call/cc) * ;* FNV_reg - the current fluid environment (saved by * ;* call/cc) * ;* GNV_reg - the current global environment (saved by * ;* call/cc) ;* FP - the current stack frame pointer * ;* BASE - the stack buffer base value * ;* TOS - the current top-of-stack pointer * ;* CB - the VM register which points to the current * ;* code block * ;* PREV_pag,PREV_dis - the VM's previous stack segment * ;* register * ;* * ;* Output Parameters: * ;* PREV_pag,PREV_dis - a pointer to the continuation * ;* object which was created * ;* BASE - updated to the new base value (stack offset) * ;* due to movement of some of the stack contents * ;* to the heap * ;* * ;* Variables Modified: (but logically unchanged) * ;* FP - the current stack frame pointer * ;* TOS - the current top of stack pointer * ;* * ;* Example: Stack Overflow Condition * ;* * ;* Before * ;* * ;* +--------+-----------------+ * ;* | prev stk seg -> = nil | * ;* +--------+-----------------+ * ;* Stack Buffer (BASE = 0) * ;* +--------+-----------------+ * ;* | Contents | * ;* : of : * ;* : Stack : * ;* | (m bytes) | * ;* |--------+-----------------| * ;* | Current |<-FP * ;* : Stack : * ;* | Frame |<-TOS * ;* +--------+-----------------+ * ;* * ;* AFTER * ;* * ;* "Continuation" in Heap * ;* +--------+-----------------+ +--------+-----------------+ * ;* | prev stk seg -> |------->| cont | length (m+24) | * ;* +--------+-----------------+ |--------+-----------------| * ;* Stack Buffer (BASE = m) | segment's stack base = 0 | * ;* +--------+-----------------+ |--------+-----------------| * ;* | Current |<-FP | code base -> = n/a | * ;* : Stack : |--------+-----------------| * ;* | Frame |<-TOS | return addr disp = n/a | * ;* |--------+-----------------| |--------+-----------------| * ;* | unused stack | | caller dynamic link = n/a| * ;* : : |--------+-----------------| * ;* : : | fluid env -> = FNV_reg | * ;* | | |--------------------------| * ;* +--------+-----------------+ | prev stk seg -> = nil | * ;* |--------+-----------------| * ;* | global env -> = GNV_reg | * ;* |--------+-----------------| * ;* | Contents | * ;* : of : * ;* : Stack : * ;* | (m bytes) | * ;* +--------+-----------------+ * ;* * ;* Notes: This routine handles both routine stack overflow, and stack * ;* overflow which is signaled during the creation of a * ;* full continuation because of a call/cc. All of the * ;* fields of the continuation object are filled in by this * ;* routine, but they are meaningless and will never be * ;* used in the case of simple stack overflow. * ;************************************************************************ stk_arg struc stk_temp dd ? ; temporary register stk_SI dw ? ; caller's SI (for continuation, rtn addr) stk_BP dw ? ; caller's BP dw ? ; return address stk_arg ends stk_ovfl proc near push BP ; save caller's BP sub SP,offset stk_BP mov BP,SP mov [BP].stk_SI,SI ; save return address disp, if meaningful ; test to see how to create continuation object mov CX,FP ; load current frame pointer, cmp CX,0 ; length of stack contents zero? jg stk_nz ; if not, create new continuation (jump) ; copy previous continuation mov AX,PREV_pag ; tmp_reg <- PREV_reg mov tmp_page,AX mov AX,PREV_dis mov tmp_disp,AX mov AX,offset PREV_reg ; load address of PREV_reg, tmp_reg pushm ; push as arguments C_call copy_blk ; call: copy_blk(&PREV_reg, &tmp_reg) mov SP,BP ; drop arguments from stack jmp stk_rtn ; return copy of previous continuation ; print warning concerning impending stack overflow s_toobig: pushm ; save active registers lea BX,m_stk_ov ; load error message text address push BX ; and push as argument to printf C_call printf,,Load_ES ; call: printf("***error... "); pop BX ; drop argument from TIPC's stack C_call force_de ; call: force_debug(); popm ; restore active registers jmp stk_go ; continue executing where we left off ; allocate a continuation object on the heap stk_nz: add CX,offset con_data-PTRSIZE ; and compute continuation's size mov DX,CONTTYPE ; load tag=CONTTYPE lea BX,[BP].stk_temp ; load address of temporary result reg pushm ; push arguments, and call mov BX,DS ; set up ES segment register for C_call mov ES,BX C_call alloc_bl ; "alloc_block(®,CONTTYPE,len)" mov SP,BP ; remove arguments from 8088's stack ; load pointer to the continuation object just allocated mov CX,FP ; reload length of continuations stack data mov BX,[BP].stk_temp.C_page ; load returned pointer to mov DI,[BP].stk_temp.C_disp ; continuation object LoadPage ES,BX ;;; mov ES,pagetabl+[BX] ; ES->continuation object's page ; define continuation object fields mov AL,SPECFIX*2 mov ES:[DI].con_btag,AL ; stack base tag=fixnum mov ES:[DI].con_rtag,AL ; return address tag=fixnum mov ES:[DI].con_dtag,AL ; dynamic link tag=fixnum mov AL,byte ptr CB_pag ; define code base pointer mov ES:[DI].con_cb_p,AL mov AX,CB_dis mov ES:[DI].con_cb_d,AX neg AX ; subtract CB_dis from SI add AX,[BP].stk_SI ; use contents of SI for return addr disp mov ES:[DI].con_ret,AX mov AX,FP ; define dynamic link mov ES:[DI].con_ddis,AX mov AX,BASE ; set continuation's stack base mov ES:[DI].con_base,AX add AX,CX ; compute new stack buffer base mov BASE,AX ; [BASE <- BASE + FP] ; Test for impending stack overflow cmp AX,-STKSIZE ; over stack buffer threshold? jae s_toobig ; if so, print warning (jump) stk_go: mov AL,byte ptr FNV_pag ; set fluild environment pointer mov ES:[DI].con_fl_p,AL mov AX,FNV_dis mov ES:[DI].con_fl_d,AX mov AL,byte ptr GNV_pag ; set global environment pointer mov ES:[DI].con_gl_p,AL mov AX,GNV_dis mov ES:[DI].con_gl_d,AX mov AX,PREV_pag ; set previous stack segment pointer mov ES:[DI].con_spag,AL mov AX,PREV_dis mov ES:[DI].con_sdis,AX mov PREV_pag,BX ; make previous stack segment register mov PREV_dis,DI ; point to the new continuation object ; update the counter of bytes transfered to the heap add word ptr stk_out,CX ; record number of bytes transfered adc word ptr stk_out+2,0 ; fix up high order part of sum ; move stack data to continuation object in the heap lea SI,S_stack ; load stack address add DI,offset con_data ; adjust for continuation header info mov DX,CX ; copy length (in bytes) and and DX,1 ; isolate lsb for fixup shr CX,1 ; convert bytes to words cld ; clear direction flag (forward move) rep movsw ; move stack contents to heap (cont obj) mov CX,DX ; copy fixup length (0 or 1 bytes) rep movsb ; copy remaining byte, if needed ; move data in current stack frame to top of stack buffer lea SI,S_stack ; load address of top of stack buffer mov DI,SI ; DI <- top of stack buffer (0) add SI,FP ; SI <- current stack frame mov CX,DS mov ES,CX ; ES->data segment mov CX,TOS ; load current top of stack, sub CX,FP ; subtract bytes moved to heap, mov TOS,CX ; and define new TOS add CX,PTRSIZE ; compute bytes of stack to move up mov DX,CX ; copy length (in bytes) and and DX,1 ; isolate lsb for fixup shr CX,1 ; convert bytes to words rep movsw ; move stack contents to top of stack buffer mov CX,DX ; copy fixup length (0 or 1 bytes) rep movsb ; copy remaining byte, if needed mov FP,0 ; current frame now at top of stack buffer ; return to caller stk_rtn: mov SI,[BP].stk_SI ; restore return address disp, if meaningful add SP,offset stk_BP ; drop local variable storage pop BP ; restore caller's BP ret ; return stk_ovfl endp ;************************************************************************ ;* Local support - stack underflow handler * ;* * ;* Purpose: To restore segments of the stack, which previously have * ;* been moved to the heap, back into the stack buffer. * ;* * ;* Description: Previously saved stack segments (moved to the heap * ;* as the result of a stack overflow or a call/cc) are * ;* represented as continuation data objects. When this * ;* routine is called, a "stack underflow" has occurred * ;* as an "EXIT" operation needs to access a stack frame * ;* higher in the stack, so data fields with a call/cc * ;* continuation are ignored. * ;************************************************************************ stk_unfl proc near push BP ; save caller's BP mov BP,SP mov BX,PREV_pag ; fetch previous stack segment's page number cmp BX,0 ; stack link nil? je unfl_nil ; if so, jump (real stack underflow) mov SI,PREV_dis ; load previous stack segment displacement push DS ; save caller's DS register mov CX,DS mov ES,CX ; ES->stack's data group LoadPage DS,BX ;;; mov DS,pagetabl+[BX] ; DS->continuation object's page mov AX,[SI].con_base ; update stack buffer's base mov ES:BASE,AX mov AL,[SI].con_spag ; update previous stack segment register mov ES:byte ptr PREV_pag,AL mov AX,[SI].con_sdis mov ES:PREV_dis,AX mov CX,[SI].con_len ; load length of saved stack data sub CX,offset con_data ; adjust length for continuation header add SI,offset con_data ; adjust offset for continuation header lea DI,S_stack ; load address of bottom of stack mov DX,CX ; compute new top of stack sub DX,PTRSIZE mov ES:TOS,DX ; in memory (temporarily covered by ES) add word ptr ES:stk_in,CX ; update count of bytes transfered adc word ptr ES:stk_in+2,0 ; fix up high order part of counter mov DX,CX ; copy the length (in bytes) and DX,1 ; and determine fixup (0 or 1 bytes) shr CX,1 ; convert length from bytes to words cld ; set direction flag = forward rep movsw ; restore the stack's contents mov CX,DX ; copy fixup length and rep movsb ; move the odd byte, if needed pop DS ; restore DS pop BP ret ; return to caller ; Error-- stack underflow unfl_nil: lea BX,m_stk_un push BX C_call printf,,Load_ES C_call exit stk_unfl endp ;************************************************************************ ;* Local support - Create new stack frame * ;* * ;* Purpose: To create and partially define a new stack frame prior * ;* to a procedure call * ;* * ;* Description: This routine allocates space on the top of the stack * ;* for a new stack frame and defines the following fields: * ;* * ;* code base pointer <- CB * ;* return addr disp <- SI (contents of reg) * ;* dynamic link <- FP * ;* static link's tag <- fixnum * ;* heap env <- current heap env * ;* static link <- current static link * ;* closure pointer <- nil (implies an open call) * ;* * ;* Input Parameters: * ;* TIPC register SI - the VM's location pointer * ;* CB_pag,CB_dis - the VM's code base register * ;* FP - the VM's current frame pointer * ;* TOS - the VM's top of stack pointer * ;* * ;* Output Parameters: * ;* TIPC register BX - pointer to new stack frame * ;* (displacement in stack) * ;* TOS - top of stack pointer updated for new stack length * ;* * ;* Variables Modified: The following variables will be modified if * ;* a stack overflow occurs during the push operation for * ;* the new stack frame: * ;* * ;* FP - the VM's current frame pointer(logically unchanged)* ;* BASE - the VM's stack buffer base * ;* PREV_pag,PREV_dis - the VM's previous stack segment reg * ;************************************************************************ new_SF proc near mov AX,TOS ; load current top of stack pointer mov BX,AX ; and make a copy add AX,SF_OVHD ; increment TOS by size of stack frame cmp AX,STKSIZE-PTRSIZE ; is there room on stack for new frame? jg new_FP_1 ; if not, process stack overflow (jump) mov TOS,AX ; update top of stack pointer add BX,PTRSIZE ; compute pointer to new stack frame mov AL,SPECFIX*2 ; load tag for fixnum's mov S_stack+[BX].sf_rtag,AL ; return address tag=fixnum mov S_stack+[BX].sf_dtag,AL ; dynamic link tag=fixnum mov S_stack+[BX].sf_stag,AL ; static link tag=fixnum xor AX,AX ; store '() into closure pointer mov S_stack+[BX].sf_cl_pg,AL mov word ptr S_stack+[BX].sf_cl_ds,AX mov AL,byte ptr CB_pag ; move current code base pointer mov S_stack+[BX].sf_cb_pag,AL ; into the new stack frame mov AX,CB_dis mov word ptr S_stack+[BX].sf_cb_dis,AX sub SI,AX ; compute ret addr relative to code block mov word ptr S_stack+[BX].sf_ret,SI ; record the return address add SI,AX ; restore SI ; copy the current heap environment pointer to the new stack frame mov DI,FP ; load the current stack frame pointer mov AL,S_stack+[DI].sf_hpage mov S_stack+[BX].sf_hpage,AL mov AX,word ptr S_stack+[DI].sf_hdisp mov word ptr S_stack+[BX].sf_hdisp,AX ; copy the static link from the current frame to the new one mov AX,word ptr S_stack+[DI].sf_sdisp mov word ptr S_stack+[BX].sf_sdisp,AX ; define the dynamic link field add DI,BASE mov word ptr S_stack+[BX].sf_ddisp,DI ret ; return to the caller ; Process stack overflow new_FP_1: push SI ; save current location pointer call stk_ovfl ; process the overflow pop SI ; restore location pointer jmp new_SF ; try again to allocate new stack frame new_SF endp ;************************************************************************ ;* Local support - drop items from the heap environment * ;* * ;* Purpose: To drop "n" items off the local heap environment * ;* * ;* Input Parameters: * ;* TIPC register CX - the number of items to drop * ;* FP - the current stack frame pointer * ;* * ;* Output Parameters: * ;* TIPC register BX - page number for the remaining * ;* heap environment list * ;* TIPC register DI - displacement pointer for the * ;* remaining heap environment * ;* * ;* Registers/Variables Modified: * ;* CX - decremented to zero * ;* TIPC register ES - contents undefined * ;************************************************************************ delta_hp proc near mov DI,FP ; load the current stack frame pointer xor BX,BX ; clear register BX mov BL,S_stack+[DI].sf_hpage ; load the current heap environment mov DI,word ptr S_stack+[DI].sf_hdisp ; pointer cmp CX,0 ; drop zero elements? jle del_h_rt ; if drop zero, jump del_h_lp: LoadPage ES,BX ;;; mov ES,pagetabl+[BX] ; load para addr of page holding list cell mov BL,ES:[DI].cdr_page ; load link pointer (cdr field) mov DI,ES:[DI].cdr loop del_h_lp ; cdr through list for "n" elements del_h_rt: ret ; return updated heap env ptr in BX,DI delta_hp endp ;************************************************************************ ;* Local support - Obtain Frame Pointer for given lexical level * ;* * ;* Input Parameters: * ;* TIPC register CX - desired lexical level number * ;* 0=current lexical level, * ;* 1=lexical parent's level, etc. * ;* FP - current frame pointer * ;* BASE - current stack buffer base * ;* * ;* Output Parameters: * ;* TIPC register BX - frame pointer for desired level * ;* (absolute location in stack) * ;* ES:[SI] - pointer to desired stack frame * ;* (either in stack buffer, or in the heap) * ;* * ;* Notes: Register usage: * ;* AX - zeroed, so page numbers can be loaded into AL * ;* prior to copying to DI * ;* BX - frame pointer for current level * ;* CX - lexical level counter. decremented at each level * ;* DX - base offset of the stack segment currently being * ;* examined * ;* SI - stack segment's (continuation's) displacement * ;* DI - temporarily hold page number of next stack segment * ;************************************************************************ delta_lv proc near mov BX,FP ; load current frame pointer mov DX,BASE ; and the stack buffer base cmp CX,0 ; reference to current stack frame? jg dlt_nt_0 ; if not, jump ; current lexical level desired-- return active stack frame pointer lea SI,S_stack+[BX] ; compute addr of current frame pointer add BX,DX ; adjust for base of stack buffer mov ES,[BP].C_ES ; load pointer to data segment ret ; return BX, ES:[SI] to caller ; find pointer to higher lexical level in stack buffer dlt_loop: sub BX,DX ; adjust absolute frame ptr by base jb dlt_in_h ; still in stack buffer? if not, jump dlt_nt_0: mov BX,word ptr S_stack+[BX].sf_sdisp ; fetch static link loop dlt_loop ; iterate until desired level found ; pointer to desired level found in stack buffer mov SI,BX ; copy absolute frame pointer sub SI,DX ; adjust for current stack buffer base jb dlt_nstk ; still within stack buffer? if not, jump add SI,offset S_stack ; compute address of frame in stack buffer mov ES,[BP].C_ES ; ES<-data segment ret ; return BX, ES:[SI] ; Frame pointer found, but frame's not in stack buffer dlt_nstk: mov DI,PREV_pag ; load pointer to previous stack segment mov SI,PREV_dis LoadPage ES,DI ;;; mov ES,pagetabl+[DI] mov DX,ES:[SI].con_base xor AX,AX dlt_nb: cmp BX,DX ; is frame within this segment? jae dlt_here ; if so, jump mov AL,ES:[SI].con_spag ; load pointer to its previous segment mov DI,AX mov SI,ES:[SI].con_sdis LoadPage ES,DI ;;; mov ES,pagetabl+[DI] mov DX,ES:[SI].con_base ; load stack segment's base offset jmp dlt_nb ; search 'til segment containing frame found dlt_here: mov AX,BX ; copy absolute frame pointer for level sub AX,DX ; subtract this stack segment's base add SI,AX ; add to continuation offset add SI,offset con_data ; add fudge factor for continuation header ret ; return BX, ES:[SI] to caller ; Desired level not found, but current reference not in stack buffer dlt_in_h: add BX,DX ; compute absolute location in stack mov DI,PREV_pag ; load previous stack segment pointer mov SI,PREV_dis LoadPage ES,DI ;;; mov ES,pagetabl+[DI] mov DX,ES:[SI].con_base xor AX,AX dlt_in_n: cmp BX,DX ; is frame in this stack segment? jae dlt_fnd ; if so, jump mov AL,ES:[SI].con_spag ; fetch pointer to next previous segment mov DI,AX mov SI,ES:[SI].con_sdis LoadPage ES,DI ;;; mov ES,pagetabl+[DI] mov DX,ES:[SI].con_base ; load this segment's base offset jmp dlt_in_n ; keep searching stack segments ; Segment containing stack frame found-- fetch static link dlt_fnd: sub BX,DX ; adjust frame displacement for seg base mov BX,ES:[SI].con_data.sf_sdisp+[BX] ; load static link loop dlt_in_n ; follow chain to desired lexical level jmp dlt_nb ; found-- return pointer to stack frame delta_lv endp ;************************************************************************ ;* Local support - Expand "apply's" argument list into registers R1-Rn * ;* * ;* Purpose: To expand the argument list of an "apply" so that the * ;* operands are in the proper operand registers (R1-Rn) * ;* for a call to a closed procedure. * ;* * ;* Input Parameters: TIPC register AH - the number of the VM's * ;* general register which contains the pointer to * ;* the linked list of arguments. * ;* * ;* Output Parameters: TIPC register CX - a count of the arguments. * ;* * ;* Note: The "apply" operation expects two operands which are a * ;* function and a 'list' of arguments. In the event that * ;* the second argument is not a list, this routine simply * ;* substitutes that value as if it were an argument. This * ;* means that the "LIST" function is not actually needed * ;* for an argument list containing only one value. * ;* For example, the following are handled equivalently: * ;* * ;* "correct" code "not-correct" code * ;* (apply ftn (list 1)) (apply ftn 1) * ;* (apply ftn (list a b)) (apply ftn (cons a b)) * ;* * ;* Although this could be viewed as an optimization, in * ;* that it saves one list cell each time the argument list * ;* is created, the real reason it is done is to provide * ;* a fixup action when an error condition is detected. * ;************************************************************************ aply_arg proc near ; Count the number of arguments to make sure there aren't too many xor BX,BX ; copy the register number of the mov BL,AH ; argument list to BX mov SI,reg0_dis+[BX] ; load the argument list pointer mov BX,reg0_pag+[BX] xor CX,CX ; zero the argument counter aply_lp1: cmp BL,0 ; is pointer nil? je aply_ok ; if so, the last argument has been moved inc CX ; increment the argument count cmp CX,NUM_REGS-2 ; (can't use R0 or R63) jg aply_err cmp byte ptr ptype+[BX],LISTTYPE*2 ; pointer to a list cell? jne aply_ok ; if not, assume last argument LoadPage ES,BX ;;; mov ES,pagetabl+[BX] ; load para addr for list cell's page mov BL,ES:[SI].cdr_page ; load the "cdr" pointer (next cell) mov SI,ES:[SI].cdr jmp aply_lp1 ; process 'til end of argument list ; copy arguments into the registers aply_ok: mov BL,AH ; copy arg list register back into BX mov SI,reg0_dis+[BX] ; load the argument list pointer mov BX,reg0_pag+[BX] lea DI,reg1 ; load the address of VM register R1 aply_lp: cmp BL,0 ; is pointer nil? je aply_don ; if so, the last argument has been moved cmp byte ptr ptype+[BX],LISTTYPE*2 ; pointer to a list cell? jne aply_huh ; if not, we've got a problem (jump) LoadPage ES,BX ;;; mov ES,pagetabl+[BX] ; load para addr for list cell's page mov AL,ES:[SI].car_page ; move the "car" portion of the list mov byte ptr [DI].C_page,AL ; cell into the next available mov AX,ES:[SI].car ; general register of the VM mov [DI].C_disp,AX mov BL,ES:[SI].cdr_page ; load the "cdr" pointer (next cell) mov SI,ES:[SI].cdr add DI,size C_ptr ; increment next register's address jmp aply_lp ; process 'til end of argument list ; If an element in the argument list is not a list cell, simply place ; that pointer into the next register. aply_huh: mov [DI].C_page,BX mov [DI].C_disp,SI aply_don: ret ; return to caller ; ***Error-- too many arguments to expand into register*** aply_err: restore ; reload the current location pointer and sub SI,3 ; back it up to start of "apply" instruction pushm ; push function name, offset C_call disassem,,Load_ES ; call: disassemble("APPLY",offset); pushm ; push arguments C_call set_nume ; call: set_numeric_error(1,code,tmp_reg) restore ; reload the location pointer jmp sch_err ; Link to Scheme debugger aply_arg endp ;************************************************************************ ; Lattice C callable routine to push a register onto Scheme's stack * ; Calling Sequence: C_push(reg) * ; where: int reg[2] - register (pointer/value) to push * ;************************************************************************ C_args struc C_BP dw ? ; Caller's BP dw ? ; Return address C_reg dw ? ; Pointer to register C_args ends public C_push C_push1 proc near ; Process overflow-- copy contents of stack to the heap C_push2: push ES ; save ES across the call call stk_ovfl ; copy the stack contents pop ES ; restore ES ; retry the push (fall through) C_push: mov AX,TOS ; load the top of stack pointer cmp AX,STKSIZE-PTRSIZE ; test for overflow jge C_push2 ; jump, if overflow is going to occur add AX,PTRSIZE ; decrement stop of stack pointer mov TOS,AX ; and update it in memory add AX,offset S_stack ; load the address of the new TOS mov DI,AX ; copy TOS address into DI pop DX ; unload the return address pop BX ; load address of register to push mov AL,byte ptr [BX].C_page ; load the page number, mov [DI].car_page,AL ; pointer displacement, mov AX,[BX].C_disp ; and move onto the top of mov [DI].car,AX ; Scheme's stack jmp DX ; return to caller C_push1 endp ;************************************************************************ ; Lattice C callable routine to pop a register from Scheme's stack * ; Calling Sequence: C_pop(reg) * ; where: int reg[2] - register to hold the value popped * ;************************************************************************ public C_pop C_pop proc near mov AX,TOS ; load the top of stack pointer sub AX,PTRSIZE ; increment stop of stack pointer mov TOS,AX ; and update it in memory add AX,offset S_stack+PTRSIZE ; load the address of the old TOS mov SI,AX ; copy top of stack address into SI pop DX ; unload the return address pop BX ; fetch address of destination register mov AL,[SI].car_page ; load page number, mov byte ptr [BX].C_page,AL ; pointer displacement, mov AX,[SI].car ; and update into mov [BX].C_disp,AX ; receiving register jmp DX ; return to caller C_pop endp ;************************************************************************ ;* Lattice C callable routine to force a Scheme VM call * ;* Calling Sequence: force_call(ret) * ;* where: int ret - the return address (relative to the * ;* current code block) * ;************************************************************************ fc_args struc dw ? ; caller's BP dw ? ; return address fc_ret dw ? ; Scheme return address fc_args ends public force_ca force_ca proc near push BP ; save the caller's BP register mov BP,SP ; establish local addressability mov SI,[BP].fc_ret ; load the Scheme program return address call new_SF ; create a new stack frame mov FP,BX ; update the current frame pointer pop BP ; restore the caller's BP ret ; return to caller force_ca endp prog ends PROGX segment byte public 'PROGX' assume CS:XGROUP bad_obj1: jmp bad_obj2 load_ex label far save ; save dest register, location pointer cmp byte ptr ptype+[DI],LISTTYPE*2 ; is "code" pointer a list? jne bad_obj1 ; if not, error (jump) %LoadPage ES,DI ;;; mov ES,pagetabl+[DI] ; load pointer to "compiled program" mov SI,reg0_dis+[BX] ; skip over "tag" portion of object program mov BL,ES:[SI].cdr_page mov SI,ES:[SI].cdr ; fetch the number of constants and multiply by three bytes/constant cmp byte ptr ptype+[BX],LISTTYPE*2 ; is this a list cell? jne bad_obj1 ; if not, error (jump) %LoadPage ES,BX ;;; mov ES,pagetabl+[BX] cmp ES:[SI].car_page,SPECFIX*2 ; is car's entry a fixnum? jne bad_obj1 ; if not, error (jump) mov AX,ES:[SI].car ; fetch immediate value of fixnum shl AX,1 ; sign extend immediate value sar AX,1 inc AX ; add a constant for entry point address mov DX,AX ; DX <- AX * 3 shl AX,1 add DX,AX mov BL,ES:[SI].cdr_page ; follow cdr field of linked list mov SI,ES:[SI].cdr ; fetch the number of code bytes cmp byte ptr ptype+[BX],LISTTYPE*2 ; is this a list cell? jne bad_obj1 ; if not, error (jump) %LoadPage ES,BX ;;; mov ES,pagetabl+[BX] cmp ES:[SI].car_page,SPECFIX*2 ; is car's entry a fixnum? jne bad_obj1 ; if not, error (jump) mov AX,ES:[SI].car ; fetch immediate value of fixnum shl AX,1 ; sign extend immediate value sar AX,1 ; compute number of bytes needed and allocate a new code block add AX,DX ; add constants*3 + codebytes mov BX,CODETYPE pushm ; push arguments onto TIPC's stack save ; preserve register DX across call mov AX,DS ; make ES point to the data segment mov ES,AX call %allocbl ; allocate the code block mov SP,BP ; drop arguments from stack ; load pointer to newly allocated code block mov DI,tmp_page %LoadPage ES,DI ;;; mov ES,pagetabl+[DI] ;;;; mov DX,ES ; save code block's paragraph address in DX mov DX,DI ; save code block's page number in DX mov DI,tmp_disp add DI,PTRSIZE ; advance DI past block header ; store entry point address into code block mov AL,SPECFIX*2 ; store tag=fixnum for entry point address stosb mov AX,[BP].save_DX ; store entry point address add AX,PTRSIZE ; adjust entry point for block header stosw ; reload pointer to object program [Note: garbage collection may have ; copied the linked list representation of the program, so pointers ; held in TIPC registers may not be valid.] restore mov SI,reg0_pag+[BX] ; load pointer to "object program" %LoadPage ES,SI ;;; mov ES,pagetabl+[SI] mov SI,reg0_dis+[BX] mov BL,ES:[SI].cdr_page ; skip over "tag" mov SI,ES:[SI].cdr %LoadPage ES,BX ;;; mov ES,pagetabl+[BX] mov CX,ES:[SI].car ; load number of constants shl CX,1 ; sign extend immediate value sar CX,1 mov BL,ES:[SI].cdr_page ; skip over number of constants mov SI,ES:[SI].cdr %LoadPage ES,BX ;;; mov ES,pagetabl+[BX] mov AX,ES:[SI].car ; load number of code bytes shl AX,1 ; sign extend immediate value sar AX,1 mov BL,ES:[SI].cdr_page ; skip over number of codebytes mov SI,ES:[SI].cdr cmp byte ptr ptype+[BX],LISTTYPE*2 je ok_obj ; ***error-- invalid object format*** bad_obj: jmp bad_obj2 ok_obj: %LoadPage ES,BX ;;; mov ES,pagetabl+[BX] pushm ; save # codebytes, ptr to const's list cell mov BL,ES:[SI].car_page ; load constant list header mov SI,ES:[SI].car ;;;; mov ES,DX %LoadPage0 ES,DX cmp CX,0 ; zero length constants list? je c_end ; if no constants, skip loop c_loop: cmp BL,0 ; end of constants list? je bad_obj ; if so, premature end of constant list cmp byte ptr SS:ptype+[BX],LISTTYPE*2 ; is entry a list cell? jne bad_obj ; if not, error (jump) %LoadPage1 DS,BX ;;; mov DS,SS:pagetabl+[BX] ; fetch page's address movsb ; copy car field to code block constants movsw ; area lodsb ; load cdr field to follow linked list mov BL,AL mov SI,[SI] loop c_loop ; continue through constants list ; end of constants list-- process byte codes c_end: pop DS ; restore previously saved regs pop SI mov CX,BX ; tempsave current bx reg pop BX ; bx = page number %LoadPage ES,BX ; load segment register mov BX,CX ; restore bx register pop CX cmp BL,0 ; end of list found? jne bad_obj ; if not, too many constants (jump) ; fetch pointer to codebyte list mov BL,ES:[SI].cdr_page mov SI,ES:[SI].cdr cmp byte ptr ptype+[BX],LISTTYPE*2 ; is next entry a list cell? jne bad_obj ; if not, error (jump) %LoadPage ES,BX ;;; mov ES,pagetabl+[BX] cmp ES:[SI].cdr_page,0 ; last entry in object program list? je next$0 jmp bad_obj ; if not, error (jump) next$0: mov BL,ES:[SI].car_page ; load header to bytecode list mov SI,ES:[SI].car %LoadPage0 ES,DX ; Restore code block's paragraph address ;;; mov ES,DX push DS d_loop: cmp BL,0 ; end of constants list? jne d_l$0 jmp bad_obj ; if so, premature end of constant list d_l$0: cmp byte ptr SS:ptype+[BX],LISTTYPE*2 ; is entry a list cell? je d_l$1 jmp bad_obj ; if not, error (jump) d_l$1: %LoadPage1 DS,BX ;;; mov DS,SS:pagetabl+[BX] ; fetch page's address lodsb ; load car's page number cmp AL,SPECFIX*2 ; is codebyte entry a fixnum? je d_lp_nxt ; Yes, continue jmp bad_obj ; No, error d_lp_nxt: lodsw ; load immediate value stosb ; store low order byte into code block lodsb ; load cdr field to follow linked list mov BL,AL mov SI,[SI] loop d_loop ; continue through codebyte list ; end of codebyte list-- move code block pointer to destination register pop DS ; restore TIPC register DS cmp BL,0 ; extraneous codebytes in list? jne bad_obj3 ; if so, error (jump) restore ; re-fetch dest reg, location pointer mov AL,byte ptr tmp_page ; copy code block pointer into mov byte ptr reg0_pag+[BX],AL ; destination register mov AX,tmp_disp mov reg0_dis+[BX],AX jmp far ptr execute1 ; execute the code block bad_obj3: jmp bad_obj PROGX ends end