329 lines
11 KiB
NASM
329 lines
11 KiB
NASM
|
;***************************************
|
|||
|
|
;* TIPC Scheme '84 Runtime Support *
|
|||
|
|
;* Garbage Collection - Mark Phase *
|
|||
|
|
;* *
|
|||
|
|
;* (C) Copyright 1984,1985 by Texas *
|
|||
|
|
;* Instruments Incorporated. *
|
|||
|
|
;* All rights reserved. *
|
|||
|
|
;* *
|
|||
|
|
;* Date Written: April 1984 *
|
|||
|
|
;* Last Modification: 06 January 1986 *
|
|||
|
|
;***************************************
|
|||
|
|
include scheme.equ
|
|||
|
|
|
|||
|
|
arguments struc
|
|||
|
|
dw ? ; Caller's BP
|
|||
|
|
dw ? ; Return address
|
|||
|
|
page_idx dw ? ; Page number of pointer
|
|||
|
|
pointer dw ? ; Displacement of pointer
|
|||
|
|
arguments ends
|
|||
|
|
|
|||
|
|
DGROUP group data
|
|||
|
|
data segment word public 'DATA'
|
|||
|
|
assume DS:DGROUP
|
|||
|
|
extrn _base:word ; base address of the TIPC runtime stack
|
|||
|
|
sum_bt dw sum_list ; [0] List cells
|
|||
|
|
dw sum_fix ; [1] Fixnums
|
|||
|
|
dw sum_flo ; [2] Flonums
|
|||
|
|
dw sum_big ; [3] Bignums
|
|||
|
|
dw sum_sym ; [4] Symbols
|
|||
|
|
dw sum_str ; [5] Strings
|
|||
|
|
dw sum_ary ; [6] Arrays
|
|||
|
|
dw sum_cont ; [7] Continuations
|
|||
|
|
dw sum_clos ; [8] Closures
|
|||
|
|
dw sum_free ; [9] Free page
|
|||
|
|
dw sum_code ; [10] Code page
|
|||
|
|
dw sum_free ; [11] (Formerly, Reference cells)
|
|||
|
|
dw sum_port ; [12] Port data objects
|
|||
|
|
dw sum_char ; [13] Characters
|
|||
|
|
dw sum_env ; [14] Environments
|
|||
|
|
; Branch table for pointer classification
|
|||
|
|
branchtab dw gcmlist ; [0] List cells
|
|||
|
|
dw gcmfix ; [1] Fixnums
|
|||
|
|
dw gcmflo ; [2] Flonums
|
|||
|
|
dw gcmbig ; [3] Bignums
|
|||
|
|
dw gcmsym ; [4] Symbols
|
|||
|
|
dw gcmstr ; [5] Strings
|
|||
|
|
dw gcmary ; [6] Arrays
|
|||
|
|
dw gcmcont ; [7] Continuations
|
|||
|
|
dw gcmclos ; [8] Closures
|
|||
|
|
dw gcmfree ; [9] Free page
|
|||
|
|
dw gcmcode ; [10] Code page
|
|||
|
|
dw gcmfree ; [11] (Formerly, Reference cells)
|
|||
|
|
dw gcmport ; [12] Port data objects
|
|||
|
|
dw gcmchar ; [13] Characters
|
|||
|
|
dw gcmenv ; [14] Environments
|
|||
|
|
|
|||
|
|
m_oops db "[VM INTERNAL ERROR] sum_spac: infinite loop page %d",LF,0
|
|||
|
|
m_format db "[VM INTERNAL ERROR] sgcmark: invalid pointer: %x:%04x "
|
|||
|
|
db "(unadjusted)",LF,0
|
|||
|
|
m_overfl db "[VM FATAL ERROR] Stack overflow during GC",LF,0
|
|||
|
|
DS_addr dw DGROUP
|
|||
|
|
data ends
|
|||
|
|
|
|||
|
|
PGROUP group prog
|
|||
|
|
prog segment byte public 'PROG'
|
|||
|
|
|
|||
|
|
assume CS:PGROUP
|
|||
|
|
|
|||
|
|
public garbage
|
|||
|
|
garbage proc near
|
|||
|
|
push ES
|
|||
|
|
mov ES,DS_addr
|
|||
|
|
C_call garbage1
|
|||
|
|
pop ES
|
|||
|
|
ret
|
|||
|
|
garbage endp
|
|||
|
|
|
|||
|
|
mark proc near
|
|||
|
|
; ***error-- bad pointer found-- report error***
|
|||
|
|
gcmfix: ; Fixnums are immediates
|
|||
|
|
gcmchar: ; Characters are immediates
|
|||
|
|
gcmfree: ; Why are we collecting in a free page?
|
|||
|
|
bad_ptr:
|
|||
|
|
push AX
|
|||
|
|
mov AX,offset m_format ; load address of format text
|
|||
|
|
push DX ; save the return address
|
|||
|
|
pushm <SI,BX,AX> ; push arguments to printf
|
|||
|
|
C_call printf,,Load_ES ; print error message
|
|||
|
|
add SP,WORDINCR*3 ; drop arguments from stack
|
|||
|
|
C_call force_de ; go into debug mode
|
|||
|
|
pop DX ; restore the return address
|
|||
|
|
pop AX
|
|||
|
|
jmp gcmret ; go on as if nothing happened
|
|||
|
|
|
|||
|
|
public gcmark
|
|||
|
|
gcmark: pop DX ; unload return address
|
|||
|
|
pop BX ; fetch page number (x 2)
|
|||
|
|
mov AX,BX ; save in AX
|
|||
|
|
pop SI ; fetch displacement
|
|||
|
|
push DX ; save return address
|
|||
|
|
push ES ; save ES
|
|||
|
|
mov DX,offset pgroup:gcmarkret
|
|||
|
|
jmp gcm_tr
|
|||
|
|
gcmarkret:
|
|||
|
|
pop ES
|
|||
|
|
pop DX
|
|||
|
|
jmp DX ; return
|
|||
|
|
|
|||
|
|
|
|||
|
|
; see if pointer is to one of the "special" non-collected pages
|
|||
|
|
gcm_tr: cmp BX,DEDPAGES*PAGEINCR ; check for non-gc'ed pages
|
|||
|
|
jge gcm_go ; if not one of the special pages, jump
|
|||
|
|
jmp DX ; return
|
|||
|
|
;
|
|||
|
|
gcm_go: push AX ; Preserve the page number
|
|||
|
|
; load pointer offset into ES:; displacement into SI
|
|||
|
|
test BX,0FF01h ; valid pointer?
|
|||
|
|
jnz bad_ptr ; if so, error (jump)
|
|||
|
|
LoadPage ES,BX
|
|||
|
|
mov AX,BX ; Use AX to store page number
|
|||
|
|
; classify pointer according to data type
|
|||
|
|
mov DI,ptype+[BX] ; load data type*2
|
|||
|
|
cmp DI,NUMTYPES*2 ; valid page type?
|
|||
|
|
jae bad_ptr ; if not, error (jump)
|
|||
|
|
jmp branchtab+[DI]
|
|||
|
|
|
|||
|
|
; Process symbol or port
|
|||
|
|
gcmport:
|
|||
|
|
gcmsym: markedp ES:[SI].sym_gc,gcmret ; already marked? if so, return (jump)
|
|||
|
|
or byte ptr ES:[SI].sym_gc,GC_BIT ; mark symbol/port as seen
|
|||
|
|
mov BL,ES:[SI].sym_page ; fetch pointer from symbol/port object
|
|||
|
|
mov SI,ES:[SI].sym_disp
|
|||
|
|
pop AX ; restore saved page number
|
|||
|
|
LoadPage ES,AX ; Get Page address
|
|||
|
|
jmp gcm_tr ; make a tail recursive call to gcmark
|
|||
|
|
|
|||
|
|
; Process List Cell-- If marked, skip rest of processing
|
|||
|
|
gcmlist: markedp ES:[SI].list_gc,gcmret ; if marked, jump to return
|
|||
|
|
; Call gcmark with CAR of list cell
|
|||
|
|
or byte ptr ES:[SI].list_gc,GC_BIT ; "mark" as referenced
|
|||
|
|
mov BL,ES:[SI].car_page ; load page number of car field
|
|||
|
|
cmp BX,DEDPAGES*PAGEINCR ; check for non-gc'ed pages
|
|||
|
|
jl gcmls_ok ; if one of the special pages, jump
|
|||
|
|
; Test for TIPC stack overflow
|
|||
|
|
push AX
|
|||
|
|
mov AX,SP ; copy the current stack top pointer
|
|||
|
|
sub AX,_base ; and compute number of bytes remaining
|
|||
|
|
cmp AX,64 ; enough space to continue?
|
|||
|
|
pop AX
|
|||
|
|
jb stk_ovfl ; if not enough room, abort (jump)
|
|||
|
|
; Mark expression pointed to by the car field
|
|||
|
|
push SI ; save offset of list cell
|
|||
|
|
push DX ; save the previous return address
|
|||
|
|
mov DX,offset PGROUP:gcmls_rt ; Load the return address
|
|||
|
|
mov SI,ES:[SI].car ; Load car field pointer
|
|||
|
|
and SI,07FFFh ; Clear out the GC bit
|
|||
|
|
jmp gcm_go ; Call gcmark recursively
|
|||
|
|
gcmls_rt:
|
|||
|
|
pop DX ; Restore previous return address
|
|||
|
|
pop SI ; Restore offset of list cell
|
|||
|
|
; Call gcmark tail recursively with CDR of list cell
|
|||
|
|
gcmls_ok: mov BL,ES:[SI].cdr_page ; load the pointer contained in the
|
|||
|
|
mov SI,ES:[SI].cdr ; cdr field
|
|||
|
|
pop AX ; restore saved page
|
|||
|
|
LoadPage ES,AX ; Get Page address
|
|||
|
|
jmp gcm_tr ; call gcmark tail recursively
|
|||
|
|
|
|||
|
|
; TIPC stack overflow-- Abort
|
|||
|
|
stk_ovfl: mov AX,offset m_overfl ; load address of error message text
|
|||
|
|
push AX ; and push it as an argument to printf
|
|||
|
|
C_call printf,,Load_ES ; print the error message
|
|||
|
|
C_call getch ; wait for any key to be pressed
|
|||
|
|
C_call exit ; return to MS-DOS
|
|||
|
|
|
|||
|
|
; Return to caller
|
|||
|
|
gcmret: pop AX ; restore saved page
|
|||
|
|
LoadPage ES,AX ; Get Page address
|
|||
|
|
jmp DX ; return to caller
|
|||
|
|
|
|||
|
|
|
|||
|
|
; Process reference to variable length data object or flonum
|
|||
|
|
gcmflo:
|
|||
|
|
gcmbig:
|
|||
|
|
gcmstr:
|
|||
|
|
or byte ptr ES:[SI].vec_gc,GC_BIT
|
|||
|
|
pop AX ; restore saved page
|
|||
|
|
LoadPage ES,AX ; Get Page address
|
|||
|
|
jmp DX ; return
|
|||
|
|
|
|||
|
|
; Process Code Block
|
|||
|
|
gcmcode: markedp ES:[SI].cod_gc,gcmret ; If already processed, return
|
|||
|
|
or byte ptr ES:[SI].cod_gc,GC_BIT
|
|||
|
|
mov CX,ES:[SI].cod_entr ; load entry point offset as counter
|
|||
|
|
jmp gcmlop1
|
|||
|
|
|
|||
|
|
; Process Variable Length Object Containing Pointers
|
|||
|
|
gcmary:
|
|||
|
|
gcmclos:
|
|||
|
|
gcmcont:
|
|||
|
|
gcmenv:
|
|||
|
|
markedp ES:[SI].vec_gc,gcmret ; If already processed, jump to return
|
|||
|
|
or byte ptr ES:[SI].vec_gc,GC_BIT ; mark as referenced
|
|||
|
|
mov CX,ES:[SI].vec_len
|
|||
|
|
cmp CX,PTRSIZE ; test for zero length vector
|
|||
|
|
jle gcmret ; if no elements, jump
|
|||
|
|
; Test the size of the TIPC stack to insure room to continue
|
|||
|
|
gcmlop1: push AX
|
|||
|
|
mov AX,SP ; load the current stack top pointer
|
|||
|
|
sub AX,_base ; and compute the number of bytes remaining
|
|||
|
|
cmp AX,64 ; are there at least 64 bytes left?
|
|||
|
|
pop AX
|
|||
|
|
jb stk_ovfl ; if not enough room, abort (jump)
|
|||
|
|
; Call gcmark with pointer in this object
|
|||
|
|
push DX ; Save previous return address
|
|||
|
|
mov DX,offset PGROUP:gcml_ret ; Load return address into DX
|
|||
|
|
gcmloop: add SI,PTRSIZE ; Increment address for next pointer
|
|||
|
|
push CX ; Save counter across calls
|
|||
|
|
push SI ; Save curr offset into vector (or whatever)
|
|||
|
|
mov BL,ES:[SI].car_page ; load next element pointer from array,
|
|||
|
|
mov SI,ES:[SI].car ; closure, etc.
|
|||
|
|
jmp gcm_tr ; call gcmark recursively
|
|||
|
|
gcml_ret: pop SI ; Restore current offset
|
|||
|
|
pop CX ; Restore iteration count
|
|||
|
|
sub CX,PTRSIZE ; Decrement counter
|
|||
|
|
cmp CX,PTRSIZE ; and test for completion
|
|||
|
|
jg gcmloop ; Loop through all pointers in object
|
|||
|
|
pop DX ; Restore previous return address
|
|||
|
|
pop AX ; Restore saved page
|
|||
|
|
LoadPage ES,AX ; Get Page address
|
|||
|
|
jmp DX ; Return
|
|||
|
|
|
|||
|
|
mark endp
|
|||
|
|
|
|||
|
|
sum_args struc
|
|||
|
|
dw ? ; caller's ES
|
|||
|
|
dw ? ; caller's BP
|
|||
|
|
dw ? ; return address
|
|||
|
|
sum_vctr dw ? ; pointer to summation vector (for results)
|
|||
|
|
sum_args ends
|
|||
|
|
|
|||
|
|
public sum_spac
|
|||
|
|
sum_spac proc near
|
|||
|
|
push BP ; save the caller's BP on entry
|
|||
|
|
push ES ; save the caller's ES
|
|||
|
|
mov BP,SP ; update BP
|
|||
|
|
|
|||
|
|
; initialize
|
|||
|
|
mov DI,[BP].sum_vctr ; load address of result vector
|
|||
|
|
xor BX,BX ; start with zero-th page
|
|||
|
|
|
|||
|
|
; top of loop-- look at next page
|
|||
|
|
sum_loop: xor AX,AX ; clear the free space counter
|
|||
|
|
cmp BX,DEDPAGES*PAGEINCR
|
|||
|
|
jl sum_end
|
|||
|
|
test attrib+[BX],NOMEMORY ; is page allocated?
|
|||
|
|
jnz sum_end ; if not, skip it (branch)
|
|||
|
|
cmp ptype+[BX],FREETYPE*2
|
|||
|
|
je sum_free ; Ignore free pages [TC]
|
|||
|
|
LoadPage ES,BX ; load current paragraph's base address
|
|||
|
|
mov SI,ptype+[BX] ; load type of current page
|
|||
|
|
jmp sum_bt+[SI] ; branch on page type
|
|||
|
|
|
|||
|
|
; add up unused list cells
|
|||
|
|
sum_list: mov CX,LISTSIZE ; load size of list cell data object
|
|||
|
|
sum_l1st: mov SI,nextcell+[BX] ; load list cell free storage chain header
|
|||
|
|
sum_lnxt: cmp SI,END_LIST ; end of list?
|
|||
|
|
je sum_end ; if so, we're through here
|
|||
|
|
add AX,CX ; increment the free list cell counter
|
|||
|
|
jo sum_oops ; if overflow, we're stuck in a loop
|
|||
|
|
mov SI,ES:[SI].car ; follow free cell chain
|
|||
|
|
jmp sum_lnxt ; keep following linked list
|
|||
|
|
|
|||
|
|
; add up unused variable length things
|
|||
|
|
sum_big:
|
|||
|
|
sum_sym:
|
|||
|
|
sum_str:
|
|||
|
|
sum_clos:
|
|||
|
|
sum_cont:
|
|||
|
|
sum_ary:
|
|||
|
|
sum_code:
|
|||
|
|
sum_port:
|
|||
|
|
sum_env:
|
|||
|
|
mov SI,0 ; initialize pointer into page
|
|||
|
|
mov CX,psize+[BX] ; load size of current page
|
|||
|
|
sub CX,PTRSIZE ; adjust size for page boundary check
|
|||
|
|
sum_vnxt: cmp SI,CX ; through with this page?
|
|||
|
|
ja sum_end ; if so, branch
|
|||
|
|
mov DX,ES:[SI].vec_len ; load block length
|
|||
|
|
cmp DX,0 ;;; check for small string
|
|||
|
|
jge sum_010
|
|||
|
|
mov DX,BLK_OVHD+PTRSIZE ;;; get the exact length
|
|||
|
|
sum_010: cmp ES:[SI].vec_type,FREETYPE ; free block?
|
|||
|
|
jne sum_used ; if so, branch around add
|
|||
|
|
add AX,DX ; add in number of free bytes
|
|||
|
|
sum_used: add SI,DX ; update pointer to next block in page
|
|||
|
|
jmp sum_vnxt ; look at next block
|
|||
|
|
|
|||
|
|
sum_free: mov AX,psize+[BX] ; load size of free page
|
|||
|
|
|
|||
|
|
sum_fix:
|
|||
|
|
sum_char:
|
|||
|
|
sum_end: mov [DI],AX ; store number of free bytes (AX)
|
|||
|
|
add DI,2 ; increment array index
|
|||
|
|
add BX,2 ; increment page index
|
|||
|
|
cmp BX,NUMPAGES*2 ; test for completion
|
|||
|
|
jl sum_loop ; if more pages, jump
|
|||
|
|
|
|||
|
|
sum_ret: pop ES ; restore caller's ES
|
|||
|
|
pop BP ; restore caller's BP
|
|||
|
|
ret ; return to caller
|
|||
|
|
|
|||
|
|
; add up unused flonums
|
|||
|
|
sum_flo: mov CX,FLOSIZE ; load size of flonum
|
|||
|
|
jmp sum_l1st ; process assuming linked list allocation
|
|||
|
|
|
|||
|
|
sum_oops: shr BX,1
|
|||
|
|
lea SI,m_oops
|
|||
|
|
pushm <BX,SI>
|
|||
|
|
mov AX,DS
|
|||
|
|
mov ES,AX
|
|||
|
|
C_call printf
|
|||
|
|
C_call exit
|
|||
|
|
|
|||
|
|
sum_spac endp
|
|||
|
|
|
|||
|
|
prog ends
|
|||
|
|
end
|
|||
|
|
|
|||
|
|
|