basis/cpu/ppc/ppc.factor

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