level1/20_math_base.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6
   7 ;; swap bytes of the low word
   8 ;; high word is untouched
   9 code: BSWAP-WORD  ( u -- u )
  10   xchg  cl,ch
  11   urnext
  12 endcode
  13
  14
  15 ;; swap all dword bytes
  16 code: BSWAP-DWORD  ( u -- u )
  17   bswap TOS
  18   urnext
  19 endcode
  20
  21
  22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23 code: CELLS  ( count -- count*4 )
  24   shl   TOS,2
  25   urnext
  26 endcode
  27
  28 code: BYTES->CELLS  ( count -- [count+3]/4 )
  29   add   TOS,3
  30   shr   TOS,2
  31   urnext
  32 endcode
  33
  34 code: +CELLS  ( addr count -- addr+count*4 )
  35   shl   TOS,2
  36   pop   eax
  37   add   TOS,eax
  38   urnext
  39 endcode
  40
  41 code: -CELLS  ( addr count -- addr-count*4 )
  42   shl   TOS,2
  43   pop   eax
  44   sub   eax,TOS
  45   ld    TOS,eax
  46   urnext
  47 endcode
  48
  49 code: CELL+  ( count -- count+4 )
  50   add   TOS,4
  51   urnext
  52 endcode
  53
  54 code: CELL-  ( count -- count-4 )
  55   sub   TOS,4
  56   urnext
  57 endcode
  58
  59
  60 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  61 code: 1+  ( n -- n+1 )
  62   inc   TOS
  63   urnext
  64 endcode
  65
  66 code: 1-  ( n -- n-1 )
  67   dec   TOS
  68   urnext
  69 endcode
  70
  71 code: 2+  ( n -- n+2 )
  72   add   TOS,2
  73   urnext
  74 endcode
  75
  76 code: 2-  ( n -- n-2 )
  77   sub   TOS,2
  78   urnext
  79 endcode
  80
  81 code: 4+  ( n -- n+4 )
  82   add   TOS,4
  83   urnext
  84 endcode
  85
  86 code: 4-  ( n -- n-4 )
  87   sub   TOS,4
  88   urnext
  89 endcode
  90
  91 code: 8+  ( n -- n+8 )
  92   add   TOS,8
  93   urnext
  94 endcode
  95
  96 code: 8-  ( n -- n-8 )
  97   sub   TOS,8
  98   urnext
  99 endcode
 100
 101
 102 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 103 ;; same as 0=
 104 code: NOT  ( n -- !n )
 105   test  TOS,TOS
 106   setz  cl
 107   movzx TOS,cl
 108   urnext
 109 endcode
 110
 111 ;; same as 0<>
 112 code: NOTNOT  ( n -- !!n )
 113   test  TOS,TOS
 114   setnz cl
 115   movzx TOS,cl
 116   urnext
 117 endcode
 118
 119 code: BITNOT  ( n -- ~n )
 120   not   TOS
 121   urnext
 122 endcode
 123
 124 code: AND  ( n0 n1 -- n0&n1 )
 125   pop   eax
 126   xchg  eax,TOS
 127   and   TOS,eax
 128   urnext
 129 endcode
 130
 131 code: SWAP-AND  ( n0 n1 -- n1&n0 )
 132   pop   eax
 133   and   TOS,eax
 134   urnext
 135 endcode
 136
 137 code: ~AND  ( n0 n1 -- n0&~n1 )
 138   not   TOS
 139   pop   eax
 140   xchg  eax,TOS
 141   and   TOS,eax
 142   urnext
 143 endcode
 144
 145 code: SWAP-~AND  ( n0 n1 -- n1&~n0 )
 146   pop   eax
 147   not   eax
 148   and   TOS,eax
 149   urnext
 150 endcode
 151
 152 code: OR  ( n0 n1 -- n0|n1 )
 153   pop   eax
 154   or    TOS,eax
 155   urnext
 156 endcode
 157
 158 code: XOR  ( n0 n1 -- n0^n1 )
 159   pop   eax
 160   xor   TOS,eax
 161   urnext
 162 endcode
 163
 164
 165 code: BIT-SET  ( u0 bitnum -- u0|[1<<bitnum] )
 166   pop   eax
 167   bts   eax,TOS
 168   ld    TOS,eax
 169   urnext
 170 endcode
 171
 172 code: BIT-RESET  ( u0 bitnum -- u0&~[1<<bitnum] )
 173   pop   eax
 174   btr   eax,TOS
 175   ld    TOS,eax
 176   urnext
 177 endcode
 178
 179 code: BIT?  ( u0 bitnum -- u0&~[1<<bitnum]<>0 )
 180   pop   eax
 181   bt    eax,TOS
 182   setc  cl
 183   movzx TOS,cl
 184   urnext
 185 endcode
 186
 187
 188 code: LOGAND  ( n0 n1 -- n0&&n1 )
 189   pop   eax
 190   xor   edx,edx
 191   xor   ebx,ebx
 192   test  eax,eax
 193   setnz dl
 194   test  TOS,TOS
 195   setnz bl
 196   ld    cl,dl
 197   and   cl,bl
 198   movzx TOS,cl
 199   urnext
 200 endcode
 201
 202 code: LOGOR  ( n0 n1 -- n0||n1 )
 203   pop   eax
 204   xor   edx,edx
 205   or    TOS,eax
 206   setnz dl
 207   movzx TOS,dl
 208   urnext
 209 endcode
 210
 211
 212 code: LSHIFT  ( n0 n1 -- n0<<n1 )
 213   pop   eax
 214   cmp   TOS,32
 215   jr    nc,.zero
 216   ;; assume that TOS is in ECX
 217   shl   eax,cl
 218   mov   TOS,eax
 219   urnext
 220 .zero:
 221   xor   TOS,TOS
 222   urnext
 223 endcode
 224
 225 code: RSHIFT  ( n0 n1 -- n0>>n1 )
 226   pop   eax
 227   cmp   TOS,32
 228   jr    nc,.zero
 229   ;; assume that TOS is in ECX
 230   shr   eax,cl
 231   mov   TOS,eax
 232   urnext
 233 .zero:
 234   xor   TOS,TOS
 235   urnext
 236 endcode
 237
 238 code: ARSHIFT  ( n0 n1 -- n0>>n1 )
 239   pop   eax
 240   cmp   TOS,32
 241   jr    nc,.toobig
 242   ;; assume that TOS is in ECX
 243   sar   eax,cl
 244   mov   TOS,eax
 245   urnext
 246 .toobig:
 247   mov   TOS,-1
 248   cmp   eax,0x80000000
 249   adc   TOS,0
 250   urnext
 251 endcode
 252
 253
 254 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 255 code: LROTATE  ( n0 n1 -- n0 rol n1 )
 256   pop   eax
 257   and   cl,31
 258   rol   eax,cl
 259   ld    TOS,eax
 260   urnext
 261 endcode
 262
 263 code: RROTATE  ( n0 n1 -- n0 ror n1 )
 264   pop   eax
 265   and   cl,31
 266   ror   eax,cl
 267   ld    TOS,eax
 268   urnext
 269 endcode
 270
 271 code: LROTATE-WORD  ( n0 n1 -- n0 rol n1 )
 272   pop   eax
 273   and   cl,31
 274   rol   ax,cl
 275   ld    TOS,eax
 276   urnext
 277 endcode
 278
 279 code: RROTATE-WORD  ( n0 n1 -- n0 ror n1 )
 280   pop   eax
 281   and   cl,31
 282   ror   ax,cl
 283   ld    TOS,eax
 284   urnext
 285 endcode
 286
 287 code: LROTATE-BYTE  ( n0 n1 -- n0 rol n1 )
 288   pop   eax
 289   and   cl,31
 290   rol   al,cl
 291   ld    TOS,eax
 292   urnext
 293 endcode
 294
 295 code: RROTATE-BYTE  ( n0 n1 -- n0 ror n1 )
 296   pop   eax
 297   and   cl,31
 298   ror   al,cl
 299   ld    TOS,eax
 300   urnext
 301 endcode
 302
 303
 304 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 305 code: +  ( n0 n1 -- n0+n1 )
 306   pop   eax
 307   add   TOS,eax
 308   urnext
 309 endcode
 310
 311 code: -  ( n0 n1 -- n0-n1 )
 312   pop   eax
 313   ;; EAX=n0
 314   ;; TOS=n1
 315   sub   eax,TOS
 316   mov   TOS,eax
 317   urnext
 318 endcode
 319
 320
 321 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 322 code: 2*  ( n -- n*2 )
 323   shl   TOS,1
 324   urnext
 325 endcode
 326
 327 code: 2/  ( n -- n/2 )
 328   sar   TOS,1
 329   urnext
 330 endcode
 331
 332
 333 code: 2U*  ( n -- n*2 )
 334   shl   TOS,1
 335   urnext
 336 endcode
 337
 338 code: 2U/  ( n -- n/2 )
 339   shr   TOS,1
 340   urnext
 341 endcode
 342
 343
 344 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 345 code: SGN  ( n -- -1/0/1 )
 346   jecxz @f
 347   test  TOS,TOS
 348   ld    TOS,1
 349   jr    ns,@f
 350   ld    TOS,-1
 351 @@:
 352   urnext
 353 endcode
 354
 355 ;; avoid overflows
 356 code: NCMP  ( n0 n1 -- -1/0/1 )
 357   pop   eax
 358   cp    eax,TOS
 359   ld    TOS,0
 360   jr    z,@f
 361   ld    TOS,1
 362   jr    g,@f
 363   ld    TOS,-1
 364 @@:
 365   urnext
 366 endcode
 367
 368 ;; avoid overflows
 369 code: UCMP  ( u0 u1 -- -1/0/1 )
 370   pop   eax
 371   cp    eax,TOS
 372   ld    TOS,0
 373   jr    z,@f
 374   ld    TOS,1
 375   jr    nc,@f
 376   ld    TOS,-1
 377 @@:
 378   urnext
 379 endcode
 380
 381 code: NEGATE  ( n -- -n )
 382   neg   TOS
 383   urnext
 384 endcode
 385
 386 code: ABS  ( n -- |n| )
 387   test  TOS,TOS
 388   jr    ns,@f
 389   neg   TOS
 390 @@:
 391   urnext
 392 endcode
 393
 394
 395 code: UMIN  ( u0 u1 -- umin )
 396   pop   eax
 397   ;; EAX=u0
 398   ;; TOS=u1
 399   cp    eax,TOS
 400   cmovc TOS,eax
 401   urnext
 402 endcode
 403
 404 code: UMAX  ( u0 u1 -- umax )
 405   pop   eax
 406   ;; EAX=u0
 407   ;; TOS=u1
 408   cp    TOS,eax
 409   cmovc TOS,eax
 410   urnext
 411 endcode
 412
 413 code: MIN  ( n0 n1 -- nmin )
 414   pop   eax
 415   ;; EAX=u0
 416   ;; TOS=u1
 417   cp    TOS,eax
 418   cmovg TOS,eax
 419   urnext
 420 endcode
 421
 422 code: MAX  ( n0 n1 -- nmax )
 423   pop   eax
 424   ;; EAX=u0
 425   ;; TOS=u1
 426   cp    TOS,eax
 427   cmovl TOS,eax
 428   urnext
 429 endcode
 430
 431
 432 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 433 code: C>S  ( n-8-bit -- n )
 434   movsx TOS,cl
 435   urnext
 436 endcode
 437
 438 code: C>U  ( u-8-bit -- u )
 439   movzx TOS,cl
 440   urnext
 441 endcode
 442
 443 code: W>S  ( n-16-bit -- n )
 444   movsx TOS,cx
 445   urnext
 446 endcode
 447
 448 code: W>U  ( u-16-bit -- u )
 449   movzx TOS,cx
 450   urnext
 451 endcode
 452
 453
 454 ;; with clamping
 455 code: S>C  ( n -- n-8-bit )
 456   test  TOS,TOS
 457   jr    s,.negative
 458   cp    TOS,0x80
 459   jr    c,.done
 460   ld    cl,0x7f
 461   jr    .done
 462 .negative:
 463   cp    TOS,0xffffff80
 464   jr    nc,.done
 465   ld    cl,0x80
 466 .done:
 467   movsx TOS,cl
 468   urnext
 469 endcode
 470
 471 ;; with clamping
 472 code: U>C  ( u -- u-8-bit )
 473   cp    TOS,0x100
 474   jr    c,.done
 475   ld    cl,0xff
 476 .done:
 477   movzx TOS,cl
 478   urnext
 479 endcode
 480
 481
 482 ;; with clamping
 483 code: S>W  ( n -- n-16-bit )
 484   test  TOS,TOS
 485   jr    s,.negative
 486   cp    TOS,0x8000
 487   jr    c,.done
 488   ld    cx,0x7fff
 489   jr    .done
 490 .negative:
 491   cp    TOS,0xffff8000
 492   jr    nc,.done
 493   ld    cx,0x8000
 494 .done:
 495   movsx TOS,cx
 496   urnext
 497 endcode
 498
 499 ;; with clamping
 500 code: U>W  ( u -- u-16-bit )
 501   cp    TOS,0x10000
 502   jr    c,.done
 503   mov   cx,0xffff
 504 .done:
 505   movzx TOS,cx
 506   urnext
 507 endcode
 508
 509
 510 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 511 ;; 32-bit integer hash
 512 ;; http://burtleburtle.net/bob/hash/integer.html
 513 (*
 514 code: U32HASH  ( u -- u )
 515   ;; a -= (a<<6);
 516   ld    eax,TOS
 517   shl   eax,6
 518   sub   TOS,eax
 519   ;; a ^= (a>>17);
 520   ld    eax,TOS
 521   shr   eax,17
 522   xor   TOS,eax
 523   ;; a -= (a<<9);
 524   ld    eax,TOS
 525   shl   eax,9
 526   sub   TOS,eax
 527   ;; a ^= (a<<4);
 528   ld    eax,TOS
 529   shl   eax,4
 530   xor   TOS,eax
 531   ;; a -= (a<<3);
 532   ld    eax,TOS
 533   shl   eax,3
 534   sub   TOS,eax
 535   ;; a ^= (a<<10);
 536   ld    eax,TOS
 537   shl   eax,10
 538   xor   TOS,eax
 539   ;; a ^= (a>>15);
 540   ld    eax,TOS
 541   shr   eax,15
 542   xor   TOS,eax
 543   urnext
 544 endcode
 545 *)
 546
 547 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 548 ;; 32-bit integer hash
 549 ;; http://burtleburtle.net/bob/hash/integer.html
 550 code: U32HASH  ( u -- u )
 551   ;; a = (a+0x7ed55d16)+(a<<12);
 552   ld    eax,TOS
 553   add   TOS,0x7ed55d16
 554   shl   eax,12
 555   add   TOS,eax
 556   ;; a = (a^0xc761c23c)^(a>>19);
 557   ld    eax,TOS
 558   xor   TOS,0xc761c23c
 559   shr   eax,19
 560   xor   TOS,eax
 561   ;; a = (a+0x165667b1)+(a<<5);
 562   ld    eax,TOS
 563   add   TOS,0x165667b1
 564   shl   eax,5
 565   add   TOS,eax
 566   ;; a = (a+0xd3a2646c)^(a<<9);
 567   ld    eax,TOS
 568   add   TOS,0xd3a2646c
 569   shl   eax,9
 570   xor   TOS,eax
 571   ;; a = (a+0xfd7046c5)+(a<<3);
 572   ld    eax,TOS
 573   add   TOS,0xfd7046c5
 574   shl   eax,3
 575   add   TOS,eax
 576   ;; a = (a^0xb55a4f09)^(a>>16);
 577   ld    eax,TOS
 578   xor   TOS,0xb55a4f09
 579   shr   eax,16
 580   xor   TOS,eax
 581   urnext
 582 endcode
 583
 584 ;; fold 32-bit hash to 16-bit hash
 585 code: UHASH32->16  ( u32hash -- u16hash )
 586   ld    eax,TOS
 587   shr   eax,16
 588   add   ecx,eax
 589   movzx TOS,cx
 590   urnext
 591 endcode
 592
 593 code: UHASH16->8  ( u16hash -- u8hash )
 594   add   cl,ch
 595   movzx TOS,cl
 596   urnext
 597 endcode
 598
 599 code: UHASH32->8  ( u32hash -- u8hash )
 600   ld    eax,TOS
 601   shr   eax,16
 602   add   ecx,eax
 603   add   cl,ch
 604   movzx TOS,cl
 605   urnext
 606 endcode