assembler.fs

\ assembler.fs ---

\ Copyright 2011 (C) David Vazquez

\ This file is part of Eulex.

\ Eulex is free software: you can redistribute it and/or modify
\ it under the terms of the GNU General Public License as published by
\ the Free Software Foundation, either version 3 of the License, or
\ (at your option) any later version.

\ Eulex is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\ GNU General Public License for more details.

\ You should have received a copy of the GNU General Public License
\ along with Eulex.  If not, see <http://www.gnu.org/licenses/>.

vocabulary Assembler
get-current
also Assembler definitions

DECIMAL

\ Assembler output

\ Cross-assembler:
\ Difference between the dictionary pointer to the target address.
0 value target-offset
: there here target-offset + ;

: lb dup 255 and c, ;
: 8>> 8 rshift ;

: byte lb drop ;
: word lb 8>> lb drop ;
: dword lb 8>> lb 8>> lb 8>> lb drop ;

1 constant OP-AL
2 constant OP-AX
4 constant OP-EAX
8 constant OP-REG8
16 constant OP-REG16
32 constant OP-REG32
64 constant OP-SREG
128 constant OP-IMM
256 constant OP-MEM8
512 constant OP-MEM16
1024 constant OP-MEM32

\ Registers

: reg8  create , does> @  OP-REG8 swap ;
: reg16 create , does> @ OP-REG16 swap ;
: reg32 create , does> @ OP-REG32 swap ;
: sreg  create , does> @  OP-SREG swap ;

: %al  OP-AL OP-REG8 or 0 ;
: %ax  OP-AX OP-REG16 or 0 ;
: %eax OP-EAX OP-REG32 or 0 ;

( 0 reg32 %eax   0 reg16 %ax     0 reg8 %al )   0 sreg %es
1 reg32 %ecx     1 reg16 %cx     1 reg8 %cl     1 sreg %cs
2 reg32 %edx     2 reg16 %dx     2 reg8 %dl     2 sreg %ss
3 reg32 %ebx     3 reg16 %bx     3 reg8 %bl     3 sreg %ds
4 reg32 %esp     4 reg16 %sp     4 reg8 %ah     4 sreg %fs
5 reg32 %ebp     5 reg16 %bp     5 reg8 %ch     5 sreg %gs
6 reg32 %esi     6 reg16 %si     6 reg8 %dh
7 reg32 %edi     7 reg16 %di     7 reg8 %bh

\ Immediate values
: # OP-IMM swap ;


\ Memory references

\ The more general memory reference mode is
\
\     base + index*scale + displacement
\
\ where BASE and INDEX are 32bits registers, SCALE is 1, 2 or 4, and
\ DISPLACEMENT is an immediate offset.
\
\ The following variables contain each one of the parts in the general
\ addressing mode. A value of -1 where a register is expected means
\ that it is omitted. Note that is it not the ModR/M either SIB
\ bytes. They are encoded later from this variables, however.
variable base
variable index
variable scale
variable displacement

: reset-addressing-mode
    -1 base !
    -1 index !
    1 scale !
    0 displacement ! ;

: check-reg32
    over OP-REG32 and 0=
    abort" Addressing mode must use 32bits registers." ;

: B check-reg32 base ! DROP ;
: I check-reg32 index ! DROP ;
: S scale ! ;
: D displacement ! ;

\ For addressing modes without base
: #PTR8 D OP-MEM8 0 ;
: #PTR16 D OP-MEM16 0 ;
: #PTR32 D OP-MEM32 0 ;
' #PTR32 alias #PTR

: 1* 1 S ;
: 2* 2 S ;
: 4* 4 S ;
: 8* 8 S ;

\ BASE                               BASE + DISP                   INDEX
: [%eax] %eax B OP-MEM32 0 ;       : +[%eax] D [%eax] ;          : >%eax %eax I ;
: [%ecx] %ecx B OP-MEM32 0 ;       : +[%ecx] D [%ecx] ;          : >%ecx %ecx I ;
: [%edx] %edx B OP-MEM32 0 ;       : +[%edx] D [%edx] ;          : >%edx %edx I ;
: [%ebx] %ebx B OP-MEM32 0 ;       : +[%ebx] D [%ebx] ;          : >%ebx %ebx I ;
: [%esp] %esp B OP-MEM32 0 ;       : +[%esp] D [%esp] ;          ( %esp is not a valid index )
: [%ebp] %ebp B OP-MEM32 0 ;       : +[%ebp] D [%ebp] ;          : >%ebp %ebp I ;
: [%esi] %esi B OP-MEM32 0 ;       : +[%esi] D [%esi] ;          : >%esi %esi I ;
: [%edi] %edi B OP-MEM32 0 ;       : +[%edi] D [%edi] ;          : >%edi %edi I ;

\ Override size of the memory reference
: PTR8 NIP OP-MEM8 SWAP ;
: PTR16 NIP OP-MEM16 SWAP ;
: PTR32 NIP OP-MEM32 SWAP ; \ Default


\ INSTRUCTION ENCODING

\ Parts of the instruction and the size in bytes of them in the
\ current instruction. A size of zero means this part is not present.
variable inst-size-override?
variable inst-opcode            variable inst-opcode#
variable inst-modr/m            variable inst-modr/m#
variable inst-sib               variable inst-sib#
variable inst-disp              variable inst-disp#
variable inst-imm               variable inst-imm#

: 0! 0 swap ! ;
: 0F, $0F byte ;        ( extended opcode )
: 66, $66 byte ;

\ Initialize the assembler state for a new instruction. It must be
\ called in the beginning of each instruction.
: reset-instruction
    reset-addressing-mode
    inst-size-override? off
    inst-opcode 0!              1 inst-opcode# !
    inst-modr/m 0!              inst-modr/m# 0!
    inst-sib 0!                 inst-sib# 0!
    inst-disp 0!                inst-disp# 0!
    inst-imm 0!                 inst-imm# 0!
; latestxt execute

\ Words to fill instruction's data

\ Set the size-override prefix.
: size-override inst-size-override? on ;

\ Set some bits in the opcode field.
: |opcode ( u -- )
    inst-opcode @ or inst-opcode ! ;

: clear-bits ( mask value -- value* )
    swap invert and ;

: set-bits! ( x mask addr -- )
    dup >r @ over swap clear-bits -rot and or r> ! ;

: set-modr/m-bits!
    inst-modr/m set-bits!
    1 inst-modr/m# ! ;

: set-sib-bits!
    inst-sib set-bits!
    1 inst-sib# ! ;

: mod!    6 lshift %11000000 set-modr/m-bits! ;
: op/reg! 3 lshift %00111000 set-modr/m-bits! ;
: r/m!             %00000111 set-modr/m-bits! ;

: s! 6 lshift %11000000 set-sib-bits! ;
: i! 3 lshift %00111000 set-sib-bits! ;
: b!          %00000111 set-sib-bits! ;

\ Set the displacement field.
: disp! inst-disp ! ;           : disp#! inst-disp# ! ;
: disp8! disp! 1 disp#! ;
: disp32! disp! 4 disp#! ;

\ Set the immediate field.
: imm! inst-imm ! ;             : imm#! inst-imm# ! ;

: flush-value ( x size -- )
    case
        0 of drop  endof
        1 of byte  endof
        2 of word  endof
        4 of dword endof
        true abort" Invalid number of bytes."
    endcase ;

: flush
    \ Prefixes
    inst-size-override? @ if 66, endif
    \ Opcode, modr/m and sib
    inst-opcode @ inst-opcode# @ flush-value
    inst-modr/m @ inst-modr/m# @ flush-value
    inst-sib    @ inst-sib#    @ flush-value
    \ Displacement and immediate
    inst-disp @ inst-disp# @ flush-value
    inst-imm  @ inst-imm#  @ flush-value
    reset-instruction ;


\ MEMORY REFERENCE ENCODING

: <=x<= ( n1 n2 n3 -- n1<=n2<=n3 )
    over -rot <= >r <= r> and ;

: 8-bit? ( n -- flag )
    -128 swap 127 <=x<= ;

\ return the mod value for a given displacement.
: disp>mod ( n -- 0|1|2 )
    ?dup 0= if 0 else
        8-bit? if 1 else 2 then
    endif ;

: scale>s ( scale -- s )
    case
        1 of 0 endof
        2 of 1 endof
        4 of 2 endof
        8 of 3 endof
        true s" Bad scale value."
    endcase ;

: null-displacement? displacement @ 0= ;

\ Encode the displacement in the displacement field and the mod field
\ of the modr/m byte. It is a general encoding which may be necessary
\ to modify for special rules.
: encode-displacement
    displacement @ dup disp>mod dup mod!
    case
        0 of 0 disp#! drop    endof
        1 of 1 disp#! disp8!  endof
        2 of 4 disp#! disp32! endof
    endcase ;

\ Encode memory references where there is not an index register. It
\ covers memory references of the form BASE + DISP, where BASE and
\ DISP are optional.
: encode-non-indexed-mref
    scale @ 1 <> abort" Scaled memory reference without index."
    base @ -1 = if
        5 r/m! displacement @ disp32!   \ only displacement
    else
        encode-displacement
        \ Special case: the ModR/M byte cannot encode [%EBP] as it is
        \ used to encode `only displacement' memory references, so we
        \ force a 8bits zero displacement.
        %ebp nip base @ = null-displacement? and if 1 mod! 0 disp8! endif
        \ Encode the base register in the ModR/M byte. If it is %esp,
        \ it requires to include the SIB byte.
        base @ r/m!
        \ NOTE: 4 means no index in SIB.
        %esp nip base @ = if base @ B! 4 I! endif
    endif ;

\ Encode memory references with an index register. It is encoded to
\ the SIB byte generally.
: encode-indexed-mref
    base @ -1 = if
        \ Special case: INDEX*SCALE + DISP. If SCALE is 1, we can
        \ encode the memory reference as a non-indexed. Otherwise, we
        \ have to force disp to 32bits.
        scale @ 1 = if
            index @ base ! -1 index ! encode-non-indexed-mref
        else
            0 mod! 4 r/m!
            scale @ scale>s s! index @ I! 5 B!
            displacement @ disp32!
        endif
    else
        \ More general addressing mode. We write R/M to 4 to specify a
        \ SIB byte, and write scale, index and base to it.
        encode-displacement 4 r/m!
        scale @ scale>s s! index @ i! base @ b!
    endif ;

\ Encode a general memory reference from the variables BASE, INDEX,
\ SCALE and DISPLACEMENT to the current instruction.
: encode-mref
    index @ -1 = if
        encode-non-indexed-mref
    else
        encode-indexed-mref
    endif ;


\ INSTRUCTION-DEFINING WORDS

\ Operands Pattern-maching
variable inst#op

: operands inst#op ! ;
' operands alias operand

: 2ops? inst#op @ 2 = ;

: 1-op-match ( op mask -- op flag )
    2 pick and 0<> ;

: 2-op-match ( op1 op2 mask1 mask2 -- op1 op2 flag )
    3 pick and 0<> swap
    5 pick and 0<> and ;

: op-match ( ops .. masks ... -- ops .. flag )
    inst#op @ 1 = if 1-op-match else 2-op-match then ;

\ Patterns
' OP-AL    alias al
' OP-AX    alias ax
' OP-EAX   alias eax
' OP-REG8  alias reg8
' OP-REG16 alias reg16
' OP-REG32 alias reg32
' OP-SREG  alias sreg
' OP-IMM   alias imm
' OP-MEM8  alias mem8
' OP-MEM16 alias mem16
' OP-MEM32 alias mem32
\ Multi-patterns
-1 constant any
al ax or eax or        constant acc
reg8 reg16 or reg32 or constant reg
mem8 mem16 or mem32 or constant mem
reg8 mem8 or           constant r/m8
reg16 mem16 or         constant r/m16
reg32 mem32 or         constant r/m32
reg mem or             constant r/m
\ any? matches with any type if the current instruction has 2
\ operands. Otherwise it is ignored.
: any? 2ops? if any then ;

: (no-dispatch)
    reset-instruction
    true abort" The instruction does not support these operands." ;

0 constant begin-dispatch immediate

: ` postpone postpone ; immediate

: dispatch:
    1+ >r
    ` op-match ` if
    r>
; immediate compile-only

: ::
    >r ` else r>
; immediate compile-only

: end-dispatch
    ` (no-dispatch)
    0 ?do ` then loop
; immediate compile-only

\ Encode some pieces of the instruction automatically.

\ Set size-override prefix if some of the operands is a r/m16.
: size-override?
    begin-dispatch
    any? r/m16 dispatch: size-override ::
    r/m16 any? dispatch: size-override ::
    exit
    end-dispatch ;

\ Encode both memory references and immediate (if there) to the ModR/M
\ byte and the Immediate field, respectively.
: encode-memory
    begin-dispatch
    mem any? dispatch: encode-mref ::
    any? mem dispatch: encode-mref ::
    exit
    end-dispatch ;

: encode-immediate-size
    \ NOTE: This is done automatically only if the instruction has
    \ _TWO_ operands. In which case, the size will match the size of
    \ the target operand. Instructions with 1 operand have to handle
    \ the immediate by themselves.
    2ops? if
        begin-dispatch
        imm r/m8  dispatch: 1 imm#! ::
        imm r/m16 dispatch: 2 imm#! ::
        imm r/m32 dispatch: 4 imm#! ::
        exit
        end-dispatch
    endif ;

\ This word can be called in the beginning of an instruction to encode
\ so much as we can automatically.
: instruction
    size-override? encode-memory encode-immediate-size ;

\ Check that the size of both operands is the same or signal an error.
: same-size
    begin-dispatch
      imm   any dispatch: ::
     r/m8  r/m8 dispatch: ::
    r/m16 r/m16 dispatch: ::
    r/m32 r/m32 dispatch: ::
    true abort" The size of the operands must match."
    end-dispatch ;

: immediate-operand 1 operand
    begin-dispatch
    imm dispatch: ::
    end-dispatch ;

\ Define an instruction with no operands
: single-instruction ( opcode -- )
    create c, does> 0 operands @ |opcode flush ;

: >reg op/reg! drop ;
: >opcode |opcode drop ;
: >imm imm! drop ;
: >imm8  >imm 1 imm#! ;
: >imm16 >imm 2 imm#! ;
: >imm32 >imm 4 imm#! ;

: >r/m
    inst#op @ >r
    1 operand begin-dispatch
    reg dispatch: 3 mod! r/m! drop ::
    mem dispatch: 2drop ::
    end-dispatch
    r> operands ;

: size-bit
    begin-dispatch
    any? r/m8  dispatch: 0 ::
    any? r/m16 dispatch: 1 ::
    any? r/m32 dispatch: 1 ::
    end-dispatch ;

: direction-bit
    begin-dispatch
    reg r/m dispatch: 0 ::
    r/m reg dispatch: 1 ::
    end-dispatch ;

: sign-extend-bit
    begin-dispatch
    imm r/m8 dispatch: 0 ::
    imm r/m dispatch:
        2swap dup >r 2swap r>
        8-bit? if 1 else 0 then ::
    end-dispatch ;

\ Set opcode and size bit.
: opcode-w |opcode size-bit |opcode ;
: opcode-wxxx |opcode size-bit 3 lshift |opcode ;
: opcode-dw opcode-w direction-bit 2 * |opcode ;
: opcode-sw opcode-w sign-extend-bit if 2 |opcode 1 imm#! endif ;

\ Generic 2 operand instructions.
: inst-imm-r/m opcode-w >r/m >imm ;
: inst-reg-reg opcode-w >r/m >reg ;
: inst-reg-r/m opcode-dw
    begin-dispatch
    reg r/m dispatch: >r/m >reg ::
    r/m reg dispatch: >reg >r/m ::
    end-dispatch ;


\ -------------------------------------------------------------------------

: ascii"
    [char] " parse dup byte
    here swap move ;


\ Arithmetic

: inst-imm-acc
    opcode-w 4 |opcode 2drop >imm ;

: arith-imm-r/m ( opext -- )
    >r $80 opcode-sw >r/m >imm r> op/reg! ;

: inst-binary-arithm ( opcode op-extension -- )
    2>r
    2 operands same-size instruction
    begin-dispatch
    imm acc dispatch:
        \ Here, you can encode as imm-r/m or imm-acc. We choose the
        \ shorter according to the size of the immediate value.
        sign-extend-bit if
            2r> nip arith-imm-r/m
        else
            2r> drop inst-imm-acc
        then ::
    imm r/m dispatch: 2r> nip arith-imm-r/m ::
    reg reg dispatch: 2r> drop inst-reg-reg ::
    r/m r/m dispatch: 2r> drop inst-reg-r/m ::
    end-dispatch
    flush ;

: adc $10 %010 inst-binary-arithm ;
: add $00 %000 inst-binary-arithm ;
: and $20 %100 inst-binary-arithm ;
: cmp $38 %111 inst-binary-arithm ;
: or  $08 %001 inst-binary-arithm ;
: sbb $18 %011 inst-binary-arithm ;
: sub $28 %101 inst-binary-arithm ;
: xor $30 %110 inst-binary-arithm ;

: inst-unary-arithm ( ext )
    >r 1 operand instruction
    begin-dispatch
    r/m dispatch: $F6 opcode-w >r/m r> op/reg! ::
    end-dispatch
    flush ;

: div  %110 inst-unary-arithm ;
: idiv %111 inst-unary-arithm ;
: imul %101 inst-unary-arithm ;  \ Binary version is not supported.
: mul  %100 inst-unary-arithm ;
: neg  %011 inst-unary-arithm ;
: not  %010 inst-unary-arithm ;

: inc 1 operand instruction
    begin-dispatch
    reg8 mem or dispatch: $FE opcode-w >r/m ::
    reg dispatch: $40 |opcode >opcode ::
    end-dispatch
    flush ;

: dec 1 operand instruction
    begin-dispatch
    reg8 mem or dispatch: $FE opcode-w >r/m 1 op/reg! ::
    reg dispatch: $48 |opcode >opcode ::
    end-dispatch
    flush ;


\ Shift

: inst-shift/rotate ( extension -- ) op/reg!
    2 operands instruction
    begin-dispatch
    imm r/m dispatch:
        $C0 opcode-w >r/m dup 1 = if
            $10 |opcode 2drop
        else
            >imm8
        then ::
    reg8 r/m dispatch:
        $D2 opcode-w >r/m
        nip %cl nip <> abort" The source register must be %cl." ::
    end-dispatch
    flush ;

: rol %000 inst-shift/rotate ;
: ror %001 inst-shift/rotate ;
: shl %100 inst-shift/rotate ;
: shr %101 inst-shift/rotate ;

\ MOVement instructions

( This variant encode the register in the opcode. Used by MOV)
: inst-imm-reg* opcode-wxxx >opcode >imm ;

: mov 2 operands instruction
    begin-dispatch
    \ Segment registers
    r/m sreg dispatch: $8E |opcode >reg >r/m ::
    sreg r/m dispatch: $8C |opcode >r/m >reg ::
    \ General purpose registers
    SAME-SIZE
    imm reg dispatch: $B0 inst-imm-reg* ::
    imm mem dispatch: $C6 inst-imm-r/m  ::
    reg reg dispatch: $88 inst-reg-reg  ::
    r/m r/m dispatch: $88 inst-reg-r/m  ::
    end-dispatch
    flush ;

: movs 2 operands encode-memory
    begin-dispatch
    r/m8  reg16 dispatch: 66, 0F, $BE |opcode >reg >r/m ::
    r/m8  reg32 dispatch:     0F, $BE |opcode >reg >r/m ::
    r/m16 reg32 dispatch:     0F, $BF |opcode >reg >r/m ::
    end-dispatch
    flush ;

: movz 2 operands encode-memory
    begin-dispatch
    r/m8  reg16 dispatch: 66, 0F, $B6 |opcode >reg >r/m ::
    r/m8  reg32 dispatch:     0F, $B6 |opcode >reg >r/m ::
    r/m16 reg32 dispatch:     0F, $B7 |opcode >reg >r/m ::
    end-dispatch
    flush ;


\ Branching

: short-jump? ( target -- flag )
    there 2 + - 8-bit? ;

: rel8  there 2 + - >imm8 ;
: rel32 there 5 + - >imm32 ;

\ Base implementation for conditional jumps.

: inst-short-jcc ( target tttn -- )
    $70 |opcode |opcode rel8 flush ;
: inst-long-jcc ( target tttn -- )
    0F, $80 |opcode |opcode rel32 flush ;

: inst-jcc ( tttn -- ) >r immediate-operand instruction r>
    over short-jump? if inst-short-jcc else inst-long-jcc endif ;

: jo  %0000 inst-jcc ;          : jno  %0001 inst-jcc ;
: jb  %0010 inst-jcc ;          : jnb  %0011 inst-jcc ;
' jb  alias jnae                ' jnb  alias jae
: je  %0100 inst-jcc ;          : jne  %0101 inst-jcc ;
' je  alias jz                  ' jne  alias jnz
: jbe %0110 inst-jcc ;          : jnbe %0111 inst-jcc ;
' jbe alias jna                 ' jnbe alias ja
: js  %1000 inst-jcc ;          : jns  %1001 inst-jcc ;
: jp  %1010 inst-jcc ;          : jnp  %1011 inst-jcc ;
' jp  alias jpe                 ' jnp  alias jpo
: jl  %1100 inst-jcc ;          : jnl  %1101 inst-jcc ;
' jl  alias jnge                ' jnl  alias jge
: jle %1110 inst-jcc ;          : jnle  %1111 inst-jcc ;
' jle alias jng                 ' jnle alias jg

\ Unconditional jump
: jmp 1 operand instruction
    begin-dispatch
    imm dispatch: $E9 |opcode
        dup short-jump? if rel8 2 |opcode else rel32 endif ::
    r/m dispatch: $FF |opcode 4 op/reg! >r/m ::
    end-dispatch
    flush ;

: ljmp ( selector imm ) 2 operands
    begin-dispatch
    imm imm dispatch: $EA |opcode >imm32 flush word drop ::
    end-dispatch ;


\ Input and output

: in 2 operands
    begin-dispatch
    imm acc dispatch: $E4 opcode-w 2drop >imm8 ::
    reg16 acc dispatch:
        $EC opcode-w 2drop
        %dx nip <> abort" The source operand must be DX" drop ::
    end-dispatch
    flush ;

: output 2 operands
    begin-dispatch
    imm acc dispatch: $E6 opcode-w 2drop >imm8 ::
    reg16 acc dispatch:
        $EE opcode-w 2drop
        %dx nip <> abort" The source operand must be DX" drop ::
    end-dispatch
    flush ;


\ Other instructions

: call 1 operand instruction
    begin-dispatch
    imm dispatch: $E8 |opcode there 5 + - >imm32 ::
    r/m dispatch: $FF |opcode 2 op/reg! >r/m ::
    end-dispatch
    flush ;

: pop 1 operand instruction
    \ TODO: Support for segment registers
    begin-dispatch
    reg32 dispatch: $58 |opcode >opcode ::
    r/m dispatch: $8F |opcode >r/m ::
    end-dispatch
    flush ;

: push 1 operand instruction
    begin-dispatch
    imm dispatch: $68 |opcode
        dup 8-bit? if 2 |opcode >imm8 else >imm32 endif ::
    r/m8 dispatch: (no-dispatch) ::
    reg dispatch: $50 |opcode >opcode ::
    r/m dispatch: $FF |opcode >r/m 6 op/reg! ::
    end-dispatch
    flush ;

: lgdt 1 operand
    begin-dispatch
    r/m32 dispatch: 0F, $01 |opcode >r/m 2 op/reg! ::
    end-dispatch
    flush ;

: lidt 1 operand
    begin-dispatch
    r/m32 dispatch: 0F, $01 |opcode >r/m 3 op/reg! ::
    end-dispatch
    flush ;

$94 single-instruction cbw
$99 single-instruction cdq

$F4 single-instruction clc
$FC single-instruction cld
$FA single-instruction cli

: cpuid 0F, $A2 |opcode flush ;

$F4 single-instruction hlt
$CF single-instruction iret

$90 single-instruction nop

$61 single-instruction popa
$9D single-instruction popf
$60 single-instruction pusha
$9C single-instruction pushf

$C3 single-instruction ret

$FB single-instruction sti


SET-CURRENT
PREVIOUS


\ Local Variables:
\ forth-local-words: ((("begin-dispatch" "end-dispatch" "dispatch:" "::")
\                      compile-only (font-lock-keyword-face . 2))
\                     (("single-instruction") immediate (font-lock-keyword-face . 2)))
\ End:

\ assembler.fs ends here