basis/cpu/x86/intrinsics/intrinsics.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.accessors arrays cpu.x86.assembler
   4 cpu.x86.allot cpu.x86.architecture cpu.architecture kernel
   5 kernel.private math math.private namespaces quotations sequences
   6 words generic byte-arrays hashtables hashtables.private
   7 sequences.private sbufs sbufs.private
   8 vectors vectors.private layouts system strings.private
   9 slots.private
  10 compiler.constants
  11 compiler.intrinsics
  12 compiler.generator
  13 compiler.generator.fixup
  14 compiler.generator.registers ;
  15 IN: cpu.x86.intrinsics
  16
  17 ! Type checks
  18 \ tag [
  19     "in" operand tag-mask get AND
  20     "in" operand %tag-fixnum
  21 ] H{
  22     { +input+ { { f "in" } } }
  23     { +output+ { "in" } }
  24 } define-intrinsic
  25
  26 ! Slots
  27 : %slot-literal-known-tag ( -- op )
  28     "obj" operand
  29     "n" get cells
  30     "obj" get operand-tag - [+] ;
  31
  32 : %slot-literal-any-tag ( -- op )
  33     "obj" operand %untag
  34     "obj" operand "n" get cells [+] ;
  35
  36 : %slot-any ( -- op )
  37     "obj" operand %untag
  38     "n" operand fixnum>slot@
  39     "obj" operand "n" operand [+] ;
  40
  41 \ slot {
  42     ! Slot number is literal and the tag is known
  43     {
  44         [ "val" operand %slot-literal-known-tag MOV ] H{
  45             { +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } }
  46             { +scratch+ { { f "val" } } }
  47             { +output+ { "val" } }
  48         }
  49     }
  50     ! Slot number is literal
  51     {
  52         [ "obj" operand %slot-literal-any-tag MOV ] H{
  53             { +input+ { { f "obj" } { [ small-slot? ] "n" } } }
  54             { +output+ { "obj" } }
  55         }
  56     }
  57     ! Slot number in a register
  58     {
  59         [ "obj" operand %slot-any MOV ] H{
  60             { +input+ { { f "obj" } { f "n" } } }
  61             { +output+ { "obj" } }
  62             { +clobber+ { "n" } }
  63         }
  64     }
  65 } define-intrinsics
  66
  67 : generate-write-barrier ( -- )
  68     #! Mark the card pointed to by vreg.
  69     "val" get operand-immediate? "obj" get fresh-object? or [
  70         ! Mark the card
  71         "obj" operand card-bits SHR
  72         "cards_offset" f temp-reg v>operand %alien-global
  73         temp-reg v>operand "obj" operand [+] card-mark <byte> MOV
  74
  75         ! Mark the card deck
  76         "obj" operand deck-bits card-bits - SHR
  77         "decks_offset" f temp-reg v>operand %alien-global
  78         temp-reg v>operand "obj" operand [+] card-mark <byte> MOV
  79     ] unless ;
  80
  81 \ set-slot {
  82     ! Slot number is literal and the tag is known
  83     {
  84         [ %slot-literal-known-tag "val" operand MOV generate-write-barrier ] H{
  85             { +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
  86             { +clobber+ { "obj" } }
  87         }
  88     }
  89     ! Slot number is literal
  90     {
  91         [ %slot-literal-any-tag "val" operand MOV generate-write-barrier ] H{
  92             { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
  93             { +clobber+ { "obj" } }
  94         }
  95     }
  96     ! Slot number in a register
  97     {
  98         [ %slot-any "val" operand MOV generate-write-barrier ] H{
  99             { +input+ { { f "val" } { f "obj" } { f "n" } } }
 100             { +clobber+ { "obj" "n" } }
 101         }
 102     }
 103 } define-intrinsics
 104
 105 ! Sometimes, we need to do stuff with operands which are
 106 ! less than the word size. Instead of teaching the register
 107 ! allocator about the different sized registers, with all
 108 ! the complexity this entails, we just push/pop a register
 109 ! which is guaranteed to be unused (the tempreg)
 110 : small-reg cell 8 = RBX EBX ? ; inline
 111 : small-reg-8 BL ; inline
 112 : small-reg-16 BX ; inline
 113 : small-reg-32 EBX ; inline
 114
 115 ! Fixnums
 116 : fixnum-op ( op hash -- pair )
 117     >r [ "x" operand "y" operand ] swap suffix r> 2array ;
 118
 119 : fixnum-value-op ( op -- pair )
 120     H{
 121         { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
 122         { +output+ { "x" } }
 123     } fixnum-op ;
 124
 125 : fixnum-register-op ( op -- pair )
 126     H{
 127         { +input+ { { f "x" } { f "y" } } }
 128         { +output+ { "x" } }
 129     } fixnum-op ;
 130
 131 : define-fixnum-op ( word op -- )
 132     [ fixnum-value-op ] keep fixnum-register-op
 133     2array define-intrinsics ;
 134
 135 {
 136     { fixnum+fast ADD }
 137     { fixnum-fast SUB }
 138     { fixnum-bitand AND }
 139     { fixnum-bitor OR }
 140     { fixnum-bitxor XOR }
 141 } [
 142     first2 define-fixnum-op
 143 ] each
 144
 145 \ fixnum-bitnot [
 146     "x" operand NOT
 147     "x" operand tag-mask get XOR
 148 ] H{
 149     { +input+ { { f "x" } } }
 150     { +output+ { "x" } }
 151 } define-intrinsic
 152
 153 \ fixnum*fast {
 154     {
 155         [
 156             "x" operand "y" get IMUL2
 157         ] H{
 158             { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
 159             { +output+ { "x" } }
 160         }
 161     } {
 162         [
 163             "out" operand "x" operand MOV
 164             "out" operand %untag-fixnum
 165             "y" operand "out" operand IMUL2
 166         ] H{
 167             { +input+ { { f "x" } { f "y" } } }
 168             { +scratch+ { { f "out" } } }
 169             { +output+ { "out" } }
 170         }
 171     }
 172 } define-intrinsics
 173
 174 : %untag-fixnums ( seq -- )
 175     [ %untag-fixnum ] unique-operands ;
 176
 177 \ fixnum-shift-fast [
 178     "x" operand "y" get
 179     dup 0 < [ neg SAR ] [ SHL ] if
 180     ! Mask off low bits
 181     "x" operand %untag
 182 ] H{
 183     { +input+ { { f "x" } { [ ] "y" } } }
 184     { +output+ { "x" } }
 185 } define-intrinsic
 186
 187 : overflow-check ( word -- )
 188     "end" define-label
 189     "z" operand "x" operand MOV
 190     "z" operand "y" operand pick execute
 191     ! If the previous arithmetic operation overflowed, then we
 192     ! turn the result into a bignum and leave it in EAX.
 193     "end" get JNO
 194     ! There was an overflow. Recompute the original operand.
 195     { "y" "x" } %untag-fixnums
 196     "x" operand "y" operand rot execute
 197     "z" get "x" get %allot-bignum-signed-1
 198     "end" resolve-label ; inline
 199
 200 : overflow-template ( word insn -- )
 201     [ overflow-check ] curry H{
 202         { +input+ { { f "x" } { f "y" } } }
 203         { +scratch+ { { f "z" } } }
 204         { +output+ { "z" } }
 205         { +clobber+ { "x" "y" } }
 206     } define-intrinsic ;
 207
 208 \ fixnum+ \ ADD overflow-template
 209 \ fixnum- \ SUB overflow-template
 210
 211 : fixnum-jump ( op inputs -- pair )
 212     >r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
 213
 214 : fixnum-value-jump ( op -- pair )
 215     { { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;
 216
 217 : fixnum-register-jump ( op -- pair )
 218     { { f "x" } { f "y" } } fixnum-jump ;
 219
 220 : define-fixnum-jump ( word op -- )
 221     [ fixnum-value-jump ] keep fixnum-register-jump
 222     2array define-if-intrinsics ;
 223
 224 {
 225     { fixnum< JGE }
 226     { fixnum<= JG }
 227     { fixnum> JLE }
 228     { fixnum>= JL }
 229     { eq? JNE }
 230 } [
 231     first2 define-fixnum-jump
 232 ] each
 233
 234 \ fixnum>bignum [
 235     "x" operand %untag-fixnum
 236     "x" get dup %allot-bignum-signed-1
 237 ] H{
 238     { +input+ { { f "x" } } }
 239     { +output+ { "x" } }
 240 } define-intrinsic
 241
 242 \ bignum>fixnum [
 243     "nonzero" define-label
 244     "positive" define-label
 245     "end" define-label
 246     "x" operand %untag
 247     "y" operand "x" operand cell [+] MOV
 248      ! if the length is 1, its just the sign and nothing else,
 249      ! so output 0
 250     "y" operand 1 v>operand CMP
 251     "nonzero" get JNE
 252     "y" operand 0 MOV
 253     "end" get JMP
 254     "nonzero" resolve-label
 255     ! load the value
 256     "y" operand "x" operand 3 cells [+] MOV
 257     ! load the sign
 258     "x" operand "x" operand 2 cells [+] MOV
 259     ! is the sign negative?
 260     "x" operand 0 CMP
 261     "positive" get JE
 262     "y" operand -1 IMUL2
 263     "positive" resolve-label
 264     "y" operand 3 SHL
 265     "end" resolve-label
 266 ] H{
 267     { +input+ { { f "x" } } }
 268     { +scratch+ { { f "y" } } }
 269     { +clobber+ { "x" } }
 270     { +output+ { "y" } }
 271 } define-intrinsic
 272
 273 ! User environment
 274 : %userenv ( -- )
 275     "x" operand 0 MOV
 276     "userenv" f rc-absolute-cell rel-dlsym
 277     "n" operand fixnum>slot@
 278     "n" operand "x" operand ADD ;
 279
 280 \ getenv [
 281     %userenv  "n" operand dup [] MOV
 282 ] H{
 283     { +input+ { { f "n" } } }
 284     { +scratch+ { { f "x" } } }
 285     { +output+ { "n" } }
 286 } define-intrinsic
 287
 288 \ setenv [
 289     %userenv  "n" operand [] "val" operand MOV
 290 ] H{
 291     { +input+ { { f "val" } { f "n" } } }
 292     { +scratch+ { { f "x" } } }
 293     { +clobber+ { "n" } }
 294 } define-intrinsic
 295
 296 \ (tuple) [
 297     tuple "layout" get size>> 2 + cells [
 298         ! Store layout
 299         "layout" get "scratch" get load-literal
 300         1 object@ "scratch" operand MOV
 301         ! Store tagged ptr in reg
 302         "tuple" get tuple %store-tagged
 303     ] %allot
 304 ] H{
 305     { +input+ { { [ ] "layout" } } }
 306     { +scratch+ { { f "tuple" } { f "scratch" } } }
 307     { +output+ { "tuple" } }
 308 } define-intrinsic
 309
 310 \ (array) [
 311     array "n" get 2 + cells [
 312         ! Store length
 313         1 object@ "n" operand MOV
 314         ! Store tagged ptr in reg
 315         "array" get object %store-tagged
 316     ] %allot
 317 ] H{
 318     { +input+ { { [ ] "n" } } }
 319     { +scratch+ { { f "array" } } }
 320     { +output+ { "array" } }
 321 } define-intrinsic
 322
 323 \ (byte-array) [
 324     byte-array "n" get 2 cells + [
 325         ! Store length
 326         1 object@ "n" operand MOV
 327         ! Store tagged ptr in reg
 328         "array" get object %store-tagged
 329     ] %allot
 330 ] H{
 331     { +input+ { { [ ] "n" } } }
 332     { +scratch+ { { f "array" } } }
 333     { +output+ { "array" } }
 334 } define-intrinsic
 335
 336 \ <ratio> [
 337     ratio 3 cells [
 338         1 object@ "numerator" operand MOV
 339         2 object@ "denominator" operand MOV
 340         ! Store tagged ptr in reg
 341         "ratio" get ratio %store-tagged
 342     ] %allot
 343 ] H{
 344     { +input+ { { f "numerator" } { f "denominator" } } }
 345     { +scratch+ { { f "ratio" } } }
 346     { +output+ { "ratio" } }
 347 } define-intrinsic
 348
 349 \ <complex> [
 350     complex 3 cells [
 351         1 object@ "real" operand MOV
 352         2 object@ "imaginary" operand MOV
 353         ! Store tagged ptr in reg
 354         "complex" get complex %store-tagged
 355     ] %allot
 356 ] H{
 357     { +input+ { { f "real" } { f "imaginary" } } }
 358     { +scratch+ { { f "complex" } } }
 359     { +output+ { "complex" } }
 360 } define-intrinsic
 361
 362 \ <wrapper> [
 363     wrapper 2 cells [
 364         1 object@ "obj" operand MOV
 365         ! Store tagged ptr in reg
 366         "wrapper" get object %store-tagged
 367     ] %allot
 368 ] H{
 369     { +input+ { { f "obj" } } }
 370     { +scratch+ { { f "wrapper" } } }
 371     { +output+ { "wrapper" } }
 372 } define-intrinsic
 373
 374 ! Alien intrinsics
 375 : %alien-accessor ( quot -- )
 376     "offset" operand %untag-fixnum
 377     "offset" operand "alien" operand ADD
 378     "offset" operand [] swap call ; inline
 379
 380 : %alien-integer-get ( quot reg -- )
 381     small-reg PUSH
 382     swap %alien-accessor
 383     "value" operand small-reg MOV
 384     "value" operand %tag-fixnum
 385     small-reg POP ; inline
 386
 387 : alien-integer-get-template
 388     H{
 389         { +input+ {
 390             { unboxed-c-ptr "alien" c-ptr }
 391             { f "offset" fixnum }
 392         } }
 393         { +scratch+ { { f "value" } } }
 394         { +output+ { "value" } }
 395         { +clobber+ { "offset" } }
 396     } ;
 397
 398 : define-getter ( word quot reg -- )
 399     [ %alien-integer-get ] 2curry
 400     alien-integer-get-template
 401     define-intrinsic ;
 402
 403 : define-unsigned-getter ( word reg -- )
 404     [ small-reg dup XOR MOV ] swap define-getter ;
 405
 406 : define-signed-getter ( word reg -- )
 407     [ [ >r MOV small-reg r> MOVSX ] curry ] keep define-getter ;
 408
 409 : %alien-integer-set ( quot reg -- )
 410     small-reg PUSH
 411     small-reg "value" operand MOV
 412     small-reg %untag-fixnum
 413     swap %alien-accessor
 414     small-reg POP ; inline
 415
 416 : alien-integer-set-template
 417     H{
 418         { +input+ {
 419             { f "value" fixnum }
 420             { unboxed-c-ptr "alien" c-ptr }
 421             { f "offset" fixnum }
 422         } }
 423         { +clobber+ { "value" "offset" } }
 424     } ;
 425
 426 : define-setter ( word reg -- )
 427     [ swap MOV ] swap
 428     [ %alien-integer-set ] 2curry
 429     alien-integer-set-template
 430     define-intrinsic ;
 431
 432 \ alien-unsigned-1 small-reg-8 define-unsigned-getter
 433 \ set-alien-unsigned-1 small-reg-8 define-setter
 434
 435 \ alien-signed-1 small-reg-8 define-signed-getter
 436 \ set-alien-signed-1 small-reg-8 define-setter
 437
 438 \ alien-unsigned-2 small-reg-16 define-unsigned-getter
 439 \ set-alien-unsigned-2 small-reg-16 define-setter
 440
 441 \ alien-signed-2 small-reg-16 define-signed-getter
 442 \ set-alien-signed-2 small-reg-16 define-setter
 443
 444 \ alien-cell [
 445     "value" operand [ MOV ] %alien-accessor
 446 ] H{
 447     { +input+ {
 448         { unboxed-c-ptr "alien" c-ptr }
 449         { f "offset" fixnum }
 450     } }
 451     { +scratch+ { { unboxed-alien "value" } } }
 452     { +output+ { "value" } }
 453     { +clobber+ { "offset" } }
 454 } define-intrinsic
 455
 456 \ set-alien-cell [
 457     "value" operand [ swap MOV ] %alien-accessor
 458 ] H{
 459     { +input+ {
 460         { unboxed-c-ptr "value" pinned-c-ptr }
 461         { unboxed-c-ptr "alien" c-ptr }
 462         { f "offset" fixnum }
 463     } }
 464     { +clobber+ { "offset" } }
 465 } define-intrinsic