libs/disx86/disx86.f

   1 \ DEBUG-INFO-OFF
   2
   3 \ 80386 Disassembler
   4 \ Andrew McKewan, April 1994
   5 \ Tom Zimmer,  05/18/94 port to Win32f
   6 \ Modified to word in decimal 08/03/94 10:04 tjz
   7 \ 06-??-1995 SMuB NEXT sequence defined in FKERNEL
   8 \ 06-21-1995 SMuB removed redundant COUNT calls from txb, lxs.
   9 \ 04-??-1997 Extended by C.L. to include P6 and MMX instructions
  10 \ 26-07-2001 Fixed MVX (Maksimov)
  11 \ 11-05-2004 Fixed FDA and CMV (Serguei Jidkov)
  12 \ 01-19-2015 Jos, Extended for XMM instructions (adaptation by Ketmar Dark)
  13 \ 25-08-2020 Fixed bug in ENTER (Ketmar Dark)
  14
  15
  16 ;; hide it all
  17 vocabulary disx86
  18 also disx86 definitions
  19
  20
  21 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22 260 constant maxstring
  23
  24 : cincr  ( n -- [n] = [n]+1 )
  25   1 swap c+!
  26 ;
  27
  28 : c+place  ( ch c-addr -- )
  29   dup cincr ccount + 1- c!
  30 ;
  31
  32 : place  ( a u dest -- )
  33 \ put a u at dest as counted string
  34   2dup 2>r  1+ swap move              \ move first to handle overlap
  35   2r> c!                              \ then store count character
  36 ;
  37
  38 : +place  ( a u dest -- )
  39 \ append string a u to counted string
  40   2dup 2>r                            \   at dest
  41   ccount + swap move
  42   2r> c+!
  43 ;
  44
  45 [IFNDEF] dabs
  46 : (dabs)  ( d -- )
  47   dup 0< if
  48     bitnot swap bitnot
  49     ;; ( dhi dlo )
  50     dup 1+         ;; ( dhi dlo dlo+1 )
  51     over           ;; ( dhi dlo dlo+1 dlo )
  52     u<             ;; ( dhi dlo flag )
  53     >r 1+ swap r>  ;; ( dlo+1 dhi flag )
  54     if 1+ endif
  55   endif
  56 ;
  57 [ELSE]
  58 alias dabs (dabs)
  59 [ENDIF]
  60
  61 : (d.) ( d -- addr len )
  62   tuck (dabs) <# #s rot sign #>
  63 ;
  64
  65 : h.r ( u n -- )
  66   base @ >r hex u.r r> base !
  67 ;
  68
  69 : h.n ( n1 n2 -- )
  70   base @ >r hex >r
  71   0 <# r>
  72   dup 0 > if
  73     0 do # loop
  74   else
  75     drop
  76   endif
  77   #> type
  78   r> base !
  79 ;
  80
  81
  82 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  83 0 value default-16bit?
  84
  85 : default-16bit ( -- )  true to default-16bit? ;
  86 : default-32bit ( -- )  false to default-16bit? ;
  87
  88 ' drop defered show-name   ( cfa -- )      \ display nearest symbol
  89
  90 0 value base-addr
  91
  92 \ use my z80-like syntax?
  93 true value k8syntax?
  94 true value k8syntax-regs?
  95
  96
  97 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  98 \ vocabulary disx86
  99 \ disx86 also definitions
 100
 101 decimal
 102
 103 : dis-wpeek ( addr -- addr word[addr] )
 104   dup w@
 105 ;
 106
 107 : dis-cfetch ( addr -- addr+1 byte[addr] )
 108   ccount
 109 ;
 110
 111 : dis-c@ ( addr -- byte[addr] )
 112   c@
 113 ;
 114
 115 create s-buf MAXSTRING allot
 116
 117
 118 : 0>s  ( -- )
 119   \ reset s-buf
 120   s-buf 0c!
 121 ;
 122
 123 : >s  ( a1 n1 -- )
 124   s-buf +place
 125 ;
 126
 127 \ strip trailing spaces from s-buf
 128 : s-xstrip ( -- )
 129   s-buf ccount
 130   begin
 131     dup
 132   while
 133     2dup + 1- c@ 32 > if
 134       swap 1- c! exit
 135     endif
 136     1-
 137   repeat
 138   swap 1- c!
 139 ;
 140
 141 : s-lastch-addr ( -- addr )
 142   s-buf ccount + 1-
 143 ;
 144
 145 : s-lastch@ ( -- ch )
 146   s-lastch-addr c@
 147 ;
 148
 149 : s-chop ( -- )
 150   s-buf ccount 1- 0 max swap 1- c!
 151 ;
 152
 153 : emit>s  ( c1 -- )
 154   s-buf c+place
 155 ;
 156
 157 : sspaces  ( n1 -- )
 158   dup 0 > if 0 do bl emit>s loop else drop endif
 159 ;
 160
 161 : sspace  ( -- )
 162   bl emit>s
 163 ;
 164
 165 : s-end-mnemo  ( -- )
 166   s-buf c@ 8 < if
 167     begin
 168       s-buf c@ 8 <
 169     while
 170       sspace
 171     repeat
 172   else
 173     \ want at least one space
 174     sspace
 175   endif
 176 ;
 177
 178 : s>  ( -- a1 n1 )
 179   s-buf ccount
 180 ;
 181
 182
 183 : (.s")  ( addr n -- )
 184   s-buf +place
 185 ;
 186
 187 : .s"  ( 'text' -- )
 188   [compile] "
 189   compile (.s")
 190 ; immediate
 191
 192
 193 : d.r>s  ( d w -- )
 194   >r (d.) r> over - sspaces >s
 195 ;
 196
 197 : disasm-s>d  ( n -- d )
 198   dup 0< if -1 else 0 endif
 199 ;
 200
 201 : .r>s  ( n w -- )
 202   >r  disasm-s>d  r>  d.r>s
 203 ;
 204
 205 : u.r>s  ( u w -- )
 206   0 swap d.r>s
 207 ;
 208
 209 : h.>s  ( u -- )
 210   base @ swap  hex 0 (d.) >s ( sspace )   base !
 211 ;
 212
 213 : h.r>s  ( n1 n2 -- )
 214   base @ >r hex >r
 215   \ 0 <# #s #>
 216   <#u #s #>
 217   r> over - sspaces >s
 218   r> base !
 219 ;
 220
 221 : 0h.r>s  ( n1 n2 -- )
 222   base @ >r hex >r
 223   \ 0 <# #s #>
 224   <#u #s #>
 225   r> over -
 226   dup 0> if
 227     0 do 48 emit>s loop
 228   else
 229     drop
 230   endif
 231   >s
 232   r> base !
 233 ;
 234
 235
 236 : ?.name>s  ( cfa -- )
 237   .s" 0x"
 238   8 0h.r>s
 239 ;
 240
 241 ' ?.name>s to show-name
 242
 243
 244
 245 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 246 ;;
 247 ;; main disassembler code
 248 ;;
 249
 250 false value size
 251 false value 16-bit-data
 252 false value 16-bit-addr
 253 false value prefix-op
 254 false value prefix-op-a16-d16  \ 0, 1, 2
 255 false value prefix-seg
 256 false value mmx-reg
 257 false value xmm-reg  \ for a 32-bit environment
 258 false value data-size-prefix    \ 0:don't need it; 1:"byte"; 2:"word"; 4:"dword"
 259 false value disp-as-reg-offset
 260
 261
 262 : .,  ( -- )  .s" ," ;
 263
 264 \ k8: use this as hex prefix
 265 : .#  ( -- )  .s" 0x" ;
 266
 267 : .,#  ( -- )  ., .# ;
 268 : .[ [char] [ emit>s ;
 269 : .] [char] ] emit>s ;
 270
 271 : .datasize  ( -- )
 272   data-size-prefix case
 273     1 of .s" byte " endof
 274     2 of .s" word " endof
 275     4 of .s" dword " endof
 276     16-bit-data prefix-op-a16-d16 2 = logand if 0 to prefix-op-a16-d16 .s" word " endif
 277   endcase
 278   0 to data-size-prefix
 279 ;
 280
 281 : .segpfx  ( -- )
 282   prefix-seg case
 283     1 of .s" cs:" endof
 284     2 of .s" ds:" endof
 285     3 of .s" ss:" endof
 286     4 of .s" es:" endof
 287     5 of .s" gs:" endof
 288     6 of .s" fs:" endof
 289   endcase
 290   false to prefix-seg
 291 ;
 292
 293 : set-data-size-with-bit ( bit -- )
 294   if
 295     16-bit-data if 2 else 4 endif
 296   else
 297     1
 298   endif
 299   to data-size-prefix
 300 ;
 301
 302 : @+  ( addr -- addr n )  dup cell+ swap @ ;
 303 : W@+ ( addr -- addr n )  dup 2+ swap W@ ;
 304
 305 : sext  ( byte -- n )  dup $80 and if $FFFFFF00 or then ;
 306
 307 : mod/sib
 308   ( mod-r-r/m -- r/m r mod ) \ r including general, special, segment, MMX
 309   ( mod-op-r/m -- r/m op mod )
 310   ( s-i-b -- b i s )
 311     255 and 8 /mod 8 /mod
 312 ;
 313
 314 : ???   ( n1 -- )
 315   .s" ???" drop
 316 ;
 317
 318 : ss. ( n adr len w )  >r drop  swap r@ * +  r> >s ; \ sspace ;
 319
 320 : tttn ( code -- ) 15 and S" o nob aee nebea s nsp npl geleg " 2 ss. s-xstrip ;
 321
 322 : sreg  ( sreg -- )  3 rshift 7 and S" escsssdsfsgsXXXX" 2 ss. ;
 323 : creg  ( eee --  )  3 rshift 7 and S" cr0???cr2cr3cr4?????????" 3 ss. ;
 324 : dreg  ( eee --  )  3 rshift 7 and S" dr0dr1dr2dr3??????dr6dr7" 3 ss. ;
 325 : treg  ( eee --  )  3 rshift 7 and S" ?????????tr3tr4tr5tr6tr7" 3 ss. ; \ obsolete
 326 : mreg  ( n -- )  7 and S" mm0mm1mm2mm3mm4mm5mm6mm7" 3 ss. ;
 327
 328 : reg8  ( n -- )  7 and S" alcldlblahchdhbh" 2 ss. ;
 329 : reg16 ( n -- )  7 and S" axcxdxbxspbpsidi" 2 ss. ;
 330 : reg32 ( n -- )
 331   7 and
 332   k8syntax-regs? if
 333     dup 1 = if .s" TOS" drop exit endif
 334     dup 5 = if .s" ERP" drop exit endif
 335     dup 6 = if .s" EIP" drop exit endif
 336   endif
 337   S" eaxecxedxebxespebpesiedi" 3 ss.
 338 ;
 339 : .xmmreg  ( n -- )  7 and S" xmm0xmm1xmm2xmm3xmm4xmm5xmm6xmm7" 4 ss. ; \ 1
 340 : reg16/32  ( n -- )
 341   16-bit-data if reg16 else reg32 then
 342 ;
 343 : reg  ( a n -- a )
 344   xmm-reg if
 345     .xmmreg
 346   else
 347     mmx-reg if
 348       mreg
 349     else
 350       size
 351       if reg16/32 else reg8 then
 352     then
 353   endif
 354 ;
 355
 356 : [base16]  ( r/m -- )
 357   .datasize .segpfx
 358   4- S" [si][di][bp][bx]" 4 ss.
 359   \ r/m = 4 , 5 , 6 , 7
 360 ;
 361
 362 : [ind16]  ( r/m -- )
 363   .datasize .segpfx
 364   S" [bx+si][bx+di][bp+si][bp+di]" 7 ss.
 365   \ r/m = 0  ,   1  ,   2  ,   3
 366 ;
 367
 368 : [reg16] ( r/m -- )
 369   dup 4 < if [ind16] else [base16] then
 370 ;
 371
 372 : [reg32]  ( n -- )
 373   .datasize .segpfx
 374   7 and
 375   k8syntax-regs? if
 376     dup 1 = if .s" [TOS]" drop exit endif
 377     dup 5 = if .s" [ERP]" drop exit endif
 378     dup 6 = if .s" [EIP]" drop exit endif
 379   endif
 380   S" [eax][ecx][edx][ebx][esp][ebp][esi][edi]" 5 ss.
 381 ;
 382
 383 \ : [reg]    ( r/m -- )  16-bit-addr
 384 \                        if   [reg16]
 385 \                        else [reg32]
 386 \                        then sspace ;
 387
 388 \ : [reg] ( n -- )
 389 \        7 and
 390 \        16-bit-addr
 391 \        if      S" [bx+si] [bx+di] [bp+si] [bp+di] [si] [di] [bp] [bx]"
 392 \                rot 0
 393 \                ?do     bl skip bl scan
 394 \                loop    bl skip 2dup bl scan nip - >s 2 sspaces
 395 \        else    S" [eax][ecx][edx][ebx][esp][ebp][esi][edi]" 5 ss. sspace
 396 \        then    ;
 397
 398 (*
 399 : [reg*2]  ( i -- )  .datasize S" [eax*2][ecx*2][edx*2][ebx*2][XXX*2][ebp*2][esi*2][edi*2]" 7 ss. ;
 400 : [reg*4]  ( i -- )  .datasize S" [eax*4][ecx*4][edx*4][ebx*4][XXX*4][ebp*4][esi*4][edi*4]" 7 ss. ;
 401 : [reg*8]  ( i -- )  .datasize S" [eax*8][ecx*8][edx*8][ebx*8][XXX*8][ebp*8][esi*8][edi*8]" 7 ss. ;
 402 *)
 403
 404 : [reg*n] ( i n -- )
 405   over 7 and 4 = if
 406     nip .datasize .segpfx .s" [XXX]"
 407   else
 408     swap [reg32]
 409   endif
 410   s-chop
 411   [char] * emit>s
 412   [char] 0 + emit>s
 413   .]
 414 ;
 415
 416 : [reg*2]  ( i -- )  2 [reg*n] ;
 417 : [reg*4]  ( i -- )  4 [reg*n] ;
 418 : [reg*8]  ( i -- )  8 [reg*n] ;
 419
 420 : [index-has-scaled]  ( sib -- add-disp-flag )
 421   mod/sib over 4 =
 422   if
 423     \ no esp scaled index
 424     2drop
 425     0
 426   else
 427     s-lastch@ [char] ] = if s-lastch-addr s-chop else 0 endif >r
 428     case ( s )
 429       0 of [reg32] endof
 430       1 of [reg*2] endof
 431       2 of [reg*4] endof
 432       3 of [reg*8] endof
 433     endcase
 434     r> ?dup if [char] + swap c! endif
 435     1
 436   then
 437   nip
 438 ;
 439
 440 : [index]  ( sib -- )
 441   [index-has-scaled] drop
 442 ;
 443
 444 : .+sign  ( val -- )  0>= if [char] + emit>s endif ;
 445
 446 : .dispnum  ( val -- )
 447   dup .+sign dup abs 10 < if 0 .r>s else .# 0 h.r>s endif
 448 ;
 449
 450 : (.dispvalue)  ( val -- )
 451   dup data-size-prefix or if .dispnum else drop endif
 452 ;
 453
 454 : .disp-value  ( val -- )
 455   \ disp-as-reg-offset if dup 0>= if .s" +" endif 0 .r>s else show-name endif
 456   data-size-prefix if .datasize .segpfx .[ endif
 457   disp-as-reg-offset if (.dispvalue) else show-name endif
 458   data-size-prefix if .] endif
 459 ;
 460
 461 : disp8-value  ( adr -- adr' value )
 462   dis-cfetch c>s
 463 ;
 464 : disp8  ( adr -- adr' )
 465   disp8-value .disp-value
 466 ;
 467
 468 : disp16-value  ( adr -- adr' value )
 469   w@+  ( w>s )
 470   dup 0x8000 u>= if 0x10000 - endif
 471 ;
 472 : disp16 ( adr -- adr' )
 473   disp16-value .disp-value
 474 ;
 475
 476 : disp32-value ( adr -- adr' value )
 477   @+ ( body> )
 478 ;
 479 : disp32 ( adr -- adr' )
 480   disp32-value .disp-value
 481 ;
 482
 483 : disp16/32  ( adr -- adr' )
 484   data-size-prefix if .datasize endif
 485   0 to data-size-prefix .segpfx .[ 16-bit-addr if disp16 else disp32 then .]
 486 ;
 487
 488 : imm8-nocomma  ( adr -- adr' )  .# dis-cfetch h.>s ;
 489 : imm8  ( adr -- adr' )  ., imm8-nocomma ;
 490
 491 \ : imm16  ( adr -- adr' )  .,# w@+ h.>s ;
 492
 493 : imm16/32-nocomma  ( adr -- adr' ) .# 16-bit-data if w@+ else @+ endif h.>s ;
 494 : imm16/32  ( adr -- adr' )  ., imm16/32-nocomma ;
 495
 496 : sib  ( adr mod -- adr )
 497   >r dis-cfetch tuck 7 and 5 = r@ 0= and
 498   if
 499     \ disp32 swap [index] rdrop  \ ebp base and mod = 00
 500     disp32-value >r
 501     swap [index-has-scaled] if
 502       \ need to add disp as scale
 503       s-chop
 504       r> (.dispvalue) \ r@ 0>= if [char] + emit>s endif r> 0 .r>s
 505       .]
 506     else
 507       rdrop
 508     endif
 509     rdrop
 510   else
 511     r> case ( mod )
 512       1 of disp8-value true  endof
 513       2 of disp32-value true endof
 514       otherwise drop false false
 515     endcase
 516     swap >r >r
 517     swap dup [reg32] [index]
 518     r> if
 519       s-chop
 520       r> (.dispvalue) \ r@ 0>= if [char] + emit>s endif r> 0 .r>s
 521       .]
 522     else
 523       rdrop
 524     endif
 525   then
 526 ;
 527
 528 \ : [*]  ( sib --  )
 529 \       .s" sib = " h.>s ;
 530
 531 \ : sib ( adr ext -- adr' )
 532 \ ?? wrong version
 533 \        swap dis-cfetch >r swap  6 rshift 3 and
 534 \        ?dup if 1 = if disp8 else disp32 then then
 535 \        r> dup 7 and dup 5 =
 536 \        if      drop [*]
 537 \        else    [reg]
 538 \                dup $38 and $20 =
 539 \                if      drop
 540 \                else    .s" [" dup 3 rshift reg32 -1 s-buf c+!
 541 \                        5 rshift 6 and
 542 \                        dup 6 = if 2+ then
 543 \                       ?dup if .s" *" 0 .r>s  then .s" ] "
 544 \                then
 545 \        then ;
 546
 547 : mod-reg-predisp ( -- )
 548   s-lastch@ [char] ] = if
 549     0 to data-size-prefix
 550     1 to disp-as-reg-offset
 551     s-chop
 552   endif
 553 ;
 554 : mod-reg-postdisp ( -- )
 555   disp-as-reg-offset if s-xstrip .] endif
 556 ;
 557
 558 : mod-r/m32  ( adr r/m mod -- adr' )
 559   dup 3 =
 560   if
 561     drop reg                \ mod = 3, register case
 562   else
 563     over 4 =
 564     if
 565       nip sib               \ r/m = 4, sib case
 566     else
 567       2dup 0= swap 5 = and  \ mod = 0, r/m = 5,
 568       if
 569         .s" dword " .segpfx .[
 570         0 to data-size-prefix
 571         2drop disp32        \ disp32 case
 572         s-xstrip .]
 573       else
 574         rot swap   >r
 575         \ case ( mod )
 576         \   1 of disp8  endof
 577         \   2 of disp32 endof
 578         \ endcase
 579         swap [reg32]
 580         \ moved here
 581         r>
 582         case ( mod )
 583           1 of mod-reg-predisp disp8  mod-reg-postdisp endof
 584           2 of mod-reg-predisp disp32 mod-reg-postdisp endof
 585         endcase
 586       then
 587     then
 588   then
 589 ;
 590
 591 : mod-r/m16  ( adr r/m mod -- adr' )
 592   2dup 0= swap 6 = and
 593   if
 594     2drop disp16  \ disp16 case
 595   else
 596     case ( mod )
 597       0 of [reg16]                  endof
 598       1 of swap disp8  swap [reg16] endof
 599       2 of swap disp16 swap [reg16] endof
 600       3 of reg                      endof
 601     endcase
 602   then
 603 ;
 604
 605 : mod-r/m  ( adr modr/m -- adr' )  mod/sib nip 16-bit-addr if mod-r/m16 else mod-r/m32 then ;
 606
 607 \ : mod-r/m  ( adr ext -- adr' )
 608 \        dup $C7 and 5 =                \ 32bit displacement
 609 \        16-bit-addr 0= and              \ and not 16bit addressing
 610 \        if      drop disp32 .s" [] "
 611 \                EXIT
 612 \        then
 613 \        dup $C0 and $C0 < over 7 and 4 = and
 614 \        16-bit-addr 0= and              \ and not 16bit addressing
 615 \        if      sib
 616 \                EXIT
 617 \        then
 618 \        dup $C7 and 6 =                \ 16bit displacement
 619 \        16-bit-addr and                 \ and 16bit addressing
 620 \        if      drop disp32 .s" [] "
 621 \                EXIT
 622 \        then
 623 \        dup 6 rshift
 624 \        case
 625 \          0 of  .s" 0 " [reg]  endof
 626 \          1 of  swap disp8  swap [reg]  endof
 627 \          2 of  swap disp32 swap [reg]  endof
 628 \          3 of  reg  endof
 629 \        endcase ;
 630
 631 : r/m8      0 to size mod-r/m ;
 632 : r/m16/32  1 to size mod-r/m ;
 633 : r/m16     true to 16-bit-data r/m16/32 ;
 634
 635 : r,r/m  ( adr -- adr' )  dis-cfetch dup 3 rshift reg ., mod-r/m ;
 636
 637 : r/m,r  ( adr -- adr' )  dis-cfetch dup >r mod-r/m ., r> 3 rshift reg ;
 638
 639 : r/m  ( adr op -- adr' )  2 and if r,r/m else r/m,r then ;
 640
 641
 642 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 643 ;; -------------------- Simple Opcodes --------------------
 644 ;;
 645
 646 : inh   ( -<name>- )
 647   create
 648   bl word
 649   \ count here place here count cell+ allot drop
 650   count cell+ allot drop
 651   does>
 652     count >s
 653     drop \ instruction code
 654     \ s-end-mnemo
 655 ;
 656
 657 inh clc  clc
 658 inh stc  stc
 659 inh cld  cld
 660 inh std  std
 661 \ inh rpnz repnz
 662 \ inh repz repz
 663 inh cbw  cbw
 664 inh cdq  cdq
 665 inh daa  daa
 666 inh das  das
 667 inh aaa  aaa
 668 inh aas  aas
 669 \ inh lock lock
 670 inh inb  insb
 671 inh osb  outsb
 672 inh sah  sahf
 673 inh lah  lahf
 674 \ inh aam  aam
 675 \ inh aad  aad
 676 inh hlt  hlt
 677 inh cmc  cmc
 678 inh xlt  xlat
 679 inh cli  cli
 680 inh sti  sti
 681
 682 inh clt clts
 683 inh inv invd
 684 inh wiv wbinvd
 685 inh ud2 ud2
 686 inh wmr wrmsr
 687 inh rtc rdtsc
 688 inh rmr rdmsr
 689 inh rpc rdpmc
 690 inh ems emms
 691 inh rsm rsm
 692 inh cpu cpuid
 693 inh ud1 ud1
 694 \ inh lss lss
 695 \ inh lfs lfs
 696 \ inh lgs lgs
 697
 698 \ inh d16: d16:
 699 \ inh a16: a16:
 700 \ inh es:  es:
 701 \ inh cs:  cs:
 702 \ inh ds:  ds:
 703 \ inh fs:  fs:
 704 \ inh gs:  gs:
 705
 706 : aam  ( adr code -- adr' )
 707   .s" aam" drop dis-cfetch drop
 708 ;
 709
 710 : aad  ( adr code -- adr' )
 711   .s" aad" drop dis-cfetch drop
 712 ;
 713
 714 : d16  ( adr code -- adr' )
 715   drop \ .s" d16:"
 716   true to 16-bit-data
 717   true to prefix-op
 718   2 to prefix-op-a16-d16
 719 ;
 720
 721 : a16  ( adr code -- adr' )
 722   drop \ .s" a16:"
 723   true to 16-bit-addr
 724   true to prefix-op
 725   1 to prefix-op-a16-d16
 726 ;
 727
 728 : rpz  ( adr code -- adr' )
 729   drop .s" repnz"
 730   true to prefix-op
 731 ;
 732
 733 : rep  ( adr code -- adr' )
 734   drop .s" repz"
 735   true to prefix-op
 736 ;
 737
 738 : lok  ( adr code -- adr' )  \ This should have error checking added
 739   drop .s" lock"
 740   true to prefix-op
 741 ;
 742
 743 : cs:  ( adr code -- adr' )
 744   drop \ .s" cs:"
 745   true to prefix-op
 746   1 to prefix-seg
 747 ;
 748
 749 : ds:  ( adr code -- adr' )
 750   drop \ .s" ds:"
 751   true to prefix-op
 752   2 to prefix-seg
 753 ;
 754
 755 : ss:  ( adr code -- adr' )
 756   drop \ .s" ss:"
 757   true to prefix-op
 758   3 to prefix-seg
 759 ;
 760
 761 : es:  ( adr code -- adr' )
 762   drop \ .s" es:"
 763   true to prefix-op
 764   4 to prefix-seg
 765 ;
 766
 767 : gs:  ( adr code -- adr' )
 768   drop \ .s" gs:"
 769   true to prefix-op
 770   5 to prefix-seg
 771 ;
 772
 773 : fs:  ( adr code -- adr' )
 774   drop \ .s" fs:"
 775   true to prefix-op
 776   6 to prefix-seg
 777 ;
 778
 779 : isd  ( adr code -- adr' )
 780   drop 16-bit-data
 781   if   .s" insw"
 782   else .s" insd"
 783   endif
 784   s-end-mnemo
 785 ;
 786
 787 : osd  ( adr code -- adr' )
 788   drop 16-bit-data
 789   if   .s" outsw"
 790   else .s" outsd"
 791   endif
 792   s-end-mnemo
 793 ;
 794
 795 : inp  ( addr code -- addr' )
 796   .s" in" s-end-mnemo
 797   1 and
 798   if
 799     16-bit-data
 800     if   .s" ax,"
 801     else .s" eax,"
 802     endif
 803   else    .s" al,"
 804   endif
 805   dis-cfetch h.>s
 806 ;
 807
 808 : otp  ( addr code -- addr' )
 809   .s" out" s-end-mnemo
 810   1 and
 811   if
 812     dis-cfetch h.>s 16-bit-data
 813     if   .s" ,ax"
 814     else .s" ,eax"
 815     endif
 816   else
 817     dis-cfetch h.>s .s" ,al"
 818   endif
 819 ;
 820
 821 : ind
 822   ( addr code -- addr' )
 823   .s" in" s-end-mnemo
 824   1 and
 825   if
 826     16-bit-data
 827     if   .s" ax,dx"
 828     else .s" eax,dx"
 829     endif
 830   else
 831     .s" al,dx"
 832   endif
 833 ;
 834
 835 : otd  ( addr code -- addr' )
 836   .s" out" s-end-mnemo
 837   1 and
 838   if
 839     16-bit-data
 840     if   .s" dx,ax"
 841     else .s" dx,eax"
 842     endif
 843   else
 844     .s" dx,al"
 845   endif
 846 ;
 847
 848 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 849 ;; -------------------- ALU Opcodes --------------------
 850 ;;
 851
 852 : .alu  ( n -- )
 853   7 and
 854   k8syntax? over 7 = logand
 855   if
 856     drop .s" cp"
 857   else
 858     S" addor adcsbbandsubxorcmp" 3 ss.
 859   endif
 860   s-end-mnemo
 861 ;
 862
 863 : alu  ( adr op -- adr' )
 864   \ k8: data size; comment it to avoid prefixes on [reg],reg
 865   dup 1 and set-data-size-with-bit
 866   dup 3 rshift .alu r/m
 867 ;
 868
 869 : ali  ( adr op -- adr' )
 870   >r dis-cfetch
 871   dup 3 rshift .alu
 872
 873   \ k8: data size
 874   r@ 1 and set-data-size-with-bit
 875
 876   mod-r/m
 877   r> 3 and ?dup
 878   if
 879     1 =
 880     if
 881       imm16/32
 882     else
 883       .,# dis-cfetch sext
 884       base @ >r hex
 885       0 .r>s  \ sspace
 886       r> base !
 887     then
 888   else
 889     imm8
 890   then
 891 ;
 892
 893 : ala  ( adr op -- adr' )
 894   dup 3 rshift .alu
 895   1 and if 0 reg imm16/32 else 0 reg8 imm8 then
 896 ;
 897
 898
 899 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 900 ;; -------------------- Test/Xchg --------------------
 901 ;;
 902
 903 : txb  ( addr op -- addr' )
 904   dup 3 and S" testtestxchgxchg" 4 ss. s-end-mnemo
 905   1 and
 906   if   1 to size r,r/m  \ SMuB removed COUNT
 907   else 0 to size r,r/m  \ SMuB removed COUNT
 908   endif
 909 ;
 910
 911 : tst  ( addr op -- addr' )
 912   .s" test" s-end-mnemo
 913   1 and if
 914     16-bit-data
 915     if   .s" ax"
 916     else .s" eax"
 917     endif
 918     imm16/32
 919   else
 920     .s" al" imm8
 921   endif
 922 ;
 923
 924 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 925 ;; -------------------- Inc/Dec ----------------------
 926 ;;
 927
 928 : inc  ( addr op -- addr' )  .s" inc" s-end-mnemo reg16/32 ;
 929 : dec  ( addr op -- addr' )  .s" dec" s-end-mnemo reg16/32 ;
 930
 931
 932 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 933 ;; -------------------- Push/Pop --------------------
 934 ;;
 935
 936 : psh  ( addr op -- addr' )  .s" push" s-end-mnemo reg16/32 ;
 937 : pop  ( addr op -- addr' )  .s" pop" s-end-mnemo reg16/32 ;
 938 : pss  ( addr op -- addr' )  .s" push" s-end-mnemo sreg ;
 939 : pps  ( addr op -- addr' )  .s" pop" s-end-mnemo sreg ;
 940
 941 : psa  ( addr op -- addr' )
 942   drop
 943   .s" pusha"
 944   16-bit-data ifnot .s" d" endif
 945   s-end-mnemo
 946 ;
 947
 948 : ppa  ( addr op -- addr' )
 949   drop
 950   .s" popa"
 951   16-bit-data ifnot .s" d" endif
 952   s-end-mnemo
 953 ;
 954
 955 : psi  ( addr op -- addr' )
 956   .s" push" s-end-mnemo
 957   2 and if imm8-nocomma else imm16/32-nocomma endif
 958 ;
 959
 960 : psf  ( addr op -- addr' )
 961   drop
 962   .s" pushf"
 963   16-bit-data ifnot .s" d" endif
 964   s-end-mnemo
 965 ;
 966
 967 : ppf  ( addr op -- addr' )
 968   drop
 969   .s" popf"
 970   16-bit-data ifnot .s" d" endif
 971   s-end-mnemo
 972 ;
 973
 974 : 8F.  ( addr op -- addr' )  drop dis-cfetch .s" pop" s-end-mnemo r/m16/32 ;
 975
 976 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 977 ;; -------------------- Move --------------------
 978 ;;
 979
 980 : mov-mnemo  ( -- )
 981   k8syntax? ifnot .s" mov" else .s" ld" endif
 982   s-end-mnemo
 983 ;
 984
 985 : mov  ( addr op -- addr' )  mov-mnemo r/m ;
 986
 987 : mri  ( addr op -- addr' ) ( mov register, imm )
 988   mov-mnemo
 989   dup 8 and if reg16/32 imm16/32 else reg8 imm8 endif
 990 ;
 991
 992 : mvi ( adr op -- adr' )   ( mov mem, imm )
 993   mov-mnemo
 994   \ drop
 995   1 and set-data-size-with-bit
 996   dis-cfetch mod-r/m size if imm16/32 else imm8 endif
 997 ;
 998
 999 : mrs  ( addr op -- addr' )
1000   ( 16-bit-data) true if
1001     mov-mnemo
1002     drop
1003     1 to size
1004     dis-cfetch dup mod-r/m .,
1005     sreg
1006   else
1007     ???
1008   endif
1009 ;
1010
1011 : msr  ( addr op -- addr' )
1012   ( 16-bit-data) true if
1013     mov-mnemo
1014     drop
1015     1 to size
1016     dis-cfetch dup sreg .,
1017     mod-r/m
1018   else
1019     ???
1020   endif
1021 ;
1022
1023 : mrc  ( addr op -- addr' )  mov-mnemo drop dis-cfetch dup reg32 ., creg ;
1024 : mcr  ( addr op -- addr' )  mov-mnemo drop dis-cfetch dup creg ., reg32 ;
1025 : mrd  ( addr op -- addr' )  mov-mnemo drop dis-cfetch dup reg32 ., dreg ;
1026 : mdr  ( addr op -- addr' )  mov-mnemo drop dis-cfetch dup dreg ., reg32 ;
1027 : mrt  ( addr op -- addr' )  mov-mnemo drop dis-cfetch dup reg32 ., treg ;  \ obsolete
1028 : mtr  ( addr op -- addr' )  mov-mnemo drop dis-cfetch dup treg ., reg32 ;  \ obsolete
1029
1030 : mv1  ( addr op -- addr' )
1031   mov-mnemo
1032   1 and if
1033     16-bit-data
1034     if   .s" ax,"
1035     else .s" eax,"
1036     endif
1037   else
1038     .s" al,"
1039   endif
1040   disp16/32
1041 ;
1042
1043 : mv2  ( addr op -- addr' )
1044   mov-mnemo
1045   \ @@@ Bh fixed bug here
1046   swap disp16/32 ., swap
1047   1 and if
1048     16-bit-data
1049     if   .s" ax"
1050     else .s" eax"
1051     endif
1052   else
1053     .s" al"
1054   endif
1055 ;
1056
1057 : lea  ( addr op -- addr' )  .s" lea" s-end-mnemo drop  1 to size r,r/m ;
1058
1059 : lxs  ( addr op -- addr' )
1060   1 and
1061   if   .s" lds"
1062   else .s" les"
1063   endif
1064   s-end-mnemo
1065   r,r/m  \ SMuB removed COUNT
1066 ;
1067
1068 : bnd  ( addr op -- addr' )  .s" bound" s-end-mnemo drop  1 to size r,r/m ;
1069
1070 : arp  ( addr op -- addr' )  .s" arpl" s-end-mnemo drop  1 to size true to 16-bit-data r,r/m ;
1071
1072 : mli  ( addr op -- addr' )
1073   1 to size
1074   .s" imul" s-end-mnemo
1075   $69 = if r,r/m imm16/32 else r,r/m imm8 endif
1076 ;
1077
1078 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1079 ;; -------------------- Jumps and Calls --------------------
1080 ;;
1081
1082 : rel8  ( addr op -- addr' )  dis-cfetch sext over + ( h.>s ) base-addr - show-name  ;
1083
1084 : rel16/32  ( addr op -- addr' ) 16-bit-addr if w@+ else @+ endif over + base-addr - show-name ;
1085
1086 : jsr  ( addr op -- addr' )  .s" call" s-end-mnemo drop rel16/32 ;
1087
1088 : jmp-jp-mnemo ( -- )  k8syntax? if .s" jp" else .s" jmp" endif ;
1089
1090 : jmp  ( addr op -- addr' )
1091   jmp-jp-mnemo
1092   s-end-mnemo
1093   2 and if rel8 else rel16/32 then
1094 ;
1095
1096 : .jxx  ( addr op -- addr' )
1097   k8syntax? if
1098     .s" jr" s-end-mnemo tttn .,
1099   else
1100     .s" j" tttn
1101     s-end-mnemo
1102   endif
1103 ;
1104
1105 : bra  ( addr op -- addr' )  .jxx rel8 ;
1106 : lup  ( addr op -- addr' ) 3 and S" loopnzloopz loop  jecxz " 6 ss. s-end-mnemo rel8 ;
1107 : lbr  ( addr op -- addr' ) .jxx rel16/32 ;
1108
1109 : rtn  ( addr op -- addr' )
1110   \ .s" ret near"
1111   .s" ret"
1112   1 and 0= if s-end-mnemo w@+ h.>s endif
1113 ;
1114
1115 : rtf  ( addr op -- addr' )
1116   .s" ret far"
1117   1 and 0= if sspace w@+ h.>s endif
1118 ;
1119
1120 : ent  ( addr op -- addr' )  drop .s" enter" s-end-mnemo w@+ 0 .r>s ., dis-cfetch 0 .r>s ;
1121
1122 : cis  ( addr op -- addr' )
1123   $9a =
1124   if   .s" call"
1125   else jmp-jp-mnemo
1126   endif
1127   s-end-mnemo
1128   16-bit-data
1129   if      .s" ptr16:16 "
1130   else    .s" ptr16:32 "
1131   endif
1132   dis-cfetch mod-r/m
1133 ;
1134
1135 : nt3  ( addr op -- addr' )  drop .s" int3" ;
1136
1137 : int  ( addr op -- addr' )  drop .s" int" s-end-mnemo dis-cfetch .# h.>s ;
1138
1139 inh lev leave
1140 inh irt  iret
1141 inh nto  into
1142
1143 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1144 ;; -------------------- string ops --------------------
1145 ;;
1146
1147 : str
1148   inh does>
1149     count >s
1150     1 and if .s" d" else .s" b" then
1151 ;
1152
1153 str mvs movs
1154 str cps cmps
1155 str sts stos
1156 str lds lods
1157 str scs scas
1158
1159 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1160 ;; -------------------- Exchange --------------------
1161 ;;
1162
1163 : xga  ( addr op -- addr' )
1164   dup 0x90 = if
1165     drop .s" nop"
1166   else
1167     .s" xchg" s-end-mnemo .s" eax," reg16/32
1168   endif
1169 ;
1170
1171 \ : xch  ( addr op -- addr' )  .s" xchg" s-end-mnemo drop r,r/m ;
1172
1173
1174 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1175 ;; -------------------- Shifts & Rotates --------------------
1176 ;;
1177
1178 : .shift ( n -- )  7 and S" rolrorrclrcrshlshrxxxsar" 3 ss. s-end-mnemo ;
1179
1180 : shf  ( addr op -- addr' )
1181   >r dis-cfetch
1182   dup 3 rshift .shift
1183   mod-r/m .,
1184   r> $D2 and
1185   case
1186     $C0 of dis-cfetch h.>s endof
1187     $D0 of 1 h.>s endof
1188     $D2 of 1 reg8 endof
1189   endcase
1190 ;
1191
1192 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1193 ;; -------------------- Extended Opcodes --------------------
1194 ;;
1195
1196 : wf1  ( addr -- addr' )
1197   1+ dis-cfetch dup
1198   $0c0 < if
1199     dup 3 rshift 7 and
1200     case
1201       6 of .s" fstenv" s-end-mnemo mod-r/m endof
1202       7 of .s" fstcw" s-end-mnemo .s" word " mod-r/m endof
1203       2drop 2- dup .s" fwait"
1204     endcase
1205   else
1206     drop 2- .s" fwait"
1207   endif
1208 ;
1209
1210 : wf2  ( addr -- addr' )
1211   1+ dis-cfetch
1212   case
1213     $e2 of .s" fclex" endof
1214     $e3 of .s" finit" endof
1215     swap 2- swap .s" fwait"
1216   endcase
1217 ;
1218
1219 : wf3  ( addr -- addr' )
1220   1+ dis-cfetch dup 3 rshift 7 and
1221   case
1222     6 of .s" fsave" s-end-mnemo mod-r/m endof
1223     7 of .s" fstsw" s-end-mnemo .s" word " mod-r/m endof
1224     2drop 2- dup .s" fwait"
1225   endcase
1226 ;
1227
1228 : wf4  ( addr -- addr' )
1229   1+ dis-cfetch $e0 =
1230   if
1231     .s" fstsw" s-end-mnemo .s" ax"
1232   else
1233     2- .s" fwait"
1234   endif
1235 ;
1236
1237 : fwaitops  ( addr op -- addr' )
1238   case
1239     $d9 of wf1 endof
1240     $db of wf2 endof
1241     $dd of wf3 endof
1242     $df of wf4 endof
1243     .s" fwait"
1244   endcase
1245 ;
1246
1247 : w8f  ( addr op -- addr' )
1248   drop dup c@ dup $f8 and $d8 =
1249   if fwaitops else drop .s" wait" endif
1250 ;
1251
1252 : falu1  ( xopcode -- )
1253   3 rshift 7 and
1254   S" fadd fmul fcom fcompfsub fsubrfdiv fdivr"
1255   5 ss. s-end-mnemo
1256 ;
1257
1258 : falu5  ( xopcode -- )
1259   3 rshift 7 and
1260   s" fadd fmul ???? ???? fsubrfsub fdivrfdiv "
1261   5 ss. s-end-mnemo
1262 ;
1263
1264 : sti.  ( op -- )  7 and .s" st(" 1 .r>s .s" )" ;
1265 \ : sti.  ( op -- )  7 and .s" st" 1 .r>s ;
1266
1267 \ : sti.st   ( op -- )
1268 \        7 and
1269 \        .s" ST(" 1 .r>s .s" )" .s"  ST " ;
1270
1271 : fd8  ( addr opcode -- addr' )
1272   drop dis-cfetch dup falu1
1273   dup $c0 <
1274   if
1275     .s" float " mod-r/m
1276   else
1277     dup $f0 and $d0 =
1278     if sti. else .s" st," sti. endif
1279   endif
1280 ;
1281
1282 : fdc  ( addr opcode -- addr' )
1283   drop dis-cfetch
1284   dup dup $c0 <
1285   if
1286     falu1 .s" double " mod-r/m
1287   else
1288     falu5 sti. .s" ,st"
1289   endif
1290 ;
1291
1292 : fnullary-f   ( op -- )
1293   $0f and dup 8 < if
1294     S" f2xm1  fyl2x  fptan  fpatan fxtractfprem1 fdecstpfincstp"
1295   else
1296     8-
1297     S" fprem  fyl2xp1fsqrt  fsincosfrndintfscale fsin   fcos   "
1298     endif
1299   7 ss.
1300   s-end-mnemo
1301 ;
1302
1303 : fnullary-e  ( op -- )
1304   $0f and dup 8 < if
1305     S" fchs   fabs   ???    ???    ftst   fxam   ???    ???    "
1306   else
1307     8-
1308     S" fld1   fldl2t fldl2e fldpi  fldlg2 fldln2 fldz   ???    "
1309   endif
1310   7 ss.
1311   s-end-mnemo
1312 ;
1313
1314 : fnullary  ( op -- )
1315   dup $ef > if fnullary-f EXIT endif
1316   dup $e0 < if
1317     $d0 = if
1318       .s" fnop"
1319     else
1320       dup ???
1321     endif
1322     EXIT
1323   endif
1324   fnullary-e
1325 ;
1326
1327
1328 \ : falu2   ( op -- )
1329 \        3 rshift 7 and
1330 \        S" fld    ???    fst    fstp   fldenv fldcw  fnstenvfnstcw "
1331 \        7 ss. ;
1332
1333 : fd9  ( addr op -- addr' )
1334   drop dis-cfetch dup $c0 < if
1335     dup $38 and
1336     case
1337       $00 of .s" fld" s-end-mnemo .s" float " endof
1338       $10 of .s" fst" s-end-mnemo .s" float " endof
1339       $18 of .s" fstp" s-end-mnemo .s" float " endof
1340       $20 of .s" fldenv" s-end-mnemo endof
1341       $28 of .s" fldcw" s-end-mnemo .s" word " endof
1342       $30 of .s" fnstenv" s-end-mnemo endof
1343       $38 of .s" fnstcw" s-end-mnemo .s" word " endof
1344       dup ??? s-end-mnemo
1345     endcase
1346     mod-r/m
1347   else
1348     dup $d0 < if
1349       dup $c8 <
1350       if .s" fld" else .s" fxch" endif
1351       s-end-mnemo
1352       sti.
1353     else
1354       fnullary
1355     endif
1356   endif
1357 ;
1358
1359 : falu3  ( op -- )
1360   3 rshift 7 and
1361   S" fiadd fimul ficom ficompfisub fisubrfidiv fidivr"
1362   6 ss.
1363   s-end-mnemo
1364 ;
1365
1366 : fcmova  ( op -- )
1367   3 rshift 7 and
1368   S" fcmovb fcmove fcmovbefcmovu ???    ???    ???    ???    "
1369   7 ss.
1370   s-end-mnemo
1371 ;
1372
1373 : fda  ( addr op -- )
1374   drop dis-cfetch dup $c0 <
1375   if
1376     dup falu3 .s" dword " mod-r/m
1377   else
1378     dup  \ 11-05-2004 Fixed FDA and CMV (Serguei Jidkov)
1379     $e9 = if
1380       .s" fucompp" drop
1381     else
1382       dup fcmova sti.
1383     endif
1384   endif
1385 ;
1386
1387 : falu7  ( op -- )
1388   3 rshift 7 and
1389   S" faddp fmulp ???   ???   fsubrpfsubp fdivrpfdivp "
1390   6 ss.
1391   s-end-mnemo
1392 ;
1393
1394 : fde  ( addr op -- addr' )
1395   drop dis-cfetch dup $c0 < if
1396     dup falu3 .s" word " mod-r/m
1397   else
1398     dup $d9 = if
1399       .s" fcompp" drop
1400     else
1401       dup falu7 sti.
1402     then
1403   endif
1404 ;
1405
1406 : fcmovb  ( op -- )
1407   3 rshift 7 and
1408   S" fcmovnb fcmovne fcmovnbefcmovnu ???     fucomi  fcomi   ???     "
1409   8 ss.
1410   s-end-mnemo
1411 ;
1412
1413 : fdb  ( addr op -- addr' )
1414   drop dis-cfetch dup $c0 < if
1415     dup $38 and case
1416       $00 of .s" fild" s-end-mnemo .s" dword " endof
1417       $10 of .s" fist" s-end-mnemo .s" dword " endof
1418       $18 of .s" fistp" s-end-mnemo .s" dword " endof
1419       $28 of .s" fld" s-end-mnemo .s" extended " endof
1420       $38 of .s" fstp" s-end-mnemo .s" extended " endof
1421       dup ??? s-end-mnemo
1422     endcase
1423     mod-r/m
1424   else
1425     case
1426       $e2 of .s" fnclex" endof
1427       $e3 of .s" fninit" endof
1428       dup dup fcmovb sti.
1429     endcase
1430   endif
1431 ;
1432
1433 : falu6  ( op -- )
1434   3 rshift 7 and
1435   S" ffree ???   fst   fstp  fucom fucomp???   ???   "
1436   6 ss.
1437   s-end-mnemo
1438 ;
1439
1440 : fdd  ( addr op -- addr' )
1441   drop dis-cfetch dup $c0 < if
1442     dup $38 and
1443     case
1444       $00 of .s" fld" s-end-mnemo .s" double "  endof
1445       $10 of .s" fst" s-end-mnemo .s" double "  endof
1446       $18 of .s" fstp" s-end-mnemo .s" double "  endof
1447       $20 of .s" frstor" s-end-mnemo endof
1448       $30 of .s" fnsave" s-end-mnemo endof
1449       $38 of .s" fnstsw" s-end-mnemo .s" word " endof
1450       dup ??? s-end-mnemo
1451     endcase
1452     mod-r/m
1453   else
1454     dup falu6 sti.
1455   endif
1456 ;
1457
1458 : fdf   ( addr op -- addr' )
1459   drop dis-cfetch dup $c0 < if
1460     dup $38 and
1461     case
1462       $00 of .s" fild" s-end-mnemo .s" word " endof
1463       $10 of .s" fist" s-end-mnemo .s" word " endof
1464       $18 of .s" fistp" s-end-mnemo .s" word " endof
1465       $20 of .s" fbld" s-end-mnemo .s" tbyte " endof
1466       $28 of .s" fild" s-end-mnemo .s" qword " endof
1467       $30 of .s" fbstp" s-end-mnemo .s" tbyte " endof
1468       $38 of .s" fistp" s-end-mnemo .s" qword " endof
1469       dup ??? s-end-mnemo
1470     endcase
1471     mod-r/m
1472   else
1473     dup $e0 = if
1474       .s" fnstsw" s-end-mnemo ." ax " drop
1475     else
1476       dup $38 and
1477       case
1478         $00 of .s" ffreep" s-end-mnemo sti. endof
1479         $28 of .s" fucomip" s-end-mnemo sti. endof
1480         $30 of .s" fcomip" s-end-mnemo sti. endof
1481         ???
1482       endcase
1483     endif
1484   endif
1485 ;
1486
1487 : gp6  ( addr op -- addr' )
1488   drop dis-cfetch dup 3 rshift
1489   7 and S" sldtstr lldtltr verrverw??? ???" 4 ss.
1490   s-end-mnemo
1491   r/m16
1492 ;
1493
1494 : gp7  ( addr op -- addr' )
1495   drop dis-cfetch dup 3 rshift
1496   7 and dup S" sgdt  sidt  lgdt  lidt  smsw  ???   lmsw  invlpg" 6 ss.
1497   s-end-mnemo
1498   4 and 4 = if r/m16 else r/m16/32 then
1499 ;
1500
1501 : btx.  ( n -- )
1502   3 rshift
1503   3 and S" bt btsbtrbtc" 3 ss.
1504   s-end-mnemo
1505 ;
1506
1507 : gp8  ( addr op -- addr' )
1508   drop dis-cfetch dup btx.
1509   r/m16/32 imm8
1510 ;
1511
1512 : lar  ( addr op -- addr' )  .s" lar" s-end-mnemo drop r,r/m ;
1513 : lsl  ( addr op -- addr' )  .s" lsl" s-end-mnemo drop r,r/m ;
1514 : lss  ( addr op -- addr' )  .s" lss" s-end-mnemo drop r,r/m ;
1515 : lfs  ( addr op -- addr' )  .s" lfs" s-end-mnemo drop r,r/m ;
1516 : lgs  ( addr op -- addr' )  .s" lgs" s-end-mnemo drop r,r/m ;
1517 : btx  ( addr op -- addr' )  btx. r/m,r ;
1518 : sli  ( addr op -- addr' )  .s" shld" s-end-mnemo drop r/m,r imm8 ;
1519 : sri  ( addr op -- addr' )  .s" shrd" s-end-mnemo drop r/m,r imm8 ;
1520 : slc  ( addr op -- addr' )  .s" shld" s-end-mnemo drop r/m,r .s" ,cl" ;
1521 : src  ( addr op -- addr' )  .s" shrd" s-end-mnemo drop r/m,r .s" ,cl" ;
1522 : iml  ( addr op -- addr' )  .s" imul" s-end-mnemo drop r,r/m ;
1523 : cxc  ( addr op -- addr' )  .s" cmpxchg" s-end-mnemo 1 and to size r/m,r ;
1524
1525 : mvx  ( addr op -- addr' )
1526   dup 8 and if .s" movsx" else .s" movzx" then
1527   s-end-mnemo
1528   1 and >r
1529   dis-cfetch mod/sib r>  \ size bit
1530   if
1531     swap reg32 .,  \ word to dword case
1532     3 = if reg16
1533     else
1534       .s" word "
1535       DROP DUP 1- C@  \ 26-07-2001 Fixed MVX (Maksimov)
1536       mod-r/m
1537     then
1538   else
1539     swap reg16/32 .,  \ byte case
1540     3 = if reg8
1541     else
1542       .s" byte "
1543       DROP DUP 1- C@  \ 26-07-2001 Fixed MVX (Maksimov)
1544       mod-r/m
1545     then
1546   then
1547 ;
1548
1549 : xad  ( addr op -- addr' )  .s" xadd" s-end-mnemo 1 and to size r/m,r ;
1550 : bsf  ( addr op -- addr' )  .s" bsf" s-end-mnemo drop r,r/m ;
1551 : bsr  ( addr op -- addr' )  .s" bsr" s-end-mnemo drop r,r/m ;
1552 : cx8  ( addr op -- addr' )  .s" cmpxchg8b" s-end-mnemo drop dis-cfetch r/m16/32 ;
1553 : bsp  ( addr op -- addr' )  .s" bswap" s-end-mnemo reg32 ;
1554
1555 : F6.  ( addr op -- addr' )
1556 \ ??
1557   >r dis-cfetch
1558   dup 3 rshift 7 and dup >r S" testXXXXnot neg mul imuldiv idiv" 4 ss.
1559   s-end-mnemo
1560   mod-r/m r> 0= if
1561     r@ 1 and if imm16/32 else imm8 then
1562   then
1563   rdrop
1564 ;
1565
1566 : FE.  ( addr op -- addr' )
1567   drop dis-cfetch
1568   dup 3 rshift 7 and
1569   case
1570     0 of .s" inc" endof
1571     1 of .s" dec" endof
1572     ???
1573   endcase
1574   s-end-mnemo
1575   r/m8
1576 ;
1577
1578 : FF.  ( addr op -- addr' )
1579   drop dis-cfetch
1580   dup 3 rshift 7 and
1581   case
1582     0 of .s" inc" s-end-mnemo endof
1583     1 of .s" dec" s-end-mnemo endof
1584     2 of .s" call" s-end-mnemo endof
1585     3 of .s" call" s-end-mnemo ." far " endof
1586     4 of jmp-jp-mnemo s-end-mnemo endof
1587     5 of jmp-jp-mnemo s-end-mnemo ." far " endof
1588     6 of .s" push " s-end-mnemo endof
1589     ??? s-end-mnemo
1590   endcase
1591   r/m16/32
1592 ;
1593
1594 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1595 ;; --------------------- conditional move ---------------
1596 ;;
1597
1598 : set  ( adr op -- ) .s" set" tttn s-end-mnemo dis-cfetch r/m8 ;
1599 : cmv  ( adr op -- ) .s" cmov" tttn s-end-mnemo ( dis-cfetch ) r,r/m ;  \ 11-05-2004 Fixed FDA and CMV (Serguei Jidkov)
1600
1601 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1602 ;; --------------------- MMX Operations -----------------
1603 ;;
1604
1605 : mmx-size  ( op -- )  3 and S" bwdq" 1 ss. ;
1606
1607 : upl  ( adr op -- adr' )  3 and S" punpcklbwpunpcklwdpunpckldq" 9 ss. s-end-mnemo r,r/m ;
1608 : uph  ( adr op -- adr' )  3 and S" punpckhbwpunpckhwdpunpckhdq" 9 ss. s-end-mnemo r,r/m ;
1609 : cgt  ( adr op -- adr' )  .s" pcmpgt" mmx-size s-end-mnemo r,r/m ;
1610 : ceq  ( adr op -- adr' )  .s" pcmpeq" mmx-size s-end-mnemo r,r/m ;
1611
1612 : psh. ( op -- )
1613   $30 and
1614   case
1615     $10 of .s" psrl" endof
1616     $20 of .s" psra" endof
1617     $30 of .s" psll" endof
1618   endcase
1619 ;
1620
1621 : gpa  ( adr op -- adr' )  >r dis-cfetch dup psh. r> mmx-size s-end-mnemo mreg imm8 ;
1622 : puw  ( adr op -- adr' )  .s" packusdw" s-end-mnemo drop r,r/m ;
1623 : psb  ( adr op -- adr' )  .s" packsswb" s-end-mnemo drop r,r/m ;
1624 : psw  ( adr op -- adr' )  .s" packssdw" s-end-mnemo drop r,r/m ;
1625
1626 : mpd  ( adr op -- adr' )
1627   .s" movd" s-end-mnemo
1628   drop dis-cfetch mod/sib
1629   swap mreg ., 3 =
1630   if reg32 else mod-r/m then
1631 ;
1632
1633 : mdp  ( adr op -- adr' )
1634   .s" movd" s-end-mnemo
1635   drop dis-cfetch mod/sib
1636   3 =
1637   if swap reg32 else swap mod-r/m then
1638   ., mreg
1639 ;
1640
1641 : mpq  ( adr op -- adr' )  .s" movq" s-end-mnemo drop r,r/m ;
1642 : mqp  ( adr op -- adr' )  .s" movq" s-end-mnemo drop r/m,r ;
1643 : shx  ( adr op -- adr' )  dup psh. mmx-size s-end-mnemo r,r/m ;
1644 : mll  ( adr op -- adr' )  .s" pmullw" s-end-mnemo drop r,r/m ;
1645 : mlh  ( adr op -- adr' )  .s" pmulhw" s-end-mnemo drop r,r/m ;
1646 : mad  ( adr op -- adr' )  .s" pmaddwd" s-end-mnemo drop r,r/m ;
1647 : sus  ( adr op -- adr' )  .s" psubus" mmx-size s-end-mnemo r,r/m ;
1648 : sbs  ( adr op -- adr' )  .s" psubs" mmx-size s-end-mnemo r,r/m ;
1649 : sub  ( adr op -- adr' )  .s" psub" mmx-size s-end-mnemo r,r/m ;
1650 : aus  ( adr op -- adr' )  .s" paddus" mmx-size s-end-mnemo r,r/m ;
1651 : ads  ( adr op -- adr' )  .s" padds" mmx-size s-end-mnemo r,r/m ;
1652 : add  ( adr op -- adr' )  .s" padd" mmx-size s-end-mnemo r,r/m ;
1653 : pad  ( adr op -- adr' )  .s" pand" s-end-mnemo drop r,r/m ;
1654 : por  ( adr op -- adr' )  .s" por" s-end-mnemo drop r,r/m ;
1655 : pan  ( adr op -- adr' )  .s" pandn" s-end-mnemo drop r,r/m ;
1656 : pxr  ( adr op -- adr' )  .s" pxor" s-end-mnemo drop r,r/m ;
1657
1658 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1659 ;; -------------------- Opcode Table --------------------
1660 ;;
1661
1662 : ops $10 0 do ' , loop ;
1663
1664 create op-table2
1665
1666 \     0   1   2   3    4   5   6   7    8   9   A   B    C   D   E   F
1667 ops  gp6 gp7 lar lsl  ??? ??? clt ???  inv wiv ??? ud2  ??? ??? ??? ???  \ 0
1668 ops  ??? ??? ??? ???  ??? ??? ??? ???  ??? ??? ??? ???  ??? ??? ??? ???  \ 1
1669 ops  mrc mrd mcr mdr  mrt ??? mtr ???  ??? ??? ??? ???  ??? ??? ??? ???  \ 2
1670 ops  wmr rtc rmr rpc  ??? ??? ??? ???  ??? ??? ??? ???  ??? ??? ??? ???  \ 3
1671
1672 ops  cmv cmv cmv cmv  cmv cmv cmv cmv  cmv cmv cmv cmv  cmv cmv cmv cmv  \ 4
1673 ops  ??? ??? ??? ???  ??? ??? ??? ???  ??? ??? ??? ???  ??? ??? ??? ???  \ 5
1674 ops  upl upl upl puw  cgt cgt cgt psb  uph uph uph psw  ??? ??? mpd mpq  \ 6
1675 ops  ??? gpa gpa gpa  ceq ceq ceq ems  ??? ??? ??? ???  ??? ??? mdp mqp  \ 7
1676
1677 ops  lbr lbr lbr lbr  lbr lbr lbr lbr  lbr lbr lbr lbr  lbr lbr lbr lbr  \ 8
1678 ops  set set set set  set set set set  set set set set  set set set set  \ 9
1679 ops  pss pps cpu btx  sli slc ??? ???  pss pps rsm btx  sri src ??? iml  \ A
1680 ops  cxc cxc lss btx  lfs lgs mvx mvx  ??? ud1 gp8 btx  bsf bsr mvx mvx  \ B
1681
1682 ops  xad xad ??? ???  ??? ??? ??? cx8  bsp bsp bsp bsp  bsp bsp bsp bsp  \ C
1683 ops  ??? shx shx shx  ??? mll ??? ???  sus sus ??? pad  aus aus ??? pan  \ D
1684 ops  ??? shx shx ???  ??? mlh ??? ???  sbs sbs ??? por  ads ads ??? pxr  \ E
1685 ops  ??? ??? shx shx  ??? mad ??? ???  sub sub sub ???  add add add ???  \ F
1686 \     0   1   2   3    4   5   6   7    8   9   A   B    C   D   E   F
1687
1688 : 0F.  ( adr code -- )
1689   drop dis-cfetch dup
1690   dup $70 and $50 $80 within to mmx-reg
1691   cells op-table2 + @execute
1692   0 to mmx-reg
1693   0 to xmm-reg
1694 ;
1695
1696 create op-table
1697
1698 \     0   1   2   3    4   5   6   7    8   9   A   B    C   D   E   F
1699 ops  alu alu alu alu  ala ala pss pps  alu alu alu alu  ala ala pss 0F.  \ 0
1700 ops  alu alu alu alu  ala ala pss pps  alu alu alu alu  ala ala pss pps  \ 1
1701 ops  alu alu alu alu  ala ala es: daa  alu alu alu alu  ala ala cs: das  \ 2
1702 ops  alu alu alu alu  ala ala ss: aaa  alu alu alu alu  ala ala ds: aas  \ 3
1703
1704 ops  inc inc inc inc  inc inc inc inc  dec dec dec dec  dec dec dec dec  \ 4
1705 ops  psh psh psh psh  psh psh psh psh  pop pop pop pop  pop pop pop pop  \ 5
1706 ops  psa ppa bnd arp  fs: gs: d16 a16  psi mli psi mli  inb isd osb osd  \ 6
1707 ops  bra bra bra bra  bra bra bra bra  bra bra bra bra  bra bra bra bra  \ 7
1708
1709 ops  ali ali ??? ali  txb txb txb txb  mov mov mov mov  mrs lea msr 8F.  \ 8
1710 ops  xga xga xga xga  xga xga xga xga  cbw cdq cis w8f  psf ppf sah lah  \ 9
1711 ops  mv1 mv1 mv2 mv2  mvs mvs cps cps  tst tst sts sts  lds lds scs scs  \ A
1712 ops  mri mri mri mri  mri mri mri mri  mri mri mri mri  mri mri mri mri  \ B
1713
1714 ops  shf shf rtn rtn  lxs lxs mvi mvi  ent lev rtf rtf  nt3 int nto irt  \ C
1715 ops  shf shf shf shf  aam aad ??? xlt  fd8 fd9 fda fdb  fdc fdd fde fdf  \ D
1716 ops  lup lup lup lup  inp inp otp otp  jsr jmp cis jmp  ind ind otd otd  \ E
1717 ops  lok ??? rpz rep  hlt cmc F6. F6.  clc stc cli sti  cld std FE. FF.  \ F
1718 \     0   1   2   3    4   5   6   7    8   9   A   B    C   D   E   F
1719
1720
1721 \ -------------------------- SSE2 Operations -------------------------------
1722
1723 \ -- swap reg fields in mod-r/m byte
1724 : swap-regs ( u1 -- u2 )
1725   \ LOCALS| mod-r/m |
1726   >r
1727   r@ ( mod-r/m ) 7 and 3 lshift
1728   r@ ( mod-r/m ) 3 rshift 7 and  or
1729   r@ ( mod-r/m ) $C0 and or
1730   rdrop
1731 ;
1732
1733 : ?swap-regs  ( u1 -- u2 )  DUP $C0 AND $C0 = IF swap-regs ENDIF ;
1734
1735 : modbyte  ( mod-r-r/m -- r/m r mod )   ( r including general, special, segment, MMX )
1736            ( mod-op-r/m -- r/m op mod )
1737   0xff AND 8 /MOD 8 /MOD
1738 ;
1739
1740 (* defined above
1741 : mod-r/m ( addr modr/m -- addr' )
1742   modbyte NIP ( [mod-r-r/m] -- r/m mod )
1743   dis.default-16bit? if mod-r/m16 else mod-r/m32 then
1744 ;
1745 *)
1746
1747 \ : ::imm8        ( addr -- addr' ) ., dis-cfetch h.>s  ;
1748 : stab          ( pos - )         s-buf c@ - 1 max sspaces ;
1749 : rstab         ( -- )            0x8 stab ;
1750 : R:sse2        ( -- )            true TO xmm-reg  false TO mmx-reg ;
1751 : R:reg         ( a n -- a )      7 and reg ;
1752 : 0f-prefix?    ( adr -- adr' flag ) dup 1+ c@ 0xF = ;
1753
1754 : xm-r/m,r      ( addr -- addr' ) rstab R:sse2 r/m,r ;
1755
1756 : xm-r,r/m      ( addr -- addr' ) rstab R:sse2 r,r/m ;
1757
1758 : r32/m,xmmr    ( addr -- addr' )                             \ the register is always XMM
1759                 rstab dis-cfetch ?swap-regs
1760                 true to xmm-reg
1761                 dup >r mod-r/m ., r> 3 rshift R:reg ;
1762
1763 : xmmr,r32/m    ( addr -- addr' )                             \ dest register is XMM
1764                 rstab true  to xmm-reg dis-cfetch dup 3 rshift R:reg
1765                 ., false to xmm-reg  r/m16/32 ;
1766
1767 : r,xmm         ( addr -- addr' )                              \ 1st=r32 2nd=XMM
1768                 rstab false to xmm-reg dis-cfetch dup 3 rshift
1769                 reg32 ., .xmmreg ;
1770
1771 : .cmp-sse ( adr -- adr' )
1772     dup 1+ dis-c@
1773      case
1774             0 of .s" cmpeq"    endof
1775             1 of .s" cmplt"    endof
1776             2 of .s" cmple"    endof
1777             3 of .s" cmpunord" endof
1778             4 of .s" cmpneq"   endof
1779             5 of .s" cmpnlt"   endof
1780             6 of .s" cmpnle"   endof
1781             7 of .s" cmpord"   endof
1782      endcase ;
1783
1784 : dis-cmpps ( adr -- adr' ) .cmp-sse .s" ps" xm-r,r/m 1+ ;
1785 : dis-cmpss ( adr -- adr' ) .cmp-sse .s" ss" xm-r,r/m 1+ ;
1786 : dis-cmppd ( adr -- adr' ) .cmp-sse .s" pd" xm-r,r/m 1+ ;
1787 : dis-cmpsd ( adr -- adr' ) .cmp-sse .s" sd" xm-r,r/m 1+ ;
1788
1789 : save-adr       ( adr flag -- flag adr adr  )   true swap dup  ;
1790 : restore-adr  ( true adr adr1 --  false adr adr adr )
1791    2drop nip false swap dup dup ;
1792
1793 : get-adrfl ( flag adr adr'  -- adrfl flag )
1794    rot
1795      if    nip true
1796      else  drop false
1797      then ;
1798
1799 : ?dis-3Aext  ( adr -- adr' )
1800     dis-cfetch
1801         case
1802           $40 of .s" dpps" xm-r,r/m  imm8  endof
1803           $41 of .s" dppd" xm-r,r/m  imm8  endof
1804         endcase
1805  ;
1806
1807 : ?dis-660f ( adr flag -- adr' flag )
1808    if save-adr 2 + dis-cfetch
1809       case
1810           $10 of .s" movupd"    xm-r,r/m        endof
1811           $11 of .s" movupd"    r32/m,xmmr      endof
1812           $12 of .s" movlpd"    xm-r,r/m        endof
1813           $13 of .s" movlpd"    r32/m,xmmr      endof
1814           $14 of .s" unpcklpd"  xmmr,r32/m      endof
1815           $15 of .s" unpckhpd"  xmmr,r32/m      endof
1816           $16 of .s" movhpd"    xm-r,r/m        endof
1817           $17 of .s" movhpd"    r32/m,xmmr      endof
1818           $28 of .s" movapd"    xm-r,r/m        endof
1819           $29 of .s" movapd"    r32/m,xmmr      endof
1820           $2e of .s" ucomisd"   xm-r,r/m        endof
1821           $2f of .s" comisd"    xm-r,r/m        endof
1822           $3a of  ?dis-3Aext                    endof
1823           $51 of .s" sqrtpd"    xm-r,r/m        endof
1824           $54 of .s" sqrtpd"    xm-r,r/m        endof
1825           $54 of .s" andpd"     xm-r,r/m        endof
1826           $55 of .s" andnpd"    xm-r,r/m        endof
1827           $56 of .s" orpd"      xm-r,r/m        endof
1828           $57 of .s" xorpd"     xm-r,r/m        endof
1829           $58 of .s" addpd"     xm-r,r/m        endof
1830           $59 of .s" mulpd"     xm-r,r/m        endof
1831           $5a of .s" cvtps2ps"  xm-r,r/m        endof
1832           $5b of .s" cvtps2dq"  xm-r,r/m        endof
1833           $5c of .s" subpd"     xm-r,r/m        endof
1834           $5d of .s" minpd"     xm-r,r/m        endof
1835           $5e of .s" divpd"     xm-r,r/m        endof
1836           $5f of .s" maxpd"     xm-r,r/m        endof
1837           $6e of .s" movd"      xm-r,r/m        endof
1838           $7e of .s" movd"      r32/m,xmmr      endof
1839           $6f of .s" movqda"    xmmr,r32/m      endof
1840           $7f of .s" movqda"    r32/m,xmmr      endof
1841           $c2 of  dis-cmppd                     endof
1842           $c6 of .s" shufpd"  xm-r,r/m  imm8  endof
1843           $d7 of .s" pmovmskb"  r,xmm           endof
1844                  restore-adr
1845         endcase  get-adrfl
1846    else   false    \ no 66 0f
1847    then ;
1848
1849 : ?dis-0f ( adr flag -- adr' flag )
1850    if  true swap 1+ dis-cfetch
1851       case
1852           $10 of .s" movups"    xm-r,r/m        endof
1853           $11 of .s" movups"    r32/m,xmmr      endof
1854           $14 of .s" unpcklps"  xmmr,r32/m      endof
1855           $15 of .s" unpckhps"  xmmr,r32/m      endof
1856           $28 of .s" movaps"    xm-r,r/m        endof
1857           $29 of .s" movaps"    r32/m,xmmr      endof
1858           $2a of .s" movaps"    xmmr,r32/m      endof
1859           $2e of .s" ucomisd"   xm-r,r/m        endof
1860           $2f of .s" comiss"    xm-r,r/m        endof
1861           $51 of .s" sqrtps"    xm-r,r/m        endof
1862           $52 of .s" rsqrtps"   xm-r,r/m        endof
1863           $53 of .s" rcpps"     xm-r,r/m        endof
1864           $54 of .s" andps"     xm-r,r/m        endof
1865           $55 of .s" andnps"    xm-r,r/m        endof
1866           $56 of .s" orps"      xm-r,r/m        endof
1867           $57 of .s" xorps"     xm-r,r/m        endof
1868           $58 of .s" addps"     xm-r,r/m        endof
1869           $59 of .s" mulps"     xm-r,r/m        endof
1870           $5a of .s" cvtps2pd"  xm-r,r/m        endof
1871           $5b of .s" cvtdq2ps"  xm-r,r/m        endof
1872           $5c of .s" subps"     xm-r,r/m        endof
1873           $5d of .s" minps"     xm-r,r/m        endof
1874           $5e of .s" divps"     xm-r,r/m        endof
1875           $5f of .s" maxps"     xm-r,r/m        endof
1876           $c2 of  dis-cmpps                     endof
1877           $c6 of .s" shufps"  xm-r,r/m    imm8  endof
1878               rot drop false nrot
1879         endcase   swap
1880    else   false    \ no 0f
1881    then ;
1882
1883 : ?dis-f20f ( adr flag -- adr' flag )
1884    if  save-adr 2 + dis-cfetch
1885       case
1886           $10 of .s" movsd"     xm-r,r/m        endof
1887           $11 of .s" movsd"     xm-r/m,r        endof
1888           $2a of .s" cvtsi2sd"  xmmr,r32/m      endof
1889           $51 of .s" sqrtsd"    xm-r,r/m        endof
1890           $52 of .s" rsqrtsd"   xm-r,r/m        endof
1891           $58 of .s" addsd"     xm-r,r/m        endof
1892           $59 of .s" mulsd"     xm-r,r/m        endof
1893           $5a of .s" cvtsd2ss"  xm-r,r/m        endof
1894           $5c of .s" subsd"     xm-r,r/m        endof
1895           $5d of .s" minsd"     xm-r,r/m        endof
1896           $5e of .s" divsd"     xm-r,r/m        endof
1897           $5f of .s" maxsd"     xm-r,r/m        endof
1898           $c2 of  dis-cmpsd                     endof
1899           $e6 of .s" cvtpd2dq"  xmmr,r32/m      endof
1900                  restore-adr
1901       endcase    get-adrfl
1902    else  false    \ no f2 0f
1903    then ;
1904
1905 : ?dis-f30f ( adr flag -- adr' flag )
1906    if  save-adr 2 + dis-cfetch \ f a0 a1
1907       case
1908         $10 of .s" movss"     xm-r,r/m endof
1909         $11 of .s" movss"     xm-r/m,r endof
1910         $2a of .s" cvtsi2ss"  xmmr,r32/m endof
1911         $51 of .s" sqrtss"    xm-r,r/m endof
1912         $52 of .s" rsqrtss"   xm-r,r/m endof
1913         $53 of .s" rcpss"     xm-r,r/m endof
1914         $58 of .s" addss"     xm-r,r/m endof
1915         $59 of .s" mulss"     xm-r,r/m endof
1916         $5a of .s" cvtss2sd"  xm-r,r/m endof
1917         $5b of .s" cvttps2dq" xm-r/m,r endof
1918         $5c of .s" subss"     xm-r,r/m endof
1919         $5d of .s" minss"     xm-r,r/m endof
1920         $5e of .s" divss"     xm-r,r/m endof
1921         $5f of .s" maxss"     xm-r,r/m endof
1922         $6f of .s" movdqu"    xm-r,r/m endof
1923         $7f of .s" movdqu"    r32/m,xmmr endof
1924         $c2 of dis-cmpss endof
1925         $e6 of .s" cvtdq2pd"  xmmr,r32/m endof
1926                  restore-adr
1927         endcase  get-adrfl
1928    else    false    \ no f3 0f
1929    then ;
1930
1931
1932 : pf-coded? ( adr -- adr' flag )
1933    dup c@
1934       case
1935         0x66 of 0f-prefix? ?dis-660f endof
1936         0xf2 of 0f-prefix? ?dis-f20f endof
1937         0xf3 of 0f-prefix? ?dis-f30f endof
1938       false swap
1939       endcase ;
1940
1941 : prefix-coded? ( adr -- adr' flag )
1942    pf-coded?
1943      if   true
1944      else dup dup c@ 0xf = ?dis-0f
1945               if    rot drop true
1946               else  drop false
1947               then
1948      then ;
1949
1950 \ ------------------- END OF SSE2 Operations -------------------------------
1951
1952
1953 : op-2byte 0xffff and , ' , ;
1954
1955 : inh-sized   ( -<name>- )
1956   create
1957   bl word
1958   count cell+ allot drop
1959   bl word
1960   count cell+ allot drop
1961   does>
1962     count
1963     default-16bit? if + count endif
1964     >s
1965     drop \ instruction code
1966     \ s-end-mnemo
1967 ;
1968
1969
1970 inh-sized cwd    cwd    cdw
1971 inh-sized cbwx   cbw    cwb
1972 inh-sized cmpsx  cmpsw  cmpsd
1973 inh-sized lodsx  lodsw  lodsd
1974 inh-sized movsx  movsw  movsd
1975 inh-sized stosx  stosw  stosd
1976 inh-sized scasx  scasw  scasd
1977 inh-sized insx   insw   insw
1978 inh-sized outsx  outsw  outsd
1979 inh-sized popax  popa   popad
1980 inh-sized pushax pusha  pushad
1981 inh-sized popfx  popf   popfd
1982 inh-sized pushfx pushf  pushfd
1983 inh-sized iretx  iretw  iret
1984
1985 \ FIXME: 16-bit is broken
1986 create 2byte-oplist
1987 0x9966 op-2byte cwd
1988 0x9866 op-2byte cbwx
1989 0xA566 op-2byte movsx
1990 0xA766 op-2byte cmpsx
1991 0xAB66 op-2byte stosx
1992 0xAF66 op-2byte scasx
1993 0xAD66 op-2byte lodsx
1994 0x6D66 op-2byte insx
1995 0x6F66 op-2byte outsx
1996 0x6166 op-2byte popax
1997 0x6066 op-2byte pushax
1998 0x9D66 op-2byte popfx
1999 0x9C66 op-2byte pushfx
2000 0xCF66 op-2byte iretx
2001 0 ,
2002
2003 : (dis-op-init-flags)  ( -- )
2004   false to data-size-prefix
2005   false to disp-as-reg-offset
2006   false to mmx-reg
2007   false to xmm-reg
2008 ;
2009
2010 : (dis-op-done-flags)  ( -- )
2011   prefix-op ifnot
2012     default-16bit? dup to 16-bit-data to 16-bit-addr
2013     false to prefix-seg
2014     false to prefix-op-a16-d16
2015   endif
2016 ;
2017
2018 : (dis-known-wtable)  ( addr -- addr' true // addr false )
2019   dis-wpeek 2byte-oplist ( addr wp tbladdr )
2020   begin 2dup w@ - while dup w@ while 2 +cells repeat
2021   nip dup w@ if
2022     \ dis-wpeek bswap-word 1 and to size
2023     cell+ @ 0 swap execute 2+ true
2024   else
2025     drop false
2026   endif
2027 ;
2028
2029 : (dis-op-intr)  ( adr -- adr' )
2030   0>s
2031   false to prefix-op  \ SMuB
2032   (dis-known-wtable) ifnot
2033     dis-cfetch
2034     dup 1 and to size
2035     dup cells op-table +  @execute
2036   endif
2037 ;
2038
2039 : dis-op  ( adr -- adr' )
2040   (dis-op-init-flags)
2041   6 for
2042     (dis-op-intr) prefix-op ifnot break endif
2043     prefix-seg prefix-op-a16-d16 or ifnot break endif
2044   endfor
2045   (dis-op-done-flags)
2046 ;
2047
2048
2049 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2050 ;; high-level stuff
2051 ;;
2052
2053 : .s-buf  ( -- )  s-buf ccount type ;
2054
2055 0 value next-inst
2056
2057 ;; on error, "next-inst" is unchanged
2058 : (.one-inst)  ( -- errorflag )
2059   next-inst   ;; addr
2060   dup dis-op  ;; addr eaddr
2061   over base-addr - .hex8 space  ;; type address
2062   swap 2dup - 16 u> if 2drop true endif
2063   over to next-inst  ;; update next instruction address
2064   2dup do i c@ .hex2 space loop
2065   - 12 swap - 3 * spaces
2066   s-buf ccount type
2067   false
2068 ;
2069
2070 : .inst  ( adr -- adr' )
2071   to next-inst
2072   (.one-inst) if 666 throw endif
2073   next-inst
2074 ;
2075
2076
2077 \ @@@ BH fixed bugs in dis-xx
2078
2079
2080 \ : dis-db ( adr -- adr' )  0>s .s" db " dis-cfetch h.>s .s-buf ;
2081 \ : dis-dw ( adr -- adr' )  0>s .s" dw " W@+ h.>s .s-buf ;
2082 \ : dis-dd ( adr -- adr' )  0>s .s" dd " @+ h.>s .s-buf ;
2083 \ : dis-ds ( adr -- adr' )  0>s .s" string " $22 emit>s ccount 2dup >s + $22 emit>s .s-buf ;
2084
2085
2086 previous definitions
2087
2088 : disasm-one  ( adr -- adr' )
2089   disx86:.inst
2090 ;
2091
2092 : disasm-word  ( cfa -- )
2093   dup word-type?
2094   ;; ( cfa type )
2095   case
2096     word-type-forth of  ." forth word" cr endof
2097     word-type-const of  ." constant" cr endof
2098     word-type-var   of  ." variable" cr endof
2099     word-type-value of  ." value" cr endof
2100     word-type-defer of  ." defer" cr endof
2101     word-type-does  of  ." doer" cr endof
2102     \ looks like a code word
2103     ;; ( cfa type )
2104     endcr ." === DISASM FOR '" over cfa->nfa id. ." '===\n"  ;; '
2105     ;; ( cfa type )
2106     over dup word-code-end
2107     ;; ( cfa type cfa endaddr )
2108     ?dup if
2109       ;; ( cfa type cfa endaddr )
2110       swap to disx86:next-inst
2111       begin
2112         ;; ( cfa type codeend )
2113         disx86:next-inst over u<
2114       while
2115         disx86:(.one-inst) cr
2116         if 666 throw endif
2117       repeat
2118       ;; ( cfa type codeend )
2119     endif
2120     drop
2121     endcr ." -------------------\n"
2122   endcase
2123   drop
2124 ;