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.generator.fixup compiler.units\r
   5 compiler.constants math math.private layouts words words.private\r
   6 vocabs slots.private ;\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 14 ;\r
  15 : rs-reg 15 ;\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     6 dup 0 LWZ\r
  28     11 6 profile-count-offset LWZ\r
  29     11 11 1 tag-fixnum ADDI\r
  30     11 6 profile-count-offset STW\r
  31     11 6 word-code-offset LWZ\r
  32     11 11 compiled-header-size ADDI\r
  33     11 MTCTR\r
  34     BCTR\r
  35 ] rc-absolute-ppc-2/2 rt-literal 1 jit-profiling jit-define\r
  36 \r
  37 [\r
  38     0 6 LOAD32\r
  39     0 MFLR\r
  40     1 1 stack-frame SUBI\r
  41     6 1 xt-save STW\r
  42     stack-frame 6 LI\r
  43     6 1 next-save STW\r
  44     0 1 lr-save stack-frame + STW\r
  45 ] rc-absolute-ppc-2/2 rt-label 1 jit-prolog jit-define\r
  46 \r
  47 [\r
  48     0 6 LOAD32\r
  49     6 dup 0 LWZ\r
  50     6 ds-reg 4 STWU\r
  51 ] rc-absolute-ppc-2/2 rt-literal 1 jit-push-literal jit-define\r
  52 \r
  53 [\r
  54     0 6 LOAD32\r
  55     6 ds-reg 4 STWU\r
  56 ] rc-absolute-ppc-2/2 rt-immediate 1 jit-push-immediate jit-define\r
  57 \r
  58 [\r
  59     0 6 LOAD32\r
  60     4 1 MR\r
  61     6 MTCTR\r
  62     BCTR\r
  63 ] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define\r
  64 \r
  65 [ 0 BL ] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define\r
  66 \r
  67 [ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define\r
  68 \r
  69 : jit-call-quot ( -- )\r
  70     4 3 quot-xt-offset LWZ\r
  71     4 MTCTR\r
  72     BCTR ;\r
  73 \r
  74 [\r
  75     0 3 LOAD32\r
  76     6 ds-reg 0 LWZ\r
  77     0 6 \ f tag-number CMPI\r
  78     2 BNE\r
  79     3 3 4 ADDI\r
  80     3 3 0 LWZ\r
  81     ds-reg dup 4 SUBI\r
  82     jit-call-quot\r
  83 ] rc-absolute-ppc-2/2 rt-literal 1 jit-if-jump jit-define\r
  84 \r
  85 [\r
  86     0 3 LOAD32\r
  87     3 3 0 LWZ\r
  88     6 ds-reg 0 LWZ\r
  89     6 6 1 SRAWI\r
  90     3 3 6 ADD\r
  91     3 3 array-start-offset LWZ\r
  92     ds-reg dup 4 SUBI\r
  93     jit-call-quot\r
  94 ] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define\r
  95 \r
  96 [\r
  97     0 1 lr-save stack-frame + LWZ\r
  98     1 1 stack-frame ADDI\r
  99     0 MTLR\r
 100 ] f f f jit-epilog jit-define\r
 101 \r
 102 [ BLR ] f f f jit-return jit-define\r
 103 \r
 104 ! Sub-primitives\r
 105 \r
 106 ! Quotations and words\r
 107 [\r
 108     3 ds-reg 0 LWZ\r
 109     ds-reg dup 4 SUBI\r
 110     jit-call-quot\r
 111 ] f f f \ (call) define-sub-primitive\r
 112 \r
 113 [\r
 114     3 ds-reg 0 LWZ\r
 115     ds-reg dup 4 SUBI\r
 116     4 3 word-xt-offset LWZ\r
 117     4 MTCTR\r
 118     BCTR\r
 119 ] f f f \ (execute) define-sub-primitive\r
 120 \r
 121 ! Objects\r
 122 [\r
 123     3 ds-reg 0 LWZ\r
 124     3 3 tag-mask get ANDI\r
 125     3 3 tag-bits get SLWI\r
 126     3 ds-reg 0 STW\r
 127 ] f f f \ tag define-sub-primitive\r
 128 \r
 129 [\r
 130     3 ds-reg 0 LWZ\r
 131     4 ds-reg -4 LWZU\r
 132     3 3 1 SRAWI\r
 133     4 4 0 0 31 tag-bits get - RLWINM\r
 134     4 3 3 LWZX\r
 135     3 ds-reg 0 STW\r
 136 ] f f f \ slot define-sub-primitive\r
 137 \r
 138 ! Shufflers\r
 139 [\r
 140     ds-reg dup 4 SUBI\r
 141 ] f f f \ drop define-sub-primitive\r
 142 \r
 143 [\r
 144     ds-reg dup 8 SUBI\r
 145 ] f f f \ 2drop define-sub-primitive\r
 146 \r
 147 [\r
 148     ds-reg dup 12 SUBI\r
 149 ] f f f \ 3drop define-sub-primitive\r
 150 \r
 151 [\r
 152     3 ds-reg 0 LWZ\r
 153     3 ds-reg 4 STWU\r
 154 ] f f f \ dup define-sub-primitive\r
 155 \r
 156 [\r
 157     3 ds-reg 0 LWZ\r
 158     4 ds-reg -4 LWZ\r
 159     ds-reg dup 8 ADDI\r
 160     3 ds-reg 0 STW\r
 161     4 ds-reg -4 STW\r
 162 ] f f f \ 2dup define-sub-primitive\r
 163 \r
 164 [\r
 165     3 ds-reg 0 LWZ\r
 166     4 ds-reg -4 LWZ\r
 167     5 ds-reg -8 LWZ\r
 168     ds-reg dup 12 ADDI\r
 169     3 ds-reg 0 STW\r
 170     4 ds-reg -4 STW\r
 171     5 ds-reg -8 STW\r
 172 ] f f f \ 3dup define-sub-primitive\r
 173 \r
 174 [\r
 175     3 ds-reg 0 LWZ\r
 176     ds-reg dup 4 SUBI\r
 177     3 ds-reg 0 STW\r
 178 ] f f f \ nip define-sub-primitive\r
 179 \r
 180 [\r
 181     3 ds-reg 0 LWZ\r
 182     ds-reg dup 8 SUBI\r
 183     3 ds-reg 0 STW\r
 184 ] f f f \ 2nip define-sub-primitive\r
 185 \r
 186 [\r
 187     3 ds-reg -4 LWZ\r
 188     3 ds-reg 4 STWU\r
 189 ] f f f \ over define-sub-primitive\r
 190 \r
 191 [\r
 192     3 ds-reg -8 LWZ\r
 193     3 ds-reg 4 STWU\r
 194 ] f f f \ pick define-sub-primitive\r
 195 \r
 196 [\r
 197     3 ds-reg 0 LWZ\r
 198     4 ds-reg -4 LWZ\r
 199     4 ds-reg 0 STW\r
 200     3 ds-reg 4 STWU\r
 201 ] f f f \ dupd define-sub-primitive\r
 202 \r
 203 [\r
 204     3 ds-reg 0 LWZ\r
 205     4 ds-reg -4 LWZ\r
 206     3 ds-reg 4 STWU\r
 207     4 ds-reg -4 STW\r
 208     3 ds-reg -8 STW\r
 209 ] f f f \ tuck define-sub-primitive\r
 210 \r
 211 [\r
 212     3 ds-reg 0 LWZ\r
 213     4 ds-reg -4 LWZ\r
 214     3 ds-reg -4 STW\r
 215     4 ds-reg 0 STW\r
 216 ] f f f \ swap define-sub-primitive\r
 217 \r
 218 [\r
 219     3 ds-reg -4 LWZ\r
 220     4 ds-reg -8 LWZ\r
 221     3 ds-reg -8 STW\r
 222     4 ds-reg -4 STW\r
 223 ] f f f \ swapd define-sub-primitive\r
 224 \r
 225 [\r
 226     3 ds-reg 0 LWZ\r
 227     4 ds-reg -4 LWZ\r
 228     5 ds-reg -8 LWZ\r
 229     4 ds-reg -8 STW\r
 230     3 ds-reg -4 STW\r
 231     5 ds-reg 0 STW\r
 232 ] f f f \ rot define-sub-primitive\r
 233 \r
 234 [\r
 235     3 ds-reg 0 LWZ\r
 236     4 ds-reg -4 LWZ\r
 237     5 ds-reg -8 LWZ\r
 238     3 ds-reg -8 STW\r
 239     5 ds-reg -4 STW\r
 240     4 ds-reg 0 STW\r
 241 ] f f f \ -rot define-sub-primitive\r
 242 \r
 243 [\r
 244     3 ds-reg 0 LWZ\r
 245     ds-reg dup 4 SUBI\r
 246     3 rs-reg 4 STWU\r
 247 ] f f f \ >r define-sub-primitive\r
 248 \r
 249 [\r
 250     3 rs-reg 0 LWZ\r
 251     rs-reg dup 4 SUBI\r
 252     3 ds-reg 4 STWU\r
 253 ] f f f \ r> define-sub-primitive\r
 254 \r
 255 ! Comparisons\r
 256 : jit-compare ( insn -- )\r
 257     0 3 LOAD32\r
 258     3 3 0 LWZ\r
 259     4 ds-reg 0 LWZ\r
 260     5 ds-reg -4 LWZU\r
 261     5 0 4 CMP\r
 262     2 swap execute ! magic number\r
 263     \ f tag-number 3 LI\r
 264     3 ds-reg 0 STW ;\r
 265 \r
 266 : define-jit-compare ( insn word -- )\r
 267     [ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-literal 1 ] dip\r
 268     define-sub-primitive ;\r
 269 \r
 270 \ BEQ \ eq? define-jit-compare\r
 271 \ BGE \ fixnum>= define-jit-compare\r
 272 \ BLE \ fixnum<= define-jit-compare\r
 273 \ BGT \ fixnum> define-jit-compare\r
 274 \ BLT \ fixnum< define-jit-compare\r
 275 \r
 276 ! Math\r
 277 : jit-math ( insn -- )\r
 278     3 ds-reg 0 LWZ\r
 279     4 ds-reg -4 LWZU\r
 280     [ 5 3 4 ] dip execute\r
 281     5 ds-reg 0 STW ;\r
 282 \r
 283 [ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive\r
 284 \r
 285 [ \ SUBF jit-math ] f f f \ fixnum-fast define-sub-primitive\r
 286 \r
 287 [\r
 288     3 ds-reg 0 LWZ\r
 289     4 ds-reg -4 LWZU\r
 290     4 4 tag-bits get SRAWI\r
 291     5 3 4 MULLW\r
 292     5 ds-reg 0 STW\r
 293 ] f f f \ fixnum*fast define-sub-primitive\r
 294 \r
 295 [ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive\r
 296 \r
 297 [ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive\r
 298 \r
 299 [ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive\r
 300 \r
 301 [\r
 302     3 ds-reg 0 LWZ\r
 303     3 3 NOT\r
 304     3 3 tag-mask get XORI\r
 305     3 ds-reg 0 STW\r
 306 ] f f f \ fixnum-bitnot define-sub-primitive\r
 307 \r
 308 [ "bootstrap.ppc" forget-vocab ] with-compilation-unit\r