basis/cpu/x86/assembler/assembler.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays io.binary kernel combinators
   4 kernel.private math namespaces make sequences words system layouts
   5 math.order accessors cpu.x86.assembler.syntax ;
   6 IN: cpu.x86.assembler
   7
   8 ! A postfix assembler for x86-32 and x86-64.
   9
  10 ! In 32-bit mode, { 1234 } is absolute indirect addressing.
  11 ! In 64-bit mode, { 1234 } is RIP-relative.
  12 ! Beware!
  13
  14 ! Register operands -- eg, ECX
  15 REGISTERS: 8 AL CL DL BL ;
  16
  17 REGISTERS: 16 AX CX DX BX SP BP SI DI ;
  18
  19 REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI ;
  20
  21 REGISTERS: 64
  22 RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ;
  23
  24 REGISTERS: 128
  25 XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
  26 XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ;
  27
  28 TUPLE: byte value ;
  29
  30 C: <byte> byte
  31
  32 <PRIVATE
  33
  34 #! Extended AMD64 registers (R8-R15) return true.
  35 GENERIC: extended? ( op -- ? )
  36
  37 M: object extended? drop f ;
  38
  39 PREDICATE: register < word
  40     "register" word-prop ;
  41
  42 PREDICATE: register-8 < register
  43     "register-size" word-prop 8 = ;
  44
  45 PREDICATE: register-16 < register
  46     "register-size" word-prop 16 = ;
  47
  48 PREDICATE: register-32 < register
  49     "register-size" word-prop 32 = ;
  50
  51 PREDICATE: register-64 < register
  52     "register-size" word-prop 64 = ;
  53
  54 PREDICATE: register-128 < register
  55     "register-size" word-prop 128 = ;
  56
  57 M: register extended? "register" word-prop 7 > ;
  58
  59 ! Addressing modes
  60 TUPLE: indirect base index scale displacement ;
  61
  62 M: indirect extended? base>> extended? ;
  63
  64 : canonicalize-EBP ( indirect -- indirect )
  65     #! { EBP } ==> { EBP 0 }
  66     dup [ base>> { EBP RBP R13 } member? ] [ displacement>> not ] bi and
  67     [ 0 >>displacement ] when ;
  68
  69 ERROR: bad-index indirect ;
  70
  71 : check-ESP ( indirect -- indirect )
  72     dup index>> { ESP RSP } memq? [ bad-index ] when ;
  73
  74 : canonicalize ( indirect -- indirect )
  75     #! Modify the indirect to work around certain addressing mode
  76     #! quirks.
  77     canonicalize-EBP check-ESP ;
  78
  79 : <indirect> ( base index scale displacement -- indirect )
  80     indirect boa canonicalize ;
  81
  82 : reg-code ( reg -- n ) "register" word-prop 7 bitand ;
  83
  84 : indirect-base* ( op -- n ) base>> EBP or reg-code ;
  85
  86 : indirect-index* ( op -- n ) index>> ESP or reg-code ;
  87
  88 : indirect-scale* ( op -- n ) scale>> 0 or ;
  89
  90 GENERIC: sib-present? ( op -- ? )
  91
  92 M: indirect sib-present?
  93     [ base>> { ESP RSP R12 } member? ] [ index>> ] [ scale>> ] tri or or ;
  94
  95 M: register sib-present? drop f ;
  96
  97 GENERIC: r/m ( operand -- n )
  98
  99 M: indirect r/m
 100     dup sib-present?
 101     [ drop ESP reg-code ] [ indirect-base* ] if ;
 102
 103 M: register r/m reg-code ;
 104
 105 ! Immediate operands
 106 UNION: immediate byte integer ;
 107
 108 GENERIC: fits-in-byte? ( value -- ? )
 109
 110 M: byte fits-in-byte? drop t ;
 111
 112 M: integer fits-in-byte? -128 127 between? ;
 113
 114 GENERIC: modifier ( op -- n )
 115
 116 M: indirect modifier
 117     dup base>> [
 118         displacement>> {
 119             { [ dup not ] [ BIN: 00 ] }
 120             { [ dup fits-in-byte? ] [ BIN: 01 ] }
 121             { [ dup immediate? ] [ BIN: 10 ] }
 122         } cond nip
 123     ] [
 124         drop BIN: 00
 125     ] if ;
 126
 127 M: register modifier drop BIN: 11 ;
 128
 129 GENERIC# n, 1 ( value n -- )
 130
 131 M: integer n, >le % ;
 132 M: byte n, [ value>> ] dip n, ;
 133 : 1, ( n -- ) 1 n, ; inline
 134 : 4, ( n -- ) 4 n, ; inline
 135 : 2, ( n -- ) 2 n, ; inline
 136 : cell, ( n -- ) bootstrap-cell n, ; inline
 137
 138 : mod-r/m, ( reg# indirect -- )
 139     [ 3 shift ] [ [ modifier 6 shift ] [ r/m ] bi ] bi* bitor bitor , ;
 140
 141 : sib, ( indirect -- )
 142     dup sib-present? [
 143         [ indirect-base* ]
 144         [ indirect-index* 3 shift ]
 145         [ indirect-scale* 6 shift ] tri bitor bitor ,
 146     ] [
 147         drop
 148     ] if ;
 149
 150 GENERIC: displacement, ( op -- )
 151
 152 M: indirect displacement,
 153     dup displacement>> dup [
 154         swap base>>
 155         [ dup fits-in-byte? [ , ] [ 4, ] if ] [ 4, ] if
 156     ] [
 157         2drop
 158     ] if ;
 159
 160 M: register displacement, drop ;
 161
 162 : addressing ( reg# indirect -- )
 163     [ mod-r/m, ] [ sib, ] [ displacement, ] tri ;
 164
 165 ! Utilities
 166 UNION: operand register indirect ;
 167
 168 GENERIC: operand-64? ( operand -- ? )
 169
 170 M: indirect operand-64?
 171     [ base>> ] [ index>> ] bi [ operand-64? ] either? ;
 172
 173 M: register-64 operand-64? drop t ;
 174
 175 M: object operand-64? drop f ;
 176
 177 : rex.w? ( rex.w reg r/m -- ? )
 178     {
 179         { [ dup register-128? ] [ drop operand-64? ] }
 180         { [ dup not ] [ drop operand-64? ] }
 181         [ nip operand-64? ]
 182     } cond and ;
 183
 184 : rex.r ( m op -- n )
 185     extended? [ BIN: 00000100 bitor ] when ;
 186
 187 : rex.b ( m op -- n )
 188     [ extended? [ BIN: 00000001 bitor ] when ] keep
 189     dup indirect? [
 190         index>> extended? [ BIN: 00000010 bitor ] when
 191     ] [
 192         drop
 193     ] if ;
 194
 195 : rex-prefix ( reg r/m rex.w -- )
 196     #! Compile an AMD64 REX prefix.
 197     2over rex.w? BIN: 01001000 BIN: 01000000 ?
 198     swap rex.r swap rex.b
 199     dup BIN: 01000000 = [ drop ] [ , ] if ;
 200
 201 : 16-prefix ( reg r/m -- )
 202     [ register-16? ] either? [ HEX: 66 , ] when ;
 203
 204 : prefix ( reg r/m rex.w -- ) 2over 16-prefix rex-prefix ;
 205
 206 : prefix-1 ( reg rex.w -- ) f swap prefix ;
 207
 208 : short-operand ( reg rex.w n -- )
 209     #! Some instructions encode their single operand as part of
 210     #! the opcode.
 211     [ dupd prefix-1 reg-code ] dip + , ;
 212
 213 : opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
 214
 215 : extended-opcode ( opcode -- opcode' ) OCT: 17 swap 2array ;
 216
 217 : extended-opcode, ( opcode -- ) extended-opcode opcode, ;
 218
 219 : opcode-or ( opcode mask -- opcode' )
 220     swap dup array?
 221     [ unclip-last rot bitor suffix ] [ bitor ] if ;
 222
 223 : 1-operand ( op reg,rex.w,opcode -- )
 224     #! The 'reg' is not really a register, but a value for the
 225     #! 'reg' field of the mod-r/m byte.
 226     first3 [ [ over ] dip prefix-1 ] dip opcode, swap addressing ;
 227
 228 : immediate-operand-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
 229     pick integer? [ first3 BIN: 1 opcode-or 3array ] when ;
 230
 231 : immediate-1 ( imm dst reg,rex.w,opcode -- )
 232     immediate-operand-size-bit 1-operand 1, ;
 233
 234 : immediate-4 ( imm dst reg,rex.w,opcode -- )
 235     immediate-operand-size-bit 1-operand 4, ;
 236
 237 : immediate-fits-in-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
 238     pick integer? [ first3 BIN: 10 opcode-or 3array ] when ;
 239
 240 : immediate-1/4 ( imm dst reg,rex.w,opcode -- )
 241     #! If imm is a byte, compile the opcode and the byte.
 242     #! Otherwise, set the 8-bit operand flag in the opcode, and
 243     #! compile the cell. The 'reg' is not really a register, but
 244     #! a value for the 'reg' field of the mod-r/m byte.
 245     pick fits-in-byte? [
 246         immediate-fits-in-size-bit immediate-1
 247     ] [
 248         immediate-4
 249     ] if ;
 250
 251 : (2-operand) ( dst src op -- )
 252     [ 2dup t rex-prefix ] dip opcode,
 253     reg-code swap addressing ;
 254
 255 : direction-bit ( dst src op -- dst' src' op' )
 256     pick register? pick register? not and
 257     [ BIN: 10 opcode-or swapd ] when ;
 258
 259 : operand-size-bit ( dst src op -- dst' src' op' )
 260     over register-8? [ BIN: 1 opcode-or ] unless ;
 261
 262 : 2-operand ( dst src op -- )
 263     #! Sets the opcode's direction bit. It is set if the
 264     #! destination is a direct register operand.
 265     2over 16-prefix
 266     direction-bit
 267     operand-size-bit
 268     (2-operand) ;
 269
 270 PRIVATE>
 271
 272 : [] ( reg/displacement -- indirect )
 273     dup integer? [ [ f f f ] dip ] [ f f f ] if <indirect> ;
 274
 275 : [+] ( reg displacement -- indirect )
 276     dup integer?
 277     [ dup zero? [ drop f ] when [ f f ] dip ]
 278     [ f f ] if
 279     <indirect> ;
 280
 281 ! Moving stuff
 282 GENERIC: PUSH ( op -- )
 283 M: register PUSH f HEX: 50 short-operand ;
 284 M: immediate PUSH HEX: 68 , 4, ;
 285 M: operand PUSH { BIN: 110 f HEX: ff } 1-operand ;
 286
 287 GENERIC: POP ( op -- )
 288 M: register POP f HEX: 58 short-operand ;
 289 M: operand POP { BIN: 000 f HEX: 8f } 1-operand ;
 290
 291 ! MOV where the src is immediate.
 292 GENERIC: (MOV-I) ( src dst -- )
 293 M: register (MOV-I) t HEX: b8 short-operand cell, ;
 294 M: operand (MOV-I)
 295     { BIN: 000 t HEX: c6 }
 296     pick byte? [ immediate-1 ] [ immediate-4 ] if ;
 297
 298 GENERIC: MOV ( dst src -- )
 299 M: immediate MOV swap (MOV-I) ;
 300 M: operand MOV HEX: 88 2-operand ;
 301
 302 : LEA ( dst src -- ) swap HEX: 8d 2-operand ;
 303
 304 ! Control flow
 305 GENERIC: JMP ( op -- )
 306 M: integer JMP HEX: e9 , 4, ;
 307 M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
 308
 309 GENERIC: CALL ( op -- )
 310 M: integer CALL HEX: e8 , 4, ;
 311 M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
 312
 313 GENERIC# JUMPcc 1 ( addr opcode -- )
 314 M: integer JUMPcc extended-opcode, 4, ;
 315
 316 : JO  ( dst -- ) HEX: 80 JUMPcc ;
 317 : JNO ( dst -- ) HEX: 81 JUMPcc ;
 318 : JB  ( dst -- ) HEX: 82 JUMPcc ;
 319 : JAE ( dst -- ) HEX: 83 JUMPcc ;
 320 : JE  ( dst -- ) HEX: 84 JUMPcc ; ! aka JZ
 321 : JNE ( dst -- ) HEX: 85 JUMPcc ;
 322 : JBE ( dst -- ) HEX: 86 JUMPcc ;
 323 : JA  ( dst -- ) HEX: 87 JUMPcc ;
 324 : JS  ( dst -- ) HEX: 88 JUMPcc ;
 325 : JNS ( dst -- ) HEX: 89 JUMPcc ;
 326 : JP  ( dst -- ) HEX: 8a JUMPcc ;
 327 : JNP ( dst -- ) HEX: 8b JUMPcc ;
 328 : JL  ( dst -- ) HEX: 8c JUMPcc ;
 329 : JGE ( dst -- ) HEX: 8d JUMPcc ;
 330 : JLE ( dst -- ) HEX: 8e JUMPcc ;
 331 : JG  ( dst -- ) HEX: 8f JUMPcc ;
 332
 333 : LEAVE ( -- ) HEX: c9 , ;
 334
 335 : RET ( n -- )
 336     dup zero? [ drop HEX: c3 , ] [ HEX: c2 , 2, ] if ;
 337
 338 ! Arithmetic
 339
 340 GENERIC: ADD ( dst src -- )
 341 M: immediate ADD swap { BIN: 000 t HEX: 80 } immediate-1/4 ;
 342 M: operand ADD OCT: 000 2-operand ;
 343
 344 GENERIC: OR ( dst src -- )
 345 M: immediate OR swap { BIN: 001 t HEX: 80 } immediate-1/4 ;
 346 M: operand OR OCT: 010 2-operand ;
 347
 348 GENERIC: ADC ( dst src -- )
 349 M: immediate ADC swap { BIN: 010 t HEX: 80 } immediate-1/4 ;
 350 M: operand ADC OCT: 020 2-operand ;
 351
 352 GENERIC: SBB ( dst src -- )
 353 M: immediate SBB swap { BIN: 011 t HEX: 80 } immediate-1/4 ;
 354 M: operand SBB OCT: 030 2-operand ;
 355
 356 GENERIC: AND ( dst src -- )
 357 M: immediate AND swap { BIN: 100 t HEX: 80 } immediate-1/4 ;
 358 M: operand AND OCT: 040 2-operand ;
 359
 360 GENERIC: SUB ( dst src -- )
 361 M: immediate SUB swap { BIN: 101 t HEX: 80 } immediate-1/4 ;
 362 M: operand SUB OCT: 050 2-operand ;
 363
 364 GENERIC: XOR ( dst src -- )
 365 M: immediate XOR swap { BIN: 110 t HEX: 80 } immediate-1/4 ;
 366 M: operand XOR OCT: 060 2-operand ;
 367
 368 GENERIC: CMP ( dst src -- )
 369 M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
 370 M: operand CMP OCT: 070 2-operand ;
 371
 372 GENERIC: TEST ( dst src -- )
 373 M: immediate TEST swap { BIN: 0 t HEX: f7 } immediate-4 ;
 374 M: operand TEST OCT: 204 2-operand ;
 375
 376 : XCHG ( dst src -- ) OCT: 207 2-operand ;
 377
 378 : BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ;
 379
 380 : NOT  ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
 381 : NEG  ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
 382 : MUL  ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
 383 : IMUL ( src -- ) { BIN: 101 t HEX: f7 } 1-operand ;
 384 : DIV  ( dst -- ) { BIN: 110 t HEX: f7 } 1-operand ;
 385 : IDIV ( src -- ) { BIN: 111 t HEX: f7 } 1-operand ;
 386
 387 : CDQ ( -- ) HEX: 99 , ;
 388 : CQO ( -- ) HEX: 48 , CDQ ;
 389
 390 : (SHIFT) ( dst src op -- )
 391     over CL eq? [
 392         nip t HEX: d3 3array 1-operand
 393     ] [
 394         swapd t HEX: c0 3array immediate-1
 395     ] if ; inline
 396
 397 : ROL ( dst n -- ) BIN: 000 (SHIFT) ;
 398 : ROR ( dst n -- ) BIN: 001 (SHIFT) ;
 399 : RCL ( dst n -- ) BIN: 010 (SHIFT) ;
 400 : RCR ( dst n -- ) BIN: 011 (SHIFT) ;
 401 : SHL ( dst n -- ) BIN: 100 (SHIFT) ;
 402 : SHR ( dst n -- ) BIN: 101 (SHIFT) ;
 403 : SAR ( dst n -- ) BIN: 111 (SHIFT) ;
 404
 405 GENERIC: IMUL2 ( dst src -- )
 406 M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ;
 407 M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
 408
 409 : MOVSX ( dst src -- )
 410     dup register-32? OCT: 143 OCT: 276 extended-opcode ?
 411     over register-16? [ BIN: 1 opcode-or ] when
 412     swapd
 413     (2-operand) ;
 414
 415 : MOVZX ( dst src -- )
 416     OCT: 266 extended-opcode
 417     over register-16? [ BIN: 1 opcode-or ] when
 418     swapd
 419     (2-operand) ;
 420
 421 ! Conditional move
 422 : MOVcc ( dst src cc -- ) extended-opcode swapd (2-operand) ;
 423
 424 : CMOVO  ( dst src -- ) HEX: 40 MOVcc ;
 425 : CMOVNO ( dst src -- ) HEX: 41 MOVcc ;
 426 : CMOVB  ( dst src -- ) HEX: 42 MOVcc ;
 427 : CMOVAE ( dst src -- ) HEX: 43 MOVcc ;
 428 : CMOVE  ( dst src -- ) HEX: 44 MOVcc ; ! aka CMOVZ
 429 : CMOVNE ( dst src -- ) HEX: 45 MOVcc ;
 430 : CMOVBE ( dst src -- ) HEX: 46 MOVcc ;
 431 : CMOVA  ( dst src -- ) HEX: 47 MOVcc ;
 432 : CMOVS  ( dst src -- ) HEX: 48 MOVcc ;
 433 : CMOVNS ( dst src -- ) HEX: 49 MOVcc ;
 434 : CMOVP  ( dst src -- ) HEX: 4a MOVcc ;
 435 : CMOVNP ( dst src -- ) HEX: 4b MOVcc ;
 436 : CMOVL  ( dst src -- ) HEX: 4c MOVcc ;
 437 : CMOVGE ( dst src -- ) HEX: 4d MOVcc ;
 438 : CMOVLE ( dst src -- ) HEX: 4e MOVcc ;
 439 : CMOVG  ( dst src -- ) HEX: 4f MOVcc ;
 440
 441 ! CPU Identification
 442
 443 : CPUID ( -- ) HEX: a2 extended-opcode, ;
 444
 445 ! Misc
 446
 447 : NOP ( -- ) HEX: 90 , ;
 448
 449 ! x87 Floating Point Unit
 450
 451 : FSTPS ( operand -- ) { BIN: 011 f HEX: d9 } 1-operand ;
 452 : FSTPL ( operand -- ) { BIN: 011 f HEX: dd } 1-operand ;
 453
 454 : FLDS ( operand -- ) { BIN: 000 f HEX: d9 } 1-operand ;
 455 : FLDL ( operand -- ) { BIN: 000 f HEX: dd } 1-operand ;
 456
 457 ! SSE multimedia instructions
 458
 459 <PRIVATE
 460
 461 : direction-bit-sse ( dst src op1 -- dst' src' op1' )
 462     pick register-128? [ swapd ] [ BIN: 1 bitor ] if ;
 463
 464 : 2-operand-sse ( dst src op1 op2 -- )
 465     , direction-bit-sse extended-opcode (2-operand) ;
 466
 467 : 2-operand-int/sse ( dst src op1 op2 -- )
 468     , swapd extended-opcode (2-operand) ;
 469
 470 PRIVATE>
 471
 472 : MOVSS   ( dest src -- ) HEX: 10 HEX: f3 2-operand-sse ;
 473 : MOVSD   ( dest src -- ) HEX: 10 HEX: f2 2-operand-sse ;
 474 : ADDSD   ( dest src -- ) HEX: 58 HEX: f2 2-operand-sse ;
 475 : MULSD   ( dest src -- ) HEX: 59 HEX: f2 2-operand-sse ;
 476 : SUBSD   ( dest src -- ) HEX: 5c HEX: f2 2-operand-sse ;
 477 : DIVSD   ( dest src -- ) HEX: 5e HEX: f2 2-operand-sse ;
 478 : SQRTSD  ( dest src -- ) HEX: 51 HEX: f2 2-operand-sse ;
 479 : UCOMISD ( dest src -- ) HEX: 2e HEX: 66 2-operand-sse ;
 480 : COMISD  ( dest src -- ) HEX: 2f HEX: 66 2-operand-sse ;
 481
 482 : CVTSS2SD ( dest src -- ) HEX: 5a HEX: f3 2-operand-sse ;
 483 : CVTSD2SS ( dest src -- ) HEX: 5a HEX: f2 2-operand-sse ;
 484
 485 : CVTSI2SD  ( dest src -- ) HEX: 2a HEX: f2 2-operand-int/sse ;
 486 : CVTSD2SI  ( dest src -- ) HEX: 2d HEX: f2 2-operand-int/sse ;
 487 : CVTTSD2SI ( dest src -- ) HEX: 2c HEX: f2 2-operand-int/sse ;