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