basis/cpu/ppc/ppc.factor

   1 ! Copyright (C) 2011 Erik Charlebois
   2 ! See https://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 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  [ 0 B  ] dip rc-relative-ppc-3-pc label-fixup ;
  38 M: label BL [ 0 BL ] dip rc-relative-ppc-3-pc label-fixup ;
  39 M: label BC [ 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
  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 31 ;
  54 M: ppc.32 vm-stack-space 16 ;
  55 M: ppc.64 vm-stack-space 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
  71     n>> spill@ cell /i ;
  72
  73 : LOAD32 ( r n -- )
  74     [ -16 shift 0xffff bitand LIS ]
  75     [ dupd 0xffff bitand ORI ] 2bi ;
  76
  77 : LOAD64 ( r n -- )
  78     dupd {
  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
 133     dup -0x8000 0x7fff between? [ LI ] [ LOAD32 ] if ;
 134 M: ppc.64 %load-immediate
 135     dup -0x8000 0x7fff between? [ LI ] [ LOAD64 ] if ;
 136
 137 M: ppc %load-reference
 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
 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
 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
 180     297 swap %replace-imm ;
 181
 182 ! Increment stack pointer by n cells.
 183 M: ppc %inc
 184     [ ds-loc? [ ds-reg ds-reg ] [ rs-reg rs-reg ] if ] [ n>> ] bi cells ADDI ;
 185
 186 M: ppc stack-frame-size
 187     (stack-frame-size)
 188     reserved-area-size +
 189     param-save-size +
 190     factor-area-size +
 191     16 align ;
 192
 193 M: ppc %call
 194     0 BL rc-relative-ppc-3-pc rel-word-pic ;
 195
 196 : instrs ( n -- b ) 4 * ; inline
 197
 198 M: ppc %jump
 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
 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
 208     [ 0 assert= ] bi@ %load-cell-x ;
 209
 210 M: ppc %slot-imm
 211     slot-offset scratch-reg swap LI
 212     scratch-reg %load-cell-x ;
 213
 214 M: ppc %set-slot
 215     [ 0 assert= ] bi@ %store-cell-x ;
 216
 217 M: ppc %set-slot-imm
 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
 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
 280     [ ADDO. ] overflow-template ;
 281
 282 M: ppc %fixnum-sub
 283     [ SUBFO. ] overflow-template ;
 284
 285 M: ppc.32 %fixnum-mul
 286     [ MULLWO. ] overflow-template ;
 287 M: ppc.64 %fixnum-mul
 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
 296     2dup [ scratch-reg ] 2dip FSUB
 297     [ scratch-reg ] 2dip FSEL ;
 298
 299 M: ppc %max-float
 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
 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?
 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 int-rep %copy ;
 361 M: spill-slot load-param [ 1 ] dip n>> spill@ %load-cell ;
 362
 363 GENERIC: store-param ( reg dst -- )
 364 M: integer store-param swap int-rep %copy ;
 365 M: spill-slot store-param [ 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
 463     '[ _ _ _ %c-invoke ] emit-alien-insn ;
 464
 465 M:: ppc %alien-indirect ( src
 466                           varargs? reg-inputs stack-inputs
 467                           reg-outputs dead-outputs
 468                           cleanup stack-size
 469                           gc-map -- )
 470     reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size [
 471         has-toc [
 472             11 src load-param
 473             2 11 1 cells %load-cell
 474             11 11 0 cells %load-cell
 475         ] [
 476             11 src load-param
 477         ] if
 478         11 MTCTR
 479         BCTRL
 480         gc-map gc-map-here
 481     ] emit-alien-insn ;
 482
 483 M: ppc %alien-assembly
 484     '[ _ call( -- ) ] emit-alien-insn ;
 485
 486 M: ppc %callback-inputs
 487     [ [ first3 load-reg-param ] each ]
 488     [ [ first3 load-stack-param ] each ] bi*
 489     3 vm-reg MR
 490     4 0 LI
 491     "begin_callback" f f %c-invoke ;
 492
 493 M: ppc %callback-outputs
 494     3 vm-reg MR
 495     "end_callback" f f %c-invoke
 496     [ first3 store-reg-param ] each ;
 497
 498 M: ppc stack-cleanup
 499     3drop 0 ;
 500
 501 M: ppc fused-unboxing? f ;
 502
 503 M: ppc %alien-global
 504     [ 0 %load-cell-imm ] 2dip %load-cell-imm-rc rel-dlsym ;
 505
 506 M: ppc %vm-field     [ vm-reg ] dip %load-cell  ;
 507 M: ppc %set-vm-field [ vm-reg ] dip %store-cell ;
 508
 509 M: ppc %unbox-alien
 510     scratch-reg alien-offset LI scratch-reg %load-cell-x ;
 511
 512 ! Convert a c-ptr object to a raw C pointer.
 513 ! if (src == F_TYPE)
 514 !   dst = NULL;
 515 ! else if ((src & tag_mask) == ALIEN_TYPE)
 516 !   dst = ((alien*)src)->address;
 517 ! else // Assume (src & tag_mask) == BYTE_ARRAY_TYPE
 518 !   dst = ((byte_array*)src) + 1;
 519 M:: ppc %unbox-any-c-ptr ( dst src -- )
 520     <label> :> end
 521     ! Is the object f?
 522     dst 0 LI
 523     0 src \ f type-number %compare-cell-imm
 524     0 end BEQ
 525
 526     ! Is the object an alien?
 527     dst src tag-mask get ANDI.
 528     ! Assume unboxing a byte-array.
 529     0 dst alien type-number %compare-cell-imm
 530     dst src byte-array-offset ADDI
 531     0 end BNE
 532
 533     ! Unbox the alien.
 534     scratch-reg alien-offset LI
 535     dst src scratch-reg %load-cell-x
 536     end resolve-label ;
 537
 538 ! Be very careful with this. It cannot be used as an immediate
 539 ! offset to a load or store.
 540 : alien@ ( n -- n' ) cells alien type-number - ;
 541
 542 ! Convert a raw C pointer to a c-ptr object.
 543 ! if (src == NULL)
 544 !   dst = F_TYPE;
 545 ! else {
 546 !   dst = allot_alien(NULL);
 547 !   dst->base = F_TYPE;
 548 !   dst->expired = F_TYPE;
 549 !   dst->displacement = src;
 550 !   dst->address = src;
 551 ! }
 552 M:: ppc %box-alien ( dst src temp -- )
 553     <label> :> f-label
 554
 555     ! Is the object f?
 556     dst \ f type-number LI
 557     0 src 0 %compare-cell-imm
 558     0 f-label BEQ
 559
 560     ! Allocate and initialize an alien object.
 561     dst 5 cells alien temp %allot
 562     temp \ f type-number LI
 563     scratch-reg dst %clear-tag-bits
 564     temp scratch-reg 1 cells %store-cell
 565     temp scratch-reg 2 cells %store-cell
 566     src scratch-reg 3 cells %store-cell
 567     src scratch-reg 4 cells %store-cell
 568
 569     f-label resolve-label ;
 570
 571 ! dst->base = base;
 572 ! dst->displacement = displacement;
 573 ! dst->displacement = displacement;
 574 :: box-displaced-alien/f ( dst displacement base -- )
 575     scratch-reg dst %clear-tag-bits
 576     base scratch-reg 1 cells %store-cell
 577     displacement scratch-reg 3 cells %store-cell
 578     displacement scratch-reg 4 cells %store-cell ;
 579
 580 ! dst->base = base->base;
 581 ! dst->displacement = base->displacement + displacement;
 582 ! dst->address = base->address + displacement;
 583 :: box-displaced-alien/alien ( dst displacement base temp -- )
 584     ! Set new alien's base to base.base
 585     scratch-reg 1 alien@ LI
 586     temp base scratch-reg %load-cell-x
 587     temp dst scratch-reg %store-cell-x
 588
 589     ! Compute displacement
 590     scratch-reg 3 alien@ LI
 591     temp base scratch-reg %load-cell-x
 592     temp temp displacement ADD
 593     temp dst scratch-reg %store-cell-x
 594
 595     ! Compute address
 596     scratch-reg 4 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 ! dst->base = base;
 602 ! dst->displacement = displacement
 603 ! dst->address = base + sizeof(byte_array) + displacement
 604 :: box-displaced-alien/byte-array ( dst displacement base temp -- )
 605     scratch-reg dst %clear-tag-bits
 606     base scratch-reg 1 cells %store-cell
 607     displacement scratch-reg 3 cells %store-cell
 608     temp base byte-array-offset ADDI
 609     temp temp displacement ADD
 610     temp scratch-reg 4 cells %store-cell ;
 611
 612 ! if (base == F_TYPE)
 613 !   box_displaced_alien_f(dst, displacement, base);
 614 ! else if ((base & tag_mask) == ALIEN_TYPE)
 615 !   box_displaced_alien_alien(dst, displacement, base, temp);
 616 ! else
 617 !   box_displaced_alien_byte_array(dst, displacement, base, temp);
 618 :: box-displaced-alien/dynamic ( dst displacement base temp end -- )
 619     <label> :> not-f
 620     <label> :> not-alien
 621
 622     ! Is base f?
 623     0 base \ f type-number %compare-cell-imm
 624     0 not-f BNE
 625     dst displacement base box-displaced-alien/f
 626     end B
 627
 628     ! Is base an alien?
 629     not-f resolve-label
 630     temp base tag-mask get ANDI.
 631     0 temp alien type-number %compare-cell-imm
 632     0 not-alien BNE
 633     dst displacement base temp box-displaced-alien/alien
 634     end B
 635
 636     ! Assume base is a byte array.
 637     not-alien resolve-label
 638     dst displacement base temp box-displaced-alien/byte-array ;
 639
 640 ! if (displacement == 0)
 641 !   dst = base;
 642 ! else {
 643 !   dst = allot_alien(NULL);
 644 !   dst->expired = F_TYPE;
 645 !   if (is_subclass(base_class, F_TYPE))
 646 !      box_displaced_alien_f(dst, displacement, base);
 647 !   else if (is_subclass(base_class, ALIEN_TYPE))
 648 !      box_displaced_alien_alien(dst, displacement, base, temp);
 649 !   else if (is_subclass(base_class, BYTE_ARRAY_TYPE))
 650 !      box_displaced_alien_byte_array(dst, displacement, base, temp);
 651 !   else
 652 !      box_displaced_alien_dynamic(dst, displacement, base, temp);
 653 ! }
 654 M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- )
 655     <label> :> end
 656
 657     ! If displacement is zero, return the base.
 658     dst base MR
 659     0 displacement 0 %compare-cell-imm
 660     0 end BEQ
 661
 662     ! Displacement is non-zero, we're going to be allocating a new
 663     ! object
 664     dst 5 cells alien temp %allot
 665
 666     ! Set expired to f
 667     temp \ f type-number %load-immediate
 668     scratch-reg 2 alien@ LI
 669     temp dst scratch-reg %store-cell-x
 670
 671     dst displacement base temp
 672     {
 673         { [ base-class \ f class<= ] [ drop box-displaced-alien/f ] }
 674         { [ base-class \ alien class<= ] [ box-displaced-alien/alien ] }
 675         { [ base-class \ byte-array class<= ] [ box-displaced-alien/byte-array ] }
 676         [ end box-displaced-alien/dynamic ]
 677     } cond
 678
 679     end resolve-label ;
 680
 681 M:: ppc.32 %convert-integer ( dst src c-type -- )
 682     c-type {
 683         { c:char   [ dst src 24 CLRLWI dst dst EXTSB ] }
 684         { c:uchar  [ dst src 24 CLRLWI ] }
 685         { c:short  [ dst src 16 CLRLWI dst dst EXTSH ] }
 686         { c:ushort [ dst src 16 CLRLWI ] }
 687         { c:int    [ ] }
 688         { c:uint   [ ] }
 689     } case ;
 690
 691 M:: ppc.64 %convert-integer ( dst src c-type -- )
 692     c-type {
 693         { c:char      [ dst src 56 CLRLDI dst dst EXTSB ] }
 694         { c:uchar     [ dst src 56 CLRLDI ] }
 695         { c:short     [ dst src 48 CLRLDI dst dst EXTSH ] }
 696         { c:ushort    [ dst src 48 CLRLDI ] }
 697         { c:int       [ dst src 32 CLRLDI dst dst EXTSW ] }
 698         { c:uint      [ dst src 32 CLRLDI ] }
 699         { c:longlong  [ ] }
 700         { c:ulonglong [ ] }
 701     } case ;
 702
 703 M: ppc.32 %load-memory-imm
 704     or* [
 705         pick %trap-null
 706         {
 707             { c:char   [ [ dup ] 2dip LBZ dup EXTSB ] }
 708             { c:uchar  [ LBZ ] }
 709             { c:short  [ LHA ] }
 710             { c:ushort [ LHZ ] }
 711             { c:int    [ LWZ ] }
 712             { c:uint   [ LWZ ] }
 713         } case
 714     ] [
 715         {
 716             { int-rep    [ LWZ ] }
 717             { float-rep  [ LFS ] }
 718             { double-rep [ LFD ] }
 719         } case
 720     ] if ;
 721
 722 M: ppc.64 %load-memory-imm
 723     or* [
 724         pick %trap-null
 725         {
 726             { c:char      [ [ dup ] 2dip LBZ dup EXTSB ] }
 727             { c:uchar     [ LBZ ] }
 728             { c:short     [ LHA ] }
 729             { c:ushort    [ LHZ ] }
 730             { c:int       [ LWZ ] }
 731             { c:uint      [ LWZ ] }
 732             { c:longlong  [ [ scratch-reg ] dip LI scratch-reg LDX ] }
 733             { c:ulonglong [ [ scratch-reg ] dip LI scratch-reg LDX ] }
 734         } case
 735     ] [
 736         {
 737             { int-rep    [ [ scratch-reg ] dip LI scratch-reg LDX  ] }
 738             { float-rep  [ [ scratch-reg ] dip LI scratch-reg LFSX ] }
 739             { double-rep [ [ scratch-reg ] dip LI scratch-reg LFDX ] }
 740         } case
 741     ] if ;
 742
 743
 744 M: ppc.32 %load-memory
 745     [ [ 0 assert= ] bi@ ] 2dip
 746     or* [
 747         pick %trap-null
 748         {
 749             { c:char   [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
 750             { c:uchar  [ LBZX ] }
 751             { c:short  [ LHAX ] }
 752             { c:ushort [ LHZX ] }
 753             { c:int    [ LWZX ] }
 754             { c:uint   [ LWZX ] }
 755         } case
 756     ] [
 757         {
 758             { int-rep    [ LWZX ] }
 759             { float-rep  [ LFSX ] }
 760             { double-rep [ LFDX ] }
 761         } case
 762     ] if ;
 763
 764 M: ppc.64 %load-memory
 765     [ [ 0 assert= ] bi@ ] 2dip
 766     or* [
 767         pick %trap-null
 768         {
 769             { c:char      [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
 770             { c:uchar     [ LBZX ] }
 771             { c:short     [ LHAX ] }
 772             { c:ushort    [ LHZX ] }
 773             { c:int       [ LWZX ] }
 774             { c:uint      [ LWZX ] }
 775             { c:longlong  [ LDX  ] }
 776             { c:ulonglong [ LDX  ] }
 777         } case
 778     ] [
 779         {
 780             { int-rep    [ LDX  ] }
 781             { float-rep  [ LFSX ] }
 782             { double-rep [ LFDX ] }
 783         } case
 784     ] if ;
 785
 786
 787 M: ppc.32 %store-memory-imm
 788     or* [
 789         {
 790             { c:char   [ STB ] }
 791             { c:uchar  [ STB ] }
 792             { c:short  [ STH ] }
 793             { c:ushort [ STH ] }
 794             { c:int    [ STW ] }
 795             { c:uint   [ STW ] }
 796         } case
 797     ] [
 798         {
 799             { int-rep    [ STW  ] }
 800             { float-rep  [ STFS ] }
 801             { double-rep [ STFD ] }
 802         } case
 803     ] if ;
 804
 805 M: ppc.64 %store-memory-imm
 806     or* [
 807         {
 808             { c:char      [ STB ] }
 809             { c:uchar     [ STB ] }
 810             { c:short     [ STH ] }
 811             { c:ushort    [ STH ] }
 812             { c:int       [ STW ] }
 813             { c:uint      [ STW ] }
 814             { c:longlong  [ [ scratch-reg ] dip LI scratch-reg STDX ] }
 815             { c:ulonglong [ [ scratch-reg ] dip LI scratch-reg STDX ] }
 816         } case
 817     ] [
 818         {
 819             { int-rep    [ [ scratch-reg ] dip LI scratch-reg STDX  ] }
 820             { float-rep  [ [ scratch-reg ] dip LI scratch-reg STFSX ] }
 821             { double-rep [ [ scratch-reg ] dip LI scratch-reg STFDX ] }
 822         } case
 823     ] if ;
 824
 825 M: ppc.32 %store-memory
 826     [ [ 0 assert= ] bi@ ] 2dip
 827     or* [
 828         {
 829             { c:char   [ STBX ] }
 830             { c:uchar  [ STBX ] }
 831             { c:short  [ STHX ] }
 832             { c:ushort [ STHX ] }
 833             { c:int    [ STWX ] }
 834             { c:uint   [ STWX ] }
 835         } case
 836     ] [
 837         {
 838             { int-rep    [ STWX  ] }
 839             { float-rep  [ STFSX ] }
 840             { double-rep [ STFDX ] }
 841         } case
 842     ] if ;
 843
 844 M: ppc.64 %store-memory
 845     [ [ 0 assert= ] bi@ ] 2dip
 846     or* [
 847         {
 848             { c:char      [ STBX ] }
 849             { c:uchar     [ STBX ] }
 850             { c:short     [ STHX ] }
 851             { c:ushort    [ STHX ] }
 852             { c:int       [ STWX ] }
 853             { c:uint      [ STWX ] }
 854             { c:longlong  [ STDX ] }
 855             { c:ulonglong [ STDX ] }
 856         } case
 857     ] [
 858         {
 859             { int-rep    [ STDX  ] }
 860             { float-rep  [ STFSX ] }
 861             { double-rep [ STFDX ] }
 862         } case
 863     ] if ;
 864
 865 M:: ppc %allot ( dst size class nursery-ptr -- )
 866     ! dst = vm->nursery.here;
 867     nursery-ptr vm-reg "nursery" vm offset-of ADDI
 868     dst nursery-ptr 0 %load-cell
 869     ! vm->nursery.here += align(size, data_alignment);
 870     scratch-reg dst size data-alignment get align ADDI
 871     scratch-reg nursery-ptr 0 %store-cell
 872     ! ((object*) dst)->header = type_number << 2;
 873     scratch-reg class type-number tag-header LI
 874     scratch-reg dst 0 %store-cell
 875     ! dst |= type_number
 876     dst dst class type-number ORI ;
 877
 878 :: (%write-barrier) ( temp1 temp2 -- )
 879     scratch-reg card-mark LI
 880     ! *(char *)(cards_offset + ((cell)slot_ptr >> card_bits))
 881     !    = card_mark_mask;
 882     temp1 temp1 card-bits %shr-imm
 883     temp2 0 %load-cell-imm %load-cell-imm-rc rel-cards-offset
 884     scratch-reg temp1 temp2 STBX
 885     ! *(char *)(decks_offset + ((cell)slot_ptr >> deck_bits))
 886     !    = card_mark_mask;
 887     temp1 temp1 deck-bits card-bits - %shr-imm
 888     temp2 0 %load-cell-imm %load-cell-imm-rc rel-decks-offset
 889     scratch-reg temp1 temp2 STBX ;
 890
 891 M:: ppc %write-barrier ( src slot scale tag temp1 temp2 -- )
 892     scale 0 assert= tag 0 assert=
 893     temp1 src slot ADD
 894     temp1 temp2 (%write-barrier) ;
 895
 896 M:: ppc %write-barrier-imm ( src slot tag temp1 temp2 -- )
 897     temp1 src slot tag slot-offset ADDI
 898     temp1 temp2 (%write-barrier) ;
 899
 900 M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- )
 901     ! if (vm->nursery.here + size >= vm->nursery.end) ...
 902     temp1 vm-reg "nursery" vm offset-of %load-cell
 903     temp2 vm-reg "nursery" vm offset-of 2 cells + %load-cell
 904     temp1 temp1 size ADDI
 905     0 temp1 temp2 %compare-cell
 906     cc {
 907         { cc<=  [ 0 label BLE ] }
 908         { cc/<= [ 0 label BGT ] }
 909     } case ;
 910
 911 M: ppc %call-gc
 912     \ minor-gc %call gc-map-here ;
 913
 914 M:: ppc %prologue ( stack-size -- )
 915     0 MFLR
 916     0 1 lr-save %store-cell
 917     11 0 %load-cell-imm %load-cell-imm-rc rel-this
 918     11 1 2 cells neg %store-cell
 919     11 stack-size LI
 920     11 1 1 cells neg %store-cell
 921     1 1 stack-size neg %store-cell-update ;
 922
 923 ! At the end of each word that calls a subroutine, we store
 924 ! the previous link register value in r0 by popping it off
 925 ! the stack, set the link register to the contents of r0,
 926 ! and jump to the link register.
 927 M:: ppc %epilogue ( stack-size -- )
 928     1 1 stack-size ADDI
 929     0 1 lr-save %load-cell
 930     0 MTLR ;
 931
 932 :: (%boolean) ( dst temp branch1 branch2 -- )
 933     "end" define-label
 934     dst \ f type-number %load-immediate
 935     0 "end" get branch1 execute( n addr -- )
 936     branch2 [ 0 "end" get branch2 execute( n addr -- ) ] when
 937     dst \ t %load-reference
 938     "end" get resolve-label ; inline
 939
 940 :: %boolean ( dst cc temp -- )
 941     cc negate-cc order-cc {
 942         { cc<  [ dst temp \ BLT f (%boolean) ] }
 943         { cc<= [ dst temp \ BLE f (%boolean) ] }
 944         { cc>  [ dst temp \ BGT f (%boolean) ] }
 945         { cc>= [ dst temp \ BGE f (%boolean) ] }
 946         { cc=  [ dst temp \ BEQ f (%boolean) ] }
 947         { cc/= [ dst temp \ BNE f (%boolean) ] }
 948     } case ;
 949
 950 : (%compare) ( src1 src2 -- ) [ 0 ] 2dip %compare-cell ; inline
 951
 952 : (%compare-integer-imm) ( src1 src2 -- )
 953     [ 0 ] 2dip %compare-cell-imm ; inline
 954
 955 : (%compare-imm) ( src1 src2 -- )
 956     [ tag-fixnum ] [ \ f type-number ] if* (%compare-integer-imm) ; inline
 957
 958 : (%compare-float-unordered) ( src1 src2 -- )
 959     [ 0 ] 2dip FCMPU ; inline
 960
 961 : (%compare-float-ordered) ( src1 src2 -- )
 962     [ 0 ] 2dip FCMPO ; inline
 963
 964 :: (%compare-float) ( src1 src2 cc compare -- branch1 branch2 )
 965     cc {
 966         { cc<    [ src1 src2 \ compare execute( a b -- ) \ BLT f     ] }
 967         { cc<=   [ src1 src2 \ compare execute( a b -- ) \ BLT \ BEQ ] }
 968         { cc>    [ src1 src2 \ compare execute( a b -- ) \ BGT f     ] }
 969         { cc>=   [ src1 src2 \ compare execute( a b -- ) \ BGT \ BEQ ] }
 970         { cc=    [ src1 src2 \ compare execute( a b -- ) \ BEQ f     ] }
 971         { cc<>   [ src1 src2 \ compare execute( a b -- ) \ BLT \ BGT ] }
 972         { cc<>=  [ src1 src2 \ compare execute( a b -- ) \ BNS f     ] }
 973         { cc/<   [ src1 src2 \ compare execute( a b -- ) \ BGE f     ] }
 974         { cc/<=  [ src1 src2 \ compare execute( a b -- ) \ BGT \ BSO ] }
 975         { cc/>   [ src1 src2 \ compare execute( a b -- ) \ BLE f     ] }
 976         { cc/>=  [ src1 src2 \ compare execute( a b -- ) \ BLT \ BSO ] }
 977         { cc/=   [ src1 src2 \ compare execute( a b -- ) \ BNE f     ] }
 978         { cc/<>  [ src1 src2 \ compare execute( a b -- ) \ BEQ \ BSO ] }
 979         { cc/<>= [ src1 src2 \ compare execute( a b -- ) \ BSO f     ] }
 980     } case ; inline
 981
 982 M: ppc %compare [ (%compare) ] 2dip %boolean ;
 983
 984 M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
 985
 986 M: ppc %compare-integer-imm [ (%compare-integer-imm) ] 2dip %boolean ;
 987
 988 M:: ppc %compare-float-ordered ( dst src1 src2 cc temp -- )
 989     src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
 990     dst temp branch1 branch2 (%boolean) ;
 991
 992 M:: ppc %compare-float-unordered ( dst src1 src2 cc temp -- )
 993     src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
 994     dst temp branch1 branch2 (%boolean) ;
 995
 996 :: %branch ( label cc -- )
 997     cc order-cc {
 998         { cc<  [ 0 label BLT ] }
 999         { cc<= [ 0 label BLE ] }
1000         { cc>  [ 0 label BGT ] }
1001         { cc>= [ 0 label BGE ] }
1002         { cc=  [ 0 label BEQ ] }
1003         { cc/= [ 0 label BNE ] }
1004     } case ;
1005
1006 M:: ppc %compare-branch ( label src1 src2 cc -- )
1007     src1 src2 (%compare)
1008     label cc %branch ;
1009
1010 M:: ppc %compare-imm-branch ( label src1 src2 cc -- )
1011     src1 src2 (%compare-imm)
1012     label cc %branch ;
1013
1014 M:: ppc %compare-integer-imm-branch ( label src1 src2 cc -- )
1015     src1 src2 (%compare-integer-imm)
1016     label cc %branch ;
1017
1018 :: (%branch) ( label branch1 branch2 -- )
1019     0 label branch1 execute( cr label -- )
1020     branch2 [ 0 label branch2 execute( cr label -- ) ] when ; inline
1021
1022 M:: ppc %compare-float-ordered-branch ( label src1 src2 cc -- )
1023     src1 src2 cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
1024     label branch1 branch2 (%branch) ;
1025
1026 M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
1027     src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
1028     label branch1 branch2 (%branch) ;
1029
1030 M: ppc %spill
1031     n>> spill@ swap  {
1032         { int-rep    [ [ 1 ] dip %store-cell ] }
1033         { tagged-rep [ [ 1 ] dip %store-cell ] }
1034         { float-rep  [ [ 1 ] dip STFS ] }
1035         { double-rep [ [ 1 ] dip STFD ] }
1036         { vector-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
1037         { scalar-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
1038     } case ;
1039
1040 M: ppc %reload
1041     n>> spill@ swap {
1042         { int-rep    [ [ 1 ] dip %load-cell ] }
1043         { tagged-rep [ [ 1 ] dip %load-cell ] }
1044         { float-rep  [ [ 1 ] dip LFS ] }
1045         { double-rep [ [ 1 ] dip LFD ] }
1046         { vector-rep [ scratch-reg swap LI 1 scratch-reg LVX ] }
1047         { scalar-rep [ scratch-reg swap LI 1 scratch-reg LVX ] }
1048     } case ;
1049
1050 M: ppc immediate-arithmetic? -32768 32767 between? ;
1051 M: ppc immediate-bitwise?    0 65535 between? ;
1052 M: ppc immediate-store?      immediate-comparand? ;
1053
1054 M: ppc enable-cpu-features
1055     enable-float-intrinsics ;
1056
1057 USE: vocabs
1058 {
1059     { [ os linux? ] [
1060         {
1061             { [ cpu ppc.32? ] [ "cpu.ppc.32.linux" require ] }
1062             { [ cpu ppc.64? ] [ "cpu.ppc.64.linux" require ] }
1063             [ ]
1064         } cond
1065       ] }
1066     [ ]
1067 } cond
1068
1069 complex-double lookup-c-type t >>return-in-registers? drop