Diff for /gforth/arch/386/asm.fs between versions 1.1 and 1.4

version 1.1, 2000/07/11 20:28:50 version 1.4, 2000/07/30 19:56:05
Line 1 Line 1
 \ asm386.fth  \         *** Assembler for the Intel i486 ***         07nov92py
 \ Andrew McKewan  \ 
 \ mckewan@netcom.com  \ The syntax is reverse polish. Source and destination are
   \ reversed. Size prefixes are used instead of AX/EAX. Example:
 \ 80386 "subset" assembler.  \ Intel                           gives
 \ Greatly inspired by:  \ mov  ax,bx                      .w bx ax mov
 \    1. 32-BIT MINI ASSEMBLER BASED ON riFORTH by Richard Astle  \ mov  eax,[ebx]                  .d bx ) ax mov
 \    2. F83 8086 Assembler by Mike Perry  \ add  eax,4                      .d 4 # ax add
   \ 
 \ This assembler will run under Win32Forth.  It was written to support a   \ in .86 mode  .w is the default size, in .386 mode  .d is default
 \ metacompiler so it does not implement the full range of opcodes and   \ .wa and .da change address size. .b, .w(a) and .d(a) are not
 \ operands.  In particular, it does not support direct memory access  \ switches like in my assem68k, they are prefixes.
 \ (i.e.  mov [memory],eax ).  This is because the Forth system, like   \ [A-D][L|H] implicitely set the .b size. So
 \ Win32Forth, uses only relative addresses (index or base+index).  \ AH AL mov
 \ The syntax is postfix and is similar to F83.  Here are some examples:  \ generates a byte move. Sure you need .b for memory operations
 \  \ like .b ax ) inc    which is  inc  BYTE PTR [eAX]
 \       EAX EBX MOV             \ move ebx,eax  
 \       3 # EAX MOV             \ mov eax,3  \ 80486 Assembler Load Screen                          21apr00py
 \       100 [EDI] EAX MOV       \ mov eax,100[edi]  
 \       4 [EBX] [ECX] EAX MOV   \ mov eax,4[ebx][ecx]  base @ get-current ALSO ASSEMBLER DEFINITIONS also
 \       16: EAX EBX MOV         \ mov bx,ax  
   &8 base !
   
 ONLY FORTH ALSO DEFINITIONS  : [F]  Forth     ; immediate
   : [A]  Assembler ; immediate
 VOCABULARY ASSEMBLER   ASSEMBLER ALSO DEFINITIONS   HEX  
   \ Assembler Forth words                                11mar00py
   
 \ ---------------------------------------------------------------------  : user' ' >body @ ; immediate
 \ Defer memory-access words for the metacompiler  : case? ( n1 n2 -- t / n1 f )
       over = IF  drop true  ELSE  false  THEN ;
 DEFER HERE     FORTH ' HERE  ASSEMBLER IS HERE  
 DEFER ,        FORTH ' ,     ASSEMBLER IS ,  \ Code generating primitives                           07mar93py
 DEFER C,       FORTH ' C,    ASSEMBLER IS C,  
 DEFER TC@      FORTH ' C@    ASSEMBLER IS TC@  Variable >codes
 DEFER TC!      FORTH ' C!    ASSEMBLER IS TC!  : (+rel      ;
   Create nrc  ] c,   here  allot  c! (+rel [
   
 \ ---------------------------------------------------------------------  : nonrelocate   nrc >codes ! ;      nonrelocate
 \ Register Fields:  8000 <flags> <sib>  
   : >exec   Create  dup c,  cell+
 \ Flag bits:    0 = size field   1 = DWORD, 0 = BYTE              Does>  c@  >codes @  +  perform ;
 \               1 = index field  1 = INDEXED MODE  
 \               2 = sib flag     1 = SIB byte required  0
   >exec ,       >exec here    >exec allot   >exec c!
 : REG     ( mask off register field )   7 AND ;  >exec +rel
 : REG?    ( reg -- f )     FFFF0200 AND 80000000 = ;  drop
 : R32?    ( reg -- f )     FFFF0300 AND 80000100 = ;  
 : INDEX?  ( reg -- f )     FFFF0200 AND 80000200 = ;  \ Stack-Buffer fr Extra-Werte                         22dec93py
 : SIZE?   ( reg -- 0/1 )   8 RSHIFT 1 AND ;  
 : SIB?    ( reg -- f )     400 AND ;  Variable ModR/M               Variable ModR/M#
   Variable SIB                  Variable SIB#
 : INDEX  ( n -- )  \ create an index register  Variable disp                 Variable disp#
     CREATE ,  DOES> @  Variable imm                  Variable imm#
     OVER INDEX?  Variable Aimm?                Variable Adisp?
     IF    REG 3 LSHIFT         ( move reg to index field in sib )  Variable byte?                Variable seg
           400 OR                ( set sib flag )  Variable .asize               Variable .anow
           SWAP FFFFFFC7 AND OR  ( put into sib byte of previous register )  Variable .osize               Variable .onow
     THEN ;  : pre-    seg off  .asize @ .anow !  .osize @ .onow !  ;
   : sclear  pre-  Aimm? off  Adisp? off
 80000100 CONSTANT EAX       80000000 CONSTANT AL      ModR/M# off  SIB# off  disp# off  imm# off  byte? off ;
 80000101 CONSTANT ECX       80000001 CONSTANT CL  
 80000102 CONSTANT EDX       80000002 CONSTANT DL  : .b  1 byte? !  imm# @ 1 min imm# ! ;
 80000103 CONSTANT EBX       80000003 CONSTANT BL  
 80000104 CONSTANT ESP       80000004 CONSTANT AH  : .w   .onow off ;              : .wa  .anow off ;
 80000105 CONSTANT EBP       80000005 CONSTANT CH  : .d   .onow on  ;              : .da  .anow on  ;
 80000106 CONSTANT ESI       80000006 CONSTANT DH  
 80000107 CONSTANT EDI       80000007 CONSTANT BH  \ Extra-Werte compilieren                              01may95py
   : bytes,  ( nr x n -- )
 80000300 INDEX [EAX]      0 ?DO  over 0< IF  +rel  swap 1+ swap  THEN  dup ,  $8 rshift
 80000301 INDEX [ECX]      LOOP   2drop ;
 80000302 INDEX [EDX]  : opcode, ( opcode -- )
 80000303 INDEX [EBX]      .asize @ .anow @  <> IF  $67 ,  THEN
 80000724 INDEX [ESP]      .osize @ .onow @  <> IF  $66 ,  THEN
 80000305 INDEX [EBP]      seg     @ IF  seg @ ,  THEN  ,  pre- ;
 80000306 INDEX [ESI]  : finish ( opcode -- )  opcode,
 80000307 INDEX [EDI]      ModR/M# @ IF  ModR/M @ ,  THEN
       SIB#    @ IF  SIB    @ ,  THEN
 80010000 CONSTANT #   ( just different from any register )      Adisp?  @ disp @ disp# @ bytes,
       Aimm?   @ imm  @ imm#  @ bytes,    sclear  ;
 \ Scaled index mode must have a base register, i.e.  : finishb  ( opcode -- )       byte? @ xor  finish ;
 \       0 [EDI] [EAX] *4 ECX MOV  : 0F,  $0F opcode, ;
 : *2  40 OR ;  : finish0F ( opcode -- )       0F,  finish ;
 : *4  80 OR ;  
 : *8  C0 OR ;  \ Register                                             29mar94py
   
 \ ---------------------------------------------------------------------  : Regs  ( mod n -- ) FOR  dup Constant 11 +  NEXT  drop ;
 \ Assembler addressing mode bytes  : breg  ( reg -- )  Create c,  DOES> c@  .b ;
   : bregs ( mod n -- ) FOR  dup breg     11 +  NEXT  drop ;
 VARIABLE SIZE  1 SIZE !  : wadr: ( reg -- )  Create c,  DOES> c@  .wa ;
 : BYTE   0 SIZE ! ;  : wadr  ( mod n -- ) FOR  dup wadr:    11 +  NEXT  drop ;
 : OP,    ( n op -- )    OR C, ;     0 7 wadr [BX+SI] [BX+DI] [BP+SI] [BP+DI] [SI] [DI] [BP] [BX]
 : SIZE,  ( op reg -- )  SIZE? OP, ;   300 7 regs  AX CX DX BX SP BP SI DI
 : SHORT? ( n -- f )    -80 80 WITHIN ;   300 7 bregs AL CL DL BL AH CH DH BH
 : DISP?  ( n reg -- n reg f )   2DUP REG 5 = ( [EBP] ) OR ;  2300 5 regs ES CS SS DS FS GS
   ' SI alias RP   ' BP alias UP   ' DI Alias OP
 : RR,   ( reg reg/op -- )  3 LSHIFT OR C0 OP, ;  : .386  .asize on   .osize on  sclear ;  .386
   : .86   .asize off  .osize off sclear ;
 : MEM,  ( operand [reg] reg -- )  : asize@  2 .anow @ IF  2*  THEN ;
     3 LSHIFT >R  ( move to reg/opcode field )  : osize@  2 .onow @ IF  2*  THEN ;
     DUP SIB?  
     IF    DISP?  \ Address modes                                        01may95py
           IF  OVER SHORT?  : #) ( disp -- reg )
               IF      R> 44 OP, C, C,    disp ! .anow @ IF  55 4  ELSE  66 2  THEN  disp# ! ;
               ELSE    R> 84 OP, C, ,  : *2   100 xor ;    : *4   200 xor ;    : *8   300 xor ;
               THEN  : index  ( reg1 reg2 -- modr/m )  370 and swap 7 and or ;
           ELSE        R> 4 OP, C, DROP   ( no displacement )  : I) ( reg1 reg2 -- ireg )  .anow @ 0= abort" No Index!"
     *8  index  SIB ! 1 SIB# ! 44 ;
   : I#) ( disp32 reg -- ireg ) BP swap I) swap #) drop ;
   : seg)  ( seg disp -- -1 )
     disp !  asize@ disp# !  imm ! 2 imm# !  -1 ;
   : )  ( reg -- reg )  dup SP = IF dup I) ELSE 77 and THEN ;
   : D) ( disp reg -- reg )  ) >r dup disp !  $80 -$80 within
     Adisp? @ or IF  200 asize@  ELSE  100 1  THEN disp# ! r> or ;
   : DI) ( disp reg1 reg2 -- ireg )  I) D) ;
   : A: ( -- )  Adisp? on ;        : A::  ( -- )  -2 Adisp? ! ;
   : A#) ( imm -- )  A: #) ;       : Aseg) ( * -- ) A: seg) ;
   
   \ # A# rel) CR DR TR ST <ST STP                        01jan98py
   : # ( imm -- ) dup imm !  -$80 $80 within  byte? @ or
     IF  1  ELSE  osize@  THEN  imm# ! ;
   : L#  ( imm -- )  imm !  osize@ imm# ! ;
   : A#  ( imm -- )  Aimm? on  L# ;
   : rel)  ( addr -- -2 )  disp ! asize@ disp# ! -2 ;
   : L) ( disp reg -- reg ) ) >r disp ! 200 asize@ disp# ! r> or ;
   : LI) ( disp reg1 reg2 -- reg ) I) L) ;
   : >>mod ( reg1 reg2 -- mod )  70 and swap 307 and or ;
   : >mod ( reg1 reg2 -- )  >>mod modR/M !  1 modR/M# ! ;
   : CR  ( n -- )  7 and 11 *  $1C0 or ;    0 CR constant CR0
   : DR  ( n -- )  7 and 11 *  $2C0 or ;
   : TR  ( n -- )  7 and 11 *  $3C0 or ;
   : ST  ( n -- )  7 and       $5C0 or ;
   : <ST ( n -- )  7 and       $7C0 or ;
   : STP ( n -- )  7 and       $8C0 or ;
   
   \ reg?                                                 10apr93py
   : reg= ( reg flag mask -- flag ) 2 pick and = ;
   : reg? ( reg -- reg flag )  $C0 -$40 reg= ;
   : ?reg ( reg -- reg )  reg? 0= abort" reg expected!" ;
   : ?mem ( mem -- mem )  dup $C0 < 0= abort" mem expected!" ;
   : ?ax  ( reg -- reg )  dup AX <> abort" ax/al expected!" ;
   : cr?  ( reg -- reg flag ) $100 -$100 reg= ;
   : dr?  ( reg -- reg flag ) $200 -$100 reg= ;
   : tr?  ( reg -- reg flag ) $300 -$100 reg= ;
   : sr?  ( reg -- reg flag ) $400 -$100 reg= ;
   : st?  ( reg -- reg flag ) dup $8 rshift 5 - ;
   : ?st  ( reg -- reg ) st? 0< abort" st expected!" ;
   : xr?  ( reg -- reg flag ) dup $FF > ;
   : ?xr  ( reg -- reg )  xr? 0= abort" xr expected!" ;
   : rel? ( reg -- reg flag ) dup -2 = ;
   : seg? ( reg -- reg flag ) dup -1 = ;
   
   \ Single Byte instruction                              27mar94py
   
   : bc:   ( opcode -- )  Create c, DOES> c@ ,        ;
   : bc.b: ( opcode -- )  Create c, DOES> c@ finishb  ;
   : bc0F: ( opcode -- )  Create c, DOES> c@ finish0F ;
   
   : seg:  ( opcode -- )  Create c, DOES> c@ seg ! ;
   
   $26 seg: ES:    $2E seg: CS:    $36 seg: SS:    $3E seg: DS:
   $64 seg: FS:    $65 seg: GS:
   
   Forth
   
   \ arithmetics                                          07nov92py
   
   : reg>mod ( reg1 reg2 -- 1 / 3 )
       reg? IF  >mod 3  ELSE  swap ?reg >mod 1  THEN  ;
   : ari: ( n -- ) Create c,
       DOES> ( reg1 reg2 / reg -- )  c@ >r imm# @
       IF    imm# @ byte? @ + 1 > over AX = and
             IF    drop $05 r> 70 and or
             ELSE  r> >mod $81 imm# @ 1 byte? @ + = IF 2 + THEN
           THEN            THEN
     ELSE  DISP?      ELSE  reg>mod  r> 70 and or
           IF  OVER SHORT?      THEN  finishb  ;
               IF    R> OR 40 OP, C,  
               ELSE  R> OR 80 OP, ,  
               THEN  
           ELSE      R> OP, DROP  ( no displacement )  
           THEN  
     THEN ;  
   
 : R/M,  ( operand [reg] reg | reg reg -- )  
     OVER REG? IF  RR,  ELSE  MEM,  THEN ;  
   
 : WR/SM,  ( r/m reg op -- )  2 PICK REG?  
     IF  2 PICK SIZE, RR,  ELSE  SIZE @ OP,  MEM,  THEN  1 SIZE ! ;  
   
   
 \ ---------------------------------------------------------------------  
 \ Opcode Defining Words  
   
 : CPU  ( op -- )  CREATE C,  DOES> C@ C, ;  
   
 66 CPU 16:      \ 16-bit opcode prefix (cannot use with immedate ops)  
 C3 CPU RET  
 F2 CPU REP   F2 CPU REPNZ   F3 CPU REPZ  
 FC CPU CLD   FD CPU STD     99 CPU CDQ  
   
   
 : SHORT  ( op opex regop -- )  
     CREATE C, C, C,  
     DOES>  ( reg | offset [reg] -- )  OVER R32?  
     IF  C@ OP,  ELSE  1+ COUNT SWAP C@ WR/SM,  THEN ;  
   
 FF 6 50 SHORT PUSH   8F 0 58 SHORT POP  
 FE 0 40 SHORT INC    FE 1 48 SHORT DEC  
   
   
 : UNARY  ( opex -- )  
     CREATE C,  DOES>  ( reg | offset [reg] )  C@ F6 WR/SM, ;  
   
 2 UNARY INV  ( INV = Intel's NOT )  00 ari: add     11 ari: or      22 ari: adc     33 ari: sbb
 3 UNARY NEG   4 UNARY MUL  44 ari: and     55 ari: sub     66 ari: xor     77 ari: cmp
 5 UNARY IMUL  6 UNARY DIV   7 UNARY IDIV  
   
   \ bit shifts    strings                                07nov92py
   
 \ The following forms are accepted for binary operands.  : shift: ( n -- )  Create c,
 \ Note that immediate to memory is not supported.      DOES> ( r/m -- )  c@ >mod  imm# @
 \       reg reg <op>      IF    imm @ 1 =
 \       n # reg <op>            IF  $D1 0  ELSE  $C1 1  THEN   imm# !
 \       ofs [reg] reg <op>      ELSE  $D3
 \       reg ofs [reg] <op>      THEN  finishb ;
   
 : BINARY  ( op -- )  00 shift: rol   11 shift: ror   22 shift: rcl   33 shift: rcr
     CREATE C,  44 shift: shl   55 shift: shr   66 shift: sal   77 shift: sar
     DOES> C@ 2 PICK # =  
     IF  OVER SIZE?  $6D bc.b: ins   $6F bc.b: outs
         IF    81 C,  RR,  DROP ,  $A5 bc.b: movs  $A7 bc.b: cmps
         ELSE  80 C,  RR,  DROP C,  $AB bc.b: stos  $AD bc.b: lods  $AF bc.b: scas
         THEN  
     ELSE  3 LSHIFT  \ movxr                                                07feb93py
           OVER INDEX? IF  >R ROT R>  ELSE  2 OR  THEN  
           OVER SIZE, R/M,  : xr>mod  ( reg1 reg2 -- 0 / 2 )
     THEN ;      xr?  IF  >mod  2  ELSE  swap ?xr >mod  0  THEN  ;
   
 : MOV   ( operands... -- )  : movxr  ( reg1 reg2 -- )
     OVER # =      2dup or sr? nip
     IF    DUP SIZE? IF  B8 OP, DROP ,  ELSE  B0 OP, DROP C,  THEN      IF    xr>mod  $8C
     ELSE  DUP INDEX? IF  ROT 88  ELSE  8A  THEN  OVER SIZE, R/M,      ELSE  2dup or $8 rshift 1+ -3 and >r  xr>mod  0F,  r> $20 or
     THEN ;      THEN  or  finish ;
   
 : LEA   ( reg/mem reg -- )   8D C,  MEM, ;  \ mov                                                  23jan93py
   
 : XCHG  ( mr1 reg -- )  : assign#  byte? @ 0= IF  osize@ imm# !  ELSE 1 imm# ! THEN ;
     OVER REG? OVER EAX = AND  
     IF    DROP REG 90 OP,  : ?ofax ( reg ax -- flag ) .anow @ IF 55 ELSE 66 THEN AX d= ;
     ELSE  86 OVER SIZE,  R/M,  THEN ;  : mov ( r/m reg / reg r/m / reg -- )  2dup or 0> imm# @ and
         IF    assign#  reg?
 ( TEST ... )          IF    7 and  $B8 or byte? @ 3 lshift xor  byte? off
           ELSE  0 >mod  $C7  THEN
     ELSE  2dup or $FF > IF  movxr exit  THEN
 \ Shift/Rotate syntax:          2dup ?ofax
 \       eax shl         0 [ecx] [edi] shl          IF  2drop $A1  ELSE  2dup swap  ?ofax
 \       eax 4 shl       0 [ecx] [edi] 4 shl              IF  2drop $A3  ELSE  reg>mod $88 or  THEN
 \       eax cl shl      0 [ecx] [edi] cl shl  
   
 : SHIFT  ( op -- )  
     CREATE C,  
     DOES> C@ OVER CL =  
     IF    NIP D2 WR/SM,  
     ELSE  OVER 0< ( reg/index)  
         IF    D0 WR/SM,  
         ELSE  OVER 1 =  
             IF    NIP D0 WR/SM,  
             ELSE  SWAP >R C0 WR/SM, R> C,  
             THEN  
         THEN          THEN
     THEN ;    THEN  finishb ;
   
 0 SHIFT ROL   1 SHIFT ROR   2 SHIFT RCL   3 SHIFT RCR  
 4 SHIFT SHL   5 SHIFT SHR   7 SHIFT SAR  
   
 \ String instructions. Precede with BYTE for byte version  
 : STR  ( op -- )  
     CREATE C,  DOES> C@ SIZE @ OP,  1 SIZE ! ;  
   
 A4 STR MOVS   A6 STR CMPS  
 AA STR STOS   AC STR LODS   AE STR SCAS  
   
   
 \ ---------------------------------------------------------------------  
 \ Relative jumps and calls  
   
 : OFFSET  ( dest source -- offset )  
    1+ -  DUP SHORT? 0= ABORT" branch target out of range"  ;  
   
 : REL8,   ( addr -- )  HERE OFFSET C, ;  
 : REL32,  ( addr -- )  HERE CELL+ - , ;  
   
 : REL  ( op -- )   CREATE C,  DOES> C@ C,  REL8, ;  
   
 70 REL JO    71 REL JNO   72 REL JB    73 REL JAE  
 74 REL JE    75 REL JNE   76 REL JBE   77 REL JA  
 78 REL JS    79 REL JNS   7A REL JPE   7B REL JNP  
 7C REL JL    7D REL JGE   7E REL JLE   7F REL JG  
 E3 REL JECXZ  
   
 : JMP  ( addr | r/m -- )  
    DUP 0< ( reg/index ) IF  FF C,  4 R/M,  
    ELSE  DUP HERE 2 + - SHORT? IF  EB C,  REL8,  
    ELSE  E9 C,  REL32,  THEN THEN ;  
   
 : CALL  ( addr | r/m -- )  
    DUP 0< ( reg/index ) IF  FF C,  2 R/M,  ELSE  E8 C,  REL32,  THEN ;  
   
   
 \ ---------------------------------------------------------------------  
 \ Local labels  
   
 10 CONSTANT MAX-LABELS  ( adjust as required )  
   
 : ARRAY  CREATE CELLS ALLOT  DOES> SWAP CELLS + ;  
   
 MAX-LABELS ARRAY LABEL-VALUE    ( value of label or zero if not resolved )  
 MAX-LABELS ARRAY LABEL-LINK     ( linked list of unresolved references   )  
   
 : CLEAR-LABELS   ( initialize label arrays )  
    0 LABEL-VALUE MAX-LABELS CELLS ERASE  
    0 LABEL-LINK  MAX-LABELS CELLS ERASE  ;   CLEAR-LABELS  
   
 : CHECK-LABELS  ( make sure all labels have been resolved )  
    MAX-LABELS 0  
    DO  I LABEL-LINK @ IF CR ." Label " I . ." not resolved" THEN  LOOP ;  
   
 : $:  ( n -- )   ( define a label )  
    DUP LABEL-VALUE @ ABORT" Duplicate label"  
    HERE OVER LABEL-LINK @ ?DUP      ( any unresolved references? )  
    IF  ( n address link )  
        BEGIN  DUP TC@ >R            ( save offset to next reference )  
               2DUP OFFSET OVER TC!  ( resolve this reference )  
               R@ 100 - +            ( go to next reference )  
               R> 0=                 ( more references? )  
        UNTIL  
        DROP OVER LABEL-LINK OFF     ( clear unresolved list )  
    THEN  
    SWAP LABEL-VALUE !  ;            ( resolve label address )  
   
 : $  ( n -- addr )    ( reference a label )  
    DUP LABEL-VALUE @  ( already resolved? )  
    IF    LABEL-VALUE @    
    ELSE  DUP LABEL-LINK @ ?DUP 0=   ( first reference? )  
          IF   HERE 1+  THEN  1+     ( link to previous label )  
          HERE 1+ ROT LABEL-LINK !   ( save current label at head of list )  
    THEN ;  
   
   
 \ ---------------------------------------------------------------------  
 \ Structured Conditionals  
   
 75 CONSTANT 0=   79 CONSTANT 0<   73 CONSTANT U<   76 CONSTANT U>  
 7D CONSTANT <    7E CONSTANT >    71 CONSTANT OV   E3 CONSTANT ECX0<>  
   
 : NOT   1 XOR ;  ( reverse logic of conditional )  
   
 : IF        C, HERE 0 C, ;  
 : THEN      HERE OVER OFFSET  SWAP TC! ;  
 : ELSE      EB IF  SWAP THEN ;  
 : BEGIN     HERE ;  
 : UNTIL     C, REL8, ;  
 : LOOP      E2 UNTIL ;  
 : AGAIN     EB UNTIL ;  
 : WHILE     IF SWAP ;  
 : REPEAT    AGAIN THEN ;  
   
 0 BINARY ADD   1 BINARY OR    2 BINARY ADC   3 BINARY SBB  
 4 BINARY AND   5 BINARY SUB   6 BINARY XOR   7 BINARY CMP  
   
 : RET#   ( n -- )  C2 C, W, ;  
 : PUSH#  ( n -- )  68 C, ,  ;  
   
 : NEXT   ( -- )  
    LODS   0 [EAX] [EDI] ECX MOV   EDI ECX ADD   ECX JMP ;  
   
 : XCALL  ( n -- )  
     EDX EBX MOV  
     6 CELLS [EDI] EAX MOV  
     ( n ) CELLS [EAX] CALL  
     EBX EDX MOV  ;  
   
 VARIABLE AVOC  
 : ASM-INIT   CONTEXT @ AVOC !  ASSEMBLER  CLEAR-LABELS  !CSP ;  
   
 : END-CODE  ?CSP  CHECK-LABELS  AVOC @ CONTEXT !  REVEAL ;  
 : C;   END-CODE ;  
   
 FORTH DEFINITIONS  \ not neg mul (imul div idiv                           29mar94py
   
 : LABEL   CREATE HIDE  ASM-INIT ;  : modf  ( r/m reg opcode -- )  -rot >mod finish   ;
 : CODE    LABEL  HERE DUP CELL - !  ;  : modfb ( r/m reg opcode -- )  -rot >mod finishb  ;
   : mod0F ( r/m reg opcode -- )  -rot >mod finish0F ;
   : modf:  Create  c,  DOES>  c@ modf ;
   : not: ( mode -- )  Create c, DOES> ( r/m -- ) c@ $F7 modfb ;
   
   00 not: test#                 22 not: NOT     33 not: NEG
   44 not: MUL     55 not: (IMUL 66 not: DIV     77 not: IDIV
   
   : inc: ( mode -- )  Create c,
       DOES>  ( r/m -- ) c@ >r reg?  byte? @ 0=  and
       IF    107 and r> 70 and or finish
       ELSE  r> $FF modfb   THEN ;
   00 inc: INC     11 inc: DEC
   
   \ test shld shrd                                       07feb93py
   
   : test  ( reg1 reg2 / reg -- )  imm# @
     IF    assign#  AX case?
           IF  $A9  ELSE  test#  exit  THEN
     ELSE  ?reg >mod  $85  THEN  finishb ;
   
   : shd ( r/m reg opcode -- )
       imm# @ IF  1 imm# ! 1-  THEN  mod0F ;
   : shld  swap 245 shd ;          : shrd  swap 255 shd ;
   
   : btx: ( r/m reg/# code -- )  Create c,
       DOES> c@ >r imm# @
       IF    1 imm# !  r> $BA
       ELSE  swap 203 r> >>mod  THEN  mod0F ;
   44 btx: bt      55 btx: bts     66 btx: btr     77 btx: btc
   
   \ push pop                                             05jun92py
   
   : pushs   swap  FS case?  IF  $A0 or finish0F exit  THEN
                     GS case?  IF  $A8 or finish0F exit  THEN
       30 and 6 or or finish ;
   
   : push  ( reg -- )
     imm# @ 1 = IF  $6A finish exit  THEN
     imm# @     IF  $68 finish exit  THEN
     reg?       IF  7 and $50 or finish exit  THEN
     sr?        IF  0 pushs  exit  THEN
     66 $FF modf ;
   : pop   ( reg -- )
     reg?       IF  7 and $58 or finish exit  THEN
     sr?        IF  1 pushs  exit  THEN
     06 $8F modf ;
   
   \ Ascii Arithmetics                                    22may93py
   
   $27 bc: DAA     $2F bc: DAS     $37 bc: AAA     $3F bc: AAS
   
   : aa:  Create c,
       DOES> ( -- ) c@
       imm# @ 0= IF  &10 imm !  THEN  1 imm# ! finish ;
   $D4 aa: AAM     $D5 aa: AAD                     $D7 bc: XLAT
   
   $60 bc: PUSHA   $61 bc: POPA
   $90 bc: NOP
   $98 bc: CBW     $99 bc: CWD                     $9B bc: FWAIT
   $9C bc: PUSHF   $9D bc: POPF    $9E bc: SAHF    $9F bc: LAHF
                   $C9 bc: LEAVE
   $CC bc: INT3                    $CE bc: INTO    $CF bc: IRET
   ' fwait Alias wait
   
   \ one byte opcodes                                     25dec92py
   
   $F0 bc: LOCK                    $F2 bc: REP     $F3 bc: REPE
   $F4 bc: HLT     $F5 bc: CMC
   $F8 bc: CLC     $F9 bc: STC     $FA bc: CLI     $FB bc: STI
   $FC bc: CLD     $FD bc: STD
   
   : ?brange ( offword --- offbyte )  dup $80 -$80 within
       IF ." branch offset out of 1-byte range" THEN ;
   : sb: ( opcode -- )  Create c,
       DOES> ( addr -- ) >r  [A] here [F] 2 + - ?brange
       disp !  1 disp# !  r> c@ finish ;
   $E0 sb: LOOPNE  $E1 sb: LOOPE   $E2 sb: LOOP    $E3 sb: JCXZ
   : (ret ( op -- )  imm# @  IF  2 imm# !  1-  THEN  finish ;
   : ret  ( -- )  $C3  (ret ;
   : retf ( -- )  $CB  (ret ;
   
   \ call jmp                                             22dec93py
   
   : call  ( reg / disp -- ) rel?
     IF  drop $E8 disp @ [A] here [F] 1+ asize@ + - disp ! finish
         exit  THEN  22 $FF modf ;
   : callf ( reg / seg -- )
     seg? IF  drop $9A  finish exit  THEN  33 $FF modf ;
   
   : jmp   ( reg / disp -- )
     rel? IF  drop disp @ [A] here [F] 2 + - dup -$80 $80 within
              IF    disp ! 1 disp# !  $EB
              ELSE  3 - disp ! $E9  THEN  finish exit  THEN
     44 $FF modf ;
   : jmpf  ( reg / seg -- )
     seg? IF  drop $EA  finish exit  THEN  55 $FF modf ;
   
   : next ['] noop >code-address rel) jmp ;
   
   \ jump if                                              22dec93py
   
   : cond: 0 DO  i Constant  LOOP ;
   
   $10 cond: vs vc   u< u>=  0= 0<>  u<= u>   0< 0>=  ps pc   <  >=   <=  >
   $10 cond: o  no   b  nb   z  nz   be  nbe  s  ns   pe po   l  nl   le  nle
   : jmpIF  ( addr cond -- )
     swap [A] here [F] 2 + - dup -$80 $80 within
     IF            disp ! $70 1
     ELSE  0F,  4 - disp ! $80 4  THEN  disp# ! or finish ;
   : jmp:  Create c,  DOES> c@ jmpIF ;
   : jmps  0 DO  i jmp:  LOOP ;
   $10 jmps jo  jno   jb  jnb   jz  jnz   jbe  jnbe  js  jns   jpe jpo   jl  jnl   jle  jnle
   
   \ xchg                                                 22dec93py
   
   : setIF ( r/m cond -- ) 0 swap $90 or mod0F ;
   : set: ( cond -- )  Create c,  DOES>  c@ setIF ;
   : sets: ( n -- )  0 DO  I set:  LOOP ;
   $10 sets: seto setno  setb  setnb  sete setne  setna seta  sets setns  setpe setpo  setl setge  setle setg
   : xchg ( r/m reg / reg r/m -- )
     over AX = IF  swap  THEN  reg?  0= IF  swap  THEN  ?reg
     byte? @ 0=  IF AX case?
     IF reg? IF 7 and $90 or finish exit THEN  AX  THEN THEN
     $87 modfb ;
   
   : movx ( r/m reg opcode -- ) 0F, modfb ;
   : movsx ( r/m reg -- )  $BF movx ;
   : movzx ( r/m reg -- )  $B7 movx ;
   
   \ misc                                                 16nov97py
   
   : ENTER ( imm8 -- ) 2 imm# ! $C8 finish [A] , [F] ;
   : ARPL ( reg r/m -- )  swap $63 modf ;
   $62 modf: BOUND ( mem reg -- )
   
   : mod0F:  Create c,  DOES> c@ mod0F ;
   $BC mod0F: BSF ( r/m reg -- )   $BD mod0F: BSR ( r/m reg -- )
   
   $06 bc0F: CLTS
   $08 bc0F: INVD  $09 bc0F: WBINVD
   
   : CMPXCHG ( reg r/m -- ) swap $A7 movx ;
   : CMPXCHG8B ( r/m -- )   $8 $C7 movx ;
   : BSWAP ( reg -- )       7 and $C8 or finish0F ;
   : XADD ( r/m reg -- )    $C1 movx ;
   
   \ misc                                                 20may93py
   
   : IMUL ( r/m reg -- )  imm# @ 0=
     IF  dup AX =  IF  drop (IMUL exit  THEN
         $AF mod0F exit  THEN
     >mod imm# @ 1 = IF  $6B  ELSE  $69  THEN  finish ;
   : io ( oc -- )  imm# @ IF  1 imm# !  ELSE  $8 +  THEN finishb ;
   : IN  ( -- ) $E5 io ;
   : OUT ( -- ) $E7 io ;
   : INT ( -- ) 1 imm# ! $CD finish ;
   : 0F.0: ( r/m -- ) Create c, DOES> c@ $00 mod0F ;
   00 0F.0: SLDT   11 0F.0: STR    22 0F.0: LLDT   33 0F.0: LTR
   44 0F.0: VERR   55 0F.0: VERW
   : 0F.1: ( r/m -- ) Create c, DOES> c@ $01 mod0F ;
   00 0F.1: SGDT   11 0F.1: SIDT   22 0F.1: LGDT   33 0F.1: LIDT
   44 0F.1: SMSW                   66 0F.1: LMSW   77 0F.1: INVLPG
   
   \ misc                                                 29mar94py
   
   $02 mod0F: LAR ( r/m reg -- )
   $8D modf:  LEA ( m reg -- )
   $C4 modf:  LES ( m reg -- )
   $C5 modf:  LDS ( m reg -- )
   $B2 mod0F: LSS ( m reg -- )
   $B4 mod0F: LFS ( m reg -- )
   $B5 mod0F: LGS ( m reg -- )
   \ Pentium/AMD K5 codes
   : cpuid ( -- )  0F, $A2 [A] , [F] ;
   : cmpchx8b ( m -- ) 0 $C7 mod0F ;
   : rdtsc ( -- )  0F, $31 [A] , [F] ;
   : rdmsr ( -- )  0F, $32 [A] , [F] ;
   : wrmsr ( -- )  0F, $30 [A] , [F] ;
   : rsm ( -- )  0F, $AA [A] , [F] ;
   
   \ Floating point instructions                          22dec93py
   
   $D8 bc: D8,   $D9 bc: D9,   $DA bc: DA,   $DB bc: DB,
   $DC bc: DC,   $DD bc: DD,   $DE bc: DE,   $DF bc: DF,
   
   : D9: Create c, DOES> D9, c@ finish ;
   
   Variable fsize
   : .fs   0 fsize ! ;  : .fl   4 fsize ! ;  : .fx   3 fsize ! ;
   : .fw   6 fsize ! ;  : .fd   2 fsize ! ;  : .fq   7 fsize ! ;
   .fx
   : fop:  Create c,  DOES>  ( fr/m -- ) c@ >r
       st? dup 0< 0= IF  swap r> >mod 2* $D8 + finish exit  THEN
       drop ?mem r> >mod $D8 fsize @ dup 1 and dup 2* + - +
       finish ;
   : f@!: Create c,  DOES>  ( fm -- ) c@ $D9 modf ;
   
   \ Floating point instructions                          08jun92py
   
   $D0 D9: FNOP
   
   $E0 D9: FCHS    $E1 D9: FABS
   $E4 D9: FTST    $E5 D9: FXAM
   $E8 D9: FLD1    $E9 D9: FLDL2T  $EA D9: FLDL2E  $EB D9: FLDPI
   $EC D9: FLDLG2  $ED D9: FLDLN2  $EE D9: FLDZ
   $F0 D9: F2XM1   $F1 D9: FYL2X   $F2 D9: FPTAN   $F3 D9: FPATAN
   $F4 D9: FXTRACT $F5 D9: FPREM1  $F6 D9: FDECSTP $F7 D9: FINCSTP
   $F8 D9: FPREM   $F9 D9: FYL2XP1 $FA D9: FSQRT   $FB D9: FSINCOS
   $FC D9: FRNDINT $FD D9: FSCALE  $FE D9: FSIN    $FF D9: FCOS
   
   \ Floating point instructions                          23jan94py
   
   00 fop: FADD    11 fop: FMUL    22 fop: FCOM    33 fop: FCOMP
   44 fop: FSUB    55 fop: FSUBR   66 fop: FDIV    77 fop: FDIVR
   
   : FCOMPP ( -- )  [A] 1 stp fcomp [F] ;
   : FBLD   ( fm -- ) 44 $D8 modf ;
   : FBSTP  ( fm -- ) 66 $DF modf ;
   : FFREE  ( st -- ) 00 $DD modf ;
   : FSAVE  ( fm -- ) 66 $DD modf ;
   : FRSTOR ( fm -- ) 44 $DD modf ;
   : FINIT  ( -- )  [A] DB, $E3 , [F] ;
   : FXCH   ( st -- ) 11 $D9 modf ;
   
   44 f@!: FLDENV  55 f@!: FLDCW   66 f@!: FSTENV  77 f@!: FSTCW
   
   \ fild fst fstsw fucom                                 22may93py
   : FUCOM ( st -- )  ?st st? IF 77 ELSE 66 THEN $DD modf ;
   : FUCOMPP ( -- )  [A] DA, $E9 , [F] ;
   : FNCLEX  ( -- )  [A] DB, $E2 , [F] ;
   : FCLEX   ( -- )  [A] fwait fnclex [F] ;
   : FSTSW ( r/m -- )
     dup AX = IF  44  ELSE  ?mem 77  THEN  $DF modf ;
   : f@!,  fsize @ 1 and IF  drop  ELSE  nip  THEN
       fsize @ $D9 or modf ;
   : fx@!, ( mem/st l x -- )  rot  st? 0=
       IF  swap $DD modf drop exit  THEN  ?mem -rot
       fsize @ 3 = IF drop $DB modf exit THEN  f@!, ;
   : FST  ( st/m -- ) st?  0=
     IF  22 $DD modf exit  THEN  ?mem 77 22 f@!, ;
   : FLD  ( st/m -- )  st? 0= IF 0 $D9 modf exit THEN 55 0 fx@!, ;
   : FSTP ( st/m -- )  77 33 fx@!, ;
   
   \ PPro instructions                                    28feb97py
   
   
   : cmovIF ( r/m r flag -- )  $40 or mod0F ;
   : cmov:  Create c, DOES> c@ cmovIF ;
   : cmovs:  0 DO  I cmov:  LOOP ;
   $10 cmovs: cmovo  cmovno   cmovb   cmovnb   cmovz  cmovnz   cmovbe  cmovnbe   cmovs  cmovns   cmovpe  cmovpo   cmovl  cmovnl   cmovle  cmovnle
   
   \ MMX opcodes                                          02mar97py
   
   300 7 regs MM0 MM1 MM2 MM3 MM4 MM5 MM6 MM7
   
   : mmxs ?DO  I mod0F:  LOOP ;
   $64 $60 mmxs PUNPCKLBW PUNPCKLWD PUNOCKLDQ PACKUSDW
   $68 $64 mmxs PCMPGTB   PCMPGTW   PCMPGTD   PACKSSWB
   $6C $68 mmxs PUNPCKHBW PUNPCKHWD PUNPCKHDQ PACKSSDW
   $78 $74 mmxs PCMPEQB   PCMPEQW   PCMPEQD   EMMS
   $DA $D8 mmxs PSUBUSB   PSUBUSW
   $EA $E8 mmxs PSUBSB    PSUBSW
   $FB $F8 mmxs PSUBB     PSUBW     PSUBD
   $DE $DC mmxs PADDUSB   PADDUSW
   $EE $EC mmxs PADDSB    PADDSW
   $FF $FC mmxs PADDB     PADDW     PADDD
   
   \ MMX opcodes                                          02mar97py
   
   $D5 mod0F: pmullw               $E5 mod0F: pmulhw
   $F5 mod0F: pmaddwd
   $DB mod0F: pand                 $DF mod0F: pandn
   $EB mod0F: por                  $EF mod0F: pxor
   : pshift ( mmx imm/m mod op -- )
     imm# @ IF  1 imm# !  ELSE  + $50 +  THEN  mod0F ;
   : PSRLW ( mmx imm/m -- )  020 $71 pshift ;
   : PSRLD ( mmx imm/m -- )  020 $72 pshift ;
   : PSRLQ ( mmx imm/m -- )  020 $73 pshift ;
   : PSRAW ( mmx imm/m -- )  040 $71 pshift ;
   : PSRAD ( mmx imm/m -- )  040 $72 pshift ;
   : PSLLW ( mmx imm/m -- )  060 $71 pshift ;
   : PSLLD ( mmx imm/m -- )  060 $72 pshift ;
   : PSLLQ ( mmx imm/m -- )  060 $73 pshift ;
   
   \ MMX opcodes                                         27jun99beu
   
   \ mmxreg --> mmxreg move
   $6F mod0F: MOVQ
   
   \ memory/reg32 --> mmxreg load
   $6F mod0F: PLDQ  \ Intel: MOVQ mm,m64
   $6E mod0F: PLDD  \ Intel: MOVD mm,m32/r
   
   \ mmxreg --> memory/reg32
   : PSTQ ( mm m64   -- ) SWAP  $7F mod0F ; \ Intel: MOVQ m64,mm
   : PSTD ( mm m32/r -- ) SWAP  $7E mod0F ; \ Intel: MOVD m32/r,mm
   
   \ 3Dnow! opcodes (K6)                                  21apr00py
   : mod0F# ( code imm -- )  # 1 imm ! mod0F ;
   : 3Dnow: ( imm -- )  Create c,  DOES> c@ mod0F# ;
   $0D 3Dnow: PI2FD                $1D 3Dnow: PF2ID
   $90 3Dnow: PFCMPGE              $A0 3Dnow: PFCMPGT
   $94 3Dnow: PFMIN                $A4 3Dnow: PFMAX
   $96 3Dnow: PFRCP                $A6 3Dnow: PFRCPIT1
   $97 3Dnow: PFRSQRT              $A7 3Dnow: PFRSQIT1
   $9A 3Dnow: PFSUB                $AA 3Dnow: PFSUBR
   $9E 3Dnow: PFADD                $AE 3Dnow: PFACC
   $B0 3Dnow: PFCMPEQ              $B4 3Dnow: PFMUL
   $B6 3Dnow: PFRCPIT2             $B7 3Dnow: PMULHRW
   $BF 3Dnow: PAVGUSB
   
   : FEMMS  $0E finish0F ;
   : PREFETCH  000 $0D mod0F ;    : PREFETCHW  010 $0D mod0F ;
   
   \ 3Dnow!+MMX opcodes (Athlon)                          21apr00py
   
   $F7 mod0F: MASKMOVQ             $E7 mod0F: MOVNTQ
   $E0 mod0F: PAVGB                $E3 mod0F: PAVGW
   $C5 mod0F: PEXTRW               $C4 mod0F: PINSRW
   $EE mod0F: PMAXSW               $DE mod0F: PMAXUB
   $EA mod0F: PMINSW               $DA mod0F: PMINUB
   $D7 mod0F: PMOVMSKB             $E4 mod0F: PMULHUW
   $F6 mod0F: PSADBW               $70 mod0F: PSHUFW
   
   $0C 3Dnow: PI2FW                $1C 3Dnow: PF2IW
   $8A 3Dnow: PFNACC               $8E 3Dnow: PFPNACC
   $BB 3Dnow: PSWABD               : SFENCE   $AE $07 mod0F# ;
   : PREFETCHNTA  000 $18 mod0F ;  : PREFETCHT0  010 $18 mod0F ;
   : PREFETCHT1   020 $18 mod0F ;  : PREFETCHT2  030 $18 mod0F ;
   
   \ Assembler Conditionals                               22dec93py
   : ~cond ( cond -- ~cond )  1 xor ;
   : >offset ( start dest --- offbyte )  swap  2 + -  ?brange ;
   : IF ( cond -- here )  [A] here [F] dup 2 + rot  ~cond  jmpIF ;
   : THEN       dup [A] here >offset swap 1+ c! [F] ;
   : AHEAD      [A] here [F] dup 2 + rel) jmp ;
   : ELSE       [A] AHEAD swap THEN [F] ;
   : BEGIN      [A] here ;         ' BEGIN Alias DO  [F]
   : WHILE      [A] IF [F] swap ;
   : UNTIL      ~cond  jmpIF ;
   : AGAIN      rel) jmp ;
   : REPEAT     [A] AGAIN  THEN [F] ;
   : ?DO        [A] here [F] dup 2 + dup jcxz ;
   : BUT        swap ;
   : YET        dup ;
   : makeflag   [A] ~cond AL swap setIF  1 # AX and  AX dec [F] ;
   
 : ;CODE   ( -- )  
    ?COMP ?CSP  COMPILE (;CODE)  [COMPILE] [  ASM-INIT ; IMMEDIATE  
   
   previous set-current decimal base !
   
 ONLY FORTH ALSO DEFINITIONS DECIMAL  

Removed from v.1.1  
changed lines
  Added in v.1.4


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>