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
|
|||
|
|
|