One of my many back burner projects is a portable forth compiler. I started it a few years ago and after a week of staring at the inefficient code generated by C compilers for a simple LED flashing program I wondered would it be be like in Forth.
The compiler reads in the definitions of standard words from the source like this
Code:
code false
dex, dex, 1 stzzx, 2 stzzx,
end-code
-1 constant true
code lshift ( n1 n2 -- n3 )
1 ldazx,
16 cmpim,
2 ldazx,
ifeq
ifcc
tay,
whilene
3 aslzx, 4 rolzx, dey,
endw
inx, inx,
rts,
then
then
0 ldaim,
2 stazx, 3 stazx,
inx, inx,
end-code
I've defined W65C134's registers and some utility words like this:
Code:
hex
\ ==============================================================================
\ Hardware Peripheral Registers
\ ------------------------------------------------------------------------------
0000 constant PD0 inline
0001 constant PD1 inline
0002 constant PD2 inline
0003 constant PD3 inline
0004 constant PDD0 inline
0005 constant PDD1 inline
0006 constant PDD2 inline
0007 constant PCS3 inline
0008 constant IFR2 inline
0009 constant IER4 inline
000a constant TCR1 inline
000b constant TCR2 inline
000c constant T1LL inline
000d constant T1LH inline
000e constant T2LL inline
000f constant T2LH inline
0010 constant T1CL inline
0011 constant T1CH inline
0012 constant T2CL inline
0013 constant T2CH inline
0014 constant STATE inline
0015 constant SR0 inline
0016 constant SR1 inline
0017 constant SR2 inline
0018 constant SR3 inline
0019 constant SCSR inline
001a constant BAR inline
001b constant BCR inline
001c constant PD4 inline
001d constant PD5 inline
001e constant PDD4 inline
001f constant PDD5 inline
0020 constant PD6 inline
0021 constant PDD6 inline
0022 constant ACSR inline
0023 constant ARTD inline
0024 constant TALL inline
0025 constant TALH inline
0026 constant TACL inline
0027 constant TACH inline
0028 constant TMLL inline
0029 constant TMLH inline
002a constant TMCL inline
002b constant TMCH inline
002c constant IFR1 inline
002d constant IER1 inline
\ ------------------------------------------------------------------------------
: INPUT ( -- pin-mode )
false
; inline
: OUTPUT ( -- pin-mode )
true
; inline
: LO ( -- pin-state )
false
; inline
: HI ( -- pin-state )
true
; inline
\ ==============================================================================
\ Pin Abstractions
\ ------------------------------------------------------------------------------
: pin50 ( -- pin-spec )
PDD5 PD5 1 0 lshift
;
: pin51 ( -- pin-spec )
PDD5 PD5 1 1 lshift
;
\ ------------------------------------------------------------------------------
code pinSetMode ( pin-spec pin-mode -- )
1 ldazx, 3 eorix, 7 andzx, 3 eorix, 3 staix,
txa, clc, 8 adcim, tax,
end-code
code pinSetState ( pin-spec pin-state -- )
1 ldazx, 5 eorix, 7 andzx, 5 eorix, 5 staix,
txa, clc, 8 adcim, tax,
end-code
And I have a simple test program like this
Code:
: led-pin ( -- pin-spec )
pin50
; inline
: boot ( -- )
led-pin OUTPUT pinSetMode
begin
led-pin HI pinSetState
led-pin LO pinSetState
again
; external
The compiler inlines words where directed and optimises both at the forth (e.g. 1 0 lshift in pin50 has become 1) and assembly levels. It only generates referenced words and internal functions (like __test which is used by IF). The result is this:
Code:
;===============================================================================
; forthcc W65C02 [20.06] -- Generated Code - Do not edit.
;-------------------------------------------------------------------------------
.65C02
.code
__test: ; code __test
00:0000' B501 : lda <1,x
00:0002' 1502 : ora <2,x
00:0004' E8 : inx
00:0005' E8 : inx
00:0006' A8 : tay
00:0007' 60 : rts ; end-code
.code
lshift: ; code lshift
00:0008' B501 : lda <1,x
00:000A' C910 : cmp #16
00:000C' B502 : lda <2,x
00:000E' D00F : if eq ; ifeq
00:0010' B00D : if cc ; ifcc
00:0012' A8 : tay
00:0013' F007 : .L1: beq .L2 ; whilene
00:0015' 1603 : asl <3,x
00:0017' 3604 : rol <4,x
00:0019' 88 : dey
00:001A' 80F7 : jpa .L1 ; endw
00:001C' E8 : .L2: inx
00:001D' E8 : inx
00:001E' 60 : rts
endif ; then
endif ; then
00:001F' A900 : lda #0
00:0021' 9502 : sta <2,x
00:0023' 9503 : sta <3,x
00:0025' E8 : inx
00:0026' E8 : inx
00:0027' 60 : rts ; end-code
.code
true: ; : true
00:0028' A9FF : lda #<-1 ; -1
00:002A' A8 : tay
00:002B' 802B : jpa __push ; ;
.code
pin50: ; : pin50
00:002D' A91F : lda #<31 ; 31
00:002F' A000 : ldy #>31
00:0031' 20???? : jsr __push
00:0034' A91D : lda #<29 ; 29
00:0036' A000 : ldy #>29
00:0038' 20???? : jsr __push
00:003B' A901 : lda #<1 ; 1
00:003D' A000 : ldy #>1
00:003F' 8017 : jpa __push ; ;
.code
false: ; code false
00:0041' CA : dex
00:0042' CA : dex
00:0043' 7401 : stz <1,x
00:0045' 7402 : stz <2,x
00:0047' 60 : rts ; end-code
.code
pinSetState: ; code pinSetState
00:0048' B501 : lda <1,x
00:004A' 4105 : eor (5,x)
00:004C' 3507 : and <7,x
00:004E' 4105 : eor (5,x)
00:0050' 8105 : sta (5,x)
00:0052' 8A : txa
00:0053' 18 : clc
00:0054' 6908 : adc #8
00:0056' AA : tax
00:0057' 60 : rts ; end-code
.code
__push: ; code __push
00:0058' CA : dex
00:0059' CA : dex
00:005A' 9501 : sta <1,x
00:005C' 9402 : sty <2,x
00:005E' 60 : rts ; end-code
.code
__pull: ; code __pull
00:005F' B501 : lda <1,x
00:0061' B402 : ldy <2,x
00:0063' E8 : inx
00:0064' E8 : inx
00:0065' 60 : rts ; end-code
.code
.global boot
boot: ; : boot
00:0066' 20???? : jsr pin50 ; pin50
00:0069' 20???? : jsr true ; true
00:006C' 20???? : jsr pinSetMode ; pinSetMode
00:006F' 20???? : .L5: jsr pin50 ; pin50
00:0072' 20???? : jsr true ; true
00:0075' 20???? : jsr pinSetState ; pinSetState
00:0078' 20???? : jsr pin50 ; pin50
00:007B' 20???? : jsr false ; false
00:007E' 20???? : jsr pinSetState ; pinSetState
00:0081' 80EC : jpa .L5 ; (branch) ;
.code
pinSetMode: ; code pinSetMode
00:0083' B501 : lda <1,x
00:0085' 4103 : eor (3,x)
00:0087' 3507 : and <7,x
00:0089' 4103 : eor (3,x)
00:008B' 8103 : sta (3,x)
00:008D' 8A : txa
00:008E' 18 : clc
00:008F' 6908 : adc #8
00:0091' AA : tax
00:0092' 60 : rts ; end-code
.end
It needs to be linked with a small routine to setup the hardware and forth stack pointers (X) before I can run it.
Login
Register
FAQ
Search
