458 lines
17 KiB
NASM
458 lines
17 KiB
NASM
; =====> SOBJHASH.ASM
|
||
;***************************************
|
||
;* TIPC Scheme Runtime Support *
|
||
;* Object Hashing Routines *
|
||
;* *
|
||
;* (C) Copyright 1985 by Texas *
|
||
;* Instruments Incorporated. *
|
||
;* All rights reserved. *
|
||
;* *
|
||
;* Date Written: 25 June 1985 *
|
||
;* Last Modification: 3 November 1985 *
|
||
;***************************************
|
||
include scheme.equ
|
||
|
||
DGROUP group data
|
||
XGROUP group PROGX
|
||
PGROUP group prog
|
||
|
||
data segment word public 'DATA'
|
||
assume DS:DGROUP
|
||
obj_cntr dw OHT_SIZE dup (1)
|
||
branchtab dw ogc_list ; [0] List cells
|
||
dw ogc_mark ; [1] Fixnums
|
||
dw ogc_var ; [2] Flonums
|
||
dw ogc_var ; [3] Bignums
|
||
dw ogc_var ; [4] Symbols
|
||
dw ogc_var ; [5] Strings
|
||
dw ogc_var ; [6] Arrays
|
||
dw ogc_var ; [7] Continuations
|
||
dw ogc_var ; [8] Closures
|
||
dw ogc_mark ; [9] Free page
|
||
dw ogc_var ; [10] Code page
|
||
dw ogc_mark ; [11] Reference cells <not anymore>
|
||
dw ogc_var ; [12] Port data objects
|
||
dw ogc_mark ; [13] Characters
|
||
dw ogc_var ; [14] Environments
|
||
ret_sav1 dw 0 ; return address save area
|
||
ret_sav2 dw 0 ; return address save area
|
||
data ends
|
||
|
||
prog segment byte public 'PROG'
|
||
assume CS:PGROUP
|
||
|
||
;************************************************************************
|
||
;* Far Linkage to "lookup" Routine *
|
||
;************************************************************************
|
||
%lookup proc far
|
||
extrn lookup:near
|
||
call lookup
|
||
ret
|
||
%lookup endp
|
||
|
||
;************************************************************************
|
||
;* Far Linkage to "cons" Routine *
|
||
;************************************************************************
|
||
public %cons
|
||
%cons proc far
|
||
pop ret_sav1
|
||
pop ret_sav2
|
||
mov AX,DS ; make ES point to the data segment
|
||
mov ES,AX
|
||
extrn cons:near
|
||
call cons
|
||
push ret_sav2
|
||
push ret_sav1
|
||
ret
|
||
%cons endp
|
||
|
||
;************************************************************************
|
||
;* Far Linkage to "alloc_block" Routine *
|
||
;************************************************************************
|
||
public %allocbl
|
||
%allocbl proc far
|
||
pop ret_sav1
|
||
pop ret_sav2
|
||
mov AX,DS ; make ES point to the data segment
|
||
mov ES,AX
|
||
extrn alloc_bl:near
|
||
call alloc_bl
|
||
push ret_sav2
|
||
push ret_sav1
|
||
ret
|
||
%allocbl endp
|
||
prog ends
|
||
|
||
PROGX segment byte public 'PROGX'
|
||
assume CS:XGROUP
|
||
;************************************************************************
|
||
;* Object Hash *
|
||
;************************************************************************
|
||
oh_args struc
|
||
oh_key dw ? ; computed hash key
|
||
oh_key3 dw ? ; computed hash key * 3
|
||
oh_disp dw ? ; page number component of a pointer
|
||
oh_page dw ? ; displacement component of a pointer
|
||
oh_reg dw ? ; pointer to argument register (s=d)
|
||
oh_ctr dw ? ; bucket's current counter value
|
||
oh_ctag db SPECFIX*2,? ; tag for counter
|
||
oh_BP dw ? ; caller's BP
|
||
dw ? ; caller's SI
|
||
dw ? ; caller's ES
|
||
dd ? ; return address (far call)
|
||
dw ? ; return address (near call)
|
||
oh_args ends
|
||
|
||
%objhash proc far
|
||
lods byte ptr ES:[SI] ; fetch operand of object-hash
|
||
push ES ; save the caller's ES register
|
||
push SI ; save the location counter
|
||
push BP ; save the caller's BP register
|
||
sub SP,offset oh_BP ; allocate local storage
|
||
mov BP,SP ; establish local addressability
|
||
; load argument and compute hash index
|
||
mov BX,AX ; copy dest=src register number to BX
|
||
add BX,offset reg0 ; and compute the register's address
|
||
mov [BP].oh_reg,BX ; save the register address
|
||
;;;
|
||
;;; Note: computing of hash value turned off 'cause relocation of
|
||
;;; pointers screws things up. For now, all objects will
|
||
;;; hash to a key of zero. (JCJ 2 OCT 85)
|
||
;;; mov DX,[BX].C_page ; load the argument's page number
|
||
;;; mov AX,[BX].C_disp ; load the argument's displacement
|
||
;;; mov CL,AH ; copy high byte of displacement
|
||
;;; xor AH,AH
|
||
;;; xor CH,CH
|
||
;;; add AX,CX
|
||
;;; add AX,DX
|
||
;;; mov CX,OHT_SIZE ; load the hash table size for divisor
|
||
;;; cwd ; convert dividend to double word
|
||
;;; div CX ; divide hash value by table size
|
||
xor DX,DX ; ***TEMPORARY*** Load a hash key of zero
|
||
;;;
|
||
mov [BP].oh_key,DX ; save computed hash key
|
||
mov SI,DX
|
||
shl DX,1
|
||
add SI,DX ; SI <- hash_key * 3
|
||
mov [BP].oh_key3,SI
|
||
|
||
; if entries exist at this hash level, search bucket for object
|
||
cmp obj_ht+[SI],0 ; anyone home in this bucket?
|
||
je oh_nf ; if no entries exist, jump
|
||
|
||
; call "lookup" to search a-list
|
||
mov AX,[BX].C_disp ; reload object's displacement
|
||
mov DX,[BX].C_page ; and page for a-list search
|
||
xor BX,BX
|
||
mov BL,obj_ht+[SI]
|
||
%LoadPage ES,BX
|
||
;;; mov ES,pagetabl+[BX]
|
||
mov SI,word ptr obj_ht+[SI]+1
|
||
call %lookup ; search the a-list
|
||
cmp BL,0
|
||
je oh_nf
|
||
|
||
; object found in hash bucket's chain-- return it
|
||
mov AX,ES:[DI].cdr ; load the hash counter
|
||
mov [BP].oh_ctr,AX ; and save it in 'oh_ctr'
|
||
jmp short oh_ret ; return hash value
|
||
|
||
; make a new entry in the current hash bucket
|
||
oh_nf: mov DI,[BP].oh_key
|
||
shl DI,1 ; multiply hash value by 2 for index
|
||
mov AX,obj_cntr+[DI] ; load obj hash counter for this bucket
|
||
inc obj_cntr+[DI] ; increment the obj hash counter
|
||
mov [BP].oh_ctag,SPECFIX*2 ; convert hash counter to a fixnum
|
||
mov [BP].oh_ctr,AX ; pointer
|
||
lea BX,[BP].oh_ctr ; load hash counter's "reg" address
|
||
mov AX,[BP].oh_reg ; load object's register address
|
||
mov CX,offset tmp_reg ; load offset of temporary register
|
||
pushm <BX,AX,CX> ; push arguments to call
|
||
call %cons ; cons(tmp_reg, object, hash-counter)
|
||
mov BX,offset nil_reg ; load address of "nil register"
|
||
mov CX,offset tmp_reg ; load address of temporary register
|
||
pushm <BX,CX,CX> ; push arguments to cons
|
||
call %cons ; cons(tmp_reg, (cons obj hash), nil)
|
||
mov SP,BP ; drop arguments from stack
|
||
mov DI,[BP].oh_key3 ; load hash bucket number * 3
|
||
mov BX,tmp_page ; load pointer to newest list cell
|
||
mov AX,tmp_disp
|
||
%LoadPage ES,BX
|
||
;;; mov ES,pagetabl+[BX]
|
||
mov SI,AX ; pointer is in ES:[SI]
|
||
xchg obj_ht+[DI],BL ; header <- pointer to list cell
|
||
xchg word ptr obj_ht+[DI]+1,AX
|
||
mov ES:[SI].cdr_page,BL ; (set-cdr! list-cell chain-header)
|
||
mov ES:[SI].cdr,AX
|
||
|
||
; create a bignum to hold the hash value
|
||
oh_ret: mov AX,WORDINCR*2+1 ; load the size of bignum result
|
||
push AX ; and push it for use as argument
|
||
mov AX,BIGTYPE ; load type=bignum
|
||
push AX ; and push it for use as argument
|
||
push [BP].oh_reg ; push address of destination register
|
||
mov AX,DS ; ES <- DS
|
||
mov ES,AX
|
||
call %allocbl ; allocate the bignum
|
||
mov SP,BP ; drop arguments off the TIPC's stack
|
||
mov BX,[BP].oh_reg ; load destination register's address
|
||
mov SI,[BX].C_page ; load bignum's page number
|
||
%LoadPage ES,SI ; load bignum page's paragraph address
|
||
;;; mov ES,pagetabl+[SI] ; load bignum page's paragraph address
|
||
mov SI,[BX].C_disp ; load bignum's displacement
|
||
mov AX,[BP].oh_key ; load hash bucket number
|
||
mov ES:[SI].big_data,AX ; and store it into LSW of bignum
|
||
mov AX,[BP].oh_ctr ; load counter for this object
|
||
mov ES:[SI].big_2nd,AX ; and store it into MSW of bignum
|
||
mov ES:[SI].big_sign,0 ; sign <- 0 (positive number)
|
||
|
||
; return to caller
|
||
add SP,offset oh_BP ; deallocate local storage
|
||
pop BP ; restore caller's BP register
|
||
pop SI ; restore the location pointer
|
||
pop ES ; restore caller's ES register
|
||
ret ; return to calling procedure
|
||
%objhash endp
|
||
|
||
;************************************************************************
|
||
;* Object Unhash *
|
||
;************************************************************************
|
||
unhs_arg struc
|
||
un_reg dw ? ; argument register address
|
||
un_BP dw ? ; caller's BP
|
||
dw ? ; caller's SI
|
||
dw ? ; caller's ES
|
||
dd ? ; return address (far call)
|
||
dw ? ; return address (near call)
|
||
unhs_arg ends
|
||
|
||
%objunhs proc far
|
||
lods byte ptr ES:[SI] ; load the operand for object-unhash
|
||
push ES ; save the caller's ES register
|
||
push SI ; save the location pointer
|
||
push BP ; save the caller's BP register
|
||
sub SP,offset un_BP ; allocate local storage
|
||
mov BP,SP ; establish local addressability
|
||
|
||
; Begin the long process of validating the input
|
||
mov SI,AX
|
||
add SI,offset reg0
|
||
mov [BP].un_reg,SI
|
||
mov BX,[SI].C_page
|
||
cmp byte ptr ptype+[BX],BIGTYPE*2
|
||
je un_maybe
|
||
|
||
; This hash-key is invalid, or object not found-- return #!false
|
||
un_false: xor AX,AX ; create a nil pointer
|
||
mov SI,[BP].un_reg ; load destination register address
|
||
mov byte ptr [SI].C_page,AL ; store nil pointer into
|
||
mov [SI].C_disp,AX ; destination register
|
||
|
||
; Return to Scheme Interpreter
|
||
un_ret: add SP,offset un_BP ; deallocate local storage
|
||
pop BP ; restore caller's BP register
|
||
pop SI ; restore the location pointer
|
||
pop ES ; restore caller's ES register
|
||
ret
|
||
|
||
; Continue checking bignum value
|
||
un_maybe: mov SI,[SI].C_disp ; load bignum's offet
|
||
%LoadPage ES,BX ; and paragraph address
|
||
;;; mov ES,pagetabl+[BX] ; and paragraph address
|
||
cmp ES:[SI].big_sign,0
|
||
jne un_false ; if negative, not one of ours
|
||
cmp ES:[SI].big_len,8
|
||
jne un_false ; if more than four bytes of data, not ours
|
||
mov DI,ES:[SI].big_data ; load least significant word (bucket no.)
|
||
cmp DI,OHT_SIZE
|
||
jae un_false ; hash bucket index too large? if so, jump
|
||
mov DX,DI ; DX <- bucket number
|
||
mov AX,ES:[SI].big_2nd
|
||
shl DI,1 ; DI <- bucket number * 2
|
||
cmp AX,obj_cntr+[DI] ; test against next available counter value
|
||
jae un_false ; hash index too large? if so, jump
|
||
; Note: Search index (key) is in AX
|
||
add DI,DX ; DI <- bucket number * 3
|
||
add DI,offset obj_ht
|
||
mov DX,DS ; ES <- DS
|
||
mov ES,DX
|
||
; Note: Search list whose header is in ES:[DI]
|
||
call oh_search ; search "ES:[DI]" for "AX"
|
||
cmp BL,0 ; was index found?
|
||
je un_false ; if not found, return #!false (jump)
|
||
; Search successful-- object/hash-value pair pointed to by ES:[SI]
|
||
mov DI,[BP].un_reg ; load destination register's address
|
||
mov AX,ES:[SI].car ; copy car field of found pair into
|
||
mov [DI].C_disp,AX ; the destination register
|
||
mov AL,ES:[SI].car_page
|
||
mov byte ptr [DI].C_page,AL
|
||
jmp un_ret ; return to caller w/ object in dest reg
|
||
%objunhs endp
|
||
|
||
;************************************************************************
|
||
;* Local Support for Object Unhash *
|
||
;************************************************************************
|
||
oh_search proc near
|
||
; Compute pointer to current entry and save it
|
||
mov BL,ES:[DI].car_page
|
||
cmp BL,0
|
||
je oh_sret
|
||
mov DI,ES:[DI].car
|
||
%LoadPage ES,BX
|
||
;;; mov ES,pagetabl+[BX]
|
||
mov DX,ES ; save ES in DX
|
||
; Compute pointer to object/hash-key pair
|
||
mov BL,ES:[DI].car_page
|
||
mov SI,ES:[DI].car
|
||
%LoadPage ES,BX
|
||
;;; mov ES,pagetabl+[BX]
|
||
; Test cdr field (hash key) of pair for match
|
||
cmp ES:[SI].cdr,AX
|
||
jne oh_smore
|
||
; A match!-- Return pair address in ES:[SI]
|
||
oh_sret: ret
|
||
|
||
oh_smore: mov ES,DX ; restore ES
|
||
add DI,PTRSIZE ; adjust pointer to cdr field of curr entry
|
||
jmp oh_search ; iterate
|
||
oh_search endp
|
||
|
||
;************************************************************************
|
||
;* Object Hash Table Garbage Collection *
|
||
;************************************************************************
|
||
gc_args struc
|
||
prev_ES dw ? ; ES for previous entry
|
||
prev_off dw ? ; offset for previous entry
|
||
curr_PG dw ? ; ES for current entry
|
||
curr_off dw ? ; offset for current entry
|
||
pair_PG dw ? ; ES for object/hash-key pair
|
||
pair_off dw ? ; offset for object/hash-key pair
|
||
gc_BP dw ? ; caller's BP
|
||
dw ? ; caller's ES
|
||
dd ? ; return address (far call)
|
||
dw ? ; return address (near call)
|
||
gc_args ends
|
||
|
||
%gc_oht proc far
|
||
push ES ; save caller's ES register
|
||
push BP ; save caller's BP register
|
||
sub SP,offset gc_BP ; allocate local storage
|
||
mov BP,SP ; establish addressibility for local storage
|
||
|
||
; Initialize parameters
|
||
mov SI,offset obj_ht ; load address of object hash table
|
||
mov CX,OHT_SIZE ; load number of entries in obj hash table
|
||
gc_loop: mov AX,DS ; ES <- DS
|
||
mov ES,AX
|
||
push SI ; load current object hash table offset
|
||
push CX ; save iteration counter
|
||
call gc_nxt ; follow this entries chain
|
||
pop CX ; restore iteration counter
|
||
pop SI ; restore obj hash table offset
|
||
add SI,PTRSIZE ; advance offset pointer
|
||
loop gc_loop ; continue 'til all buckets processed
|
||
|
||
; Return to caller
|
||
gc_xit: add SP,offset gc_BP ; release local storage
|
||
pop BP ; restore the caller's BP register
|
||
pop ES ; restore the caller's ES register
|
||
ret ; return
|
||
%gc_oht endp
|
||
|
||
;************************************************************************
|
||
;* Local Support for Object Hash Table Garbage Collection *
|
||
;************************************************************************
|
||
gc_nxt proc near
|
||
xor BX,BX ; clear register BX
|
||
mov BL,ES:[SI].car_page ; load page number for next entry
|
||
cmp BL,0 ; does entry exist?
|
||
jne ogc_010 ; if null pointer, jump to exit
|
||
ret ; return to gc_oht
|
||
; save pointer to previous cell
|
||
ogc_010: mov [BP].prev_ES,ES
|
||
mov [BP].prev_off,SI
|
||
; compute and save pointer to current cell
|
||
mov DI,ES:[SI].car
|
||
%LoadPage ES,BX
|
||
;;; mov ES,pagetabl+[BX]
|
||
mov [BP].curr_PG,BX
|
||
mov [BP].curr_off,DI
|
||
; compute and save pointer to object/hash-key pair
|
||
mov BL,ES:[DI].car_page
|
||
mov SI,ES:[DI].car
|
||
test SI,08000h ; is current cell marked as referenced?
|
||
jnz ogc_skip ; if marked, GC during OBJECT-HASH (jump)
|
||
%LoadPage ES,BX
|
||
;;; mov ES,pagetabl+[BX]
|
||
mov [BP].pair_PG,BX
|
||
mov [BP].pair_off,SI
|
||
; see what object pointer points to
|
||
mov BL,ES:[SI].car_page
|
||
cmp BL,DEDPAGES*PAGEINCR ; is object a "special" one?
|
||
jb ogc_mark ; if a non-gc'ed page, must keep entry
|
||
mov SI,ES:[SI].car ; load object offset
|
||
%LoadPage ES,BX
|
||
;;; mov ES,pagetabl+[BX] ; load object's paragraph address
|
||
mov DI,ptype+[BX] ; load type code for object
|
||
jmp branchtab+[DI] ; jump to appropriate routine
|
||
|
||
; object is a list cell-- test to see if it's marked
|
||
ogc_list: test byte ptr ES:[SI].list_gc,GC_BIT
|
||
jnz ogc_mark
|
||
jmp short ogc_del
|
||
|
||
; Variable length object
|
||
ogc_var: test byte ptr ES:[SI].vec_gc,GC_BIT
|
||
jnz ogc_mark
|
||
|
||
; Object not referenced-- delete object hash table entry for it
|
||
ogc_del: %LoadPage ES,[BP].curr_PG ; reload pointer to current entry
|
||
mov SI,[BP].curr_off
|
||
mov AX,ES:[SI].cdr ; load cdr field of current entry
|
||
mov BL,ES:[SI].cdr_page
|
||
mov ES,[BP].prev_ES ; reload pointer to previous entry
|
||
mov SI,[BP].prev_off
|
||
mov ES:[SI].car,AX ; store cdr field of current entry into
|
||
mov ES:[SI].car_page,BL ; previous entry
|
||
jmp gc_nxt ; process next entry
|
||
|
||
; Object is marked as referenced-- mark obj hash table cells as referenced
|
||
ogc_mark: %LoadPage ES,[BP].pair_PG ; load pointer to object/hash-key pair
|
||
mov SI,[BP].pair_off
|
||
or byte ptr ES:[SI].list_gc,GC_BIT ; mark pair entry referenced
|
||
ogc_skip: %LoadPage ES,[BP].curr_PG ; load pointer to current entry
|
||
mov SI,[BP].curr_off
|
||
or byte ptr ES:[SI].list_gc,GC_BIT ; mark curr entry referenced
|
||
add SI,PTRSIZE ; advance pointer to cdr field of curr entry
|
||
jmp gc_nxt ; process next entry
|
||
gc_nxt endp
|
||
|
||
PROGX ends
|
||
|
||
prog segment byte public 'PROG'
|
||
assume CS:PGROUP
|
||
;************************************************************************
|
||
;* Linkage to Object Hash Routine *
|
||
;************************************************************************
|
||
public obj_hash
|
||
obj_hash proc near
|
||
call %objhash
|
||
extrn next:near
|
||
jmp next ; return to the Scheme interpreter
|
||
obj_hash endp
|
||
|
||
public obj_unhs
|
||
obj_unhs proc near
|
||
call %objunhs
|
||
jmp next ; return to the Scheme interpreter
|
||
obj_unhs endp
|
||
|
||
public gc_oht
|
||
gc_oht proc near
|
||
call %gc_oht
|
||
ret
|
||
gc_oht endp
|
||
|
||
prog ends
|
||
end
|
||
|