352 lines
11 KiB
NASM
352 lines
11 KiB
NASM
; =====> BASICIO.ASM
|
||
;********************************************************
|
||
;* Scheme Runtime Support *
|
||
;* Memory Allocation Routines *
|
||
;* for Variable Length Objects *
|
||
;* *
|
||
;* (C) Copyright 1985 by Texas *
|
||
;* Instruments Incorporated. *
|
||
;* All rights reserved. *
|
||
;* *
|
||
;* Date Written: 31 December 1987 *
|
||
;* Last Modification: *
|
||
;********************************************************
|
||
page 60,132
|
||
include memtype.equ
|
||
include scheme.equ
|
||
|
||
SMALL_SIZE equ 1024 ;space in page not worth searching
|
||
|
||
DGROUP group data
|
||
data segment word public 'DATA'
|
||
assume DS:DGROUP
|
||
data ends
|
||
|
||
PGROUP group prog
|
||
prog segment byte public 'PROG'
|
||
assume CS:PGROUP
|
||
|
||
extrn alloc_bi:near,alloc_pa:near,garbage:near,gcsquish:near
|
||
extrn out_of_m:near
|
||
|
||
;;;ALLOC_BLOCK
|
||
;;;
|
||
;;; calling sequence: alloc_block(reg, type, size)
|
||
;;;
|
||
;;; local storage: int temp_ret,*last_page,page,str_size
|
||
;;;
|
||
al_args struc
|
||
temp_ret dw ? ;return address from srch_block
|
||
last_page dw ? ;address of pagelink chain
|
||
page dw ? ;page # of candidate
|
||
str_size dw ? ;actual size of object
|
||
al_bp dw ? ;callers bp
|
||
dw ? ;callers es
|
||
dw ? ;return address
|
||
ret_reg dw ? ;register for return value
|
||
ob_typ dw ? ;type of object to find
|
||
ob_siz dw ? ;size of object to find
|
||
al_args ends
|
||
|
||
public alloc_bl
|
||
alloc_bl proc near
|
||
|
||
push es
|
||
push bp
|
||
sub sp,al_bp
|
||
mov bp,sp
|
||
|
||
;if object is string, check for small string and adjust size appropriately
|
||
mov ax,[bp].ob_siz ;get object size
|
||
mov [bp].str_size,ax ;and save for later
|
||
cmp [BP].ob_typ,STRTYPE ;is it a string?
|
||
jnz al005 ; no, jump
|
||
cmp ax,PTRSIZE ;is it a small string?
|
||
jge al005 ; no, jump
|
||
mov [bp].ob_siz,PTRSIZE ;size = PTRSIZE
|
||
al005:
|
||
add [bp].ob_siz,BLK_OVHD ;size += BLK_OVHD
|
||
|
||
;search page type chain for block
|
||
call srch_block
|
||
jc al050 ;jump if block found
|
||
|
||
; Didn't find a block, test for a large block
|
||
mov ax,[BP].ob_siz
|
||
cmp ax,pagesize ;requested size > pagesize?
|
||
jb al010 ; no, jump
|
||
|
||
public try_big
|
||
try_big:
|
||
|
||
;try to allocate a big block
|
||
mov si,[bp].ret_reg
|
||
mov word ptr [si+02],NIL_PAGE*2 ;clear ret reg in case of GC
|
||
push ax ;size
|
||
push [BP].ob_typ ;type
|
||
push si ;return reg
|
||
call alloc_bi ;Allocate Big Block
|
||
mov sp,bp
|
||
jmp al050 ;return to caller
|
||
|
||
;block not found in allocated pages, try to allocate a new page
|
||
al010:
|
||
push [bp].ob_typ ;type
|
||
call alloc_pa ;Allocate new page
|
||
mov sp,bp
|
||
mov [bp].page,ax ;update page
|
||
cmp ax,END_LIST ;did we succeed?
|
||
jnz al040 ; yes, jump
|
||
;no more pages, try a garbage collection, then search the pages again
|
||
;for a free block
|
||
mov si,[bp].ret_reg
|
||
mov word ptr [si+02],NIL_PAGE*2 ;clear reg before GC
|
||
call garbage ;do garbage collection
|
||
call srch_block ;search for block again
|
||
jc al050 ;return on success
|
||
;
|
||
; Still couldn't find a block large enough, try to allocate a new page once
|
||
; again (since we just did a garbage collection).
|
||
;
|
||
push [BP].ob_typ ;type
|
||
call alloc_pa ;Allocate a new page
|
||
mov sp,bp
|
||
mov [bp].page,AX ;save page number
|
||
cmp ax,END_LIST ;did we succeed?
|
||
jnz al040 ; yes, jump
|
||
; We're getting desperate now. Try a collection with compaction, then try to
|
||
; allocate a new page for the object
|
||
mov si,[bp].ret_reg
|
||
mov word ptr [si+02],0 ;clear for possible GC
|
||
call gcsquish ;Compact memory
|
||
push [bp].ob_typ ;type
|
||
call alloc_pa ;Allocate a new page
|
||
mov sp,bp
|
||
mov [bp].page,ax
|
||
cmp ax,END_LIST ;Did we succeed?
|
||
jz alloc_err ; no, out of memory
|
||
;at this point, a new page has been allocated; get a block from it
|
||
al040:
|
||
push [bp].page ;page
|
||
push [bp].ob_siz ;size
|
||
push [bp].ob_typ ;type
|
||
push [bp].ret_reg ;return reg
|
||
call find_block ;Allocate a Block
|
||
mov sp,bp
|
||
jnc alloc_err
|
||
;
|
||
; We have found a block, set up the header and return
|
||
;
|
||
al050:
|
||
cmp [bp].ob_typ,STRTYPE
|
||
jnz alloc_ret
|
||
cmp [bp].str_size,PTRSIZE
|
||
jge alloc_ret
|
||
;for small strings, put the negative value for object length
|
||
push es
|
||
mov si,[bp].ret_reg
|
||
mov bx,[si+02] ;bx = page
|
||
mov si,[si] ;si = displacement
|
||
LoadPage es,bx
|
||
mov cx,[bp].str_size
|
||
sub cx,PTRSIZE ;cx = size - PTRSIZE
|
||
mov word ptr es:[si+1],cx ;replace object length
|
||
pop es ;restore extra segment
|
||
alloc_ret:
|
||
add sp,al_bp ;remove local data
|
||
pop bp ;restore base pointer
|
||
pop es ;restore extra segment
|
||
ret ;return to caller
|
||
public alloc_err
|
||
alloc_err:
|
||
call out_of_m ;out of memory
|
||
jmp alloc_ret ;control will not return here
|
||
|
||
|
||
; SRCH_BLOCK - Search through all the pages of a given type looking for a
|
||
; block large enough to fill the size request.
|
||
;
|
||
; Upon Entry: All local storage and args to ALLOC_BLOCK are used. Do
|
||
; not modify BP.
|
||
;
|
||
; Upon Exit: Carry Flag set, ret_reg will contain the page:disp of the block.
|
||
; Carry Flag clear, ret_reg will contain page of -1
|
||
;
|
||
public srch_block
|
||
srch_block label near
|
||
pop [bp].temp_ret ;save return value
|
||
|
||
mov bx,[bp].ob_typ ;bx = object type
|
||
shl bx,1 ;make into table index
|
||
mov si,bx
|
||
add bx,offset pagelist ;bx = address of pagelist[type]
|
||
mov [bp].last_page,bx ;save in last_page
|
||
mov ax,pagelist[si] ;ax = page number for this type
|
||
cmp ax,END_LIST ;any pages to search?
|
||
clc ;carry clear = failure
|
||
jz srch_end ; no, skip loop
|
||
srch_loop:
|
||
mov [bp].page,ax ;save page number for later
|
||
|
||
push ax ;page number
|
||
push [bp].ob_siz ;size of object
|
||
push [bp].ob_typ ;type of object
|
||
push [bp].ret_reg ;register to return value in
|
||
call find_block ;look for free space in page
|
||
mov sp,bp ;dump args off stack
|
||
jc srch_end ;carry set = success
|
||
;
|
||
; Block not found within current page.
|
||
;
|
||
mov si,[bp].page ;get page number
|
||
shl si,1 ; and make into index
|
||
cmp [bp].ob_siz,SMALL_SiZE ;size <= SMALL_SIZE?
|
||
jg sr10 ; no, jump
|
||
; less than small_size space is left within the page; this isn't worth searching
|
||
; again, so update the last position in the chain (last_page) to point to the
|
||
; next page in the chain.
|
||
mov ax,pagelink[si] ;get next page link
|
||
mov di,[bp].last_page
|
||
mov [di],ax ;*last_page = pagelink[page]
|
||
sr10:
|
||
; update last_page to contain the address of the next position in the chain,
|
||
; and get the next page from pagelink[page].
|
||
mov bx,offset pagelink ;bx = address of pagelink table
|
||
add bx,si ;bx = address of pagelink[page]
|
||
mov [bp].last_page,bx ;save in last_page
|
||
mov ax,pagelink[si] ;get next page number
|
||
cmp ax,END_LIST ;reached end of chain?
|
||
jne srch_loop ; no, continue search for block
|
||
clc ;carry clear = failure
|
||
srch_end:
|
||
jmp [bp].temp_ret ;return to caller
|
||
|
||
alloc_bl endp
|
||
|
||
;;;FIND_BLOCK
|
||
;;;
|
||
;;; calling sequence: find_block(reg, type, size, page)
|
||
;;;
|
||
;;; Upon Exit: carry flag set: reg contains page:displ of new block
|
||
;;; carry flag clr: reg contains page of -1
|
||
;;;
|
||
fb_args struc
|
||
dw ? ;callers bp
|
||
dw ? ;return address
|
||
r_reg dw ? ;register for return value
|
||
bl_typ dw ? ;block type
|
||
bl_siz dw ? ;block size
|
||
bl_pag dw ? ;page number
|
||
fb_args ends
|
||
|
||
public find_block
|
||
find_block proc near
|
||
push bp
|
||
mov bp,sp
|
||
|
||
mov si,[bp].r_reg ;get return register
|
||
mov Word Ptr [si+02],-1 ;default to block not found
|
||
|
||
mov si,[bp].bl_pag ;get page number
|
||
shl si,1 ;si = page index
|
||
LoadPage es,si ;es => page
|
||
|
||
; lets see if there's space in the free pool of this block
|
||
mov bx,nextcell[si] ;bx = next cell in page
|
||
cmp bx,END_LIST ;if no more space
|
||
jz fb015 ; then jump
|
||
mov ax,es:[bx+1] ;ax = free pool size
|
||
mov dx,[bp].bl_siz ;get size required
|
||
cmp ax,dx ;if not enough space in pool
|
||
jl fb015 ; then jump
|
||
|
||
; allocate a block from the free pool.
|
||
; ax = free pool size, bx = displacement, dx = object size
|
||
mov cx,[bp].bl_typ ;cx = type of object
|
||
mov byte ptr es:[bx],cl ;store type of new object
|
||
mov word ptr es:[bx+1],dx ;store size of new object
|
||
mov di,bx ;cx = displacement
|
||
add di,dx ;di = new displacement
|
||
mov cx,psize[si] ;get page size
|
||
sub cx,BLK_OVHD ; and subtract block overhead
|
||
cmp cx,di ;next displ still in page?
|
||
jb fb010 ; no, jump
|
||
mov byte ptr es:[di],FREETYPE ;mark next area as free
|
||
sub ax,dx ;ax = pool size - object size
|
||
mov word ptr es:[di+1],ax ;update free pool size
|
||
mov nextcell[si],di ;update nextcell chain
|
||
jmp fb045 ;return to caller
|
||
fb010:
|
||
mov nextcell[si],END_LIST ;nextcell[page] = END_LIST
|
||
jmp fb045 ;return to caller
|
||
|
||
; A block was not found in the free pool. Search the entire block for a fragment
|
||
; to satisfy the request.
|
||
fb015:
|
||
xor bx,bx ;bx = displacement
|
||
mov cx,psize[si]
|
||
sub cx,[bp].bl_siz ;cx = displacement threshold
|
||
cmp cx,bx ;threshhold >= displacement?
|
||
clc ;zero flag not set = failure
|
||
jl fb050 ;return with no block found
|
||
|
||
;the following loop requires bx=displacement, cx=threshold, dx=free size
|
||
fb020:
|
||
mov dx,word ptr es:[bx+1] ;dx = size of object
|
||
cmp byte ptr es:[bx],FREETYPE ;is next area free?
|
||
jz fb035 ; yes, jump
|
||
fb025: mov ax,BLK_OVHD+PTRSIZE ;ax = ovhd for small string
|
||
test dx,dx ;if size negative
|
||
js fb030 ; then jump
|
||
mov ax,dx ; else ax = size of object
|
||
fb030: add bx,ax ;displacement += size
|
||
cmp cx,bx ;if disp <= threshhold
|
||
jge fb020 ; then go look at next object
|
||
clc ;zero flag not set = failure
|
||
jmp fb050 ;return with no block found
|
||
|
||
;we have found a free space in the block; if not big enough then jump back
|
||
;into loop above, otherwise allocate the new storage
|
||
fb035:
|
||
mov ax,[bp].bl_siz
|
||
cmp ax,dx ;compare size to free size
|
||
jl fb025 ;if less, return to loop
|
||
jnz fb040 ;if not equal, jump
|
||
; we found an exact match
|
||
mov ax,[bp].bl_typ
|
||
mov byte ptr es:[bx],al ;just update the type field
|
||
jmp fb045 ;and return to caller
|
||
fb040:
|
||
mov di,dx
|
||
sub di,BLK_OVHD ;di = free size - block overhead
|
||
cmp di,ax ;can object fit into free space?
|
||
jle fb025 ; no, return to loop
|
||
; we can fit into a larger block, split block to allocate storage
|
||
mov cx,[bp].bl_typ ;cx = type of object
|
||
mov byte ptr es:[bx],cl ;store type of new object
|
||
mov word ptr es:[bx+1],ax ;store size of new object
|
||
;ax=new object size, bx=disp, dx= free size
|
||
mov di,bx
|
||
add di,ax ;di = new displacement
|
||
mov cx,dx
|
||
sub cx,ax ;cx = free size - new size
|
||
mov byte ptr es:[di],FREETYPE ;mark next area as free
|
||
mov word ptr es:[di+1],cx ;update next area free size
|
||
;
|
||
; block found; return page,disp in return register.
|
||
; si = page index, bx = displacement
|
||
fb045:
|
||
mov ax,si ;ax = page index
|
||
mov si,[bp].r_reg ;si = address of return reg
|
||
mov [si+02],ax ;put page index in register
|
||
mov [si],bx ;put diplacement in register
|
||
stc ;carry set = success
|
||
fb050:
|
||
pop bp ;restore base pointer
|
||
ret ;return to caller
|
||
|
||
find_block endp
|
||
|
||
prog ends
|
||
END
|
||
|