basis/cpu/ppc/bootstrap.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov.\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 USING: bootstrap.image.private kernel kernel.private namespaces\r
   4 system cpu.ppc.assembler compiler.codegen.fixup compiler.units\r
   5 compiler.constants math math.private layouts words\r
   6 vocabs slots.private locals.backend ;\r
   7 FROM: cpu.ppc.assembler => B ;\r
   8 IN: bootstrap.ppc\r
   9 \r
  10 4 \ cell set\r
  11 big-endian on\r
  12 \r
  13 CONSTANT: ds-reg 13\r
  14 CONSTANT: rs-reg 14\r
  15 \r
  16 : factor-area-size ( -- n ) 4 bootstrap-cells ;\r
  17 \r
  18 : stack-frame ( -- n )\r
  19     factor-area-size c-area-size + 4 bootstrap-cells align ;\r
  20 \r
  21 : next-save ( -- n ) stack-frame bootstrap-cell - ;\r
  22 : xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;\r
  23 \r
  24 [\r
  25     0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
  26     11 3 profile-count-offset LWZ\r
  27     11 11 1 tag-fixnum ADDI\r
  28     11 3 profile-count-offset STW\r
  29     11 3 word-code-offset LWZ\r
  30     11 11 compiled-header-size ADDI\r
  31     11 MTCTR\r
  32     BCTR\r
  33 ] jit-profiling jit-define\r
  34 \r
  35 [\r
  36     0 3 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel\r
  37     0 MFLR\r
  38     1 1 stack-frame SUBI\r
  39     3 1 xt-save STW\r
  40     stack-frame 3 LI\r
  41     3 1 next-save STW\r
  42     0 1 lr-save stack-frame + STW\r
  43 ] jit-prolog jit-define\r
  44 \r
  45 [\r
  46     0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
  47     3 ds-reg 4 STWU\r
  48 ] jit-push-immediate jit-define\r
  49 \r
  50 [\r
  51     0 3 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel\r
  52     4 3 0 LWZ\r
  53     1 4 0 STW\r
  54     0 3 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel\r
  55     3 MTCTR\r
  56     BCTR\r
  57 ] jit-primitive jit-define\r
  58 \r
  59 [ 0 BL rc-relative-ppc-3 rt-xt-pic jit-rel ] jit-word-call jit-define\r
  60 \r
  61 [\r
  62     0 6 LOAD32 rc-absolute-ppc-2/2 rt-here jit-rel\r
  63     0 B rc-relative-ppc-3 rt-xt-pic-tail jit-rel\r
  64 ] jit-word-jump jit-define\r
  65 \r
  66 [ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-special jit-define\r
  67 \r
  68 [\r
  69     3 ds-reg 0 LWZ\r
  70     ds-reg dup 4 SUBI\r
  71     0 3 \ f tag-number CMPI\r
  72     2 BEQ\r
  73     0 B rc-relative-ppc-3 rt-xt jit-rel\r
  74     0 B rc-relative-ppc-3 rt-xt jit-rel\r
  75 ] jit-if jit-define\r
  76 \r
  77 : jit->r ( -- )\r
  78     4 ds-reg 0 LWZ\r
  79     ds-reg dup 4 SUBI\r
  80     4 rs-reg 4 STWU ;\r
  81 \r
  82 : jit-2>r ( -- )\r
  83     4 ds-reg 0 LWZ\r
  84     5 ds-reg -4 LWZ\r
  85     ds-reg dup 8 SUBI\r
  86     rs-reg dup 8 ADDI\r
  87     4 rs-reg 0 STW\r
  88     5 rs-reg -4 STW ;\r
  89 \r
  90 : jit-3>r ( -- )\r
  91     4 ds-reg 0 LWZ\r
  92     5 ds-reg -4 LWZ\r
  93     6 ds-reg -8 LWZ\r
  94     ds-reg dup 12 SUBI\r
  95     rs-reg dup 12 ADDI\r
  96     4 rs-reg 0 STW\r
  97     5 rs-reg -4 STW\r
  98     6 rs-reg -8 STW ;\r
  99 \r
 100 : jit-r> ( -- )\r
 101     4 rs-reg 0 LWZ\r
 102     rs-reg dup 4 SUBI\r
 103     4 ds-reg 4 STWU ;\r
 104 \r
 105 : jit-2r> ( -- )\r
 106     4 rs-reg 0 LWZ\r
 107     5 rs-reg -4 LWZ\r
 108     rs-reg dup 8 SUBI\r
 109     ds-reg dup 8 ADDI\r
 110     4 ds-reg 0 STW\r
 111     5 ds-reg -4 STW ;\r
 112 \r
 113 : jit-3r> ( -- )\r
 114     4 rs-reg 0 LWZ\r
 115     5 rs-reg -4 LWZ\r
 116     6 rs-reg -8 LWZ\r
 117     rs-reg dup 12 SUBI\r
 118     ds-reg dup 12 ADDI\r
 119     4 ds-reg 0 STW\r
 120     5 ds-reg -4 STW\r
 121     6 ds-reg -8 STW ;\r
 122 \r
 123 [\r
 124     jit->r\r
 125     0 BL rc-relative-ppc-3 rt-xt jit-rel\r
 126     jit-r>\r
 127 ] jit-dip jit-define\r
 128 \r
 129 [\r
 130     jit-2>r\r
 131     0 BL rc-relative-ppc-3 rt-xt jit-rel\r
 132     jit-2r>\r
 133 ] jit-2dip jit-define\r
 134 \r
 135 [\r
 136     jit-3>r\r
 137     0 BL rc-relative-ppc-3 rt-xt jit-rel\r
 138     jit-3r>\r
 139 ] jit-3dip jit-define\r
 140 \r
 141 : prepare-(execute) ( -- operand )\r
 142     3 ds-reg 0 LWZ\r
 143     ds-reg dup 4 SUBI\r
 144     4 3 word-xt-offset LWZ\r
 145     4 ;\r
 146 \r
 147 [ prepare-(execute) MTCTR BCTR ] jit-execute-jump jit-define\r
 148 \r
 149 [ prepare-(execute) MTLR BLRL ] jit-execute-call jit-define\r
 150 \r
 151 [\r
 152     0 1 lr-save stack-frame + LWZ\r
 153     1 1 stack-frame ADDI\r
 154     0 MTLR\r
 155 ] jit-epilog jit-define\r
 156 \r
 157 [ BLR ] jit-return jit-define\r
 158 \r
 159 ! ! ! Polymorphic inline caches\r
 160 \r
 161 ! Don't touch r6 here; it's used to pass the tail call site\r
 162 ! address for tail PICs\r
 163 \r
 164 ! Load a value from a stack position\r
 165 [\r
 166     4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel\r
 167 ] pic-load jit-define\r
 168 \r
 169 ! Tag\r
 170 : load-tag ( -- )\r
 171     4 4 tag-mask get ANDI\r
 172     4 4 tag-bits get SLWI ;\r
 173 \r
 174 [ load-tag ] pic-tag jit-define\r
 175 \r
 176 ! Hi-tag\r
 177 [\r
 178     3 4 MR\r
 179     load-tag\r
 180     0 4 object tag-number tag-fixnum CMPI\r
 181     2 BNE\r
 182     4 3 object tag-number neg LWZ\r
 183 ] pic-hi-tag jit-define\r
 184 \r
 185 ! Tuple\r
 186 [\r
 187     3 4 MR\r
 188     load-tag\r
 189     0 4 tuple tag-number tag-fixnum CMPI\r
 190     2 BNE\r
 191     4 3 tuple tag-number neg bootstrap-cell + LWZ\r
 192 ] pic-tuple jit-define\r
 193 \r
 194 ! Hi-tag and tuple\r
 195 [\r
 196     3 4 MR\r
 197     load-tag\r
 198     ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)\r
 199     0 4 BIN: 110 tag-fixnum CMPI\r
 200     5 BLT\r
 201     ! Untag r3\r
 202     3 3 0 0 31 tag-bits get - RLWINM\r
 203     ! Set r4 to 0 for objects, and bootstrap-cell for tuples\r
 204     4 4 1 tag-fixnum ANDI\r
 205     4 4 1 SRAWI\r
 206     ! Load header cell or tuple layout cell\r
 207     4 4 3 LWZX\r
 208 ] pic-hi-tag-tuple jit-define\r
 209 \r
 210 [\r
 211     0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel\r
 212 ] pic-check-tag jit-define\r
 213 \r
 214 [\r
 215     0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
 216     4 0 5 CMP\r
 217 ] pic-check jit-define\r
 218 \r
 219 [ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define\r
 220 \r
 221 ! ! ! Megamorphic caches\r
 222 \r
 223 [\r
 224     ! cache = ...\r
 225     0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
 226     ! key = class\r
 227     5 4 MR\r
 228     ! key &= cache.length - 1\r
 229     5 5 mega-cache-size get 1 - bootstrap-cell * ANDI\r
 230     ! cache += array-start-offset\r
 231     3 3 array-start-offset ADDI\r
 232     ! cache += key\r
 233     3 3 5 ADD\r
 234     ! if(get(cache) == class)\r
 235     6 3 0 LWZ\r
 236     6 0 4 CMP\r
 237     10 BNE\r
 238     ! megamorphic_cache_hits++\r
 239     0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel\r
 240     5 4 0 LWZ\r
 241     5 5 1 ADDI\r
 242     5 4 0 STW\r
 243     ! ... goto get(cache + bootstrap-cell)\r
 244     3 3 4 LWZ\r
 245     3 3 word-xt-offset LWZ\r
 246     3 MTCTR\r
 247     BCTR\r
 248     ! fall-through on miss\r
 249 ] mega-lookup jit-define\r
 250 \r
 251 ! ! ! Sub-primitives\r
 252 \r
 253 ! Quotations and words\r
 254 [\r
 255     3 ds-reg 0 LWZ\r
 256     ds-reg dup 4 SUBI\r
 257     4 3 quot-xt-offset LWZ\r
 258     4 MTCTR\r
 259     BCTR\r
 260 ] \ (call) define-sub-primitive\r
 261 \r
 262 ! Objects\r
 263 [\r
 264     3 ds-reg 0 LWZ\r
 265     3 3 tag-mask get ANDI\r
 266     3 3 tag-bits get SLWI\r
 267     3 ds-reg 0 STW\r
 268 ] \ tag define-sub-primitive\r
 269 \r
 270 [\r
 271     3 ds-reg 0 LWZ\r
 272     4 ds-reg -4 LWZU\r
 273     3 3 1 SRAWI\r
 274     4 4 0 0 31 tag-bits get - RLWINM\r
 275     4 3 3 LWZX\r
 276     3 ds-reg 0 STW\r
 277 ] \ slot define-sub-primitive\r
 278 \r
 279 ! Shufflers\r
 280 [\r
 281     ds-reg dup 4 SUBI\r
 282 ] \ drop define-sub-primitive\r
 283 \r
 284 [\r
 285     ds-reg dup 8 SUBI\r
 286 ] \ 2drop define-sub-primitive\r
 287 \r
 288 [\r
 289     ds-reg dup 12 SUBI\r
 290 ] \ 3drop define-sub-primitive\r
 291 \r
 292 [\r
 293     3 ds-reg 0 LWZ\r
 294     3 ds-reg 4 STWU\r
 295 ] \ dup define-sub-primitive\r
 296 \r
 297 [\r
 298     3 ds-reg 0 LWZ\r
 299     4 ds-reg -4 LWZ\r
 300     ds-reg dup 8 ADDI\r
 301     3 ds-reg 0 STW\r
 302     4 ds-reg -4 STW\r
 303 ] \ 2dup define-sub-primitive\r
 304 \r
 305 [\r
 306     3 ds-reg 0 LWZ\r
 307     4 ds-reg -4 LWZ\r
 308     5 ds-reg -8 LWZ\r
 309     ds-reg dup 12 ADDI\r
 310     3 ds-reg 0 STW\r
 311     4 ds-reg -4 STW\r
 312     5 ds-reg -8 STW\r
 313 ] \ 3dup define-sub-primitive\r
 314 \r
 315 [\r
 316     3 ds-reg 0 LWZ\r
 317     ds-reg dup 4 SUBI\r
 318     3 ds-reg 0 STW\r
 319 ] \ nip define-sub-primitive\r
 320 \r
 321 [\r
 322     3 ds-reg 0 LWZ\r
 323     ds-reg dup 8 SUBI\r
 324     3 ds-reg 0 STW\r
 325 ] \ 2nip define-sub-primitive\r
 326 \r
 327 [\r
 328     3 ds-reg -4 LWZ\r
 329     3 ds-reg 4 STWU\r
 330 ] \ over define-sub-primitive\r
 331 \r
 332 [\r
 333     3 ds-reg -8 LWZ\r
 334     3 ds-reg 4 STWU\r
 335 ] \ pick define-sub-primitive\r
 336 \r
 337 [\r
 338     3 ds-reg 0 LWZ\r
 339     4 ds-reg -4 LWZ\r
 340     4 ds-reg 0 STW\r
 341     3 ds-reg 4 STWU\r
 342 ] \ dupd define-sub-primitive\r
 343 \r
 344 [\r
 345     3 ds-reg 0 LWZ\r
 346     4 ds-reg -4 LWZ\r
 347     3 ds-reg 4 STWU\r
 348     4 ds-reg -4 STW\r
 349     3 ds-reg -8 STW\r
 350 ] \ tuck define-sub-primitive\r
 351 \r
 352 [\r
 353     3 ds-reg 0 LWZ\r
 354     4 ds-reg -4 LWZ\r
 355     3 ds-reg -4 STW\r
 356     4 ds-reg 0 STW\r
 357 ] \ swap define-sub-primitive\r
 358 \r
 359 [\r
 360     3 ds-reg -4 LWZ\r
 361     4 ds-reg -8 LWZ\r
 362     3 ds-reg -8 STW\r
 363     4 ds-reg -4 STW\r
 364 ] \ swapd define-sub-primitive\r
 365 \r
 366 [\r
 367     3 ds-reg 0 LWZ\r
 368     4 ds-reg -4 LWZ\r
 369     5 ds-reg -8 LWZ\r
 370     4 ds-reg -8 STW\r
 371     3 ds-reg -4 STW\r
 372     5 ds-reg 0 STW\r
 373 ] \ rot define-sub-primitive\r
 374 \r
 375 [\r
 376     3 ds-reg 0 LWZ\r
 377     4 ds-reg -4 LWZ\r
 378     5 ds-reg -8 LWZ\r
 379     3 ds-reg -8 STW\r
 380     5 ds-reg -4 STW\r
 381     4 ds-reg 0 STW\r
 382 ] \ -rot define-sub-primitive\r
 383 \r
 384 [ jit->r ] \ load-local define-sub-primitive\r
 385 \r
 386 ! Comparisons\r
 387 : jit-compare ( insn -- )\r
 388     0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
 389     4 ds-reg 0 LWZ\r
 390     5 ds-reg -4 LWZU\r
 391     5 0 4 CMP\r
 392     2 swap execute( offset -- ) ! magic number\r
 393     \ f tag-number 3 LI\r
 394     3 ds-reg 0 STW ;\r
 395 \r
 396 : define-jit-compare ( insn word -- )\r
 397     [ [ jit-compare ] curry ] dip define-sub-primitive ;\r
 398 \r
 399 \ BEQ \ eq? define-jit-compare\r
 400 \ BGE \ fixnum>= define-jit-compare\r
 401 \ BLE \ fixnum<= define-jit-compare\r
 402 \ BGT \ fixnum> define-jit-compare\r
 403 \ BLT \ fixnum< define-jit-compare\r
 404 \r
 405 ! Math\r
 406 [\r
 407     3 ds-reg 0 LWZ\r
 408     ds-reg ds-reg 4 SUBI\r
 409     4 ds-reg 0 LWZ\r
 410     3 3 4 OR\r
 411     3 3 tag-mask get ANDI\r
 412     \ f tag-number 4 LI\r
 413     0 3 0 CMPI\r
 414     2 BNE\r
 415     1 tag-fixnum 4 LI\r
 416     4 ds-reg 0 STW\r
 417 ] \ both-fixnums? define-sub-primitive\r
 418 \r
 419 : jit-math ( insn -- )\r
 420     3 ds-reg 0 LWZ\r
 421     4 ds-reg -4 LWZU\r
 422     [ 5 3 4 ] dip execute( dst src1 src2 -- )\r
 423     5 ds-reg 0 STW ;\r
 424 \r
 425 [ \ ADD jit-math ] \ fixnum+fast define-sub-primitive\r
 426 \r
 427 [ \ SUBF jit-math ] \ fixnum-fast define-sub-primitive\r
 428 \r
 429 [\r
 430     3 ds-reg 0 LWZ\r
 431     4 ds-reg -4 LWZU\r
 432     4 4 tag-bits get SRAWI\r
 433     5 3 4 MULLW\r
 434     5 ds-reg 0 STW\r
 435 ] \ fixnum*fast define-sub-primitive\r
 436 \r
 437 [ \ AND jit-math ] \ fixnum-bitand define-sub-primitive\r
 438 \r
 439 [ \ OR jit-math ] \ fixnum-bitor define-sub-primitive\r
 440 \r
 441 [ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive\r
 442 \r
 443 [\r
 444     3 ds-reg 0 LWZ\r
 445     3 3 NOT\r
 446     3 3 tag-mask get XORI\r
 447     3 ds-reg 0 STW\r
 448 ] \ fixnum-bitnot define-sub-primitive\r
 449 \r
 450 [\r
 451     3 ds-reg 0 LWZ\r
 452     3 3 tag-bits get SRAWI\r
 453     ds-reg ds-reg 4 SUBI\r
 454     4 ds-reg 0 LWZ\r
 455     5 4 3 SLW\r
 456     6 3 NEG\r
 457     7 4 6 SRAW\r
 458     7 7 0 0 31 tag-bits get - RLWINM\r
 459     0 3 0 CMPI\r
 460     2 BGT\r
 461     5 7 MR\r
 462     5 ds-reg 0 STW\r
 463 ] \ fixnum-shift-fast define-sub-primitive\r
 464 \r
 465 [\r
 466     3 ds-reg 0 LWZ\r
 467     ds-reg ds-reg 4 SUBI\r
 468     4 ds-reg 0 LWZ\r
 469     5 4 3 DIVW\r
 470     6 5 3 MULLW\r
 471     7 6 4 SUBF\r
 472     7 ds-reg 0 STW\r
 473 ] \ fixnum-mod define-sub-primitive\r
 474 \r
 475 [\r
 476     3 ds-reg 0 LWZ\r
 477     ds-reg ds-reg 4 SUBI\r
 478     4 ds-reg 0 LWZ\r
 479     5 4 3 DIVW\r
 480     5 5 tag-bits get SLWI\r
 481     5 ds-reg 0 STW\r
 482 ] \ fixnum/i-fast define-sub-primitive\r
 483 \r
 484 [\r
 485     3 ds-reg 0 LWZ\r
 486     4 ds-reg -4 LWZ\r
 487     5 4 3 DIVW\r
 488     6 5 3 MULLW\r
 489     7 6 4 SUBF\r
 490     5 5 tag-bits get SLWI\r
 491     5 ds-reg -4 STW\r
 492     7 ds-reg 0 STW\r
 493 ] \ fixnum/mod-fast define-sub-primitive\r
 494 \r
 495 [\r
 496     3 ds-reg 0 LWZ\r
 497     3 3 1 SRAWI\r
 498     rs-reg 3 3 LWZX\r
 499     3 ds-reg 0 STW\r
 500 ] \ get-local define-sub-primitive\r
 501 \r
 502 [\r
 503     3 ds-reg 0 LWZ\r
 504     ds-reg ds-reg 4 SUBI\r
 505     3 3 1 SRAWI\r
 506     rs-reg 3 rs-reg SUBF\r
 507 ] \ drop-locals define-sub-primitive\r
 508 \r
 509 [ "bootstrap.ppc" forget-vocab ] with-compilation-unit\r