mirror of
https://github.com/PDP-10/stacken.git
synced 2026-01-31 05:42:03 +00:00
309 lines
11 KiB
Plaintext
309 lines
11 KiB
Plaintext
title amis
|
|
search jobdat,uuosym
|
|
extern main,bug
|
|
entry amis,catch,throw,new,free,corerr,offset
|
|
|
|
ifndef cdebug,<cdebug==0> ;Track core usage.
|
|
ifndef cdblen,<cdblen==^D20> ;... for these block sizes.
|
|
|
|
t0=0 ; temporary accumulators
|
|
t1=1
|
|
a1=2 ; arguments to procedures
|
|
a2=3
|
|
a3=4
|
|
a4=5
|
|
a5=6
|
|
a6=7
|
|
fp=15 ; frame pointer
|
|
np=16 ; new pointer which holds top of stack
|
|
sp=17 ; stack pointer
|
|
|
|
false=0 ; representation of false
|
|
true=1 ; representation of true
|
|
nil=0 ; representation of nil
|
|
|
|
loc .jbren ; start address for reenter command
|
|
exp amis
|
|
|
|
twoseg 400000 ; start of reentrant code
|
|
|
|
;------------------------------------------------------------------------------
|
|
; program amis;
|
|
; main program written in assembly language
|
|
;------------------------------------------------------------------------------
|
|
|
|
amis: tdza a1,a1 ; run entry
|
|
movei a1,1 ; ccl entry
|
|
movem a1,offset ; save run offset
|
|
skipn total ; check if restart,
|
|
jrst amis.2 ; and skip once-only things if so.
|
|
reset ; reset world otherwise
|
|
movei sp,stkblk+1 ; Need stack for rrspar call.
|
|
skipn offset ; If no run offset, -
|
|
pushj sp,rrspar## ; rescan the command line.
|
|
|
|
amis.2: move fp,[ ; initialize pointer registers
|
|
xwd stkblk,stkblk]
|
|
movei np,stkend-1
|
|
move sp,[
|
|
xwd 400000,stkblk+1]
|
|
move a1,total ; get total initialization flag,
|
|
setzm total ; and clear it for restart
|
|
pushj sp,main ; call main procedure
|
|
movei a1,[ ; main procedure may never terminate
|
|
asciz "AMIS main loop terminated"]
|
|
pushj sp,bug
|
|
|
|
;------------------------------------------------------------------------------
|
|
; procedure catch(ref catchblock: context);
|
|
; saves context in catchblock
|
|
; accumulators used: a1, a2
|
|
;------------------------------------------------------------------------------
|
|
|
|
context=a1 ; address of catchblock
|
|
|
|
catch: caig np,100(sp) ; check if we have enough stack
|
|
pushj sp,corerr ; no, so catching is meaningless
|
|
movem np,0(context) ; save top of stack pointer
|
|
movem fp,1(context) ; save frame pointer
|
|
movem sp,2(context) ; save stack pointer
|
|
move a2,0(sp) ; fetch return address,
|
|
hrlm a2,0(context) ; and save it in catchblock
|
|
movei a2,false ; return false this time
|
|
movem a2,1(sp)
|
|
popj sp,
|
|
|
|
;------------------------------------------------------------------------------
|
|
; procedure throw(var Context: catchblock);
|
|
; restores context from catchblock
|
|
; accumulators used: a1, a2, np, fp, sp
|
|
;------------------------------------------------------------------------------
|
|
|
|
context=a1 ; address of catchblock
|
|
|
|
throw: move a2,0(sp) ; fetch program counter with status flags
|
|
hrrz np,0(context) ; restore top of stack pointer
|
|
move fp,1(context) ; restore frame pointer
|
|
move sp,2(context) ; restore stack pointer
|
|
hlr a2,0(context) ; restore old return address
|
|
movem a2,0(sp) ; and save on stack
|
|
movei a2,true ; return true this time
|
|
movem a2,1(sp)
|
|
popj sp,
|
|
|
|
;------------------------------------------------------------------------------
|
|
; procedure new(pointer: ^any data type);
|
|
; implements the standard procedure new
|
|
; length of data type comes in a1, address of allocated object is left in a1
|
|
; ackumulator used: a1
|
|
; accumulators saved before use: a2, a3, a4, a5, a6
|
|
;------------------------------------------------------------------------------
|
|
|
|
overhead=1 ; one word memory manager overhead
|
|
extra=2000 ; allocate two extra memory pages
|
|
|
|
length=a1 ; length to allocate
|
|
this=a2 ; block which we are trying to allocate
|
|
pred=a3 ; that block's predecessor in linked list
|
|
succ=a4 ; that block's successor in linked list
|
|
|
|
new: jumple a2,[
|
|
movei a1,[
|
|
asciz "New: Allocating 0 or negative length"]
|
|
pushj sp,bug]
|
|
ifn cdebug,<
|
|
caig a2,cdblen ;In range?
|
|
aos cortab(a2) ; Yes, count this block.
|
|
cain a2,200 ;Text chunk?
|
|
aos cortab ; Yes, count it.
|
|
>;ifn cdebug
|
|
push sp,this ; saving accumulators is neccessary, since
|
|
push sp,pred ; this is a runtime system routine
|
|
push sp,succ
|
|
push sp,a5
|
|
push sp,a6
|
|
move length,a2 ;*** STUPID GERMANS THAT CHANGE REGISTERS ***
|
|
movei pred,freelist ; start with pointer to pointer to free list
|
|
newloop:hrrz this,(pred) ; scan the free list for nil, which means that
|
|
cain this,nil ; we have reached the end of the free list
|
|
jrst newzero ; without finding an appropriate chunk,
|
|
hlrz a5,(this) ; or a chunk which is long enough to keep the
|
|
cail a5,overhead(length); data type plus the memory manager's
|
|
jrst newtwo ; overhead
|
|
move pred,this
|
|
jrst newloop
|
|
newzero:move this,.jbff ; we didn't find an appropriate chunk, so we
|
|
move a5,this ; have to reserve some memory after the last
|
|
addi a5,overhead(length); allocated chunk
|
|
hrrz a6,.jbrel ; do we have to ask the operating system for
|
|
cail a6,-1(a5) ; more memory?
|
|
jrst newmos ; no, we already have that much memory
|
|
movei a6,extra-1(a5) ; yes, try to allocate some extra memory at
|
|
core a6, ; the same time
|
|
skipa ; did operating system give us extra memory?
|
|
jrst newmos ; yes, go on
|
|
movei a6,-1(a5) ; no, try to allocate just as much as we need
|
|
core a6,
|
|
skipa ; successfull this time?
|
|
jrst newmos ; yes, go on
|
|
movei a1,[ ; no, go print error message
|
|
ascii "URK? Buffer Space Exhausted "]
|
|
jrst error## ; *** try to do something smarter here ***
|
|
newmos: movei a6,overhead(length); set up chunk length in overhead word
|
|
movsm a6,(this)
|
|
movem a5,.jbff ; update address of first free location
|
|
hrlm a5,.jbsa
|
|
jrst newret
|
|
newtwo: hlrz a5,(this) ; we found a chunk, now check if we can split
|
|
caig a5,2*overhead(length); it into two parts
|
|
jrst newone ; too short, don't split it
|
|
move succ,this ; long enough, calculate start address of 2nd
|
|
addi succ,overhead(length); part
|
|
subi a5,overhead(length); calculate length of 2nd part and store
|
|
hrl a5,(this) ; length and pointer in overhead word of 2nd
|
|
movsm a5,(succ) ; part
|
|
movei a5,overhead(length); change length of 1st part
|
|
hrlm a5,(this)
|
|
hrrm succ,(pred) ; finally remove 1st part from free list
|
|
jrst newret
|
|
newone: hrrz succ,(this) ; remove unsplit chunk from free list
|
|
hrrm succ,(pred)
|
|
newret: movei a1,overhead(this); return address of first word after overhead
|
|
pop sp,a6 ; restoring accumulators is also neccessary
|
|
pop sp,a5
|
|
pop sp,succ
|
|
pop sp,pred
|
|
pop sp,this
|
|
popj sp,
|
|
|
|
;------------------------------------------------------------------------------
|
|
; procedure free(pointer: ^any data type);
|
|
; implements the standard procedure dispose
|
|
; address of object to deallocate comes in t0 and length in t1
|
|
; accumulators saved before use: a1, a2, a3, a4
|
|
;------------------------------------------------------------------------------
|
|
|
|
overhead=1 ; one word memory manager overhead
|
|
keep=1000 ; keep spare memory if less than one page
|
|
|
|
this=a1 ; block which we are about to deallocate
|
|
pred=a2 ; that block's predecessor in linked list
|
|
succ=a3 ; that block's successor in linked list
|
|
|
|
free: jumpe a1,[ ; address must not be zero or nil
|
|
movei a1,[
|
|
asciz "Dispose: Deallocating 0 or NIL"]
|
|
pushj sp,bug]
|
|
ifn cdebug,<
|
|
caig a2,cdblen ;In range?
|
|
sos cortab(a2) ; Yes, discount this block.
|
|
cain a2,200 ;Text chunk?
|
|
sos cortab ; Yes, discount it.
|
|
>;ifn cdebug
|
|
dmove t0,a1 ;*** STUPID GERMANS ***
|
|
move this,t0
|
|
push sp,this ; saving accumulators is neccessary, since
|
|
push sp,pred ; this is a runtime system routine
|
|
push sp,succ
|
|
push sp,a4
|
|
movei pred,freelist ; start with pointer to pointer to free list
|
|
movei this,-overhead(this); point to memory manager data instead
|
|
disloop:hrrz succ,(pred) ; scan the free list for nil, which means that
|
|
caie succ,nil ; we reached the end of the free list, or a
|
|
caml succ,this ; higher address, which means that we shall
|
|
jrst dispred ; insert this chunk there
|
|
hrlz pred,pred
|
|
hrr pred,succ
|
|
jrst disloop
|
|
dispred:camn succ,this ; chunk addresses must not be equal
|
|
jrst[ movei a1,[
|
|
asciz "Dispose: Deallocating object twice"]
|
|
pushj sp,bug]
|
|
hlrz a4,(pred) ; see if this chunk starts at the same address
|
|
addi a4,(pred) ; as the previous one ends at
|
|
came a4,this
|
|
jrst disinto ; it doesn't, go insert it into list
|
|
hllz a4,(this) ; it does, concatenate the two adjancent chunks
|
|
addm a4,(pred) ; by increasing the size of the first one
|
|
hrrz this,pred ; back up pointers for further calculations
|
|
hlrz pred,pred
|
|
jrst dissucc
|
|
disinto:hrrm succ,(this) ; not adjancent, so just insert this chunk into
|
|
hrrm this,(pred) ; the free list
|
|
dissucc:hlrz a4,(this) ; see if this chunk ends at the same address
|
|
add a4,this ; as the next one starts at
|
|
came a4,succ
|
|
jrst diszero ; it doesn't, go check if at end of memory
|
|
hrrz a4,(succ) ; it does, concatenate the two adjancent chunks
|
|
hrrm a4,(this) ; by moving a pointer and increasing the size
|
|
hllz a4,(succ) ; of the first one
|
|
addm a4,(this)
|
|
jrst disret
|
|
diszero:came a4,.jbff ; is this the last allocated chunk in memory?
|
|
jrst disret ; no, so there's nothing more to do
|
|
movei a4,nil ; yes, discard this chunk from the free list
|
|
hrrm a4,(pred) ; and try to deallocate some memory
|
|
movem this,.jbff
|
|
hrlm this,.jbsa
|
|
andi this,777000
|
|
hrrz a4,.jbrel
|
|
caige this,1-1000-keep(a4)
|
|
core this,
|
|
jfcl
|
|
disret: pop sp,a4 ; restoring accumulators is also neccessary
|
|
pop sp,succ
|
|
pop sp,pred
|
|
pop sp,this
|
|
popj sp,
|
|
|
|
;------------------------------------------------------------------------------
|
|
; procedure corerr;
|
|
; implements the runtime system routine for stack overflow
|
|
; accumulators used: a1, np, fp, sp
|
|
;------------------------------------------------------------------------------
|
|
|
|
corerr: caie np,stkend-1 ; executing on normal stack?
|
|
jrst corbug ; no, hard bug
|
|
movei np,sofend-1 ; initialize pointer registers
|
|
move fp,[
|
|
xwd sofblk,sofblk]
|
|
move sp,[
|
|
xwd 400000,sofblk+1]
|
|
movei a1,[ ; get error message string address
|
|
ascii "SOF? Stack Overflow "]
|
|
pushj sp,error ; soft error
|
|
corbug: movei a1,[ ; hard stack overflow detected
|
|
asciz "Stack Overflow"]
|
|
pushj sp,bug
|
|
|
|
seterr::
|
|
inxerr::
|
|
srerr:: movei a1,[ ; These routines shall not be used anyway...
|
|
asciz "Horrendeous system error"]
|
|
pushj sp,bug
|
|
|
|
|
|
bittb.::i==0
|
|
repeat ^D36,<
|
|
exp 1B<i>
|
|
i==i+1
|
|
>;End of bit table.
|
|
|
|
lit ; put literals in reentrant segment
|
|
reloc ; start of non reentrant data area
|
|
|
|
ifn cdebug,< ; Count use of core blocks:
|
|
cortab: exp 0 ; Text chunks.
|
|
repeat cdblen,<exp 0> ; Blocks 1..cdblen words.
|
|
>;ifn cdebug
|
|
|
|
total: exp 1 ; total initialization flag is true initially
|
|
offset: block 1 ; run offset stored here
|
|
freelist: xwd 0,nil ; pointer to first element in free list
|
|
stkblk: block 1000 ; runtime stack
|
|
stkend: ; end of runtime stack
|
|
sofblk: block 100 ; stack overflow stack
|
|
sofend: ; end of stack overflow stack
|
|
|
|
end amis
|