conservatory
/
pcs
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
pcs/sobjhash.asm

458 lines
17 KiB
NASM
Raw Normal View History

Unpack disk3.tgz
2023-05-20 05:57:06 -04:00
; =====> 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