OPT PRT * runtimelib FOR 6800 * Joel Matthew Rees April 2020 * Borrowing some concepts from fig-Forth. * Not tested! * ------------------------------------LICENSE------------------------------------- * * Copyright (c) 2009, 2010, 2011, 2020 Joel Matthew Rees * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to deal * in the Software without restriction, including without limitation the rights * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell * copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN * THE SOFTWARE. * * --------------------------------END-OF-LICENSE---------------------------------- * * These must be edited for target runtime: * Necessary here for forward referencing: BYTESZ EQU 8 ; bit count in byte ADRWDSZ EQU 2 ; bytes per address word * If at all possible, a CELL should be able to contain an address. * Otherwise, fetch and store become oddities. CELLSZ EQU ADRWDSZ CELLBSZ EQU (CELLSZ*BYTESZ) ; bit count in CELL DBLSZ EQU (CELLSZ*2) DBLBSZ EQU (DBLSZ*BYTESZ) ; bit count in DOUBLE GAPCT EQU 2 ; address words for the gaps ALLOGAP EQU (GAPCT*CELLSZ) ; For crude checks, gaps always zero. * Declare initial Return Stack (flow-of-control stack): RSTKBND EQU $8000 ; Bound: one beyond RSTKINI EQU (RSTKBND-1) ; Init: next available byte on 6800 RSTKSZ EQU (62*CELLSZ) ; Size: Safe for most purposes. RSTKLIM EQU (RSTKBND-RSTKSZ) ; Limit: Last useable (Ignore pre-dec.) * Kibitzing -- CPUs really should have automatic stack bounds checking. * Don't forget gaps for CPUs that don't automatically check. * Crude guard rails is better than none? * Declare initial Locals Stack (temporaries stack): LSTKBND EQU (RSTKLIM-ALLOGAP) LSTKINI EQU (LSTKBND-CELLSZ) ; Pre-dec, even on 6800, but on address word boundary. LSTKSZ EQU (30*CELLSZ) ; Size: CELL addressing, small stacks. LSTKLIM EQU (LSTKBND-LSTKSZ) * Declare initial Parameter Stack (data stack): SSTKBND EQU (LSTKLIM-ALLOGAP) SSTKINI EQU (SSTKBND-CELLSZ) ; Pre-dec, even on 6800, but on address word boundary. SSTKSZ EQU (126*CELLSZ) ; Size: CELL addressing, small stacks. SSTKLIM EQU (SSTKBND-SSTKSZ) * The paramater stack and heap at opposite ends of the same region * has mixed benefits. * The initial per-user allocation heap: UPGBND EQU (SSTKLIM-ALLOGAP) UPGSZ EQU (30*CELLSZ) ; This will need adjusting in many cases. UPGBASE EQU (UPGBND-UPGSZ) UPGINI EQU UPGBASE * ORG directives in older assemblers can get tangled up * if they are convoluted. * Keep the ORGs in ascending order. ORG $40 * Internal registers -- * (When switching contexts, these must be saved and restored.): * RP RMB ADRWDSZ ; the return/flow-of-control stack pointer is 6800 S * A software locals stack would require thrashing X, * so we'll take the unwise expedient of using the return stack. LSP RMB ADRWDSZ ; the locals stack pointer (for locals, i. e., instead of RP) PSP RMB ADRWDSZ ; the parameter/data stack pointer (Forth SP) UP RMB ADRWDSZ ; pointer to the per-task heap TEMP RMB 2*CELLSZ ; for general math GCOUNT RMB CELLSZ ; general counter IXDEST RMB ADRWDSZ ; destination index pointer IXSRC RMB ADRWDSZ ; source index pointer IXTERM RMB ADRWDSZ ; terminator for moves ORG $100 NOP COLD JMP COLDENT NOP WARM JMP WARMENT * _LOWORD_ Subtract byte in B from cell pointed to by X: * Not really all that useful when you can CLRA and SUBCELL? * SUBBYT * LDAA 1,X * SBA * STAA 1,X * BCC ADDBYTX * DEC 0,X * SUBBYTX RTS * _LOWORD_ Add byte in B to cell pointed to by X: * Not really all that useful when you can CLRA and ADDCELL? * ADDBYT * ADDB 1,X * STAB 1,X * BCC ADDBYTX * INC 0,X * ADDBYTX RTS * GETAB MACRO * LDX PSP * LDAB 1,X * LDAA 0,X * INX * INX * STX PSP * ENDM * Or doing as subroutine would would add 4 bytes and about ten cycles? * How useful would it be? * * Instead of providing such here, plan on providing funtionality later. * _WORD_ AND Take logical AND of top two on stack ( n1 n2 --- n3 ): AND LDX PSP LDAA 0,X LDAB 1,X ANDA CELLSZ,X ANDB 1+CELLSZ,X BRA STDEALL * * Stack maintenance: * * Might replace the first three instructions with * LDDACCM * LDX PSP * LDAA 0,X * LDAB 1,X * RTS * * AND * BSR LDDSUB * * But that only saves four bytes each, * at a cost of some thirteen cycles * in code that we assume will become a bottleneck. * * The number of places it would be used are less than ten, I think. * Less than 40 bytes saved. * * Tail-stealing the STDEALL code costs enough to throw that into question as it is, * but that's seven bytes saved at a cost of four cycles. * * We will assume that auto-in-lining for the 6800 will be not be in this version. * _WORD_ OR Take logical OR of top two on stack ( n1 n2 --- n3 ): OR LDX PSP LDAA 0,X LDAB 1,X ORAA CELLSZ,X ORAB 1+CELLSZ,X BRA STDEALL * _WORD_ XOR Take logical OR of top two on stack ( n1 n2 --- n3 ): XOR LDX PSP LDAA 0,X LDAB 1,X EORA CELLSZ,X EORB 1+CELLSZ,X BRA STDEALL * _WORD_ Add top two cells on stack ( n1 n2 --- sum ): ADD LDX PSP ; MACRO GETAB LDAB 1+CELLSZ,X ; n2 LDAA CELLSZ,X * Fall through: * * _LOWORD_ + Add cell in A:B to cell pointed to by X: ADDCELL ADDB 1,X ADCA 0,X * Keep rob point for storing over 2nd and deallocating top. STDEALL STAB 1+CELLSZ,X STAA CELLSZ,X INX ; deallocate INX STX PSP RTS * _WORD_ - Subtract top cell on stack from second ( n1 n2 --- difference(n1-n2) ): SUB LDX PSP ; MACRO GETAB LDAB 1+CELLSZ,X LDAA CELLSZ,X * Fall through: * * !xxx _LOWORD_ Subtract cell pointed to by 2,X from cell in A:B (not useful?): SUBCELL SUBB 1,X SBCA 0,X BRA STDEALL * STAB 1+CELLSZ,X * STAA CELLSZ,X * INX ; deallocate * INX * STX PSP * RTS * ASSERT CELLSZ == ADRWDSZ * _WORD_ B@ Fetch byte only pointed to by top cell on stack ( adr --- b(at adr) ): * (Refer to Forth's C@, but byte is not character!) BFETCH LDX PSP LDX 0,X ; adr LDAB 1,X LDX PSP CLR 0,X STAB 1,X ; Not worth robbing. RTS * _WORD_ B! Store low byte of cell at 2nd at address on top of stack, deallocate both ( n adr --- ): * (Refer to Forth's C!, but byte is not character!) BSTORE LDX PSP LDAB 1+ADRWDSZ,X ; n low byte only LDX 0,X ; adr STAB 0,X ; Store only byte, do not clear high byte! BRA DEALL2 ; Rob code to deallocate, assumes CELLSZ == ADRWDSZ. * _WORD_ @ Fetch cell pointed to by top cell on stack ( adr --- n(at adr) ): FETCH LDX PSP LDX 0,X ; adr LDAA 0,X LDAB 1,X LDX PSP STAA 0,X STAB 1,X RTS * _WORD_ ! Store cell at 2nd at address on top of stack, deallocate both ( n adr --- ): STORE LDX PSP LDAA ADRWDSZ,X ; n LDAB 1+ADRWDSZ,X LDX 0,X ; adr STAA 0,X STAB 1,X * Rob point to deallocate 2 on stack. DEALL2 LDX PSP INX ; implicit dependency on CELLSZ and ADRWDSZ INX INX INX STX PSP RTS * _WORD_ U* Unsigned multiply of top two on stack ( n1 n2 --- udproduct(n1*n2) ): USTAR LDX PSP LDAA #CELLBSZ ; bits/cell STAA 1+GCOUNT CLRA ; Clear Carry, too. CLRB USTARL ROR CELLSZ,X ; shift multiplier ROR 1+CELLSZ,X DEC 1+GCOUNT ; done? BMI USTARX BCC USTARNA ADDB 1+CELLSZ,X ADCA CELLSZ,X USTARNA RORA RORB ; shift result in BRA USTARL USTARX STAB 1,X ; store more significant 16 bits STAA 0,X RTS * _WORD_ SWAP swap top two cells on stack ( n1 n2 --- n2 n1 ): SWAP LDX PSP SWAPROB LDAA 0,X LDAB CELLSZ,X STAB 0,X STAA CELLSZ,x LDAA 1,X LDAB 1+CELLSZ,X STAB 1,X STAA 1+CELLSZ,x RTS * _WORD_ U/MOD Unsigned divide of unsigned double dividend in 2nd:3rd on stack by top unsigned divisor * ( ud u --- uremainder uquotient ) * Dividend should be range of product of 16 by 16 bit unsigned multiply, * divisor should be the multiplier or multiplicand: USLASH LDX PSP LDAA #1+CELLBSZ ; one more than bits/cell STAA 1+GCOUNT LDAA CELLSZ,X ; dividend LDAB 1+CELLSZ,X USLLUP CMPA 0,X ; divisor BHI USLSUB ; If equal, must compare low byte. BCS USLNSUB CMPB 1,X BCC USLSUB ; CC = HS (High or Same) USLNSUB CLC ; For shifting BRA USLNEXT USLSUB SUBB 1,X SBCA 0,X SEC ; For shifting USLNEXT ROL 1+2*CELLSZ,X ROL 2*CELLSZ,X DEC 1+GCOUNT BEQ USLX ROLB ROLA BCC USLLUP BRA USLSUB ; Catch the excess. USLX INX ; Drop high cell. INX STX PSP STAA 0,X ; High cell now empty, save remainder. STAB 1,X ; But remainder is now top. BRA SWAPROB ; PSP in X, reverse quotient & remainder. * Steal return. * _WORD_ >L Save top cell on stack to locals stack ( n --- ) { --- n }: TOL LDX PSP LDAA 0,X LDAB 1,X INX ; Not worth robbing code. INX STX PSP LDX LSP DEX DEX STAA 0,X ; save it STAB 1,X STX LSP RTS * _WORD_ >R Save top cell on stack to return stack ( n --- ) { --- n }: TOR LDX PSP LDAA 0,X LDAB 1,X INX ; Not worth robbing code. INX STX PSP TSX LDX 0,X ; get return address INS ; drop it INS PSHB ; Watch order! PSHA JMP 0,X * _WORD_ L> Pop top of locals stack to parameter stack ( --- n ) { n --- }: LFROM LDX LSP LDAA 0,X top cell on locals stack LDAB 1,X INX INX STX LSP LDX PSP DEX DEX STX PSP STAA 0,X ; save it before you leave STAB 1,X RTS * _WORD_ R> Pop top of return stack to parameter stack ( --- n ) { n --- }: RFROM TSX LDAA ADRWDSZ,X top cell on R stack -- dodge return address LDAB 1+ADRWDSZ,X LDX PSP DEX DEX STX PSP STAA 0,X ; save it first STAB 1,X TSX LDX 0,X ; get return address INS ; drop it INS JMP 0,X ; return * _WORD_ L Retrieve, do not pop top of locals stack to parameter stack ( --- n ) { n --- n }: L LDX LSP LDAA 0,X top cell on locals stack LDAB 1,X LDX PSP BRA DUPST * _WORD_ R Retrieve, do not pop top of return stack to parameter stack ( --- n ) { n --- n }: R TSX LDAA ADRWDSZ,X ; top cell on R stack -- dodge return address LDAB 1+ADRWDSZ,X LDX PSP ; allocate BRA DUPST * _WORD_ DUP Duplicate top cell on stack ( n --- n n ): DUP LDX PSP LDAA 0,X LDAB 1,X DUPST DEX DEX STX PSP STAA 0,X STAB 1,X RTS * _WORD_ DROP Remove a cell from the parameter stack ( n --- ) DROP LDX PSP INX INX STX PSP RTS * _WORD_ 2DROP Remove two cells from the parameter stack ( d --- ) DDROP LDX PSP INX INX INX INX STX PSP RTS * Should true be set as 1 or -1? * Going with all bits False (0) * or all bits True (-1) as the flag to set. * _WORD_ 0= Test top cell on stack for zero ( n --- f(top==0) ): ZEQU LDX PSP CLRA LDAB 0,X ORAB 1,X BNE ZEQUF COMA ZEQUF STAA 0,X STAA 1,X RTS * * True as 1 would look like * ZEQU * LDX PSP * CLRA * LDAB 0,X * ORAB 1,X * BNE ZEQUF * INCA * ZEQUF * CLR 0,X * STAA 1,X * RTS * _LOWORD_ Duplicate (count in B) bytes on stack: NDUP LDX PSP STX TEMP * _LOWORD_ Move 256 bytes or less going up: * 0=256, do not enter without pretesting for 0 count! * source in IXSRC, destination in IXDEST, count in B: * Overlaps only work if source is higher than dest. SMOVEUP BSR GMVPRM SMOVEUL LDX IXSRC LDAA 0,X INX STX IXSRC LDX IXDEST STAA 0,X INX STX IXDEST DECB BNE SMOVEUL RTS * _LOWORD_ Move 256 bytes or less going down: * 0=256, do not enter without pretesting for 0 count! * source in IXSRC, destination in IXDEST, count in B, A is overwritten: * Overlaps only work if source is higher than dest. SMOVEDN BSR GMVPRM SMOVEDL TBA ADDA 1+IXSRC STAA 1+IXSRC CLRA ; 1# 2~ -- BCC takes 2#, 4~; INC IXSRC takes 3# & 6~ ADCA IXSRC ; 2# 3~ STAA IXSRC ; 2# 4~ TBA ADDA 1+IXDEST STAA 1+IXDEST CLRA ; 1# 2~ -- BCC takes 2#, 4~; INC IXDEST takes 3# & 6~ ADCA IXDEST ; 2# 3~ STAA IXDEST ; 2# 4~ SMOVEDL LDX IXSRC DEX LDAA 0,X STX IXSRC LDX IXDEST DEX STAA 0,X STX IXDEST DECB BNE SMOVEDL RTS * _LOWORD_ Set up parameters for MOVE ( src dest count --- ) * Return without copying if count is zero or if 2^15 or more. * Make sure destination is left in A:B for math. GMVPRM LDX PSP ; get paramaters for move LDX 0,X ; count BEQ GMVPRX ; bail now if zero BMI GMVPRX ; also if greater than 32K STX GCOUNT LDX PSP LDAA CELLSZ,X ; preparing for math LDAB 1+CELLSZ,X STAA IXDEST STAB 1+IXDEST LDX CELLSZ+ADRWDSZ,X STX IXDEST RTS ; Back to MOVE that called us. * GMVPRX INS ; Drop return to MOVE code. INS BRA DEALL3 * _WORD_ Move up to 32K bytes ( src dest count --- ): * Copies zero when count >= 2^15 * Compare CMOVE in Forth. BMOVE BSR GMVPRM SUBB 1+CELLSZ+ADRWDSZ,X ; SBCA CELLSZ+ADRWDSZ,X STAB 1+TEMP STAA TEMP BCS BMOVEDN BMOVEUP ****** Working in here to make it go both ways. ****** Also need to check multiply and divide. LDX PSP LDX CELLSZ+ADRWDSZ,X STX IXSRC * SUBB LDAB 1+GCOUNT ; Get low byte for partial block CLR 1+GCOUNT ; To avoid debugging confusion. BMOVEL BSR SMOVE ; partial block and full blocks DEC GCOUNT ; count high byte down (blocks) BPL BMOVEL ; This limits the count. * Rob point to deallocate 3 on stack, as long as CELLSZ == ADRWDSZ. DEALL3 LDAB 1+PSP ; 2# 3~ ADDB #(CELLSZ+2*ADRWDSZ) ; 2# 3~ STAB 1+PSP ; 2# 4~ BCC BMOVEX ; 2# 4~ INC PSP ; 3# 6~ Unaries have no direct page version. => 11# 20~ BMOVEX RTS * DEALL3 * LDAB 1+PSP ; 2# 3~ * ADDB #(CELLSZ+2*ADRWDSZ) ; 2# 3~ * STAB 1+PSP ; 2# 4~ * LDAA PSP ; 2# 3~ * ADCA #(CELLSZ+2*ADRWDSZ) ; 2# 3~ * STAA PSP ; 2# 4~ => 12# 20~ * RTS * DEALL3 * LDX PSP ; 6 INXs is around the breakover point in the 6800. * INX ; 2 + 6 + 2 bytes => 11# * INX ; 4 + 24 + 5 cycles => 33~ * INX * INX * INX * INX * STX PSP * RTS * * _WORD_ Execute the address on the stack: EXEC LDX PSP INX INX STX PSP LDX 0,X JSR 0,X ; For debugging and flattening, no early optimizations. RTS COLDENT EQU * WARMENT EQU * LDS #RSTKINI LDX #SSTKINI STX PSP LDX #LSTKINI STX LSP LDX #UPGINI STX UP