6502/of816
1
0
Fork 0
mirror of https://github.com/mgcaret/of816.git synced 2024-12-27 19:29:58 +00:00
Code Issues Projects Releases Wiki Activity
c718260118
of816/asm/interpreter.s
mgcaret 8245ce322b optimizations
2021-07-29 21:07:06 -07:00

1045 lines
26 KiB
ArmAsm
Raw Blame History

; Inner interpreter and support routines, and basic stack manipulation routines.
; Inner interpreter entry and Forth call nesting
; this inner interpreter expects cell-sized absolute references to other definitions
; Expectations:
; call with JSL in native mode with long registers
; D register: address of direct page to be used for low-level system functions and
; working registers.
; S register: return stack
; X register: data stack pointer in bank 0, relative to D register.
; See equates.inc. SP_MIN and SP_MAX reflect minimum and maximum allowed stack pointer
; Pops caller from return stack and initializes IP with it
; saving previous IP on return stack.
.if 1 ; faster
.proc _enter
.if trace
lda IP
ldy IP+2
wdm $81
.endif
phb ; (3) dummy value
lda 2,s ; (5)
ldy IP ; (4)
sta IP ; (4)
tya ; (2)
sta 1,s ; (5)
lda 4,s ; (5)
ldy IP+2 ; (4)
and #$FF ; (3)
sta IP+2 ; (4)
tya ; (2)
sta 3,s ; (5)
; fall-through ; (46 cycles)
.endproc
.else ; original implementation
.proc _enter
ldy IP ; (4)
lda IP+2 ; (4)
.if trace
wdm $81
.endif
sta TMP1 ; (4)
pla ; (5)
sta IP ; (4)
sep #SHORT_A ; (3)
pla ; (4)
rep #SHORT_A ; (3)
and #$FF ; (3)
sta IP+2 ; (4)
lda TMP1 ; (4)
pha ; (4)
phy ; (4)
; fall-through ; (50 cycles)
.endproc
.endif
.proc _next
.if 1
ldy #$0003 ; (3)/3
lda [IP],y ; (7)/2
.if !no_fast_lits
bne :++
jsr _stackdecr
sta STACKBASE+2,x
dey
dey
lda [IP],y
sta STACKBASE+0,x
lda IP
clc
adc #$0004
sta IP
bcc :+
inc IP+2
: bra _next
:
.endif
xba ; (3)/1 xxHH -> HHxx
pha ; (4)/1 stack ...HHxx
phb ; (3)/1 stack ...HHxxxx
dey ; (2)/1
dey ; (2)/1
lda [IP],y ; (7)/2 MMLL
sta 1,s ; (5)/2 stack ...HHMMLL
lda IP ; (4)/2
clc ; (2)/1
adc #$0004 ; (3)/2
sta IP ; (4)/2
bcc :+ ; (2)/2
inc IP+2 ; (6)/2
: rtl ; (6)/1 (63)/26
.else
; old implementation
inc IP ; (6)/2 inline fetch
bne :+ ; (2)/2
inc IP+2 ; (6)/2
: lda [IP] ; (7)/2 low word
tay ; (2)/1
inc IP ; (6)/2
bne :+ ; (2)/2
inc IP+2 ; (6)/2
: inc IP ; (6)/2
bne :+ ; (2)/2
inc IP+2 ; (6)/2
: lda [IP] ; (7)/2 high word
inc IP ; (6)/2
bne :+ ; (2)/2
inc IP+2 ; (6)/2 = (72)/29+run=(82)
:
.if !no_fast_lits
ora #$0000 ; faster than php+plp
beq fast_num
.endif
.endif
run: sep #SHORT_A ; (3)/1
pha ; (4)/1
rep #SHORT_A ; (3)/1
phy ; (4)/1
rtl ; (6)/1 = 20/5
fast_num: jsr _pushay
bra _next
.endproc
; Exit Forth thread: restore previous IP from return stack
; and resume execution
.proc _exit_next
ply
pla
.if trace
wdm $83
.endif
sty IP
sta IP+2
NEXT
.endproc
; Exit Forth thread, resume native code execution at IP+1 by swapping the 32-bit IP on the
; stack for the low 24 bits of the Forth IP
.proc _exit_code
.if 1 ; ever so slightly faster, eliminate TMP1 use
.if trace
lda IP+2
ldy IP
wdm $82
.endif
lda 3,s ; (5)
tay ; (2)
lda IP+1 ; (4) note offset is 1 to get high & middle bytes
sta 3,s ; (5)
sty IP+2 ; (4)
lda 1,s ; (5)
tay ; (2)
lda IP ; (4)
sta 2,s ; (5) note offset is 2 to place low (& middle again) bytes
sty IP ; (4)
tsc ; (2)
inc a ; (2) drop the extra byte
tcs ; (2)
rtl ; (47 cycles)
.else ; original
ldy IP ; (4)
lda IP+2 ; (4)
sta TMP1 ; (4)
pla ; (5)
sta IP ; (4)
pla ; (5)
sta IP+2 ; (4)
lda TMP1 ; (4)
.if trace
wdm $82
.endif
sep #SHORT_A ; (3)
pha ; (4)
rep #SHORT_A ; (3)
phy ; (4)
rtl ; (48 cycles)
.endif
.endproc
.proc _fetch_ip_word
inc IP
bne :+
inc IP+2
: lda [IP]
; fall-through
.endproc
.proc _inc_ip ; note fall-through from above!
inc IP
bne :+
inc IP+2
: rts
.endproc
.proc _fetch_ip_byte
inc IP
bne :+
inc IP+2
: lda [IP]
and #$00FF
rts
.endproc
.proc _fetch_ip_cell
inc IP
bne :+
inc IP+2
: lda [IP]
tay
inc IP
bne :+
inc IP+2
: inc IP
bne :+
inc IP+2
: lda [IP]
inc IP
bne :+
inc IP+2
: rts
.endproc
; convert XT address in YR to header address in YR
; return carry set if word has header
; return carry clear if word does not have header (is noname)
; Y = name length
.proc _xttohead
lp: jsr _decyr ; first one decrements before flags
lda [YR]
and #$80 ; see if it's the name length field
beq lp ; nope, go back again
lda [YR] ; get it back
and #$7F ; mask in length
tay ; and save it
beq nohead
yrminus4: lda YR
sec ; move to link field
sbc #$04
sta YR
lda YR+2
sbc #$00
sta YR+2
sec ; flag OK
rts
nohead: clc
rts
.endproc
_yrminus4 = _xttohead::yrminus4
.if 0
; Get caller address (must call with JSL)
.proc _trace_word
ldy #'>'
jsr _emit
lda 1,S ; get caller address
sta WR
lda 3,S
sta WR+2
jsr _wrminus4 ; get xt
lda WR ; copy xt to YR
sta YR
lda WR+2
sta YR+2
jsr _xttohead ; go to header
bcc do_hex ; No name
sty XR ; save length
stz XR+2
lda YR ; put address of name back into WR
clc
adc #$04
sta WR
lda YR+2
adc #$00
sta WR+2
ldy #.loword(do_emit-1)
lda #.hiword(do_emit-1)
jsr _str_op_ay ; now print word (destroys YR)
spacer: lda #' ' ; print a space and cleverly fall through
do_emit: tay
jsr _emit
clc
rtl
do_hex: jsr _incwr ; Move to word XT address
ldy #'$' ; because that's what we want to print
jsr _emit
lda WR+2 ; high word
jsr prhex ; print
lda WR ; low word
jsr prhex ; print
bra spacer ; and done
prhex: sta XR ; save it
lda #$04 ; 4 digits to do
sta XR+2 ; counter loc
digit: lda #$0000 ; start with nothing
clc ; rotate 4 bits from XR to A
rol XR
rol a
rol XR
rol a
rol XR
rol a
jsr _dtoc ; convert to ASCII
tay
jsr _emit ; and print
dec XR+2
bne digit ; do the rest if there are some left
rts
.endproc
.endif
; Stack primitives
; stack starts at STK_TOP and grows down toward STK_BTM
; STK_BTM points at the last usable cell
; STK_TOP points at the location above the first usable cell
.proc _stackdecr
cpx STK_BTM ; past the bottom already?
bcc _stko_err
dex
dex
dex
dex
rts
.endproc
.proc _stackincr
cpx STK_TOP ; already past where we can be?
bcs _stku_err ; yep, underflowed stack
inx
inx
inx
inx
rts
.endproc
.proc _popay
lda STACKBASE+2,x
ldy STACKBASE+0,x
.if trace
wdm $85
.endif
bra _stackincr
.endproc
.proc _peekay
cpx STK_TOP
bcs _stku_err
lda STACKBASE+2,x
ldy STACKBASE+0,x
rts
.endproc
.proc _popwr
jsr _popay
sty WR
sta WR+2
rts
.endproc
; no stack depth check
.proc _peekwr
lda STACKBASE+0,x
sta WR
lda STACKBASE+2,x
sta WR+2
rts
.endproc
.proc _popxr
jsr _popay
sty XR
sta XR+2
rts
.endproc
.proc _popyr
jsr _popay
sty YR
sta YR+2
rts
.endproc
.proc _stku_err
ldx STK_TOP
ldy #.loword(-4)
lda #.hiword(-4)
jmp _throway
.endproc
.proc _1parm
cpx STK_TOP
bcs _stku_err
rts
.endproc
.proc _l1parm
jsr _1parm
rtl
.endproc
.proc _2parm
txa
clc
adc #$04
docmp: cmp STK_TOP
bcs _stku_err
rts
.endproc
.proc _l2parm
jsr _2parm
rtl
.endproc
.proc _3parm
txa
clc
adc #$08
bra _2parm::docmp
.endproc
.proc _l3parm
jsr _3parm
rtl
.endproc
.proc _4parm
txa
clc
adc #$0C
bra _2parm::docmp
.endproc
.proc _l4parm
jsr _4parm
rtl
.endproc
.proc _stko_err
lda STK_BTM
clc
adc #32 ; 8 cells
tax
ldy #.loword(-3)
lda #.hiword(-3)
jmp _throway
.endproc
.proc _pushay
.if trace
wdm $86
.endif
jsr _stackdecr
sta STACKBASE+2,x
sty STACKBASE,x
rts
.endproc
.proc _pusha
.if trace
phy
tay
lda #$00
jsr _pushay
ply
.else
jsr _stackdecr
stz STACKBASE+2,x
sta STACKBASE,x
.endif
rts
.endproc
.proc _swap
jsr _2parm
; fall-through
.endproc
; when we know there are 2 parms on stack...
.proc _swap1
lda STACKBASE+6,x
ldy STACKBASE+2,x
sty STACKBASE+6,x
sta STACKBASE+2,x
lda STACKBASE+4,x
ldy STACKBASE+0,x
sty STACKBASE+4,x
sta STACKBASE+0,x
rts
.endproc
.proc _over
jsr _2parm
ldy STACKBASE+4,x
lda STACKBASE+6,x
jmp _pushay
.endproc
; Interpretation routines
; Push word data address, default routine used by CREATE
; call via JSL, pops return stack entry, pushes data address
; onto data stack
.proc _pushda
pla
clc
adc #$01
tay
sep #SHORT_A
pla
rep #SHORT_A
and #$FF
adc #$00
PUSHNEXT
.endproc
; Pushes cell following JSL onto the stack
.proc _pushvalue
pla
clc
adc #$01
sta WR
sep #SHORT_A
pla
rep #SHORT_A
and #$FF
adc #$00
sta WR+2
pushv2: ldy #$02
lda [WR],y ; high word
pha ; save for now
lda [WR] ; low word
tay
pla
PUSHNEXT
.endproc
; Pushes stack top + cell following JSL onto the stack
.proc _field
jsr _1parm
pla
clc
adc #$01
sta WR
sep #SHORT_A
pla
rep #SHORT_A
and #$FF
adc #$00
sta WR+2
lda [WR] ; low word
clc
adc STACKBASE+0,x
sta STACKBASE+0,x
ldy #$02
lda [WR],y ; low word
adc STACKBASE+0,x
sta STACKBASE+0,x
NEXT
.endproc
.proc _push2value
pla
clc
adc #$01
sta WR
sep #SHORT_A
pla
rep #SHORT_A
and #$FF
adc #$00
sta WR+2
ldy #$06
lda [WR],y ; high word
pha ; save for now
dey
dey
lda [WR],y ; low word
tay
pla
jsr _pushay
bra _pushvalue::pushv2
.endproc
; Return address of system variable # following the JSL
.proc _sysvar
pla ; return address + 1 -> WR
clc
adc #$01
sta WR
sep #SHORT_A
pla
rep #SHORT_A
and #$FF
adc #$00
sta WR+2
lda [WR] ; get sysvar number (max of 16384*4)
clc
adc SYSVARS ; add to address of SYSVARS
tay
lda SYSVARS+2
adc #$00
PUSHNEXT
.endproc
; Jumps to the XT following JSL
.proc _deferred
pla
clc
adc #$01
sta WR
sep #SHORT_A
pla
rep #SHORT_A
and #$FF
adc #$00
sta WR+2
ldy #$02
lda [WR],y ; high word
sep #SHORT_A
pha ; bank byte on stack
rep #SHORT_A
lda [WR] ; low word
pha ; address on stack
rtl ; really a jump
.endproc
; After pop from data stack into AY, jumps to the XT following JSL
.proc _pop_deferred
pla
clc
adc #$01
sta WR
sep #SHORT_A
pla
rep #SHORT_A
and #$FF
adc #$00
sta WR+1
ldy #$02
lda [WR],y ; high word
sep #SHORT_A
pha ; bank byte on stack
rep #SHORT_A
lda [WR] ; low word
pha ; RTS address on stack
jsr _popay
rts ; really a jump
.endproc
; ensure at least room for 8 items on stack
.proc _stackroom
txa
sec
sbc #$20 ; see if there is room for 8 items on stack
cmp STK_BTM
bcc makeroom
chktop: cpx STK_TOP ; new see if we are above the top
bcc :+
ldx STK_TOP
: rts
makeroom: txa
adc #$20
tax
bra chktop
.endproc
.proc _unimpl
ldy #.loword(-21)
lda #.hiword(-21)
jmp _throway
.endproc
.proc _callyr
tay
lda YR+2
sep #SHORT_A
pha
rep #SHORT_A
lda YR
pha
tya
rtl
.endproc
.proc _str_op_ay
sta YR+2
sty YR
; fall-through
.endproc
; Perform a "string" operation on the string pointed at in WR
; with length in XR and function in YR (address less 1)
; YR is called with A containing the byte from the string
; XR is converted to last address plus one of the string
; [YR] should return with carry clear if processing is to continue
; and carry set if it not.
; note YR is called with long registers
.proc _str_op
lda WR
clc
adc XR
sta XR
lda WR+2
adc XR+2
sta XR+2
loop: lda WR+2
cmp XR+2
bne :+
lda WR
cmp XR
: bcc :+
done: rts
: lda [WR]
and #$00FF ; compensate for long register
jsl f:_callyr
bcs done
jsr _incwr
bra loop
.endproc
; do string op with function in AY and string described by (c-addr u) on
; top of data stack
.proc _str_op_ays
sta YR+2
sty YR
jsr _popxr ; u -> XR
jsr _popwr ; c-addr -> YR
bra _str_op
.endproc
.proc _iter_ay
sta YR+2
sty YR
; fall-through
.endproc
; Perform a function pointed at in YR with count in XR times
; iteration # (from 0) will be in WR
; [YR] should return with carry clear if processing is to continue
; and carry set if it not.
.proc _iter
stz WR
stz WR+2
lda XR
ora XR+2
beq done ; in case no loops requested
loop: jsl f:_callyr
bcs done
jsr _incwr
lda WR+2
cmp XR+2
bne :+
lda WR
cmp XR
: bcc loop
done: rts
.endproc
.proc _decay
cpy #$0000
bne :+
dec a
: dey
rts
.endproc
; get AY from [WR]
.proc _wrfetchind
ldy #$02
lda [WR],y
pha
lda [WR]
tay
pla
rts
.endproc
; store AY into [WR]
.proc _wrstoreind
phy
ldy #$02
sta [WR],y
pla
sta [WR]
rts
.endproc
.proc _incwr
inc WR
bne :+
inc WR+2
: rts
.endproc
.proc _decwr
lda WR
bne :+
dec WR+2
: dec WR
rts
.endproc
.proc _decxr
lda XR
bne :+
dec XR+2
: dec XR
rts
.endproc
.proc _decyr
lda YR
bne :+
dec YR+2
: dec YR
rts
.endproc
.proc _wrplus4
lda WR
clc
adc #$04
sta WR
lda WR+2
adc #$00
sta WR+2
rts
.endproc
.proc _wrminus4
lda WR
sec
sbc #$04
sta WR
lda WR+2
sbc #$00
sta WR+2
rts
.endproc
.if 0
.proc _wrplusxr
lda WR
clc
adc XR
sta WR
lda WR+2
adc XR+2
sta WR+2
rts
.endproc
.proc _wrminusxr
lda WR
sec
sbc XR
sta WR
lda WR+2
sbc XR+2
sta WR+2
rts
.endproc
.endif
; conversion helpers
; Digit to ASCII character
.proc _d_to_c
clc
adc #'0'
cmp #'9'+1
bcc :+
adc #6
: rts
.endproc
; ASCII character to digit
; return carry clear if bad
; carry set if good
.proc _c_to_d
and #$ff
jsr _cupper
sec
sbc #'0'
bmi bad
cmp #10
bcc good
sbc #7
bmi bad
cmp #10
bcc bad ; so things like < don't convert
cmp #37
bcc good
bad: clc
rts
good: sec
rts
.endproc
; Upper case a character in accumulator
.proc _cupper
cmp #'z'+1
bcs :+
cmp #'a'
bcc :+
and #$DF
: rts
.endproc
; Upper case a character, 8 bit accumulator
.a8
.proc _cupper8
and #$7F
cmp #'z'+1
bcs :+
cmp #'a'
bcc :+
and #$DF
: rts
.endproc
.a16
; With word header address in YR, set YR to previous dictionary entry header
; return with Z flag set if the new address is zero
.proc _prevword
ldy #$00
lda [YR],y ; low word
pha
iny
iny
lda [YR],y ; high word
sta YR+2
pla
sta YR
ora YR+2 ; set Z flag
rts
.endproc
; search dictionary for word at WR, length in XR, start of search (header) at YR
; if found, AY=XT and carry set, otherwise
; AY=0 and carry clear
; preserves WR, XR; YR points at the header of the last word considered
.proc _search
olp: lda YR
ora YR+2
beq notfnd
ldy #$04 ; offset of length
lda [YR],y ; get name length (we pull in two bytes)
and #NAMEMSK ; mask in significant bits
cmp XR ; compare to supplied
bne snext ; not the right word
; its the right length, compare name
lda WR+2 ; save WR
pha
lda WR
pha
phx ; save SP
sep #SHORT_A ; need to compare bytes
.a8
ldx XR ; get length to match
ldy #$05 ; offset of name
clp: lda [WR] ; char in the word we are searching for
jsr _cupper8 ; upper case it
pha ; save on stack
lda [YR],y ; compare to char in definition
jsr _cupper8 ; upper case it, too
cmp 1,s ; compare to saved
bne xsnext ; no match
pla ; drop char saved on stack
iny ; move to next char of name in def
rep #SHORT_A
jsr _incwr ; move to next char of word we are searching for
sep #SHORT_A
dex ; if X hit zero, matched it all
bne clp ; if it didn't, keep going
rep #SHORT_A ; match!
.a16
plx ; restore SP
pla
sta WR ; restore WR, in case caller needs it
pla
sta WR+2
tya ; y = 5+namelen=offset of flags=XT
clc
adc YR
tay
lda YR+2
adc #$00 ; AY=XT
sec
rts
xsnext: pla ; drop char saved on stack
rep #SHORT_A
.a16 ; good habit
plx
pla
sta WR
pla
sta WR+2
snext: jsr _prevword
bne olp
notfnd: lda #$00
tay
clc
rts
.endproc
; find word, skipping any smudged word
.proc _search_unsmudged
lp: jsr _search
bcs :+ ; if carry clear
rts ; it wasn't found anyway
: pha ; save xt
phy
lda WR+2 ; save WR
pha
lda WR
pha
lda 5,s ; put xt in WR
sta WR
lda 7,s
sta WR+2
lda [WR] ; get flags at xt address
ply ; restore WR
sty WR
ply
sty WR+2
and #F_SMUDG
beq f_ok ; not set, word is OK
pla ; otherwise drop xt from return stack
pla
jsr _prevword ; go to previous word
bne lp ; and search if more
clc ; otherwise flag not found
rts
f_ok: ply ; get XT back
pla
sec
rts
.endproc
Reference in New Issue View Git Blame Copy Permalink