basis/cpu/ppc/ppc.factor

   1 ! Copyright (C) 2011 Erik Charlebois
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.accessors alien.c-types alien.complex alien.data
   4 alien.libraries assocs byte-arrays classes.algebra classes.struct combinators
   5 compiler.cfg compiler.cfg.build-stack-frame compiler.cfg.comparisons
   6 compiler.cfg.instructions compiler.cfg.intrinsics compiler.cfg.registers
   7 compiler.cfg.stack-frame compiler.codegen compiler.codegen.fixup
   8 compiler.constants compiler.units cpu.architecture cpu.ppc.assembler fry io
   9 kernel layouts literals locals make math math.order math.ranges memory
  10 namespaces prettyprint sequences system vm words ;
  11 QUALIFIED-WITH: alien.c-types c
  12 FROM: cpu.ppc.assembler => B ;
  13 FROM: math => float ;
  14 IN: cpu.ppc
  15
  16 ! PowerPC register assignments:
  17 ! r0: reserved for function prolog/epilogues
  18 ! r1: call stack register
  19 ! r2: toc register / system reserved
  20 ! r3-r12: integer vregs
  21 ! r13: reserved by OS
  22 ! r14: data stack
  23 ! r15: retain stack
  24 ! r16: VM pointer
  25 ! r17-r29: integer vregs
  26 ! r30: integer scratch
  27 ! r31: frame register
  28 ! f0-f29: float vregs
  29 ! f30: float scratch
  30 ! f31: ?
  31
  32 HOOK: lr-save os ( -- n )
  33 HOOK: has-toc os ( -- ? )
  34 HOOK: reserved-area-size os ( -- n )
  35 HOOK: allows-null-dereference os ( -- ? )
  36
  37 M: label B  ( label -- )       [ 0 B  ] dip rc-relative-ppc-3-pc label-fixup ;
  38 M: label BL ( label -- )       [ 0 BL ] dip rc-relative-ppc-3-pc label-fixup ;
  39 M: label BC ( bo bi label -- ) [ 0 BC ] dip rc-relative-ppc-2-pc label-fixup ;
  40
  41 CONSTANT: scratch-reg    30
  42 CONSTANT: fp-scratch-reg 30
  43 CONSTANT: ds-reg         14
  44 CONSTANT: rs-reg         15
  45 CONSTANT: vm-reg         16
  46
  47 M: ppc machine-registers ( -- assoc )
  48     {
  49         { int-regs $[ 3 12 [a,b] 17 29 [a,b] append ] }
  50         { float-regs $[ 0 29 [a,b] ] }
  51     } ;
  52
  53 M: ppc frame-reg ( -- reg ) 31 ;
  54 M: ppc.32 vm-stack-space ( -- n ) 16 ;
  55 M: ppc.64 vm-stack-space ( -- n ) 32 ;
  56 M: ppc complex-addressing? ( -- ? ) f ;
  57
  58 ! PW1-PW8 parameter save slots
  59 : param-save-size ( -- n ) 8 cells ; foldable
  60 ! here be spill slots
  61 ! xt, size
  62 : factor-area-size ( -- n ) 2 cells ; foldable
  63
  64 : spill@ ( n -- offset )
  65     spill-offset reserved-area-size + param-save-size + ;
  66
  67 : param@ ( n -- offset )
  68     reserved-area-size + ;
  69
  70 M: ppc gc-root-offset ( spill-slot -- n )
  71     n>> spill@ cell /i ;
  72
  73 : LOAD32 ( r n -- )
  74     [ -16 shift 0xffff bitand LIS ]
  75     [ [ dup ] dip 0xffff bitand ORI ] 2bi ;
  76
  77 : LOAD64 ( r n -- )
  78     [ dup ] dip {
  79         [ nip -48 shift 0xffff bitand LIS ]
  80         [ -32 shift 0xffff bitand ORI ]
  81         [ drop 32 SLDI ]
  82         [ -16 shift 0xffff bitand ORIS ]
  83         [ 0xffff bitand ORI ]
  84     } 3cleave ;
  85
  86 HOOK: %clear-tag-bits cpu ( dst src -- )
  87 M: ppc.32 %clear-tag-bits tag-bits get CLRRWI ;
  88 M: ppc.64 %clear-tag-bits tag-bits get CLRRDI ;
  89
  90 HOOK: %store-cell cpu ( dst src offset -- )
  91 M: ppc.32 %store-cell STW ;
  92 M: ppc.64 %store-cell STD ;
  93
  94 HOOK: %store-cell-x cpu ( dst src offset -- )
  95 M: ppc.32 %store-cell-x STWX ;
  96 M: ppc.64 %store-cell-x STDX ;
  97
  98 HOOK: %store-cell-update cpu ( dst src offset -- )
  99 M: ppc.32 %store-cell-update STWU ;
 100 M: ppc.64 %store-cell-update STDU ;
 101
 102 HOOK: %load-cell cpu ( dst src offset -- )
 103 M: ppc.32 %load-cell LWZ ;
 104 M: ppc.64 %load-cell LD ;
 105
 106 HOOK: %trap-null cpu ( src -- )
 107 M: ppc.32 %trap-null
 108     allows-null-dereference [ 0 TWEQI ] [ drop ] if ;
 109 M: ppc.64 %trap-null
 110     allows-null-dereference [ 0 TDEQI ] [ drop ] if ;
 111
 112 HOOK: %load-cell-x cpu ( dst src offset -- )
 113 M: ppc.32 %load-cell-x LWZX ;
 114 M: ppc.64 %load-cell-x LDX ;
 115
 116 HOOK: %load-cell-imm cpu ( dst imm -- )
 117 M: ppc.32 %load-cell-imm LOAD32 ;
 118 M: ppc.64 %load-cell-imm LOAD64 ;
 119
 120 HOOK: %compare-cell cpu ( cr lhs rhs -- )
 121 M: ppc.32 %compare-cell CMPW ;
 122 M: ppc.64 %compare-cell CMPD ;
 123
 124 HOOK: %compare-cell-imm cpu ( cr lhs imm -- )
 125 M: ppc.32 %compare-cell-imm CMPWI ;
 126 M: ppc.64 %compare-cell-imm CMPDI ;
 127
 128 HOOK: %load-cell-imm-rc cpu ( -- rel-class )
 129 M: ppc.32 %load-cell-imm-rc rc-absolute-ppc-2/2 ;
 130 M: ppc.64 %load-cell-imm-rc rc-absolute-ppc-2/2/2/2  ;
 131
 132 M: ppc.32 %load-immediate ( reg val -- )
 133     dup -0x8000 0x7fff between? [ LI ] [ LOAD32 ] if ;
 134 M: ppc.64 %load-immediate ( reg val -- )
 135     dup -0x8000 0x7fff between? [ LI ] [ LOAD64 ] if ;
 136
 137 M: ppc %load-reference ( reg obj -- )
 138     [ [ 0 %load-cell-imm ] [ %load-cell-imm-rc rel-literal ] bi* ]
 139     [ \ f type-number LI ]
 140     if* ;
 141
 142 M:: ppc %load-float ( dst val -- )
 143     scratch-reg 0 %load-cell-imm val %load-cell-imm-rc rel-binary-literal
 144     dst scratch-reg 0 LFS ;
 145
 146 M:: ppc %load-double ( dst val -- )
 147     scratch-reg 0 %load-cell-imm val %load-cell-imm-rc rel-binary-literal
 148     dst scratch-reg 0 LFD ;
 149
 150 M:: ppc %load-vector ( dst val rep -- )
 151     scratch-reg 0 %load-cell-imm val %load-cell-imm-rc rel-binary-literal
 152     dst 0 scratch-reg LVX ;
 153
 154 GENERIC: loc-reg ( loc -- reg )
 155 M: ds-loc loc-reg drop ds-reg ;
 156 M: rs-loc loc-reg drop rs-reg ;
 157
 158 ! Load value at stack location loc into vreg.
 159 M: ppc %peek ( vreg loc -- )
 160     [ loc-reg ] [ n>> cells neg ] bi %load-cell ;
 161
 162 ! Replace value at stack location loc with value in vreg.
 163 M: ppc %replace ( vreg loc -- )
 164     [ loc-reg ] [ n>> cells neg ] bi %store-cell ;
 165
 166 ! Replace value at stack location with an immediate value.
 167 M:: ppc %replace-imm ( src loc -- )
 168     loc loc-reg :> reg
 169     loc n>> cells neg :> offset
 170     src {
 171         { [ dup not ] [
 172             drop scratch-reg \ f type-number LI ] }
 173         { [ dup fixnum? ] [
 174             [ scratch-reg ] dip tag-fixnum LI ] }
 175         [ scratch-reg 0 LI rc-absolute rel-literal ]
 176     } cond
 177     scratch-reg reg offset %store-cell ;
 178
 179 M: ppc %clear ( loc -- )
 180     297 swap %replace-imm ;
 181
 182 ! Increment stack pointer by n cells.
 183 M: ppc %inc ( loc -- )
 184     [ ds-loc? [ ds-reg ds-reg ] [ rs-reg rs-reg ] if ] [ n>> ] bi cells ADDI ;
 185
 186 M: ppc stack-frame-size ( stack-frame -- i )
 187     (stack-frame-size)
 188     reserved-area-size +
 189     param-save-size +
 190     factor-area-size +
 191     16 align ;
 192
 193 M: ppc %call ( word -- )
 194     0 BL rc-relative-ppc-3-pc rel-word-pic ;
 195
 196 : instrs ( n -- b ) 4 * ; inline
 197
 198 M: ppc %jump ( word -- )
 199     6 0 %load-cell-imm 1 instrs %load-cell-imm-rc rel-here
 200     0 B rc-relative-ppc-3-pc rel-word-pic-tail ;
 201
 202 M: ppc %dispatch ( src temp -- )
 203     [ nip 0 %load-cell-imm 3 instrs %load-cell-imm-rc rel-here ]
 204     [ swap dupd %load-cell-x ]
 205     [ nip MTCTR ] 2tri BCTR ;
 206
 207 M: ppc %slot ( dst obj slot scale tag -- )
 208     [ 0 assert= ] bi@ %load-cell-x ;
 209
 210 M: ppc %slot-imm ( dst obj slot tag -- )
 211     slot-offset scratch-reg swap LI
 212     scratch-reg %load-cell-x ;
 213
 214 M: ppc %set-slot ( src obj slot scale tag -- )
 215     [ 0 assert= ] bi@ %store-cell-x ;
 216
 217 M: ppc %set-slot-imm ( src obj slot tag -- )
 218     slot-offset [ scratch-reg ] dip LI scratch-reg %store-cell-x ;
 219
 220 M: ppc    %jump-label B     ;
 221 M: ppc    %return     BLR   ;
 222 M: ppc    %add        ADD   ;
 223 M: ppc    %add-imm    ADDI  ;
 224 M: ppc    %sub        SUB   ;
 225 M: ppc    %sub-imm    SUBI  ;
 226 M: ppc.32 %mul        MULLW ;
 227 M: ppc.64 %mul        MULLD ;
 228 M: ppc    %mul-imm    MULLI ;
 229 M: ppc    %and        AND   ;
 230 M: ppc    %and-imm    ANDI. ;
 231 M: ppc    %or         OR    ;
 232 M: ppc    %or-imm     ORI   ;
 233 M: ppc    %xor        XOR   ;
 234 M: ppc    %xor-imm    XORI  ;
 235 M: ppc.32 %shl        SLW   ;
 236 M: ppc.64 %shl        SLD   ;
 237 M: ppc.32 %shl-imm    SLWI  ;
 238 M: ppc.64 %shl-imm    SLDI  ;
 239 M: ppc.32 %shr        SRW   ;
 240 M: ppc.64 %shr        SRD   ;
 241 M: ppc.32 %shr-imm    SRWI  ;
 242 M: ppc.64 %shr-imm    SRDI  ;
 243 M: ppc.32 %sar        SRAW  ;
 244 M: ppc.64 %sar        SRAD  ;
 245 M: ppc.32 %sar-imm    SRAWI ;
 246 M: ppc.64 %sar-imm    SRADI ;
 247 M: ppc.32 %min        [ 0 CMPW ] [ 0 ISEL ] 2bi ;
 248 M: ppc.64 %min        [ 0 CMPD ] [ 0 ISEL ] 2bi ;
 249 M: ppc.32 %max        [ 0 CMPW ] [ swap 0 ISEL ] 2bi ;
 250 M: ppc.64 %max        [ 0 CMPD ] [ swap 0 ISEL ] 2bi ;
 251 M: ppc    %not        NOT ;
 252 M: ppc    %neg        NEG ;
 253 M: ppc.32 %log2       [ CNTLZW ] [ drop dup NEG ] [ drop dup 31 ADDI ] 2tri ;
 254 M: ppc.64 %log2       [ CNTLZD ] [ drop dup NEG ] [ drop dup 63 ADDI ] 2tri ;
 255 M: ppc.32 %bit-count  POPCNTW ;
 256 M: ppc.64 %bit-count  POPCNTD ;
 257
 258 M: ppc %copy ( dst src rep -- )
 259     2over eq? [ 3drop ] [
 260         {
 261             { tagged-rep [ MR ] }
 262             { int-rep    [ MR ] }
 263             { float-rep  [ FMR ] }
 264             { double-rep [ FMR ] }
 265             { vector-rep [ dup VOR ] }
 266             { scalar-rep [ dup VOR ] }
 267         } case
 268     ] if ;
 269
 270 :: overflow-template ( label dst src1 src2 cc insn -- )
 271     scratch-reg 0 LI
 272     scratch-reg MTXER
 273     dst src2 src1 insn call
 274     cc {
 275         { cc-o [ 0 label BSO ] }
 276         { cc/o [ 0 label BNS ] }
 277     } case ; inline
 278
 279 M: ppc %fixnum-add ( label dst src1 src2 cc -- )
 280     [ ADDO. ] overflow-template ;
 281
 282 M: ppc %fixnum-sub ( label dst src1 src2 cc -- )
 283     [ SUBFO. ] overflow-template ;
 284
 285 M: ppc.32 %fixnum-mul ( label dst src1 src2 cc -- )
 286     [ MULLWO. ] overflow-template ;
 287 M: ppc.64 %fixnum-mul ( label dst src1 src2 cc -- )
 288     [ MULLDO. ] overflow-template ;
 289
 290 M: ppc %add-float FADD ;
 291 M: ppc %sub-float FSUB ;
 292 M: ppc %mul-float FMUL ;
 293 M: ppc %div-float FDIV ;
 294
 295 M: ppc %min-float ( dst src1 src2 -- )
 296     2dup [ scratch-reg ] 2dip FSUB
 297     [ scratch-reg ] 2dip FSEL ;
 298
 299 M: ppc %max-float ( dst src1 src2 -- )
 300     2dup [ scratch-reg ] 2dip FSUB
 301     [ scratch-reg ] 2dip FSEL ;
 302
 303 M: ppc %sqrt                FSQRT ;
 304 M: ppc %single>double-float FMR   ;
 305 M: ppc %double>single-float FRSP  ;
 306
 307 M: ppc integer-float-needs-stack-frame? t ;
 308
 309 : scratch@ ( n -- offset )
 310     reserved-area-size + ;
 311
 312 M:: ppc.32 %integer>float ( dst src -- )
 313     ! Sign extend to a doubleword and store.
 314     scratch-reg src 31 %sar-imm
 315     scratch-reg 1 0 scratch@ STW
 316     src 1 4 scratch@ STW
 317     ! Load back doubleword into FPR and convert from integer.
 318     dst 1 0 scratch@ LFD
 319     dst dst FCFID ;
 320
 321 M:: ppc.64 %integer>float ( dst src -- )
 322     src 1 0 scratch@ STD
 323     dst 1 0 scratch@ LFD
 324     dst dst FCFID ;
 325
 326 M:: ppc.32 %float>integer ( dst src -- )
 327     fp-scratch-reg src FRIZ
 328     fp-scratch-reg fp-scratch-reg FCTIWZ
 329     fp-scratch-reg 1 0 scratch@ STFD
 330     dst 1 4 scratch@ LWZ ;
 331
 332 M:: ppc.64 %float>integer ( dst src -- )
 333     fp-scratch-reg src FRIZ
 334     fp-scratch-reg fp-scratch-reg FCTID
 335     fp-scratch-reg 1 0 scratch@ STFD
 336     dst 1 0 scratch@ LD ;
 337
 338 ! Scratch registers by register class.
 339 : scratch-regs ( -- regs )
 340     {
 341         { int-regs { 30 } }
 342         { float-regs { 30 } }
 343     } ;
 344
 345 ! Return values of this class go here
 346 M: ppc return-regs ( -- regs )
 347     {
 348         { int-regs { 3 4 5 6 } }
 349         { float-regs { 1 2 3 4 } }
 350     } ;
 351
 352 ! Is this structure small enough to be returned in registers?
 353 M: ppc return-struct-in-registers? ( c-type -- ? )
 354     lookup-c-type return-in-registers?>> ;
 355
 356 ! If t, the struct return pointer is never passed in a param reg
 357 M: ppc struct-return-on-stack? ( -- ? ) f ;
 358
 359 GENERIC: load-param ( reg src -- )
 360 M: integer load-param ( reg src -- ) int-rep %copy ;
 361 M: spill-slot load-param ( reg src -- ) [ 1 ] dip n>> spill@ %load-cell ;
 362
 363 GENERIC: store-param ( reg dst -- )
 364 M: integer store-param ( reg dst -- ) swap int-rep %copy ;
 365 M: spill-slot store-param ( reg dst -- ) [ 1 ] dip n>> spill@ %store-cell ;
 366
 367 M:: ppc %unbox ( dst src func rep -- )
 368     3 src load-param
 369     4 vm-reg MR
 370     func f f %c-invoke
 371     3 dst store-param ;
 372
 373 M:: ppc %unbox-long-long ( dst1 dst2 src func -- )
 374     3 src load-param
 375     4 vm-reg MR
 376     func f f %c-invoke
 377     3 dst1 store-param
 378     4 dst2 store-param ;
 379
 380 M:: ppc %local-allot ( dst size align offset -- )
 381     dst 1 offset local-allot-offset reserved-area-size + ADDI ;
 382
 383 : param-reg ( n rep -- reg )
 384     reg-class-of cdecl param-regs at nth ;
 385
 386 M:: ppc %box ( dst src func rep gc-map -- )
 387     3 src load-param
 388     4 vm-reg MR
 389     func f gc-map %c-invoke
 390     3 dst store-param ;
 391
 392 M:: ppc %box-long-long ( dst src1 src2 func gc-map -- )
 393     3 src1 load-param
 394     4 src2 load-param
 395     5 vm-reg MR
 396     func f gc-map %c-invoke
 397     3 dst store-param ;
 398
 399 M:: ppc %save-context ( temp1 temp2 -- )
 400     temp1 %context
 401     1 temp1 "callstack-top" context offset-of %store-cell
 402     ds-reg temp1 "datastack" context offset-of %store-cell
 403     rs-reg temp1 "retainstack" context offset-of %store-cell ;
 404
 405 M:: ppc %c-invoke ( name dll gc-map -- )
 406     11 0 %load-cell-imm name dll %load-cell-imm-rc rel-dlsym
 407     has-toc [
 408         2 0 %load-cell-imm name dll %load-cell-imm-rc rel-dlsym-toc
 409     ] when
 410     11 MTCTR
 411     BCTRL
 412     gc-map gc-map-here ;
 413
 414 : return-reg ( rep -- reg )
 415     reg-class-of return-regs at first ;
 416
 417 : scratch-reg-class ( rep -- reg )
 418     reg-class-of scratch-regs at first ;
 419
 420 :: store-stack-param ( vreg rep n -- )
 421     rep scratch-reg-class rep vreg %reload
 422     rep scratch-reg-class n param@ rep {
 423         { int-rep    [ [ 1 ] dip %store-cell ] }
 424         { tagged-rep [ [ 1 ] dip %store-cell ] }
 425         { float-rep  [ [ 1 ] dip STFS ] }
 426         { double-rep [ [ 1 ] dip STFD ] }
 427         { vector-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
 428         { scalar-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
 429     } case ;
 430
 431 :: store-reg-param ( vreg rep reg -- )
 432     reg rep vreg %reload ;
 433
 434 : discard-reg-param ( rep reg -- )
 435     2drop ;
 436
 437 :: load-reg-param ( vreg rep reg -- )
 438     reg rep vreg %spill ;
 439
 440 :: load-stack-param ( vreg rep n -- )
 441     rep scratch-reg-class n param@ rep {
 442         { int-rep    [ [ frame-reg ] dip %load-cell ] }
 443         { tagged-rep [ [ frame-reg ] dip %load-cell ] }
 444         { float-rep  [ [ frame-reg ] dip LFS ] }
 445         { double-rep [ [ frame-reg ] dip LFD ] }
 446         { vector-rep [ scratch-reg swap LI frame-reg scratch-reg LVX ] }
 447         { scalar-rep [ scratch-reg swap LI frame-reg scratch-reg LVX ] }
 448     } case
 449     rep scratch-reg-class rep vreg %spill ;
 450
 451 :: emit-alien-insn ( varargs? reg-inputs stack-inputs
 452                      reg-outputs dead-outputs
 453                      cleanup stack-size
 454                      quot -- )
 455     stack-inputs [ first3 store-stack-param ] each
 456     reg-inputs [ first3 store-reg-param ] each
 457     quot call
 458     reg-outputs [ first3 load-reg-param ] each
 459     dead-outputs [ first2 discard-reg-param ] each
 460     ; inline
 461
 462 M: ppc %alien-invoke ( varargs? reg-inputs stack-inputs
 463                        reg-outputs dead-outputs
 464                        cleanup stack-size
 465                        symbols dll gc-map -- )
 466     '[ _ _ _ %c-invoke ] emit-alien-insn ;
 467
 468 M:: ppc %alien-indirect ( src
 469                           varargs? reg-inputs stack-inputs
 470                           reg-outputs dead-outputs
 471                           cleanup stack-size
 472                           gc-map -- )
 473     reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size [
 474         has-toc [
 475             11 src load-param
 476             2 11 1 cells %load-cell
 477             11 11 0 cells %load-cell
 478         ] [
 479             11 src load-param
 480         ] if
 481         11 MTCTR
 482         BCTRL
 483         gc-map gc-map-here
 484     ] emit-alien-insn ;
 485
 486 M: ppc %alien-assembly ( varargs? reg-inputs stack-inputs
 487                          reg-outputs dead-outputs
 488                          cleanup stack-size
 489                          quot -- )
 490     '[ _ call( -- ) ] emit-alien-insn ;
 491
 492 M: ppc %callback-inputs ( reg-outputs stack-outputs -- )
 493     [ [ first3 load-reg-param ] each ]
 494     [ [ first3 load-stack-param ] each ] bi*
 495     3 vm-reg MR
 496     4 0 LI
 497     "begin_callback" f f %c-invoke ;
 498
 499 M: ppc %callback-outputs ( reg-inputs -- )
 500     3 vm-reg MR
 501     "end_callback" f f %c-invoke
 502     [ first3 store-reg-param ] each ;
 503
 504 M: ppc stack-cleanup ( stack-size return abi -- n )
 505     3drop 0 ;
 506
 507 M: ppc fused-unboxing? f ;
 508
 509 M: ppc %alien-global ( register symbol dll -- )
 510     [ 0 %load-cell-imm ] 2dip %load-cell-imm-rc rel-dlsym ;
 511
 512 M: ppc %vm-field     ( dst field -- ) [ vm-reg ] dip %load-cell  ;
 513 M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip %store-cell ;
 514
 515 M: ppc %unbox-alien ( dst src -- )
 516     scratch-reg alien-offset LI scratch-reg %load-cell-x ;
 517
 518 ! Convert a c-ptr object to a raw C pointer.
 519 ! if (src == F_TYPE)
 520 !   dst = NULL;
 521 ! else if ((src & tag_mask) == ALIEN_TYPE)
 522 !   dst = ((alien*)src)->address;
 523 ! else // Assume (src & tag_mask) == BYTE_ARRAY_TYPE
 524 !   dst = ((byte_array*)src) + 1;
 525 M:: ppc %unbox-any-c-ptr ( dst src -- )
 526     <label> :> end
 527     ! Is the object f?
 528     dst 0 LI
 529     0 src \ f type-number %compare-cell-imm
 530     0 end BEQ
 531
 532     ! Is the object an alien?
 533     dst src tag-mask get ANDI.
 534     ! Assume unboxing a byte-array.
 535     0 dst alien type-number %compare-cell-imm
 536     dst src byte-array-offset ADDI
 537     0 end BNE
 538
 539     ! Unbox the alien.
 540     scratch-reg alien-offset LI
 541     dst src scratch-reg %load-cell-x
 542     end resolve-label ;
 543
 544 ! Be very careful with this. It cannot be used as an immediate
 545 ! offset to a load or store.
 546 : alien@ ( n -- n' ) cells alien type-number - ;
 547
 548 ! Convert a raw C pointer to a c-ptr object.
 549 ! if (src == NULL)
 550 !   dst = F_TYPE;
 551 ! else {
 552 !   dst = allot_alien(NULL);
 553 !   dst->base = F_TYPE;
 554 !   dst->expired = F_TYPE;
 555 !   dst->displacement = src;
 556 !   dst->address = src;
 557 ! }
 558 M:: ppc %box-alien ( dst src temp -- )
 559     <label> :> f-label
 560
 561     ! Is the object f?
 562     dst \ f type-number LI
 563     0 src 0 %compare-cell-imm
 564     0 f-label BEQ
 565
 566     ! Allocate and initialize an alien object.
 567     dst 5 cells alien temp %allot
 568     temp \ f type-number LI
 569     scratch-reg dst %clear-tag-bits
 570     temp scratch-reg 1 cells %store-cell
 571     temp scratch-reg 2 cells %store-cell
 572     src scratch-reg 3 cells %store-cell
 573     src scratch-reg 4 cells %store-cell
 574
 575     f-label resolve-label ;
 576
 577 ! dst->base = base;
 578 ! dst->displacement = displacement;
 579 ! dst->displacement = displacement;
 580 :: box-displaced-alien/f ( dst displacement base -- )
 581     scratch-reg dst %clear-tag-bits
 582     base scratch-reg 1 cells %store-cell
 583     displacement scratch-reg 3 cells %store-cell
 584     displacement scratch-reg 4 cells %store-cell ;
 585
 586 ! dst->base = base->base;
 587 ! dst->displacement = base->displacement + displacement;
 588 ! dst->address = base->address + displacement;
 589 :: box-displaced-alien/alien ( dst displacement base temp -- )
 590     ! Set new alien's base to base.base
 591     scratch-reg 1 alien@ LI
 592     temp base scratch-reg %load-cell-x
 593     temp dst scratch-reg %store-cell-x
 594
 595     ! Compute displacement
 596     scratch-reg 3 alien@ LI
 597     temp base scratch-reg %load-cell-x
 598     temp temp displacement ADD
 599     temp dst scratch-reg %store-cell-x
 600
 601     ! Compute address
 602     scratch-reg 4 alien@ LI
 603     temp base scratch-reg %load-cell-x
 604     temp temp displacement ADD
 605     temp dst scratch-reg %store-cell-x ;
 606
 607 ! dst->base = base;
 608 ! dst->displacement = displacement
 609 ! dst->address = base + sizeof(byte_array) + displacement
 610 :: box-displaced-alien/byte-array ( dst displacement base temp -- )
 611     scratch-reg dst %clear-tag-bits
 612     base scratch-reg 1 cells %store-cell
 613     displacement scratch-reg 3 cells %store-cell
 614     temp base byte-array-offset ADDI
 615     temp temp displacement ADD
 616     temp scratch-reg 4 cells %store-cell ;
 617
 618 ! if (base == F_TYPE)
 619 !   box_displaced_alien_f(dst, displacement, base);
 620 ! else if ((base & tag_mask) == ALIEN_TYPE)
 621 !   box_displaced_alien_alien(dst, displacement, base, temp);
 622 ! else
 623 !   box_displaced_alien_byte_array(dst, displacement, base, temp);
 624 :: box-displaced-alien/dynamic ( dst displacement base temp end -- )
 625     <label> :> not-f
 626     <label> :> not-alien
 627
 628     ! Is base f?
 629     0 base \ f type-number %compare-cell-imm
 630     0 not-f BNE
 631     dst displacement base box-displaced-alien/f
 632     end B
 633
 634     ! Is base an alien?
 635     not-f resolve-label
 636     temp base tag-mask get ANDI.
 637     0 temp alien type-number %compare-cell-imm
 638     0 not-alien BNE
 639     dst displacement base temp box-displaced-alien/alien
 640     end B
 641
 642     ! Assume base is a byte array.
 643     not-alien resolve-label
 644     dst displacement base temp box-displaced-alien/byte-array ;
 645
 646 ! if (displacement == 0)
 647 !   dst = base;
 648 ! else {
 649 !   dst = allot_alien(NULL);
 650 !   dst->expired = F_TYPE;
 651 !   if (is_subclass(base_class, F_TYPE))
 652 !      box_displaced_alien_f(dst, displacement, base);
 653 !   else if (is_subclass(base_class, ALIEN_TYPE))
 654 !      box_displaced_alien_alien(dst, displacement, base, temp);
 655 !   else if (is_subclass(base_class, BYTE_ARRAY_TYPE))
 656 !      box_displaced_alien_byte_array(dst, displacement, base, temp);
 657 !   else
 658 !      box_displaced_alien_dynamic(dst, displacement, base, temp);
 659 ! }
 660 M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- )
 661     <label> :> end
 662
 663     ! If displacement is zero, return the base.
 664     dst base MR
 665     0 displacement 0 %compare-cell-imm
 666     0 end BEQ
 667
 668     ! Displacement is non-zero, we're going to be allocating a new
 669     ! object
 670     dst 5 cells alien temp %allot
 671
 672     ! Set expired to f
 673     temp \ f type-number %load-immediate
 674     scratch-reg 2 alien@ LI
 675     temp dst scratch-reg %store-cell-x
 676
 677     dst displacement base temp
 678     {
 679         { [ base-class \ f class<= ] [ drop box-displaced-alien/f ] }
 680         { [ base-class \ alien class<= ] [ box-displaced-alien/alien ] }
 681         { [ base-class \ byte-array class<= ] [ box-displaced-alien/byte-array ] }
 682         [ end box-displaced-alien/dynamic ]
 683     } cond
 684
 685     end resolve-label ;
 686
 687 M:: ppc.32 %convert-integer ( dst src c-type -- )
 688     c-type {
 689         { c:char   [ dst src 24 CLRLWI dst dst EXTSB ] }
 690         { c:uchar  [ dst src 24 CLRLWI ] }
 691         { c:short  [ dst src 16 CLRLWI dst dst EXTSH ] }
 692         { c:ushort [ dst src 16 CLRLWI ] }
 693         { c:int    [ ] }
 694         { c:uint   [ ] }
 695     } case ;
 696
 697 M:: ppc.64 %convert-integer ( dst src c-type -- )
 698     c-type {
 699         { c:char      [ dst src 56 CLRLDI dst dst EXTSB ] }
 700         { c:uchar     [ dst src 56 CLRLDI ] }
 701         { c:short     [ dst src 48 CLRLDI dst dst EXTSH ] }
 702         { c:ushort    [ dst src 48 CLRLDI ] }
 703         { c:int       [ dst src 32 CLRLDI dst dst EXTSW ] }
 704         { c:uint      [ dst src 32 CLRLDI ] }
 705         { c:longlong  [ ] }
 706         { c:ulonglong [ ] }
 707     } case ;
 708
 709 M: ppc.32 %load-memory-imm ( dst base offset rep c-type -- )
 710     [
 711         pick %trap-null
 712         {
 713             { c:char   [ [ dup ] 2dip LBZ dup EXTSB ] }
 714             { c:uchar  [ LBZ ] }
 715             { c:short  [ LHA ] }
 716             { c:ushort [ LHZ ] }
 717             { c:int    [ LWZ ] }
 718             { c:uint   [ LWZ ] }
 719         } case
 720     ] [
 721         {
 722             { int-rep    [ LWZ ] }
 723             { float-rep  [ LFS ] }
 724             { double-rep [ LFD ] }
 725         } case
 726     ] ?if ;
 727
 728 M: ppc.64 %load-memory-imm ( dst base offset rep c-type -- )
 729     [
 730         pick %trap-null
 731         {
 732             { c:char      [ [ dup ] 2dip LBZ dup EXTSB ] }
 733             { c:uchar     [ LBZ ] }
 734             { c:short     [ LHA ] }
 735             { c:ushort    [ LHZ ] }
 736             { c:int       [ LWZ ] }
 737             { c:uint      [ LWZ ] }
 738             { c:longlong  [ [ scratch-reg ] dip LI scratch-reg LDX ] }
 739             { c:ulonglong [ [ scratch-reg ] dip LI scratch-reg LDX ] }
 740         } case
 741     ] [
 742         {
 743             { int-rep    [ [ scratch-reg ] dip LI scratch-reg LDX  ] }
 744             { float-rep  [ [ scratch-reg ] dip LI scratch-reg LFSX ] }
 745             { double-rep [ [ scratch-reg ] dip LI scratch-reg LFDX ] }
 746         } case
 747     ] ?if ;
 748
 749
 750 M: ppc.32 %load-memory ( dst base displacement scale offset rep c-type -- )
 751     [ [ 0 assert= ] bi@ ] 2dip
 752     [
 753         pick %trap-null
 754         {
 755             { c:char   [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
 756             { c:uchar  [ LBZX ] }
 757             { c:short  [ LHAX ] }
 758             { c:ushort [ LHZX ] }
 759             { c:int    [ LWZX ] }
 760             { c:uint   [ LWZX ] }
 761         } case
 762     ] [
 763         {
 764             { int-rep    [ LWZX ] }
 765             { float-rep  [ LFSX ] }
 766             { double-rep [ LFDX ] }
 767         } case
 768     ] ?if ;
 769
 770 M: ppc.64 %load-memory ( dst base displacement scale offset rep c-type -- )
 771     [ [ 0 assert= ] bi@ ] 2dip
 772     [
 773         pick %trap-null
 774         {
 775             { c:char      [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
 776             { c:uchar     [ LBZX ] }
 777             { c:short     [ LHAX ] }
 778             { c:ushort    [ LHZX ] }
 779             { c:int       [ LWZX ] }
 780             { c:uint      [ LWZX ] }
 781             { c:longlong  [ LDX  ] }
 782             { c:ulonglong [ LDX  ] }
 783         } case
 784     ] [
 785         {
 786             { int-rep    [ LDX  ] }
 787             { float-rep  [ LFSX ] }
 788             { double-rep [ LFDX ] }
 789         } case
 790     ] ?if ;
 791
 792
 793 M: ppc.32 %store-memory-imm ( src base offset rep c-type -- )
 794     [
 795         {
 796             { c:char   [ STB ] }
 797             { c:uchar  [ STB ] }
 798             { c:short  [ STH ] }
 799             { c:ushort [ STH ] }
 800             { c:int    [ STW ] }
 801             { c:uint   [ STW ] }
 802         } case
 803     ] [
 804         {
 805             { int-rep    [ STW  ] }
 806             { float-rep  [ STFS ] }
 807             { double-rep [ STFD ] }
 808         } case
 809     ] ?if ;
 810
 811 M: ppc.64 %store-memory-imm ( src base offset rep c-type -- )
 812     [
 813         {
 814             { c:char      [ STB ] }
 815             { c:uchar     [ STB ] }
 816             { c:short     [ STH ] }
 817             { c:ushort    [ STH ] }
 818             { c:int       [ STW ] }
 819             { c:uint      [ STW ] }
 820             { c:longlong  [ [ scratch-reg ] dip LI scratch-reg STDX ] }
 821             { c:ulonglong [ [ scratch-reg ] dip LI scratch-reg STDX ] }
 822         } case
 823     ] [
 824         {
 825             { int-rep    [ [ scratch-reg ] dip LI scratch-reg STDX  ] }
 826             { float-rep  [ [ scratch-reg ] dip LI scratch-reg STFSX ] }
 827             { double-rep [ [ scratch-reg ] dip LI scratch-reg STFDX ] }
 828         } case
 829     ] ?if ;
 830
 831 M: ppc.32 %store-memory ( src base displacement scale offset rep c-type -- )
 832     [ [ 0 assert= ] bi@ ] 2dip
 833     [
 834         {
 835             { c:char   [ STBX ] }
 836             { c:uchar  [ STBX ] }
 837             { c:short  [ STHX ] }
 838             { c:ushort [ STHX ] }
 839             { c:int    [ STWX ] }
 840             { c:uint   [ STWX ] }
 841         } case
 842     ] [
 843         {
 844             { int-rep    [ STWX  ] }
 845             { float-rep  [ STFSX ] }
 846             { double-rep [ STFDX ] }
 847         } case
 848     ] ?if ;
 849
 850 M: ppc.64 %store-memory ( src base displacement scale offset rep c-type -- )
 851     [ [ 0 assert= ] bi@ ] 2dip
 852     [
 853         {
 854             { c:char      [ STBX ] }
 855             { c:uchar     [ STBX ] }
 856             { c:short     [ STHX ] }
 857             { c:ushort    [ STHX ] }
 858             { c:int       [ STWX ] }
 859             { c:uint      [ STWX ] }
 860             { c:longlong  [ STDX ] }
 861             { c:ulonglong [ STDX ] }
 862         } case
 863     ] [
 864         {
 865             { int-rep    [ STDX  ] }
 866             { float-rep  [ STFSX ] }
 867             { double-rep [ STFDX ] }
 868         } case
 869     ] ?if ;
 870
 871 M:: ppc %allot ( dst size class nursery-ptr -- )
 872     ! dst = vm->nursery.here;
 873     nursery-ptr vm-reg "nursery" vm offset-of ADDI
 874     dst nursery-ptr 0 %load-cell
 875     ! vm->nursery.here += align(size, data_alignment);
 876     scratch-reg dst size data-alignment get align ADDI
 877     scratch-reg nursery-ptr 0 %store-cell
 878     ! ((object*) dst)->header = type_number << 2;
 879     scratch-reg class type-number tag-header LI
 880     scratch-reg dst 0 %store-cell
 881     ! dst |= type_number
 882     dst dst class type-number ORI ;
 883
 884 :: (%write-barrier) ( temp1 temp2 -- )
 885     scratch-reg card-mark LI
 886     ! *(char *)(cards_offset + ((cell)slot_ptr >> card_bits))
 887     !    = card_mark_mask;
 888     temp1 temp1 card-bits %shr-imm
 889     temp2 0 %load-cell-imm %load-cell-imm-rc rel-cards-offset
 890     scratch-reg temp1 temp2 STBX
 891     ! *(char *)(decks_offset + ((cell)slot_ptr >> deck_bits))
 892     !    = card_mark_mask;
 893     temp1 temp1 deck-bits card-bits - %shr-imm
 894     temp2 0 %load-cell-imm %load-cell-imm-rc rel-decks-offset
 895     scratch-reg temp1 temp2 STBX ;
 896
 897 M:: ppc %write-barrier ( src slot scale tag temp1 temp2 -- )
 898     scale 0 assert= tag 0 assert=
 899     temp1 src slot ADD
 900     temp1 temp2 (%write-barrier) ;
 901
 902 M:: ppc %write-barrier-imm ( src slot tag temp1 temp2 -- )
 903     temp1 src slot tag slot-offset ADDI
 904     temp1 temp2 (%write-barrier) ;
 905
 906 M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- )
 907     ! if (vm->nursery.here + size >= vm->nursery.end) ...
 908     temp1 vm-reg "nursery" vm offset-of %load-cell
 909     temp2 vm-reg "nursery" vm offset-of 2 cells + %load-cell
 910     temp1 temp1 size ADDI
 911     0 temp1 temp2 %compare-cell
 912     cc {
 913         { cc<=  [ 0 label BLE ] }
 914         { cc/<= [ 0 label BGT ] }
 915     } case ;
 916
 917 M: ppc %call-gc ( gc-map -- )
 918     \ minor-gc %call gc-map-here ;
 919
 920 M:: ppc %prologue ( stack-size -- )
 921     0 MFLR
 922     0 1 lr-save %store-cell
 923     11 0 %load-cell-imm %load-cell-imm-rc rel-this
 924     11 1 2 cells neg %store-cell
 925     11 stack-size LI
 926     11 1 1 cells neg %store-cell
 927     1 1 stack-size neg %store-cell-update ;
 928
 929 ! At the end of each word that calls a subroutine, we store
 930 ! the previous link register value in r0 by popping it off
 931 ! the stack, set the link register to the contents of r0,
 932 ! and jump to the link register.
 933 M:: ppc %epilogue ( stack-size -- )
 934     1 1 stack-size ADDI
 935     0 1 lr-save %load-cell
 936     0 MTLR ;
 937
 938 :: (%boolean) ( dst temp branch1 branch2 -- )
 939     "end" define-label
 940     dst \ f type-number %load-immediate
 941     0 "end" get branch1 execute( n addr -- )
 942     branch2 [ 0 "end" get branch2 execute( n addr -- ) ] when
 943     dst \ t %load-reference
 944     "end" get resolve-label ; inline
 945
 946 :: %boolean ( dst cc temp -- )
 947     cc negate-cc order-cc {
 948         { cc<  [ dst temp \ BLT f (%boolean) ] }
 949         { cc<= [ dst temp \ BLE f (%boolean) ] }
 950         { cc>  [ dst temp \ BGT f (%boolean) ] }
 951         { cc>= [ dst temp \ BGE f (%boolean) ] }
 952         { cc=  [ dst temp \ BEQ f (%boolean) ] }
 953         { cc/= [ dst temp \ BNE f (%boolean) ] }
 954     } case ;
 955
 956 : (%compare) ( src1 src2 -- ) [ 0 ] 2dip %compare-cell ; inline
 957
 958 : (%compare-integer-imm) ( src1 src2 -- )
 959     [ 0 ] 2dip %compare-cell-imm ; inline
 960
 961 : (%compare-imm) ( src1 src2 -- )
 962     [ tag-fixnum ] [ \ f type-number ] if* (%compare-integer-imm) ; inline
 963
 964 : (%compare-float-unordered) ( src1 src2 -- )
 965     [ 0 ] 2dip FCMPU ; inline
 966
 967 : (%compare-float-ordered) ( src1 src2 -- )
 968     [ 0 ] 2dip FCMPO ; inline
 969
 970 :: (%compare-float) ( src1 src2 cc compare -- branch1 branch2 )
 971     cc {
 972         { cc<    [ src1 src2 \ compare execute( a b -- ) \ BLT f     ] }
 973         { cc<=   [ src1 src2 \ compare execute( a b -- ) \ BLT \ BEQ ] }
 974         { cc>    [ src1 src2 \ compare execute( a b -- ) \ BGT f     ] }
 975         { cc>=   [ src1 src2 \ compare execute( a b -- ) \ BGT \ BEQ ] }
 976         { cc=    [ src1 src2 \ compare execute( a b -- ) \ BEQ f     ] }
 977         { cc<>   [ src1 src2 \ compare execute( a b -- ) \ BLT \ BGT ] }
 978         { cc<>=  [ src1 src2 \ compare execute( a b -- ) \ BNS f     ] }
 979         { cc/<   [ src1 src2 \ compare execute( a b -- ) \ BGE f     ] }
 980         { cc/<=  [ src1 src2 \ compare execute( a b -- ) \ BGT \ BSO ] }
 981         { cc/>   [ src1 src2 \ compare execute( a b -- ) \ BLE f     ] }
 982         { cc/>=  [ src1 src2 \ compare execute( a b -- ) \ BLT \ BSO ] }
 983         { cc/=   [ src1 src2 \ compare execute( a b -- ) \ BNE f     ] }
 984         { cc/<>  [ src1 src2 \ compare execute( a b -- ) \ BEQ \ BSO ] }
 985         { cc/<>= [ src1 src2 \ compare execute( a b -- ) \ BSO f     ] }
 986     } case ; inline
 987
 988 M: ppc %compare [ (%compare) ] 2dip %boolean ;
 989
 990 M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
 991
 992 M: ppc %compare-integer-imm [ (%compare-integer-imm) ] 2dip %boolean ;
 993
 994 M:: ppc %compare-float-ordered ( dst src1 src2 cc temp -- )
 995     src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
 996     dst temp branch1 branch2 (%boolean) ;
 997
 998 M:: ppc %compare-float-unordered ( dst src1 src2 cc temp -- )
 999     src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
1000     dst temp branch1 branch2 (%boolean) ;
1001
1002 :: %branch ( label cc -- )
1003     cc order-cc {
1004         { cc<  [ 0 label BLT ] }
1005         { cc<= [ 0 label BLE ] }
1006         { cc>  [ 0 label BGT ] }
1007         { cc>= [ 0 label BGE ] }
1008         { cc=  [ 0 label BEQ ] }
1009         { cc/= [ 0 label BNE ] }
1010     } case ;
1011
1012 M:: ppc %compare-branch ( label src1 src2 cc -- )
1013     src1 src2 (%compare)
1014     label cc %branch ;
1015
1016 M:: ppc %compare-imm-branch ( label src1 src2 cc -- )
1017     src1 src2 (%compare-imm)
1018     label cc %branch ;
1019
1020 M:: ppc %compare-integer-imm-branch ( label src1 src2 cc -- )
1021     src1 src2 (%compare-integer-imm)
1022     label cc %branch ;
1023
1024 :: (%branch) ( label branch1 branch2 -- )
1025     0 label branch1 execute( cr label -- )
1026     branch2 [ 0 label branch2 execute( cr label -- ) ] when ; inline
1027
1028 M:: ppc %compare-float-ordered-branch ( label src1 src2 cc -- )
1029     src1 src2 cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
1030     label branch1 branch2 (%branch) ;
1031
1032 M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
1033     src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
1034     label branch1 branch2 (%branch) ;
1035
1036 M: ppc %spill ( src rep dst -- )
1037     n>> spill@ swap  {
1038         { int-rep    [ [ 1 ] dip %store-cell ] }
1039         { tagged-rep [ [ 1 ] dip %store-cell ] }
1040         { float-rep  [ [ 1 ] dip STFS ] }
1041         { double-rep [ [ 1 ] dip STFD ] }
1042         { vector-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
1043         { scalar-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
1044     } case ;
1045
1046 M: ppc %reload ( dst rep src -- )
1047     n>> spill@ swap {
1048         { int-rep    [ [ 1 ] dip %load-cell ] }
1049         { tagged-rep [ [ 1 ] dip %load-cell ] }
1050         { float-rep  [ [ 1 ] dip LFS ] }
1051         { double-rep [ [ 1 ] dip LFD ] }
1052         { vector-rep [ scratch-reg swap LI 1 scratch-reg LVX ] }
1053         { scalar-rep [ scratch-reg swap LI 1 scratch-reg LVX ] }
1054     } case ;
1055
1056 M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
1057 M: ppc immediate-bitwise?    ( n -- ? ) 0 65535 between? ;
1058 M: ppc immediate-store?      ( n -- ? ) immediate-comparand? ;
1059
1060 M: ppc enable-cpu-features ( -- )
1061     enable-float-intrinsics ;
1062
1063 USE: vocabs
1064 {
1065     { [ os linux? ] [
1066         {
1067             { [ cpu ppc.32? ] [ "cpu.ppc.32.linux" require ] }
1068             { [ cpu ppc.64? ] [ "cpu.ppc.64.linux" require ] }
1069             [ ]
1070         } cond
1071       ] }
1072     [ ]
1073 } cond
1074
1075 complex-double lookup-c-type t >>return-in-registers? drop