runt6801.68c

   1         OPT PRT
   2
   3 * runtimelib FOR 6801
   4 * Joel Matthew Rees April 2020
   5
   6 * Borrowing some concepts from fig-Forth.
   7 * Not tested!
   8
   9 * ------------------------------------LICENSE-------------------------------------
  10 *
  11 * Copyright (c) 2009, 2010, 2011 Joel Matthew Rees
  12 *
  13 * Permission is hereby granted, free of charge, to any person obtaining a copy
  14 * of this software and associated documentation files (the "Software"), to deal
  15 * in the Software without restriction, including without limitation the rights
  16 * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  17 * copies of the Software, and to permit persons to whom the Software is
  18 * furnished to do so, subject to the following conditions:
  19 *
  20 * The above copyright notice and this permission notice shall be included in
  21 * all copies or substantial portions of the Software.
  22 *
  23 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  24 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  25 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  26 * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  27 * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  28 * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
  29 * THE SOFTWARE.
  30 *
  31 * --------------------------------END-OF-LICENSE----------------------------------
  32 *
  33
  34
  35 * These must be edited for target runtime:
  36
  37 * Necessary here for forward referencing:
  38
  39
  40         OPT 6801
  41
  42
  43 BYTESZ  EQU 8   ; bit count in byte
  44
  45 ADRWDSZ EQU 2   ; bytes per address word
  46
  47 * If at all possible, a CELL should be able to contain an address.
  48 * Otherwise, fetch and store become oddities.
  49 CELLSZ  EQU ADRWDSZ
  50 CELLBSZ EQU (ADRWDSZ*BYTESZ)    ; bit count in CELL
  51 DBLSZ   EQU (ADRWDSZ*2)
  52 DBLBSZ  EQU (DBLSZ*BYTESZ)      ; bit count in DOUBLE
  53
  54 GAPCT   EQU 2   ; address words for the gaps
  55 ALLOGAP EQU (GAPCT*ADRWDSZ)     ; For crude checks, gaps always zero.
  56
  57
  58 * Declare initial Return Stack (flow-of-control stack):
  59 RSTKBND EQU $8000       ; Bound: one beyond
  60 RSTKINI EQU (RSTKBND-1) ; Init: next available byte on 6800/6801
  61 RSTKSZ  EQU (62*ADRWDSZ)        ; Size: Safe for most purposes.
  62 RSTKLIM EQU (RSTKBND-RSTKSZ)    ; Limit: Last useable
  63 * Kibitzing -- CPUs really should have automatic stack bounds checking.
  64 * Don't forget gaps for CPUs that don't automatically check.
  65 * Crude guard rails is better than none?
  66
  67 * Declare initial Locals Stack (temporaries stack):
  68 LSTKBND EQU (RSTKLIM-ALLOGAP)
  69 LSTKINI EQU (LSTKBND-CELLSZ)    ; Pre-dec, even on 6801, but on address word boundary.
  70 LSTKSZ  EQU (30*CELLSZ) ; Size: CELL addressing, small stacks.
  71 LSTKLIM EQU (LSTKBND-LSTKSZ)
  72
  73 * Declare initial Parameter Stack (data stack):
  74 SSTKBND EQU (LSTKLIM-ALLOGAP)
  75 SSTKINI EQU (SSTKBND-ADRWDSZ)   ; Pre-dec, even on 6801, but on address word boundary.
  76 SSTKSZ  EQU (126*ADRWDSZ)       ; Size: CELL addressing, small stacks.
  77 SSTKLIM EQU (SSTKBND-SSTKSZ)
  78
  79 * The paramater stack and heap at opposite ends of the same region
  80 * has mixed benefits.
  81
  82 * The initial per-user allocation heap:
  83 UPGBND  EQU (SSTKLIM-ALLOGAP)
  84 UPGSZ   EQU 30*ADRWDSZ  ; This will need adjusting in many cases.
  85 UPGBASE EQU (UPGBND-UPGSZ)
  86 UPGINI  EQU UPGBASE
  87
  88
  89 * ORG directives in older assemblers can get tangled up
  90 * if they are convoluted.
  91 * Keep the ORGs in assending order.
  92
  93
  94         ORG $40
  95
  96 * Internal registers --
  97 * (When switching contexts, these must be saved and restored.):
  98
  99 * RP    RMB ADRWDSZ     ; the return/flow-of-control stack pointer is 6801 S
 100 * A software locals stack would require thrashing X,
 101 * so we'll take the unwise expedient of using the return stack.
 102 LSP     RMB ADRWDSZ     ; the locals stack pointer (for locals, i. e., instead of RP)
 103 PSP     RMB ADRWDSZ     ; the parameter/data stack pointer (Forth SP)
 104 UP      RMB ADRWDSZ     ; pointer to the per-task heap
 105 TEMP    RMB 2*CELLSZ    ; for general math
 106 GCOUNT  RMB CELLSZ      ; general counter
 107 IXDEST  RMB ADRWDSZ     ; destination index pointer
 108 IXSRC   RMB ADRWDSZ     ; source index pointer
 109 IXTERM  RMB ADRWDSZ     ; terminator for moves
 110
 111
 112
 113
 114         ORG $100
 115         NOP
 116 COLD    JMP COLDENT
 117         NOP
 118 WARM    JMP WARMENT
 119
 120
 121 * See runt6800.68c for consideration of byte operators and a GETAB routine.
 122
 123 * _WORD_ AND Take logical AND of top two on stack ( n1 n2 --- n3 ):
 124 AND
 125         LDX PSP
 126         LDD 0,X
 127         ANDA CELLSZ,X
 128         ANDB 1+CELLSZ,X
 129         BRA STDEALL
 130
 131 * See runt6800.68c for more discussion of the following.
 132 *
 133 * Stack maintenance:
 134 *
 135 * Might replace the first two instructions with
 136 * LDDACCM
 137 *       LDX PSP
 138 *       LDD 0,X
 139 *       RTS
 140 *
 141 * AND
 142 *       BSR LDDSUB
 143 *
 144 * But that only saves two bytes each,
 145 * at a cost of some eleven cycles on the 6801
 146 * in code that we assume will become a bottleneck.
 147 *
 148 * The number of places it would be used are less than ten, I think.
 149 * Less than 20 bytes saved.
 150 *
 151 * Tail-stealing the STDEALL code costs enough to throw that into question as it is,
 152 * but that's six bytes saved at a cost of three cycles.
 153 *
 154 * We will assume that auto-in-lining for the 6801 will be not be in this version.
 155
 156 * _WORD_ OR Take logical OR of top two on stack ( n1 n2 --- n3 ):
 157 OR
 158         LDX PSP
 159         LDD 0,X
 160         ORAA CELLSZ,X
 161         ORAB 1+CELLSZ,X
 162         BRA STDEALL
 163
 164 * _WORD_ XOR Take logical OR of top two on stack ( n1 n2 --- n3 ):
 165 XOR
 166         LDX PSP
 167         LDD 0,X
 168         EORA CELLSZ,X
 169         EORB 1+CELLSZ,X
 170         BRA STDEALL
 171
 172 * _WORD_ + Add top two cells on stack ( n1 n2 --- sum ):
 173 ADD
 174         LDX PSP ; MACRO GETAB
 175         LDD 0,X ; n2
 176 * Fall through:
 177 *
 178 * _LOWORD_ Add cell in A:B to cell pointed to by X:
 179 ADDCELL
 180         ADDD CELLSZ,X
 181 * Keep rob point for storing over 2nd and deallocating top.
 182 STDEALL
 183         STD CELLSZ,X
 184         INX     ; deallocate
 185         INX
 186         STX PSP
 187         RTS
 188
 189 * _WORD_ - Subtract top cell on stack from second ( n1 n2 --- difference(n1-n2) ):
 190 SUB
 191         LDX PSP ; MACRO GETAB
 192         LDD CELLSZ,X
 193 * Fall through:
 194 *
 195 * !xxx _LOWORD_ Subtract cell pointed to by CELLSZ,X from cell in A:B (not useful?):
 196 SUBCELL
 197         SUBD 0,X
 198         BRA STDEALL
 199 *       STAB 1+CELLSZ,X
 200 *       STAA CELLSZ,X
 201 *       INX     ; deallocate
 202 *       INX
 203 *       STX PSP
 204 *       RTS
 205
 206 * ASSERT CELLSZ == ADRWDSZ
 207
 208 * _WORD_ B@ Fetch byte only pointed to by top cell on stack ( adr --- b(at adr) ):
 209 * (Refer to Forth's C@, but byte is not character!)
 210 BFETCH
 211         LDX PSP
 212         LDX 0,X ; adr
 213         LDAB 1,X
 214         LDX PSP
 215         CLR 0,X
 216         STAB 1,X        ; Not worth robbing.
 217         RTS
 218
 219 * _WORD_ B! Store low byte of cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
 220 * (Refer to Forth's C!, but byte is not character!)
 221 BSTORE
 222         LDX PSP
 223         LDAB 1+ADRWDSZ,X        ; n low byte only
 224         LDX 0,X         ; adr
 225         STAB 0,X        ; Store only byte, do not clear high byte!
 226         BRA DEALL2      ; Rob code to deallocate, assumes CELLSZ == ADRWDSZ.
 227
 228 * _WORD_ @ Fetch cell pointed to by top cell on stack ( adr --- n(at adr) ):
 229 FETCH
 230         LDX PSP
 231         LDX 0,X ; adr
 232         LDD 0,X
 233         LDX PSP
 234         STD 0,X
 235         RTS
 236
 237 * _WORD_ ! Store cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
 238 STORE
 239         LDX PSP
 240         LDD ADRWDSZ,X   ; n
 241         LDX 0,X         ; adr
 242         STD 0,X
 243 * Rob point to deallocate 2 on stack.
 244 DEALL2
 245         LDD PSP
 246         ADDD #(CELLSZ+ADRWDSZ)
 247         STD PSP
 248         RTS
 249
 250 * _WORD_ U* Unsigned multiply of top two on stack ( n1 n2 --- udproduct(n1*n2) ):
 251 * USTARB
 252 *       LDX PSP
 253 *       LDAA #CELLBSZ   ; bits/cell
 254 *       STAA 1+GCOUNT
 255 *       CLRA    ; Clear Carry, too. LDD #0 does not clear carry.
 256 *       CLRB
 257 * USTARL        ROR CELLSZ,X    ; shift multiplier
 258 *       ROR 1+CELLSZ,X
 259 *       DEC 1+GCOUNT    ; done?
 260 *       BMI USTARX
 261 *       BCC USTARNA
 262 *       ADDD CELLSZ,X
 263 * USTARNA       RORA
 264 *       RORB ; shift result in
 265 *       BRA USTARL
 266 * USTARX        STD 0,X ; store more significant 16 bits
 267 *       RTS
 268
 269 * _WORD_ U* Unsigned multiply of top two on stack ( n1 n2 --- udproduct(n1*n2) )
 270 * Using 6801's MUL for speed -- more code less time:
 271 USTAR
 272         LDX PSP
 273         LDAA 1,X ; least
 274         LDAB 1+CELLSZ,X
 275         MUL
 276         STD CELLSZ+TEMP
 277         LDAA 0,X ; most
 278         LDAB CELLSZ,X
 279         MUL
 280         STD TEMP
 281         LDD 1,X inner
 282         MUL
 283         ADDD 1+TEMP
 284         BCC USTARI1
 285         INC TEMP
 286 USTARI1 STD 1+TEMP
 287         LDAA 0,X
 288         LDAB 1+CELLSZ,X
 289         MUL
 290         ADDD 1+TEMP
 291         BCC USTARI2
 292         INC TEMP
 293 USTARI2 STD 1+TEMP
 294         LDD TEMP
 295         STD 0,X
 296         LDD CELLSZ+TEMP
 297         STX CELLSZ,X
 298         RTS
 299
 300 * _WORD_ SWAP swap top two cells on stack ( n1 n2 --- n2 n1 ):
 301 * Use TEMP for speed and code size, since we're using it anyway.
 302 SWAP
 303         LDX PSP
 304 SWAPROB
 305         LDD 0,X
 306         STD TEMP
 307         LDD CELLSZ,X
 308         STD 0,X
 309         LDD TEMP
 310         STD CELLSZ,X
 311         RTS
 312 * To compare the 6800 way with (avoids TEMP):
 313 * SWAP00
 314 *       LDX PSP
 315 * SWAPROB00
 316 *       LDAA 0,X
 317 *       LDAB CELLSZ,X
 318 *       STAB 0,X
 319 *       STAA CELLSZ,x
 320 *       LDAA 1,X
 321 *       LDAB 1+CELLSZ,X
 322 *       STAB 1,X
 323 *       STAA 1+CELLSZ,x
 324 *       RTS
 325
 326 * _WORD_ U/MOD Unsigned divide of unsigned double dividend in 2nd:3rd on stack by top unsigned divisor
 327 * ( ud u --- uremainder uquotient )
 328 * Dividend should be range of product of 16 by 16 bit unsigned multiply,
 329 * divisor should be the multiplier or multiplicand:
 330 USLASH
 331         LDX PSP
 332         LDAA #1+CELLBSZ ; one more than bits/cell
 333         STAA 1+GCOUNT
 334         LDD CELLSZ,X    ; dividend
 335 USLLUP  SUBD 0,X        ; divisor
 336         BCC USLSUBD     ; CC = HS (High or Same)
 337         ADDD 0,X        ; restore
 338         CLC     ; shouldn't ever get set?
 339         BRA USLNEXT
 340 USLSUBD SEC     ; For shifting
 341 USLNEXT ROL 1+2*CELLSZ,X
 342         ROL 2*CELLSZ,X
 343         DEC 1+GCOUNT
 344         BEQ USLX
 345         ROLB    ; No, the 6801 does not have ROLD.
 346         ROLA
 347         BCC USLLUP
 348         SUBD 0,X        ; Catch the excess.
 349         BRA USLSUBD
 350 USLX    INX     ; Drop high cell.
 351         INX
 352         STX PSP
 353         STAA 0,X        ; High cell now emptu, save remainder.
 354         STAB 1,X        ; But remainder is now top.
 355         BRA SWAPROB     ; PSP in X, reverse quotient & remainder.
 356 * Steal return.
 357
 358 * _WORD_ >L Save top cell on stack to locals stack ( n --- ) { --- n }:
 359 TOL
 360         LDX PSP
 361         LDD 0,X ; top cell
 362         INX
 363         INX
 364         STX PSP
 365         LDX LSP
 366         DEX
 367         EDX
 368         STD 0,X ; top cell
 369         STX LSP
 370         RTS
 371
 372 * _WORD_ >R Save top cell on stack to return stack ( n --- ) { --- n }:
 373 TOR
 374         LDX PSP
 375         LDD 0,X ; top cell
 376         INX
 377         INX
 378         STX PSP
 379         PULX    ; Get the return address
 380         PSHB    ; Watch order!
 381         PSHA
 382         JMP 0,X ; return
 383
 384 * _WORD_ L> Pop top of parameter stack to locals stack ( --- n ) { n --- }:
 385 LFROM
 386         LDX LSP
 387         LDD 0,X top cell on locals stack
 388         INX
 389         INX
 390         STX LSP
 391         LDX PSP
 392         DEX
 393         DEX
 394         STX PSP
 395         STD 0,X ; save it
 396         RTS
 397
 398 * _WORD_ R> Pop top of locals stack to parameter stack ( --- n ) { n --- }:
 399 RFROM
 400         TSX
 401         LDD ADRWDSZ,X top cell on R stack -- dodge return address
 402         LDX PSP
 403         DEX
 404         DEX
 405         STX PSP
 406         STD 0,X ; save it first
 407         PULX    ; return address
 408         INS     ; drop top from return stack
 409         INS
 410         JMP 0,X ; return
 411
 412 * _WORD_ L Retrieve, do not pop top of locals stack to parameter stack ( --- n ) { n --- n }:
 413 L
 414         LDX LSP
 415         LDD ADRWDSZ,X top cell on locals stack
 416         LDX PSP
 417         DEX
 418         DEX
 419         STX PSP
 420         STD 0,X ; save it
 421         RTS
 422
 423 * _WORD_ R Retrieve, do not pop top of return stack to parameter stack ( --- n ) { n --- n }:
 424 R
 425         TSX
 426         LDD ADRWDSZ,X top cell on R stack -- dodge return address
 427         LDX PSP
 428         DEX
 429         DEX
 430         STX PSP
 431         STD 0,X ; save it
 432         RTS
 433
 434 * _WORD_ DUP Duplicate top cell on stack ( n --- n n ):
 435 DUP
 436         LDX PSP
 437         LDD 0,X
 438         DEX
 439         DEX
 440         STX PSP
 441         STD 0,X
 442         RTS
 443
 444 * _WORD_ DROP Remove a cell from the parameter stack ( n --- )
 445 DROP
 446         LDX PSP
 447         INX     ; LDAB #2 1 more byte, 1 less cycle
 448         INX     ; ABX same cycles
 449         STX PSP
 450         RTS
 451
 452 * _WORD_ 2DROP Remove a cell from the parameter stack ( n --- )
 453 DDROP
 454         LDX PSP
 455         LDAB #2*CELLSZ
 456         ABX
 457         STX PSP
 458         RTS
 459
 460
 461 * Should true be set as 1 or -1?
 462 * Going with all bits False (0)
 463 * or all bits True (-1) as the flag to set.
 464 * D really doesn't help here. (Compare 6800 code.)
 465 * _WORD_ 0= Test top cell on stack for zero ( n --- f(top==0) ):
 466 ZEQU
 467         LDX PSP
 468         LDD 0,X
 469         BNE ZEQUF
 470         LDD #0
 471         BRA ZEQUR
 472 ZEQUF   LDD #-1
 473 ZEQUR   STD 0,X
 474         RTS
 475 *
 476 * True as 1 is obvious.
 477
 478
 479
 480 * _LOWORD_ Duplicate (count in B) bytes on stack:
 481 NDUP
 482         LDX PSP
 483         STX TEMP
 484
 485
 486
 487 * _LOWORD_ Move 256 bytes or less, going up:
 488 * 0=256, do not enter without pretesting for 0 count!
 489 * source in IXSRC, destination in IXDEST, count in 1+GCOUNT:
 490 * Overlaps only work if source is higher than dest.
 491 SMOVEUP
 492
 493 SMOVEUE
 494         LDAB 1+GCOUNT
 495 SMOVEUL LDX IXSRC
 496         ABX
 497         LDAA 0,X
 498         LDX IXDEST
 499         ABX
 500         STAA 0,X
 501         INCB
 502         CMPB 1+GCOUNT
 503         BNE SMOVEUL
 504         RTS
 505
 506 * _LOWORD_ Move 256 bytes or less, going down:
 507 * 0=256, do not enter without pretesting for 0 count!
 508 * source in IXSRC, destination in IXDEST, count in 1+GCOUNT:
 509 * Overlaps only work if source is lower than dest.
 510 SMOVEDN
 511         LDAB 1+GCOUNT
 512         DECB    ; adjust to offset
 513 SMOVEDL LDX IXSRC
 514         ABX
 515         LDAA 0,X
 516         LDX IXDEST
 517         ABX
 518         STAA 0,X
 519         DECB
 520         BNE SMOVEDL
 521         RTS
 522
 523 * _WORD_ Move up to 32K bytes ( src dest count --- ):
 524 * Copies zero when count >= 2^15
 525 * Compare CMOVE in Forth.
 526
 527 ****** Working in here to make it go both ways.
 528 ****** Also need to check multiply and divide.
 529
 530 BMOVE
 531         LDX PSP
 532         LDD 0,X
 533         STD GCOUNT
 534         BEQ BMOVEX      ; Do nothing if zero.
 535         BMI BMOVEX      ; Do nothing if too big.
 536         LDD ADRWDSZ,X
 537         STD IXDEST
 538         LDD 2*ADRWDSZ,X
 539         STD IXSRC
 540         LDAB 1+GCOUNT   ; Get low byte for partial block.
 541         CLR 1+GCOUNT    ; To avoid debugging confusion.
 542 BMOVEL  BSR SMOVE       ; partial block and full blocks
 543         DEC GCOUNT      ; count high byte down (blocks)
 544         BPL BMOVEL ; This limits the count.
 545         LDD PSP
 546         ADDD #3*ADRWDSZ
 547         STD PSP
 548 BMOVEX  RTS
 549 * compare:
 550 *       LDX PSP
 551 *       LDB #3*ADRWDSZ  ; ADDD #3*ADRWDSZ is probably faster. Byte count is same.
 552 *       ABX
 553 *       STX PSP
 554 *
 555
 556 * _WORD_ Execute the address on the stack:
 557 EXEC
 558         LDX PSP
 559         INX
 560         INX
 561         STX PSP
 562         LDX 0,X
 563         JSR 0,X ; For debugging and flattening, no early optimizations.
 564         RTS
 565
 566
 567
 568 COLDENT EQU *
 569 WARMENT EQU *
 570         LDS #RSTKINI
 571         LDX #SSTKINI
 572         STX PSP
 573         LDX #LSTKINI
 574         STX LSP
 575         LDX #UPGINI
 576         STX UP
 577
 578
 579