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