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