ftp.barnyard.co.uk

home *** CD-ROM | disk | FTP | other *** search

/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / BEEHIVE / OS / SUPER8.ARC / FORTH.S8 next >

Wrap

Text File | 1990-09-21 | 8KB | 446 lines

;-------------------------------------------------------- ; FORTH for the Super8 ; jdw 2/87 ; ; Working register assignment: ; ; rr0 datastack ; rr2 registered top of stack ; rr4 temp, SP on task switch ; rr6 temp ; ; rr8 registered DO index ; rr10 registered DO terminal count ; rr12 registered LOOP jp address ; rr14 user base ;---------------------------------------------------------------- ; Multi-tasking: ; ; A task's context is contained in 16 working registers. Changing ; RP0 & RP1 effects a context switch. Tasks use consecutive 16 byte ; register sets starting at 0. The register <tskptr> points to the ; highest set in use (0 for one task). Reserving 16 bytes for system ; registers (such as tskptr), a maximum of 15 tasks could run. ; ; Note that killing off a task other than the last requires that the ; registers used by the last task be copied into the task to be killed. ; A new task is always added at <tskptr+16> ; ; It is not decided how much gain there would be in registering ; a few more things, such as do loop index and count. ;----------------------------------------------------------------- ; Note: monitor uses $FB00-$FFFF and reg $80-$B9 ;----------------------------------------------------------------- ; Note: in register pairs, the low register is the high byte! ; I.E. top of stack, r2= high, r3 = low. The same is true for ; memory organization! ; org $C000 flgs equ $C300 tskptr equ $7F ; higest task register ukey? equ 0 ; user variables ukey equ 2 uemit equ 4 test: sb0 ld emt,#%00000011 ; 1 wait, data stack, data dma srp #0 ; set up RP0 and RP1 ldw rr0,#$F800 ; set up dstack ldw sp,#$F000 ldw rr2,#0 ;--------------------------------------------------- ; Sieve benchmark, 6.81s/10 iterations size equ 8190 enter ; brenchmark starts here dw adotq .ascil "start\n" dw lit,10 dw zero dw do dw prime dw loop dw adotq .ascil "stop\n" dw pbrk pbrk: jr $ nop prime: enter ; sieve benchmark dw lit,flgs dw lit,size dw one dw fill dw zero dw lit,size dw zero dw do dw ficf,prime1 ; FLAGS I + C@ IF dw op1 ; i dup plus 3 + dup i + dw begin dw op2,prime2 ; WHILE dw caf ; 0 over flags + c! dw over, plus dw again prime2: dw xwhile dw ddrop dw onep prime1: dw loop dw exit ; Sieve benchmark primitive, FLAGS I + C@ IF ficf: lde r4,flgs(rr8) ; 20 get the flag btjrt ficf1,r4,#0 ; 10/12 if the flag was = 1, do not jump ldw rr4,ip lde r6,@rr4 lde r7,1(rr4) ldw ip,rr6 next ficf1: incw ip ; 10 incw ip next ; 14 caf: ; same as 0 over flgs + c! ; stack: (index--index) ld r4,#0 ldc flgs(rr2),r4 ; clear it next op1: ; i dup + 3 + dup i + ; ( --2i+3,3i+3) ldepd @rr0,r3 ; push tos ldepd @rr0,r2 ldw rr2,rr8 ; I add r3,r9 adc r2,r8 ; 2I add r3,#3 adc r2,#0 ; 2I+3 ldepd @rr0,r3 ; push 2I+3 ldepd @rr0,r2 add r3,r9 adc r2,r8 ; 3I+3 next ;---------- op2: ; dup size less if ldw rr4,rr2 sub r5,#^LB size sbc r4,#^HB size jp pl,branch ; if tos >= size, take branch incw IP incw IP next ;-------------------------------------------------- ZERO: ldepd @rr0,r3 ; 46 clocks ldepd @rr0,r2 ldw rr2,#0 next ONE: ldepd @rr0,r3 ; 46 clocks ldepd @rr0,r2 ldw rr2,#1 next ONEP: incw rr2 ; 26 next TWO: ldepd @rr0,r3 ldepd @rr0,r2 ldw rr2,#2 next THREE: ldepd @rr0,r3 ldepd @rr0,r2 ldw rr2,#3 next ;------------------------------------------ LESS: ldei r4,@rr0 ldei r5,@rr0 sub r5,r3 sbc r4,r2 ; rr4-rr2 ldw rr2,#0 jr pl,next ; if tos (rr2) > nos, return false inc r3 ; else true next: next ADOTQ: enter ; <."> print imbeded string dw RAT dw COUNT dw DUP dw ONEP dw FROMR dw PLUS dw TOR dw TYPE dw EXIT C!: incw rr0 ; address = rr2 ldei r5,@rr0 ; get data lde @rr2,r5 ; stash byte ldei r2,@rr0 ldei r3,@rr0 next C@: lde r3,@rr2 clr r2 next CMOVE: ldei r4,@rr0 ; count in RR2 ldei r5,@rr0 ; des to rr4 ldei r6,@rr0 ldei r7,@rr0 ; src to rr6 incw rr2 decw rr2 jr z,cmove1 ; if count = 0 push r0 cmv1: ldei r0,@rr6 ; read 1 byte lde @rr4,r0 ; write 1 byte incw rr4 decw rr2 jr nz,cmv1 pop r0 cmove1: ldei r2,@rr0 ; 46 clocks ldei r3,@rr0 ; low byte next COUNT: ldei r4,@rr2 ; count byte ldepd @rr0,r3 ldepd @rr0,r2 ld r3,r4 clr r2 next DDROP: incw rr0 incw rr0 DROP: ldei r2,@rr0 ; 46 clocks ldei r3,@rr0 ; low byte next DUP: ldepd @rr0,r3 ; 46 clocks ldepd @rr0,r2 next FILL: ldei r4,@rr0 ; character in RR2 (r3) ldei r5,@rr0 ; count to rr4 ldei r6,@rr0 ldei r7,@rr0 ; src to rr6 incw rr4 decw rr4 jr z,FL1 ; if count = 0 FL2: lde @rr6,r3 ; write 1 byte incw rr6 decw rr4 jr nz,FL2 FL1: ldei r2,@rr0 ldei r3,@rr0 next EXIT: exit PLUS: ldei r4,@rr0 ; 58 ldei r5,@rr0 add r3,r5 adc r2,r4 next OVER: ldepd @rr0,r3 ldepd @rr0,r2 lde r2,2(rr0) lde r3,3(rr0) next RAT: ldepd @rr0,r3 ; R@ ldepd @rr0,r2 ldw rr4,sp ldei r2,@rr4 lde r3,@rr4 next FROMR: ldepd @rr0,r3 ; R> ldepd @rr0,r2 pop r2 pop r3 next TOR: push r3 ; >R push r2 ldei r2,@rr0 ldei r3,@rr0 next SWAP: lde r4,@rr0 lde r5,1(rr0) lde @rr0,r2 lde 1(rr0),r3 ld r2,r4 ld r3,r5 next TYPE: enter dw zero dw do dw dup dw c@ dw emit dw onep dw loop dw drop dw exit ;--------------------------------- ; Do loop, registered I ; ; 5.0 us (9.0 every 256'th) ; loop + i = 10.6 ; do: push r13 push r12 push r11 push r10 push r9 ; save old loop registers push r8 ldw rr12,ip ; branch address to rr12 ldw rr8,rr2 ; index to rr8 ldei r10,@rr0 ldei r11,@rr0 ; TC to rr10 ldei r2,@rr0 ; refresh tos ldei r3,@rr0 next loop: incw rr8 ; 10 bump I cp r9,r11 ; 6 jr z,lp1 ; 10 ldw ip,rr12 ; 10 next ; 14 lp1: cp r8,r10 ; 6 jr z,lp2 ; 10 ldw ip,rr12 ; 10 next ; 14 lp2: pop r8 pop r9 pop r10 ; restore loop registers pop r11 pop r12 pop r13 next ;-------------------------------------- ; Registered I, 5.6 us i: ldepd @rr0,r3 ; 16 ; push tos ldepd @rr0,r2 ; 16 ldw rr2,rr8 ; 10 next ; 14 ;------------------------------------ dovar: ; called version, 7.4us ; CALL is 18 ldepd @rr0,r3 ; 16 ; push tos ldepd @rr0,r2 ; 16 ldw rr2,@SP ; 10 next ; 14 ;-------------------------------------------------------- emit: tm utc,#2 ; transmit buffer empty yet? jr z,emit ; if not, wait until it is ld uio,r3 ; load the character into the transmitter ldei r2,@rr0 ; get new TOS ldei r3,@rr0 ; low byte next key: tm urc,#1 ; character available? jr z,key ; if not, wait until it is ldepd @rr0,r3 ; push old tos ldepd @rr0,r2 ld r3,uio ; the character cp r3,#4 jp z,$20 ; control D abort clr r2 next clit: ldepd @rr0,r3 ; Imbeded byte literal ldepd @rr0,r2 ldw rr4,ip lde r3,@rr4 ; low byte clr r2 incw ip next lit: ldepd @rr0,r3 ; Imbeded literal ldepd @rr0,r2 ldw rr4,ip ldei r2,@rr4 ; hi byte ldei r3,@rr4 ; low byte ldw ip,rr4 next branch: ldw rr4,ip lde r6,@rr4 lde r7,1(rr4) ldw ip,rr6 next zbran: or r2,r3 ; test for zero ldei r2,@rr0 ; pop tos ldei r3,@rr0 jr nz,skip ldw rr4,ip ; take the branch lde r6,@rr4 lde r7,1(rr4) ldw ip,rr6 next skip: incw ip incw ip next begin: push r12 push r13 ldw rr12,ip next again: ldw ip,rr12 next xwhile: pop r13 pop r12 next .xlist PAUSE: push ipl ; push IP onto RSTACK push iph ldw rr4,SP sub rp1,#8 ; 16 byte context model sub rp0,#8 jr nc,pause1 ld rp0,tskptr add rp1,tskptr pause1: ldw SP,rr4 pop iph pop ipl next ;------------------------------------------------------------------- end