runt68000.ask

   1         LIST
   2
   3 * runtimelib FOR 68000
   4 * Joel Matthew Rees April 2020
   5
   6 * Borrowing some concepts from fig-Forth.
   7 * Purely theoretical, 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 fake forward referencing:
  38
  39
  40 KERNLIB SECTION.S 0
  41
  42
  43 BYTESZ  EQU 8   ; bit count in byte
  44
  45 * I may want to explore non-linear addressing in the 68000
  46 * (and apply it to the 6805) once the basic interpreter is done
  47 * in the natural 32-bit CELL.
  48
  49 ADRWDSZ EQU 4   ; bytes per address word
  50 ADRWREM EQU (ADRWDSZ-1) ; for masking in address-odd remainder bits
  51 ADRWMSK EQU ((-ADRWREM)-1)      ; for masking out odd parts of addresses (manual bit invert)
  52
  53 HALFSZ  EQU 2
  54 HALFBSZ EQU (HALFSZ*2)          ; bit count in half-CELL
  55 * If at all possible, a CELL should be able to contain an address.
  56 * Otherwise, fetch and store become oddities.
  57 CELLSZ  EQU ADRWDSZ
  58 CELLBSZ EQU (ADRWDSZ*BYTESZ)    ; bit count in CELL
  59 DBLSZ   EQU (ADRWDSZ*2)
  60 DBLBSZ  EQU (DBLSZ*BYTESZ)      ; bit count in DOUBLE
  61
  62 GAPCT   EQU 2   ; address words for the gaps
  63 ALLOGAP EQU (GAPCT*ADRWDSZ)     ; For crude checks, gaps always zero.
  64
  65
  66 * Declare initial Return Stack (flow-of-control stack):
  67 RSTKBND EQU ($8000-ADRWDSZ      ; Bound: one beyond, but avoiding wraparound
  68 RSTKINI EQU (RSTKBND)   ; Init: next available byte on 68000 -- pre-dec
  69 RSTKSZ  EQU (62*ADRWDSZ)        ; Size: Safe for most purposes.
  70 RSTKLIM EQU (RSTKBND-RSTKSZ)    ; Limit: Last useable
  71 * Kibitzing -- CPUs really should have automatic stack bounds checking.
  72 * Don't forget gaps for CPUs that don't automatically check.
  73 * Crude guard rails is better than none?
  74
  75 * Declare initial Locals Stack (temporaries stack):
  76 LSTKBND EQU (RSTKLIM-ALLOGAP)
  77 LSTKINI EQU (LSTKBND-CELLSZ)    ; Pre-dec, but on address word boundary.
  78 LSTKSZ  EQU (30*CELLSZ) ; Size: CELL addressing, small stacks.
  79 LSTKLIM EQU (LSTKBND-LSTKSZ)
  80
  81 * Declare initial Parameter Stack (data stack):
  82 SSTKBND EQU (LSTKLIM-ALLOGAP)
  83 SSTKINI EQU (SSTKBND)   ; Also pre-dec, but on address word boundary.
  84 SSTKSZ  EQU (126*ADRWDSZ)       ; Size: CELL addressing, small stacks.
  85 SSTKLIM EQU (SSTKBND-SSTKSZ)
  86
  87 * The paramater stack and heap at opposite ends of the same region
  88 * has mixed benefits.
  89
  90 * The initial per-user allocation heap:
  91 UPGBND  EQU (SSTKLIM-ALLOGAP)
  92 UPGSZ   EQU 30*ADRWDSZ  ; This will need adjusting in many cases.
  93 UPGBASE EQU (UPGBND-UPGSZ)
  94 UPGINI  EQU UPGBASE
  95
  96
  97 * On 6809, BRN is being inserted at the top of routines
  98 * with an offset to the end, to mark what can be pulled in
  99 * for blind in-lining.
 100 *
 101 * But I'm not sure I'm actually going to use it.
 102
 103
 104 * ORG directives in older assemblers can get tangled up
 105 * if they are convoluted.
 106 * Keep the ORGs in assending order.
 107
 108
 109 * Check DP handling!
 110         ORG.S $40
 111
 112 * Internal registers --
 113 * (When switching contexts, these must be saved and restored.):
 114
 115 * RP    RMB ADRWDSZ
 116 *                       A7/SP == RP, the return/flow-of-control stack on 68000
 117 *
 118 * PSP   RMB ADRWDSZ
 119 *                       A6 == PSP, the parameter/data stack pointer on 68000
 120 * UP    RMB ADRWDSZ
 121 *                       A5 == UP, the pointer to the per-task heap on 68000
 122 * LP    RMB ADRWDSZ
 123 *                       A4 == LSP, optional local stack pointer on 68000
 124 * TEMP  RMB 2*ADRWDSZ
 125 *                       all temps not in registers are allocated locally
 126 *                       -- on RP/A7, PSP/A6, UP/A5, or possibly LSP/A4
 127 * GCOUNT        RMB ADRWDSZ
 128 *                       general counter allocated in any free Dn
 129 * IXDEST        RMB ADRWDSZ
 130 *                       destination index pointer as any free An (A0 .. A3)
 131 * IXSRC RMB ADRWDSZ
 132 *                       source index pointer as any free An (A0 .. A3)
 133
 134
 135 ***    D0 to D3, A0, and A1 are throwaway or return values
 136 * and should be saved by the caller before calls when necessary;
 137 * maybe be used freely in called routines.
 138
 139 ***    D4 to D7, A2, A3, and maybe A4 are persistent or parameters
 140 * and should be saved before being used in called routines.
 141
 142
 143         ORG.S $100
 144         NOP
 145 COLD    JMP.S COLDENT
 146         NOP
 147 WARM    JMP.S WARMENT
 148
 149
 150 * Definitions which are good candidates for direct substitution instead of call
 151 * might be marked by something like
 152 *
 153 *       DC.B CODE_ST-*
 154 *       DC.B CODE_END-*
 155 * CODE
 156 *       CODE ...        ; not needed in substitution
 157 * CODE_ST
 158 *       CODE ...        ; code which gets substituted instead of call
 159 * CODE_END
 160 *       CODE ...        ; not needed in substitution
 161 *       RTS     ; or whatever
 162 * to bracket the substitution for the interpreter/compiler.
 163 *
 164 * This would be part of the _WORD_ macro.
 165
 166
 167 * _WORD_ Take logical AND of top two on stack ( n1 n2 --- n3 ):
 168 AND
 169         MOVE.L ADRWDSZ(A6),D3
 170         AND.L (A6)+,D3
 171         MOVE.l D0,(A6)
 172         RTS
 173
 174 * _WORD_ Take logical OR of top two on stack ( n1 n2 --- n3 ):
 175 OR
 176         MOVE.L ADRWDSZ(A6),D3
 177         OR.L (A6)+,D3
 178         MOVE.l D0,(A6)
 179         RTS
 180
 181 * _WORD_ Take logical OR of top two on stack ( n1 n2 --- n3 ):
 182 XOR
 183         MOVE.L ADRWDSZ(A6),D3
 184         EOR.L (A6)+,D3
 185         MOVE.l D0,(A6)
 186         RTS
 187
 188 * _WORD_ + Add top two cells on stack ( n1 n2 --- sum ):
 189 ADD
 190         MOVE.L ADRWDSZ(A6),D3
 191         ADD.L (A6)+,D3
 192         MOVE.l D0,(A6)
 193         RTS
 194
 195 * _WORD_ - Subtract top cell on stack from second ( n1 n2 --- difference(n1-n2) ):
 196 SUB
 197         MOVE.L ADRWDSZ(A6),D3
 198         SUB.L (A6)+,D3
 199         MOVE.l D0,(A6)
 200         RTS
 201
 202 * _WORD_ B@ Fetch byte only pointed to by top cell on stack ( adr --- b(at adr) ):
 203 * (Refer to Forth's C@, but byte is not character!)
 204 BFETCH
 205         MOVE.L (A6),A1
 206         CLR.L D3
 207         MOVE.B (A1),D3
 208         MOVE.L D3,(A6)
 209         RTS
 210
 211 * _WORD_ B! Store low byte of cell at 2nd at address on top of stack, deallocate both ( b adr --- ):
 212 * (Refer to Forth's C!, but byte is not character!)
 213 BSTORE
 214         MOVE.L (A6)+,A1
 215         MOVE.L (A6)+,D3 ; Get whole cell instead of pre-clearing.
 216         MOVE.B D3,(A1)  ; Store only byte, do not clear high bytes!
 217         RTS
 218
 219 * _WORD_ S@ Fetch half-cell only pointed to by top cell on stack ( adr --- h(at adr) ):
 220 * adr must be even address aligned on many 68K.
 221 SFETCH
 222         MOVE.L (A6),A1
 223         CLR.L D3
 224         MOVE.W (A1),D3
 225         MOVE.L D3,(A6)
 226         RTS
 227
 228 * _WORD_ S! Store half-cell at 2nd at address on top of stack, deallocate both ( h adr --- ):
 229 * adr must be even address aligned on many 68K.
 230 SSTORE
 231         MOVE.L (A6)+,A1
 232         MOVE.L (A6)+,D3 ; Get whole cell from stack instead of pre-clearing.
 233         MOVE.W D3,(A1)  ; Store only half-cell, do not clear high half!
 234         RTS
 235
 236 * _WORD_ @ Fetch cell pointed to by top cell on stack ( adr --- n(at adr) ):
 237 * adr must be even address aligned on many 68K.
 238 FETCH
 239         MOVE.L (A6).A1
 240         MOVE.L (A1),D3
 241         MOVE.L D3,(A6)
 242         RTS
 243
 244 * _WORD_ ! Store cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
 245 * adr must be even address aligned on many 68K.
 246 STORE
 247         MOVE.L (A6)+,A1
 248         MOVE.L (A6)+,D3
 249         MOVE.L D3,(A1)
 250         RTS
 251
 252 * Low confidence in the multiply and divide without an emulator to check.
 253
 254 * u1  h1:l1 ADRWDSZ:HALFSZ+ADRWDSZ
 255 * u2  h2:l2               0:HALFSZ
 256 *
 257 * _WORD_ U*bit Unsigned multiply of top two on stack ( u1 u2 --- udproduct(n1*n2) ):
 258 * Consider bit test instead of shift?
 259 USTARB
 260         MOVEQ #CELLBSZ,D0       ; bits/cell -- maybe count is one less for DBcc?
 261         MOVEQ #0,D2     ; Clears carry, not extend
 262         MOVE.L ADRWDSZ(A6),D3   ; multiplicand
 263         MOVE.L (A6),D1  ; multiplier
 264 USTARL
 265         ROXR.L D3
 266         DBF D0,USTART   ; done? hits both carry and extend!
 267         BRA.B USTARX
 268 USTART
 269         BCC.B USTARNA
 270         ADD.L ADRWDSZ(A6),D2
 271 USTARNA RORX.L D2       ; shift result in
 272         BRA USTARL
 273 USTARX  MOVEM.L D2/D3,(A6)      ; Store result.
 274         RTS
 275
 276 * u1  h1:l1 ADRWDSZ:HALFSZ+ADRWDSZ
 277 * u2  h2:l2               0:HALFSZ
 278 *
 279 * _WORD_ U* Unsigned multiply of top two on stack ( u1 u2 --- udproduct(n1*n2) )
 280 * Using 68000's MUL for speed.
 281 * More code, less time, but I need to check that I'm handling the halves right:
 282 USTAR
 283         MOVEQ #0 D1     ; Scratch area for inner products
 284         MOVEQ #0 D0
 285 *
 286         MOVE.W HALFSZ+ADRWDSZ(A6),D3    ; low halves
 287         MULU HALFSZ(A6),D3
 288 * max: $FFFE0001
 289 *
 290         MOVE.W ADRWDSZ(A6),D2   ; inner1: u1 high
 291         MULU HALFSZ(A6),D2      ; u2 low
 292 * max: $FFFE0001
 293 *
 294         MOVE.W D2,D1    ; lower half of inner1
 295         ADD.L D1,D3     ; No carry possible yet.
 296 * bound: $FFFE0001+$0000FFFF=$FFFF0000
 297 *
 298         SWAP D2
 299         MOVE.W D2,D1    ; higher half of inner1, hold it.
 300 *
 301         MOVE.W HALFSZ+ADRWDSZ(A6),D2    ; inner2: u1 low
 302         MULU (A6),D2    ; u2 high
 303 * max: $FFFE0001
 304 *
 305         MOVE.W D2,D0    ; lower half of inner2
 306         ADD.L D0,D3     ; Still no carry possible.
 307 * bound: $FFFF0000+$0000FFFF=$FFFFFFFF
 308         SWAP D2
 309         MOVE.W D2,D0    ; higher half of inner2
 310         ADD.L D0,D1     ; add to inner1 higher half
 311 * bound: $0000FFFF+$0000FFFF=$0001FFFE
 312         MOVE.W ADRWDSZ(A6),D2   ; high halves
 313         MULU (A6),D2
 314 * max $FFFE0001
 315         ADD.L D1,D2
 316 * bound: $FFFE0001+$0001FFFE=$FFFFFFFF
 317 * Done, result in D2:D3
 318         MOVEM.L D2/D3,(A6)
 319         RTS
 320
 321 * _WORD_ SWAP swap top two cells on stack ( n1 n2 --- n2 n1 ):
 322 SWAP
 323         MOVEM.L (A6),D2/D3
 324         EXG D2,D3
 325         MOVEM.L D2/D3,(A6)
 326         RTS
 327 * As opposed to
 328 *       MOVEM.L (A6),D2/D3
 329 *       MOVE.L D2,(ADRWDSZ,A6)
 330 *       MOVE.L D3,(A6)
 331 * Which will be smaller, faster, less bus activity?
 332
 333
 334 * _WORD_ U/MODbit Unsigned divide of unsigned double dividend in 2nd:3rd on stack by top unsigned divisor
 335 * ( ud u --- uremainder uquotient )
 336 * Dividend should be range of product of 16 by 16 bit unsigned multiply,
 337 * divisor should be the multiplier or multiplicand:
 338 * Consider bit test instead of shift?
 339 * Also, examine the native divide again.
 340 * ** Native divide requires divide-by-zero trap code!
 341 USLASHB
 342         MOVEQ #1+CELLBSZ,D0     ; bit ct
 343         MOVEM.L (A6),D3/D2/D1   ; D1 is divisor, D2:D3 is dividend
 344 USLDIV
 345         CMP.L D1,D2     ; dividend high in D2 - divisor in D1
 346         BHS.B USLSUB    ; *** need to look at this carefully
 347         ANDI #^1,CCR    ; clear carry bit
 348         BRA.B USLBIT
 349 USLSUB
 350         SUB.L D1,D2
 351         ORI #1,CCR      ; quotient bit,
 352 USLBIT
 353         ROXL.L D3       ; save it
 354         SUBQ #1,D0      ; more bits?
 355         BEQ.B USLR      ; Can DBcc be used here?
 356         ROXL.L D2       ; move remainder in as we move dividend out
 357         BCC USLDIV
 358         BRA USLSUB
 359 USLR
 360         LEA ADRWDSZ(A6),A6
 361         MOVE.L D3,(A6)          ; quotient
 362         MOVE.L D2,ADRWDSZ(A6)   ; remainder
 363         RTS
 364
 365 * _WORD_ >L Save top cell on stack to locals stack ( n --- ) { --- n }:
 366 TOL
 367         MOVE.L (A4)+,-(A6)
 368         RTS
 369
 370 * _WORD_ >R Save top cell on stack to return stack ( n --- ) { --- n }:
 371 TOR
 372         MOVE.L (A7),A1
 373         MOVE.L (A6)+,(A7)
 374         JMP (A1)
 375 * In-lining:
 376 TOR_ST
 377         MOVE.L (A6)+,-(A7)
 378 TOR_END
 379
 380 * _WORD_ L> Pop top of locals stack to parameter stack ( --- n ) { n --- }:
 381 LFROM
 382         MOVE.L (A4)+,-(a6)
 383         RTS
 384
 385 * _WORD_ R> Pop top of return stack to parameter stack ( --- n ) { n --- }:
 386 RFROM
 387         MOVEM.L (A7)+,A1/A0
 388         MOVE.L A1,-(A6)
 389         JMP (A0)
 390 *
 391 * In-lining:
 392 RFROM_ST
 393         MOVEM.L (A7)+,-(A6)
 394 RFROM_END
 395
 396 * _WORD_ L Retrieve, do not pop top of locals stack to parameter stack ( --- n ) { n --- n }:
 397 L
 398         MOVE.L (A4),-(a6)
 399         RTS
 400
 401 * _WORD_ R Retrieve, do not pop top of return stack to parameter stack ( --- n ) { n --- n }:
 402 R
 403         MOVE.L ADRWDSZ(A7),-(A6)
 404         RTS
 405 * In-lining:
 406 R_ST
 407         MOVE.L (A7),-(A6)
 408 R_END
 409
 410 * _WORD_ DUP Duplicate top cell on stack ( n --- n n ):
 411 DUP
 412         MOVE.l (A6),-(A6)
 413         RTS
 414
 415 * _WORD_ DROP Remove a cell from the parameter stack ( n --- )
 416 DROP
 417         LEA CELLSZ(A7),A7       ; or PULU D and throw away
 418         RTS
 419
 420 * _WORD_ 2DROP Remove a cell from the parameter stack ( n --- )
 421 DDROP
 422         LEAU 2*CELLSZ(A7),U     ; or PULU D,X and throw away
 423         RTS
 424
 425 * Should true be set as 1 or -1?
 426 * Going with all bits False (0)
 427 * or all bits True (-1) as the flag to set.
 428 * _WORD_ 0= Test top cell on stack for zero ( n --- f(top==0) ):
 429 ZEQU
 430         MOVE.L (A7),D0
 431         SNE DO
 432         COM.B D0
 433         EXT.W D0        ; CPU32 can EXTB.L
 434         EXT.L D0
 435         MOVE.L D0,(A7)
 436         RTS
 437 *
 438 * ZEQUB
 439 *       MOVE.L (A7),D0
 440 *       BNE ZEQUBF
 441 *       CLR (A7)
 442 *       BRA ZEQUBR
 443 * ZEQUBF
 444 *       MOVE #-1,(A7)
 445 * ZEQUBR
 446 *       RTS
 447
 448 *
 449 * True as 1 would look like
 450 * ZEQU
 451 * ZEQU_ST
 452 *       MOVE.L (A7),D0
 453 *       SNE DO
 454 *       COM.B D0
 455 *       AND.L #1,D0
 456 *       MOVE.L D0,(A7)
 457 * ZEQU_END
 458 *       RTS
 459
 460
 461
 462 * _LOWORD_ Duplicate (count in B) bytes on stack:
 463 NDUP
 464         LDX PSP
 465         STX TEMP
 466
 467
 468
 469 ****** Working in here to make it go both ways.
 470 ****** Also need to check multiply and divide.
 471 ****** And need to convert the stuff past multiply and divide to 68000
 472
 473
 474 * Entry point below.
 475 * SMOVEL
 476 *       MOVE.B (A2)+,(A3)+
 477 *
 478 * not_LOWORD_ Move 2^16-1 bytes or less:
 479 * source in A2, destination in A3, count in D4:
 480 * Overlaps only work if source is higher than dest.
 481 * SMOVE
 482 *       DBF D4,SMOVEL
 483 *       RTS
 484
 485 * _WORD_ Move up to 32K (2^15) bytes ( src dest count --- ):
 486 * Copies zero when count > 2^15. (Limited for safety.)
 487 * Compare CMOVE in Forth.
 488 BMOVE
 489         MOVE.L (2*ADRWDSZ,A6),A2        ; src
 490         MOVE.L (ADRWDSZ,A6),A3 ; dest
 491         MOVE.L (A6),D4
 492         CMP.L #$8000    ; Pre-test, do nothing if too big,
 493         BLS.B BMOVEE    ; or if zero.
 494         BRA.B BMOVEX
 495 BMOVEL
 496         MOVE.B (A2)+,(A3)+
 497 BMOVEE
 498         DBF D4,SMOVEL   ; Catches zero count here and stops.
 499 BMOVEX  LEAU (3*ADRWDSZ,A6),A6
 500         RTS
 501
 502 * _WORD_ Execute the address on the stack:
 503 EXEC
 504         LDX PSP
 505         INX
 506         INX
 507         STX PSP
 508         LDX 0,X
 509         JSR 0,X ; For debugging and flattening, no early optimizations.
 510         RTS
 511
 512
 513
 514 COLDENT EQU *
 515 WARMENT EQU *
 516         MOVE.L #RSTKINI,A7
 517         MOVE.L #SSTKINI,A6
 518         MOVE.L #LSTKINI,A4
 519         MOVE.L #UPGINI,A5
 520
 521
 522
 523