fth/flkprim.fs

   1 \  FLK primitive optimizer
   2 \
   3 \  Copyright (C) 1998 Lars Krueger
   4 \
   5 \  This file is part of FLK.
   6 \
   7 \  FLK is free software; you can redistribute it and/or
   8 \  modify it under the terms of the GNU General Public License
   9 \  as published by the Free Software Foundation; either version 2
  10 \  of the License, or (at your option) any later version.
  11 \
  12 \  This program is distributed in the hope that it will be useful,
  13 \  but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 \  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 \  GNU General Public License for more details.
  16 \
  17 \  You should have received a copy of the GNU General Public License
  18 \  along with this program; if not, write to the Free Software
  19 \  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20
  21 \ $Id: flkprim.fs,v 1.20 1998/08/30 10:50:59 root Exp $
  22 \ $Log: flkprim.fs,v $
  23 \ Revision 1.20  1998/08/30 10:50:59  root
  24 \ new optimizing algorithm
  25 \
  26 \ Revision 1.19  1998/07/13 18:08:54  root
  27 \ various optimizations
  28 \
  29 \ Revision 1.18  1998/07/03 20:57:50  root
  30 \ level 2 optimimizer added
  31 \
  32 \ Revision 1.17  1998/07/03 09:09:28  root
  33 \ support for level 2 optimizer
  34 \
  35 \ Revision 1.16  1998/06/08 22:14:51  root
  36 \ literals cache (preparation to level 2 optimizer)
  37 \
  38 \ Revision 1.15  1998/06/01 17:51:42  root
  39 \ SEE shows the sourcefile using VIEW
  40 \
  41 \ Revision 1.14  1998/05/27 18:52:12  root
  42 \ \: commants added for SEE and HELP
  43 \
  44 \ Revision 1.13  1998/05/16 16:19:24  root
  45 \ direct terminfo access
  46 \
  47 \ Revision 1.12  1998/05/09 21:47:05  root
  48 \ primitives added
  49 \
  50 \ Revision 1.11  1998/05/03 12:06:37  root
  51 \ added macro support
  52 \
  53 \ Revision 1.10  1998/05/02 14:27:58  root
  54 \ compile only primitives
  55 \
  56 \ Revision 1.9  1998/05/01 18:11:25  root
  57 \ GNU license text added
  58 \ comments checked
  59 \
  60 \ Revision 1.8  1998/04/29 18:20:30  root
  61 \ ROTARE/-ROTARE
  62 \
  63 \ Revision 1.7  1998/04/27 18:41:42  root
  64 \ exchange primitive added
  65 \
  66 \ Revision 1.6  1998/04/25 11:02:07  root
  67 \ * fixed (crrect now and faster)
  68 \
  69 \ Revision 1.5  1998/04/24 16:47:39  root
  70 \ bug fixes
  71 \
  72 \ Revision 1.4  1998/04/10 14:42:50  root
  73 \ bugs corrected
  74 \
  75 \ Revision 1.3  1998/04/09 11:35:03  root
  76 \ primitives added and checked, all OK
  77 \
  78 \ Revision 1.2  1998/04/09 09:18:11  root
  79 \ primives checked, roll corrected
  80 \
  81 \ Revision 1.1  1998/04/07 20:10:33  root
  82 \ Initial revision
  83 \
  84
  85 \ See standard.
  86 p: CHARS ;
  87 ( OK )
  88
  89 \ See standard.
  90 p: @                     ( addr -- n )
  91 ( OK )
  92   regalloc-reset
  93   #tos-cache #USEREGS = IF
  94     req-any
  95     0 [tos0] tos0 mov,
  96   ELSE
  97     req-any req-free
  98     0 [tos0] free0 mov,
  99     1 reg-free
 100     0 free>tos
 101   THEN
 102   ;
 103
 104 \ See standard.
 105 p: !                     ( n addr -- )
 106 ( OK )
 107   regalloc-reset
 108   req-any
 109   req-any
 110   tos1 0 [tos0] mov,
 111   2 reg-free ;
 112
 113 \ Store FALSE at the given address.
 114 p: OFF      ( addr -- )
 115 ( OK )
 116   regalloc-reset
 117   req-any
 118   DWORD
 119   0 ## 0 [tos0] mov,
 120   1 reg-free ;
 121
 122 \ Store TRUE at the given address.
 123 p: ON       ( addr -- )
 124 ( OK )
 125   regalloc-reset
 126   req-any
 127   DWORD
 128   -1 ## 0 [tos0] mov,
 129   1 reg-free ;
 130
 131 \ See standard.
 132 p: 1+                    ( n -- n+1 )
 133 ( OK )
 134   regalloc-reset
 135   req-any
 136   tos0 inc, ;
 137
 138 \ See standard.
 139 p: CHAR+        ( addr -- addr+char)
 140 ( OK )
 141   regalloc-reset
 142   req-any
 143   tos0 inc, ;
 144
 145 \ Decrease the given address by the size of a character (1 byte).
 146 p: CHAR-        ( addr -- addr-char )
 147 ( OK )
 148   regalloc-reset
 149   req-any
 150   tos0 dec, ;
 151
 152 \ See standard.
 153 p: 1-
 154 ( OK )
 155   regalloc-reset
 156   req-any
 157   tos0 dec, ;
 158
 159 \ See standard.
 160 p: 2*
 161 ( OK )
 162   regalloc-reset
 163   req-any
 164   1 ## tos0 shl, ;
 165
 166 \ See standard.
 167 p: 2/
 168 ( OK )
 169   regalloc-reset
 170   req-any
 171   1 ## tos0 sar, ;
 172
 173 \ See standard.
 174 p: AND
 175 ( OK )
 176   regalloc-reset
 177   req-any
 178   req-any
 179   0 1 tos-swap
 180   tos0 tos1 and,
 181   1 reg-free ;
 182
 183 \ See standard.
 184 p: OR
 185 ( OK )
 186   regalloc-reset
 187   req-any
 188   req-any
 189   0 1 tos-swap
 190   tos0 tos1 or,
 191   1 reg-free ;
 192
 193 \ See standard.
 194 p: XOR
 195 ( OK )
 196   regalloc-reset
 197   req-any
 198   req-any
 199   0 1 tos-swap
 200   tos0 tos1 xor,
 201   1 reg-free ;
 202
 203 \ See standard.
 204 p: *          ( t1 t0 -- t1*t0 )
 205 ( OK )
 206   regalloc-reset
 207   req-edx       \ tos0
 208   req-eax       \ tos1
 209   tos0 mul,
 210   1 reg-free ;
 211
 212 \ See standard.
 213 p: +
 214 ( OK )
 215   regalloc-reset
 216   req-any req-any
 217   0 1 tos-swap
 218   tos0 tos1 add,
 219   1 reg-free ;
 220
 221 \ See standard.
 222 p: -
 223 ( OK )
 224   regalloc-reset
 225   req-any req-any
 226   tos0 tos1 sub,
 227   1 reg-free ;
 228
 229 \ See standard.
 230 p: INVERT
 231 ( OK )
 232   regalloc-reset
 233   req-any
 234   tos0 not, ;
 235
 236 \ See standard.
 237 p: NEGATE
 238 ( OK )
 239   regalloc-reset
 240   req-any
 241   tos0 neg, ;
 242
 243 \ See standard.
 244 p: C@
 245 ( OK )
 246   regalloc-reset
 247   req-any
 248   a-d-free
 249   free0 free0 xor,
 250   0 [tos0] free0l mov,
 251   1 reg-free
 252   0 free>tos ;
 253
 254 \ See standard.
 255 p: C! ( c addr -- )
 256 ( OK )
 257   regalloc-reset
 258   req-any req-a-d
 259   tos1l 0 [tos0] mov,
 260   2 reg-free ;
 261
 262 \ See standard.
 263 p: +!
 264 ( OK )
 265   regalloc-reset
 266   req-any
 267   req-any
 268   tos1 0 [tos0] add,
 269   2 reg-free ;
 270
 271 \ See standard.
 272 p: 2!
 273 ( OK )
 274   regalloc-reset
 275   req-any
 276   req-any
 277   req-any
 278   tos1 0       [tos0] mov,
 279   tos2 1 CELLS [tos0] mov,
 280   3 reg-free ;
 281
 282 \ See standard.
 283 p: 2@
 284 ( OK )
 285   regalloc-reset
 286   req-any
 287   req-free
 288   req-free
 289   0       [tos0] free0 mov,
 290   1 CELLS [tos0] free1 mov,
 291   1 reg-free
 292   1 free>tos
 293   0 free>tos ;
 294
 295 \ See standard.
 296 p: 2OVER    ( n1 n2 n3 n4 --- n1 n2 n3 n4 n1 n2 )
 297 ( OK )
 298   regalloc-reset
 299   req-any req-any req-any req-any
 300   req-free req-free
 301   tos3 free0 mov,
 302   tos2 free1 mov,
 303   0 free>tos
 304   1 free>tos ;
 305
 306 \ See standard.
 307 p: 2SWAP      ( n1 n2 n3 n4 --- n3 n4 n1 2n )
 308 ( OK )
 309   regalloc-reset
 310   req-any req-any req-any req-any
 311   1 3 tos-swap
 312   0 2 tos-swap ;
 313
 314 \ See standard.
 315 p: 2DUP     ( n1 n2 -- n1 n2 n1 n2 )
 316 ( OK )
 317   regalloc-reset
 318   req-any req-any
 319   req-free req-free
 320   tos1 free0 mov,
 321   tos0 free1 mov,
 322   0 free>tos
 323   1 free>tos ;
 324
 325 \ Duplicate the top 3 values on the stack.
 326 p: 3DUP       ( t2 t1 t0 -- t2 t1 t0 f2 f1 f0 )
 327 ( OK )
 328   regalloc-reset
 329   req-any req-any req-any
 330   req-free req-free req-free
 331   tos2 free2 mov,
 332   tos1 free1 mov,
 333   tos0 free0 mov,
 334   2 free>tos
 335   1 free>tos
 336   0 free>tos ;
 337
 338 \ See standard.
 339 p: DROP       ( n -- )
 340 ( OK )
 341   regalloc-reset
 342   req-any
 343   1 reg-free ;
 344
 345 \ See standard.
 346 p: D>S        ( d -- n )
 347 ( OK )
 348   regalloc-reset
 349   req-any
 350   1 reg-free ;
 351
 352 \ See standard.
 353 p: NIP        ( a b -- b )
 354 ( OK )
 355   regalloc-reset
 356   req-any req-any
 357   0 1 tos-swap 1 reg-free ;
 358
 359 \ See standard.
 360 p: 2DROP      ( n1 n2 -- )
 361 ( OK )
 362   regalloc-reset
 363   req-any req-any
 364   2 reg-free ;
 365
 366 \ See standard.
 367 p: DUP        ( n -- n  n)
 368 ( OK )
 369   regalloc-reset
 370   req-any
 371   req-free
 372   tos0 free0 mov,
 373   0 free>tos ;
 374
 375 \ See standard.
 376 p: OVER       ( n1 n2 -- n1 n2 n1 )
 377 ( OK )
 378   regalloc-reset
 379   req-any
 380   req-any
 381   req-free
 382   tos1 free0 mov,
 383   0 free>tos ;
 384
 385 \ See standard.
 386 p: ROT        ( n1 n2 n3 --- n2 n3 n1 )
 387 ( OK )
 388   regalloc-reset
 389   req-any req-any req-any
 390   0 1 tos-swap    \ t2 t0 t1
 391   0 2 tos-swap ;  \ t1 t0 t2
 392
 393 \ Put the the top of stack value below the two next values. Inverse operation
 394 \ to ROT.
 395 p: -ROT       ( n1 n2 n3 --- n3 n1 n2 )
 396 ( OK )
 397   regalloc-reset
 398   req-any req-any
 399   req-any     \ t2 t1 t0
 400   0 1 tos-swap    \ t2 t0 t1
 401   1 2 tos-swap ;  \ t0 t2 t1
 402
 403 \ Rotate the top four items upwards.
 404 p: TURN       ( t3 t2 t1 t0 -- t2 t1 t0 t3 )
 405 ( OK )
 406   regalloc-reset
 407   req-any req-any req-any req-any
 408   0 1 tos-swap    \ t3 t2 t0 t1
 409   0 3 tos-swap    \ t1 t2 t0 t3
 410   2 3 tos-swap ;  \ t2 t1 t0 t3
 411
 412 \ Rotate the top four items downwards.
 413 p: -TURN      ( t3 t2 t1 t0 -- t0 t3 t2 t1 )
 414 ( OK )
 415   regalloc-reset
 416   req-any req-any
 417   req-any req-any   \ t3 t2 t1 t0
 418   0 1 tos-swap    \ t3 t2 t0 t1
 419   1 2 tos-swap    \ t3 t0 t2 t1
 420   2 3 tos-swap    \ t0 t3 t2 t1
 421   ;
 422
 423 \ Rotate the top five items upwards.
 424 p: TWIST      ( t4 t3 t2 t1 t0 -- t3 t2 t1 t0 t4 )
 425 ( OK )
 426   regalloc-reset
 427   req-any req-any
 428   req-any req-any
 429   req-any       \ t4 t3 t2 t1 t0
 430   0 4 tos-swap      \ t0 t3 t2 t1 t4
 431   4 3 tos-swap      \ t3 t0 t2 t1 t4
 432   3 2 tos-swap      \ t3 t2 t0 t1 t4
 433   2 1 tos-swap      \ t3 t2 t1 t0 t4
 434 ;
 435
 436 \ Rotate the top five items downwards.
 437 p: -TWIST       ( t4 t3 t2 t1 t0 -- t0 t4 t3 t2 t1 )
 438 ( OK )
 439   regalloc-reset
 440   req-any req-any
 441   req-any req-any
 442   req-any       \ t4 t3 t2 t1 t0
 443   0 1 tos-swap      \ t4 t3 t2 t0 t1
 444   1 2 tos-swap      \ t4 t3 t0 t2 t1
 445   2 3 tos-swap      \ t4 t0 t3 t2 t1
 446   3 4 tos-swap      \ t0 t4 t3 t2 t1
 447 ;
 448
 449 \ Rotate the top six items upwards.
 450 p: ROTARE       ( t5 t4 t3 t2 t1 t0 -- t4 t3 t2 t1 t0 t5 )
 451   regalloc-reset
 452   req-any req-any
 453   req-any req-any
 454   req-any req-any     \ t5 t4 t3 t2 t1 t0
 455   5 4 tos-swap      \ t4 t5 t3 t2 t1 t0
 456   4 3 tos-swap      \ t4 t3 t5 t2 t1 t0
 457   3 2 tos-swap      \ t4 t3 t2 t5 t1 t0
 458   2 1 tos-swap      \ t4 t3 t2 t1 t5 t0
 459   1 0 tos-swap      \ t4 t3 t2 t1 t0 t5
 460 ;
 461
 462 \ Rotate the top six items downwards.
 463 p: -ROTARE      ( t5 t4 t3 t2 t1 t0 -- t0 t5 t4 t3 t2 t1 )
 464   regalloc-reset
 465   req-any req-any
 466   req-any req-any
 467   req-any req-any     \ t5 t4 t3 t2 t1 t0
 468   0 1 tos-swap      \ t5 t4 t3 t2 t0 t1
 469   1 2 tos-swap      \ t5 t4 t3 t0 t2 t1
 470   2 3 tos-swap      \ t5 t4 t0 t3 t2 t1
 471   3 4 tos-swap      \ t5 t0 t4 t3 t2 t1
 472   4 5 tos-swap      \ t0 t5 t4 t3 t2 t1
 473 ;
 474
 475 \ See standard.
 476 p: TUCK       ( t1 t0 -- t0 t1 t0 )
 477 ( OK )
 478   regalloc-reset
 479   req-any req-any
 480   req-free
 481   tos0 free0 mov,
 482   0 1 tos-swap    \ t0 t1
 483   0 free>tos    \ t0 t1 f0
 484 ;
 485
 486 \ Copy the third stack item on top.
 487 p: PLUCK    ( t2 t1 t0 -- t2 t1 t0 t2 )
 488 ( OK )
 489   regalloc-reset
 490   req-any req-any req-any
 491   req-free
 492   tos2 free0 mov,
 493   0 free>tos ;
 494
 495 \ Copy the fourth stack item on top.
 496 p: FLOCK    ( t3 t2 t1 t0 -- t3 t2 t1 t0 t3 )
 497 ( OK )
 498   regalloc-reset
 499   req-any req-any req-any req-any
 500   req-free
 501   tos3 free0 mov,
 502   0 free>tos ;
 503
 504 \ See standard.
 505 c: 2>R
 506 ( OK )
 507   regalloc-reset
 508   req-any req-any
 509   tos1 push,
 510   tos0 push,
 511   2 reg-free
 512 ;
 513
 514 \ See standard.
 515 c: 2R>
 516 ( OK )
 517   regalloc-reset
 518   req-free req-free
 519   free0 pop,
 520   free1 pop,
 521   1 free>tos
 522   0 free>tos
 523 ;
 524
 525 \ See standard.
 526 c: 2R@
 527   regalloc-reset
 528   req-free req-free
 529   0 [esp] free0 mov,
 530   4 [esp] free1 mov,
 531   1 free>tos
 532   0 free>tos ;
 533
 534 \ See standard.
 535 p: D0=
 536 ( OK )
 537   regalloc-reset
 538   req-any req-any
 539   tos0 tos1 or,
 540   tos1l setz,
 541   31 ## tos1 shl,
 542   31 ## tos1 sar,
 543   1 reg-free ;
 544
 545 \ See standard.
 546 p: S>D
 547 ( OK )
 548   regalloc-reset
 549   req-eax     \ t0=eax
 550   free-edx    \ f0=edx
 551   cdq, 0 free>tos ;
 552
 553 \ See standard.
 554 p: SWAP
 555 ( OK )
 556   regalloc-reset
 557   req-any
 558   req-any
 559   0 1 tos-swap ;
 560
 561 \ See standard.
 562 c: >R
 563 ( OK )
 564   regalloc-reset
 565   req-any
 566   tos0 push,
 567   1 reg-free ;
 568
 569 \ See standard.
 570 c: R>
 571 ( OK )
 572   regalloc-reset
 573   req-free
 574   free0 pop,
 575   0 free>tos ;
 576
 577 \ See standard.
 578 c: R@
 579   regalloc-reset
 580   req-free
 581   0 [esp] free0 mov,
 582   0 free>tos ;
 583
 584 \ See standard.
 585 p: LSHIFT         ( x1 u -- x2 )
 586 ( OK )
 587   regalloc-reset
 588   req-ecx
 589   req-any
 590   tos0 tos1 shl,
 591   1 reg-free ;
 592
 593 \ See standard.
 594 p: RSHIFT         ( x1 u -- x2 )
 595 ( OK )
 596   regalloc-reset
 597   req-ecx         \ tos0
 598   req-any         \ tos1
 599   tos0 tos1 shr,
 600   1 reg-free ;
 601
 602 \ See standard.
 603 p: 0=           ( n -- f )
 604 ( OK )
 605   regalloc-reset
 606   req-a-d
 607   tos0 tos0 or,
 608   tos0l setz,
 609   31 ## tos0 shl,
 610   31 ## tos0 sar, ;
 611
 612 \ See standard.
 613 p: 0<           ( n -- f )
 614 ( OK )
 615   regalloc-reset
 616   req-a-d
 617   tos0 tos0 or,
 618   tos0l setl,
 619   31 ## tos0 shl,
 620   31 ## tos0 sar, ;
 621
 622 \ See standard.
 623 p: 0>           ( n -- f )
 624 ( OK )
 625   regalloc-reset
 626   req-a-d
 627   tos0 tos0 or,
 628   tos0l setg,
 629   31 ## tos0 shl,
 630   31 ## tos0 sar, ;
 631
 632 \ See standard.
 633 p: 0<>          ( n -- f )
 634 ( OK )
 635   regalloc-reset
 636   req-a-d
 637   tos0 tos0 or,
 638   tos0l setnz,
 639   31 ## tos0 shl,
 640   31 ## tos0 sar, ;
 641
 642 \ See standard.
 643 p: =          ( n1 n2 -- f )
 644 ( OK )
 645   regalloc-reset
 646   req-any
 647   req-any
 648   a-d-free
 649   free0 free0 xor,
 650   tos0 tos1 cmp,
 651   free0l setne,
 652   free0 dec,
 653   2 reg-free
 654   0 free>tos ;
 655
 656 \ See standard.
 657 p: <>           ( n1 n2 -- f )
 658 ( OK )
 659   regalloc-reset
 660   req-any
 661   req-any
 662   a-d-free
 663   free0 free0 xor,
 664   tos0 tos1 cmp,
 665   free0l sete,
 666   free0 dec,
 667   2 reg-free
 668   0 free>tos ;
 669
 670 \ See standard.
 671 p: <          ( n1 n2 -- f )
 672 ( OK )
 673   regalloc-reset
 674   req-any
 675   req-any
 676   a-d-free
 677   free0 free0 xor,
 678   tos0 tos1 cmp,
 679   free0l setge,
 680   free0 dec,
 681   2 reg-free
 682   0 free>tos ;
 683
 684 \ Perform a less or equal comparison. Equivalent to > INVERT
 685 p: <=           ( n1 n2 -- f )
 686 ( OK )
 687   regalloc-reset
 688   req-any
 689   req-any
 690   a-d-free
 691   free0 free0 xor,
 692   tos0 tos1 cmp,
 693   free0l setg,
 694   free0 dec,
 695   2 reg-free
 696   0 free>tos ;
 697
 698 \ See standard.
 699 p: >          ( n1 n2 -- f )
 700 ( OK )
 701   regalloc-reset
 702   req-any
 703   req-any
 704   a-d-free
 705   free0 free0 xor,
 706   tos0 tos1 cmp,
 707   free0l setle,
 708   free0 dec,
 709   2 reg-free
 710   0 free>tos ;
 711
 712 \ Perform a greater or equal comparison. Equivalent to < INVERT
 713 p: >=           ( n1 n2 -- f )
 714 ( OK )
 715   regalloc-reset
 716   req-any
 717   req-any
 718   a-d-free
 719   free0 free0 xor,
 720   tos0 tos1 cmp,
 721   free0l setl,
 722   free0 dec,
 723   2 reg-free
 724   0 free>tos ;
 725
 726 \ See standard.
 727 p: U<           ( n1 n2 -- f )
 728 ( OK )
 729   regalloc-reset
 730   req-any
 731   req-a-d
 732   tos0 tos1 cmp,
 733   tos1l setb,
 734   31 ## tos1 shl,
 735   31 ## tos1 sar,
 736   1 reg-free ;
 737
 738 \ See standard.
 739 p: U>           ( n1 n2 -- f )
 740 ( OK )
 741   regalloc-reset
 742   req-any
 743   req-a-d
 744   tos0 tos1 cmp,
 745   tos1l seta,
 746   31 ## tos1 shl,
 747   31 ## tos1 sar,
 748   1 reg-free ;
 749
 750 \ See standard.
 751 p: 2ROT ( x1 x2 x3 x4 x5 x6 -- x3 x4 x5 x6 x1 x2 )
 752 ( OK )
 753   regalloc-reset
 754   req-any req-any req-any
 755   req-any req-any req-any     \ t5 t4 t3 t2 t1 t0
 756   0 4 tos-swap        \ t5 t0 t3 t2 t1 t4
 757   1 5 tos-swap        \ t1 t0 t3 t2 t5 t4
 758   2 4 tos-swap        \ t1 t2 t3 t0 t5 t4
 759   3 5 tos-swap ;      \ t3 t2 t1 t0 t5 t4
 760
 761 c: EXIT           ( -- )
 762 ( OK )
 763   regalloc-reset
 764   regalloc-flush
 765   ret, ;
 766
 767 c: ?EXIT          ( flag -- )
 768 ( OK )
 769   regalloc-reset
 770   req-any
 771   tos0 tos0 or,
 772   0 jz,
 773   1 reg-free
 774   save-allocator
 775   regalloc-flush
 776   ret,
 777   0 $:
 778   restore-allocator ;
 779
 780 \ See standard.
 781 p: FILL         ( addr cnt char -- )
 782 ( OK )
 783   regalloc-reset
 784   req-eax         \ eax=char
 785   req-ecx         \ ecx=cnt
 786   req-edi         \ edi=addr
 787   rep, stosb,
 788   3 reg-free ;
 789
 790 \ See standard.
 791 p: D+           ( d1 d2 -- d1+d2 )
 792 ( OK )
 793   regalloc-reset
 794   req-any req-any req-any req-any
 795   tos1 tos3 add,
 796   tos0 tos2 adc,
 797   2 reg-free ;
 798
 799 \ See standard.
 800 p: D-           ( d1 d2 -- d1-d2 )
 801 ( OK )
 802   regalloc-reset
 803   req-any req-any req-any req-any
 804   tos1 tos3 sub,
 805   tos0 tos2 sbb,
 806   2 reg-free ;
 807
 808 \ See standard.
 809 p: D2*          ( d1 -- d2 )
 810 ( OK )
 811   regalloc-reset
 812   req-any req-any
 813   clc,
 814   1 ## tos1 rcl,
 815   1 ## tos0 rcl, ;
 816
 817 \ See standard.
 818 p: D2/          ( d1l d1h -- d2l d2h )
 819 ( OK )
 820   regalloc-reset
 821   req-any req-any req-free
 822   tos0 free0 mov,
 823   1 ## free0 rcl,
 824   1 ## tos0 rcr,
 825   1 ## tos1 rcr, ;
 826
 827 \ See standard.
 828 p: D0<          ( dl dh -- flag )
 829 ( OK )
 830   regalloc-reset
 831   req-any req-any
 832   tos0 tos1 mov,
 833   31 ## tos1 sar,
 834   1 reg-free ;
 835
 836 \ See standard.
 837 p: DNEGATE        ( dl dh -- d1l d1h )
 838 ( OK )
 839   regalloc-reset
 840   req-any req-any
 841   tos0 neg,
 842   tos1 neg,
 843   0 ## tos0 sbb, ;
 844
 845 \ See standard.
 846 p: CMOVE        ( a1 a2 cnt -- )
 847 ( OK )
 848   regalloc-reset
 849   req-ecx         \ ecx=cnt
 850   req-edi         \ edi=a2
 851   req-esi         \ esi=a1
 852   rep, movsb,
 853   3 reg-free ;
 854
 855 \ See standard.
 856 p: CMOVE>         ( a1 a2 cnt -- )
 857 ( OK )
 858   regalloc-reset
 859   req-ecx         \ ecx=cnt
 860   req-edi         \ edi=a2
 861   req-esi         \ esi=a1
 862   ecx edi add,
 863   ecx esi add,
 864   edi dec,
 865   esi dec,
 866   std,
 867   rep, movsb,
 868   cld,
 869   3 reg-free ;
 870
 871 \ See standard.
 872 p: M*           ( n1 n2 -- d )
 873 ( OK )
 874   regalloc-reset
 875   req-edx
 876   req-eax
 877   edx imul, ;
 878
 879 \ See standard.
 880 p: UM*          ( u1 u2 -- ud )
 881 ( OK )
 882   regalloc-reset
 883   req-edx
 884   req-eax
 885   edx mul, ;
 886
 887 \ See standard.
 888 p: UM/MOD         ( ud un -- ur uq )
 889 ( OK )
 890   regalloc-reset
 891   req-any         \ un=tos0
 892   req-edx         \ udh=edx=tos1=rem
 893   req-eax         \ udl=eax=tos2=quot
 894   tos0 div,
 895   1 2 tos-swap
 896   1 reg-free ;
 897
 898 \ See standard.
 899 p: SM/REM         ( d1l d1h n1 -- nrem nquot )
 900 ( OK )
 901   regalloc-reset
 902   req-ebx
 903   req-edx
 904   req-eax
 905   ebx idiv,
 906   1 reg-free
 907   0 1 tos-swap ;
 908
 909 c: SP@        ( -- sp )
 910 ( OK )
 911   regalloc-reset
 912   req-free
 913   ebp free0 mov,
 914   offs-ebp ## free0 add,
 915   0 free>tos ;
 916
 917 c: SP!        ( sp -- )
 918 ( OK )
 919   regalloc-reset
 920   regalloc-flush
 921   req-any
 922   1 reg-free
 923   0 TO offs-ebp
 924   eax ebp mov, ;
 925
 926 \ Retrieve the current return stack pointer.
 927 c: RP@        ( -- rp )
 928 ( OK )
 929   regalloc-reset
 930   req-free
 931   esp free0 mov,
 932   0 free>tos ;
 933
 934 \ Set the return stack pointer. Attention: A wrong value does not lead to a
 935 \ segmentation fault immediate, but at the next call or return.
 936 c: RP!        ( rp -- )
 937 ( OK )
 938   regalloc-reset
 939   req-any
 940   tos0 esp mov,
 941   1 reg-free ;
 942
 943 \ See standard.
 944 p: DU<        ( d1l d1h d2l d2h -- flag )
 945 ( OK )
 946   regalloc-reset
 947   req-any       \ tos0=d2h
 948   req-any       \ tos1=d2l
 949   req-any       \ tos2=d1h
 950   req-any       \ tos3=d1l
 951   tos1 tos3 sub,
 952   tos0 tos2 sbb,
 953   tos3 tos3 sbb,
 954   3 reg-free ;
 955
 956 \ See standard.
 957 p: PICK       ( n -- tos+n )
 958 ( OK )
 959   regalloc-reset
 960   regalloc-flush
 961   req-any
 962   tos0 inc,
 963   2 ## tos0 shl,
 964   ebp tos0 add,
 965   offs-ebp [tos0] tos0 mov, ;
 966
 967 \ Return the base address of the data stack. This is the highest accessable
 968 \ address plus one cell since the stack grows downwards.
 969 p: SP-BASE      ( -- sp-base)
 970 ( OK )
 971   regalloc-reset
 972   req-free
 973   HA-INIT-DATASTACK #[] free0 mov,
 974   0 free>tos ;
 975
 976 \ Return the base address of the return stack. This is the highest accessable
 977 \ address plus one cell since the stack grows downwards.
 978 p: RP-BASE      ( -- rp-base)
 979 ( OK )
 980   regalloc-reset
 981   req-free
 982   HA-INIT-CALLSTACK #[] free0 mov,
 983   0 free>tos ;
 984
 985 \ See standard.
 986 p: ROLL       ( xu xu-1 ... x0 u -- xu-1 ... x0 xu )
 987 ( OK )
 988   regalloc-reset
 989   regalloc-flush
 990   req-any       \ tos0=eax=u
 991   tos0 ecx mov,
 992   2 ## tos0 shl,    \ tos0=4*u
 993   ebp edi mov,
 994   ebp esi mov,
 995   tos0 edi add,
 996   tos0 esi add,
 997   4 ## edi add,
 998   0 [edi] ebx mov,
 999   std,
1000   rep, movsd,
1001   cld,
1002   ebx 0 [edi] mov,
1003   1 reg-free ;
1004
1005 \ See standard.
1006 p: FORTH-WORDLIST       ( -- wid )
1007 ( OK )
1008   regalloc-reset
1009   req-free
1010   +relocate
1011   HA-DEF-WL ## free0 mov,
1012   0 free>tos ;
1013
1014 \ Return the wordlist identifier for the environment wordlist.
1015 p: ENVIRONMENT-WORDLIST     ( -- wid )
1016 ( OK )
1017   regalloc-reset
1018   req-free
1019   +relocate
1020   HA-ENV-WL ## free0 mov,
1021   0 free>tos ;
1022
1023 \ Return the wordlist identifier for the ASSEMBLER wordlist.
1024 p: ASSEMBLER-WORDLIST       ( -- wid )
1025 ( OK )
1026   regalloc-reset
1027   req-free
1028   +relocate
1029   HA-ASS-WL ## free0 mov,
1030   0 free>tos ;
1031
1032 \ Return the wordlist identifier for the EDITOR wordlist.
1033 p: EDITOR-WORDLIST      ( -- wid )
1034 ( OK )
1035   regalloc-reset
1036   req-free
1037   +relocate
1038   HA-EDT-WL ## free0 mov,
1039   0 free>tos ;
1040
1041 \ Return the last possible address in the data area.
1042 p: HERE-LIMIT         ( -- here-limit )
1043 ( OK )
1044   regalloc-reset
1045   req-free
1046   HA-HERE-LIMIT #[] free0 mov,
1047   0 free>tos ;
1048
1049 \ Return the last possible address in the code area.
1050 p: CHERE-LIMIT        ( -- here-limit )
1051 ( OK )
1052   regalloc-reset
1053   req-free
1054   HA-CHERE-LIMIT #[] free0 mov,
1055   0 free>tos ;
1056
1057 \ Return inital value of HERE.
1058 p: HERE-INIT        ( -- here-limit )
1059 ( OK )
1060   regalloc-reset
1061   req-free
1062   HA-HERE-INIT #[] free0 mov,
1063   0 free>tos ;
1064
1065 \ Return inital value of CHERE.
1066 p: CHERE-INIT         ( -- here-limit )
1067 ( OK )
1068   regalloc-reset
1069   req-free
1070   HA-CHERE-INIT #[] free0 mov,
1071   0 free>tos ;
1072
1073 \ See standard.
1074 p: COUNT        ( c-addr1 -- c-addr2 u )
1075 ( OK )
1076   regalloc-reset
1077   req-any
1078   a-d-free
1079   free0 free0 xor,
1080   0 [tos0] free0l mov,
1081   tos0 inc,
1082   0 free>tos ;
1083
1084 \ Primitive for EXECUTE. Jumps to the given address.
1085 p: (EXECUTE)        ( addr -- )
1086 ( OK )
1087   regalloc-reset
1088   req-ebx
1089   1 reg-free
1090   regalloc-flush
1091   ebx call, ;
1092
1093 \ See standard.
1094 p: CELLS        ( x -- x*4 )
1095 ( OK )
1096   regalloc-reset
1097   req-any
1098   2 ## tos0 shl, ;
1099
1100 \ See standard.
1101 p: CELL+        ( x -- x+4)
1102 ( OK )
1103   regalloc-reset
1104   req-any
1105   4 ## tos0 add, ;
1106
1107 \ Decrease the given address by one cell (4 bytes).
1108 p: CELL-        ( x -- x-4)
1109 ( OK )
1110   regalloc-reset
1111   req-any
1112   4 ## tos0 sub, ;
1113
1114 \ Get the relocation table.
1115 p: RELOCATION-TABLE@      ( -- reltab )
1116 ( OK )
1117   regalloc-reset
1118   req-free
1119   HA-RELTABLE #[] free0 mov,
1120   0 free>tos ;
1121
1122 \ Store the relocation table.
1123 p: RELOCATION-TABLE!      ( reltab -- )
1124 ( OK )
1125   regalloc-reset
1126   req-any
1127   tos0 HA-RELTABLE #[] mov,
1128   1 reg-free ;
1129
1130 \ See standard.
1131 p: /          ( n1 n2 -- n3 )
1132 ( OK )
1133   regalloc-reset
1134   req-edx         \ n2=tos0=edx
1135   req-eax         \ n1=tos1=eax
1136   req-free
1137   eax free0 mov,
1138   31 ## free0 sar,
1139   edx free0 xchg,
1140   free0 idiv,         \ eax=quot edx=rem
1141   1 reg-free ;
1142
1143 \ See standard.
1144 p: MOD          ( n1 n2 -- n3 )
1145 ( OK )
1146   regalloc-reset
1147   req-edx         \ n2=tos0=edx
1148   req-eax         \ n1=tos1=eax
1149   req-free
1150   eax free0 mov,
1151   31 ## free0 sar,
1152   edx free0 xchg,
1153   free0 idiv,         \ eax=quot edx=rem
1154   0 1 tos-swap
1155   1 reg-free ;
1156
1157 \ See standard.
1158 p: M+           ( dl dh n -- dl dh )
1159 ( OK )
1160    regalloc-reset
1161    req-any        \ tos0=n
1162    req-any        \ tos1=dh
1163    req-any        \ tos2=dl
1164    tos0 tos2 add,
1165    0 ## tos1 adc,
1166    1 reg-free ;
1167
1168 \ Return TRUE if the two numbers differ in their sign.
1169 p: SignsDiffer?       ( n1 n2 -- flag )
1170 ( OK )
1171    regalloc-reset
1172    req-any
1173    req-any
1174    tos0 tos1 xor,
1175    31 ## tos1 sar,
1176    1 reg-free ;
1177
1178 \ Exchange the number and the content of the address.
1179 p: exchange         ( x1 addr -- x2 )
1180    regalloc-reset
1181    req-any        \ tos0=addr
1182    req-any        \ tos1=x1
1183    tos1 0 [tos0] xchg,
1184    1 reg-free ;
1185
1186 \ See standard.
1187 p: ALIGNED        ( addr -- addr2 )
1188 ( OK )
1189    regalloc-reset
1190    req-any
1191    3 ## tos0 add,
1192    3 INVERT ## tos0 and, ;
1193
1194 \ See standard.
1195 p: MAX          ( n1 n2 -- n3 )
1196 ( OK )
1197    regalloc-reset
1198    req-any req-any
1199    tos0 tos1 cmp,
1200    0 jg,
1201    tos0 tos1 mov,
1202 0 $:
1203    1 reg-free ;
1204
1205 \ See standard.
1206 p: MIN          ( n1 n2 -- n3 )
1207 ( OK )
1208    regalloc-reset
1209    req-any req-any
1210    tos0 tos1 cmp,
1211    0 jl,
1212    tos0 tos1 mov,
1213 0 $:
1214    1 reg-free ;
1215
1216 \ See standard.
1217 p: ABS          ( n1 -- n2 )
1218 ( OK )
1219    regalloc-reset
1220    req-any
1221    tos0 tos0 or,
1222    0 jns,
1223    tos0 neg,
1224 0 $: ;
1225
1226 \ Same as COUNT, but for cell counted strings.
1227 p: $COUNT         ( c-addr1 -- c-addr2 u )
1228   regalloc-reset
1229   req-any
1230   req-free
1231   0 [tos0] free0 mov,
1232   4 ## tos0 add,
1233   0 free>tos ;
1234
1235 \ Put a 0 onto the stack. Generates smaller code that the normal inline
1236 \ constant.
1237 \ p: 0          ( -- 0 )
1238 \    regalloc-reset
1239 \    req-free
1240 \    free0 free0 xor,
1241 \    0 free>tos ;
1242
1243 \ Advance to the cell containing the address of the interpretation semantics of
1244 \ the word.
1245 p: >CFA         ( xt -- cfa )
1246    regalloc-reset
1247    req-any
1248    4 ## tos0 add, ;
1249
1250 \ Advance to the cell containing the address of the optimization semantics of
1251 \ the word.
1252 p: >OCFA        ( xt -- ocfa )
1253    regalloc-reset
1254    req-any
1255    8 ## tos0 add, ;
1256
1257 \ Advance to the cell containing the address of the data field of the word.
1258 p: >DFA           ( xt -- dfa )
1259    regalloc-reset
1260    req-any
1261    12 ## tos0 add, ;
1262
1263 \ Advance to the cell containing the address of the filename of the word.
1264 p: >FN            ( xt -- filename )
1265    regalloc-reset
1266    req-any
1267    16 ## tos0 add, ;
1268
1269 \ Advance to the cell containing the line number of the word.
1270 p: >DL            ( xt -- definition-line )
1271    regalloc-reset
1272    req-any
1273    20 ## tos0 add, ;
1274
1275 \ Advance to the byte containing the flags of the word.
1276 p: >FLAGS         ( xt -- ffa )
1277    regalloc-reset
1278    req-any
1279    24 ## tos0 add, ;
1280
1281 \ Advance to the byte containing the byte counted string containing the name
1282 \ of the word.
1283 p: >NAME        ( xt -- nfa )
1284    regalloc-reset
1285    req-any
1286    25 ## tos0 add, ;
1287
1288 \ Convert name to a printable string (same as COUNT for now)
1289 p: NAME>STRING  ( nfa -- c-addr u )
1290 ( OK )
1291   regalloc-reset
1292   req-any
1293   a-d-free
1294   free0 free0 xor,
1295   0 [tos0] free0l mov,
1296   tos0 inc,
1297   0 free>tos ;