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