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