PageRenderTime 86ms CodeModel.GetById 4ms app.highlight 76ms RepoModel.GetById 1ms app.codeStats 0ms

/unmaintained/ppc/ppc.factor

http://github.com/abeaumont/factor
text | 826 lines | 660 code | 166 blank | 0 comment | 0 complexity | 2630b4589e14bac291fc3678ff270e92 MD5 | raw file
  1! Copyright (C) 2005, 2010 Slava Pestov.
  2! See http://factorcode.org/license.txt for BSD license.
  3USING: accessors assocs sequences kernel combinators
  4classes.algebra byte-arrays make math math.order math.ranges
  5system namespaces locals layouts words alien alien.accessors
  6alien.c-types alien.complex alien.data alien.libraries
  7literals cpu.architecture cpu.ppc.assembler cpu.ppc.assembler.backend
  8compiler.cfg.registers compiler.cfg.instructions
  9compiler.cfg.comparisons compiler.codegen.fixup
 10compiler.cfg.intrinsics compiler.cfg.stack-frame
 11compiler.cfg.build-stack-frame compiler.units compiler.constants
 12compiler.codegen vm ;
 13QUALIFIED-WITH: alien.c-types c
 14FROM: cpu.ppc.assembler => B ;
 15FROM: layouts => cell ;
 16FROM: math => float ;
 17IN: cpu.ppc
 18
 19! PowerPC register assignments:
 20! r2-r12: integer vregs
 21! r13: data stack
 22! r14: retain stack
 23! r15: VM pointer
 24! r16-r29: integer vregs
 25! r30: integer scratch
 26! f0-f29: float vregs
 27! f30: float scratch
 28
 29! Add some methods to the assembler that are useful to us
 30M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
 31M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
 32
 33enable-float-intrinsics
 34
 35M: ppc machine-registers
 36    {
 37        { int-regs $[ 2 12 [a,b] 16 29 [a,b] append ] }
 38        { float-regs $[ 0 29 [a,b] ] }
 39    } ;
 40
 41CONSTANT: scratch-reg 30
 42CONSTANT: fp-scratch-reg 30
 43
 44M: ppc complex-addressing? f ;
 45
 46M: ppc fused-unboxing? f ;
 47
 48M: ppc %load-immediate ( reg n -- ) swap LOAD ;
 49
 50M: ppc %load-reference ( reg obj -- )
 51    [ [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-literal ] bi* ]
 52    [ \ f type-number swap LI ]
 53    if* ;
 54
 55M: ppc %alien-global ( register symbol dll -- )
 56    [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
 57
 58CONSTANT: ds-reg 13
 59CONSTANT: rs-reg 14
 60CONSTANT: vm-reg 15
 61
 62: %load-vm-addr ( reg -- ) vm-reg MR ;
 63
 64M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip LWZ ;
 65
 66M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip STW ;
 67
 68GENERIC: loc-reg ( loc -- reg )
 69
 70M: ds-loc loc-reg drop ds-reg ;
 71M: rs-loc loc-reg drop rs-reg ;
 72
 73: loc>operand ( loc -- reg n )
 74    [ loc-reg ] [ n>> cells neg ] bi ; inline
 75
 76M: ppc %peek loc>operand LWZ ;
 77M: ppc %replace loc>operand STW ;
 78
 79:: (%inc) ( n reg -- ) reg reg n cells ADDI ; inline
 80
 81M: ppc %inc-d ( n -- ) ds-reg (%inc) ;
 82M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
 83
 84HOOK: reserved-area-size os ( -- n )
 85
 86! The start of the stack frame contains the size of this frame
 87! as well as the currently executing code block
 88: factor-area-size ( -- n ) 2 cells ; foldable
 89: next-save ( n -- i ) cell - ; foldable
 90: xt-save ( n -- i ) 2 cells - ; foldable
 91
 92! Next, we have the spill area as well as the FFI parameter area.
 93! It is safe for them to overlap, since basic blocks with FFI calls
 94! will never spill -- indeed, basic blocks with FFI calls do not
 95! use vregs at all, and the FFI call is a stack analysis sync point.
 96! In the future this will change and the stack frame logic will
 97! need to be untangled somewhat.
 98
 99: param@ ( n -- x ) reserved-area-size + ; inline
100
101: param-save-size ( -- n ) 8 cells ; foldable
102
103: local@ ( n -- x )
104    reserved-area-size param-save-size + + ; inline
105
106: spill@ ( n -- offset )
107    spill-offset local@ ;
108
109! Some FP intrinsics need a temporary scratch area in the stack
110! frame, 8 bytes in size. This is in the param-save area so it
111! does not overlap with spill slots.
112: scratch@ ( n -- offset )
113    factor-area-size + ;
114
115! Finally we have the linkage area
116HOOK: lr-save os ( -- n )
117
118M: ppc stack-frame-size ( stack-frame -- i )
119    (stack-frame-size)
120    param-save-size +
121    reserved-area-size +
122    factor-area-size +
123    4 cells align ;
124
125M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ;
126
127M: ppc %jump ( word -- )
128    0 6 LOAD32 4 rc-absolute-ppc-2/2 rel-here
129    0 B rc-relative-ppc-3 rel-word-pic-tail ;
130
131M: ppc %jump-label ( label -- ) B ;
132M: ppc %return ( -- ) BLR ;
133
134M:: ppc %dispatch ( src temp -- )
135    0 temp LOAD32
136    3 cells rc-absolute-ppc-2/2 rel-here
137    temp temp src LWZX
138    temp MTCTR
139    BCTR ;
140
141: (%slot) ( dst obj slot scale tag -- obj dst slot )
142    [ 0 assert= ] bi@ swapd ;
143
144M: ppc %slot ( dst obj slot scale tag -- ) (%slot) LWZX ;
145M: ppc %slot-imm ( dst obj slot tag -- ) slot-offset LWZ ;
146M: ppc %set-slot ( src obj slot scale tag -- ) (%slot) STWX ;
147M: ppc %set-slot-imm ( src obj slot tag -- ) slot-offset STW ;
148
149M: ppc %add     ADD ;
150M: ppc %add-imm ADDI ;
151M: ppc %sub     swap SUBF ;
152M: ppc %sub-imm SUBI ;
153M: ppc %mul     MULLW ;
154M: ppc %mul-imm MULLI ;
155M: ppc %and     AND ;
156M: ppc %and-imm ANDI ;
157M: ppc %or      OR ;
158M: ppc %or-imm  ORI ;
159M: ppc %xor     XOR ;
160M: ppc %xor-imm XORI ;
161M: ppc %shl     SLW ;
162M: ppc %shl-imm swapd SLWI ;
163M: ppc %shr     SRW ;
164M: ppc %shr-imm swapd SRWI ;
165M: ppc %sar     SRAW ;
166M: ppc %sar-imm SRAWI ;
167M: ppc %not     NOT ;
168M: ppc %neg     NEG ;
169
170:: overflow-template ( label dst src1 src2 cc insn -- )
171    0 0 LI
172    0 MTXER
173    dst src2 src1 insn call
174    cc {
175        { cc-o [ label BO ] }
176        { cc/o [ label BNO ] }
177    } case ; inline
178
179M: ppc %fixnum-add ( label dst src1 src2 cc -- )
180    [ ADDO. ] overflow-template ;
181
182M: ppc %fixnum-sub ( label dst src1 src2 cc -- )
183    [ SUBFO. ] overflow-template ;
184
185M: ppc %fixnum-mul ( label dst src1 src2 cc -- )
186    [ MULLWO. ] overflow-template ;
187
188M: ppc %add-float FADD ;
189M: ppc %sub-float FSUB ;
190M: ppc %mul-float FMUL ;
191M: ppc %div-float FDIV ;
192
193M: ppc integer-float-needs-stack-frame? t ;
194
195M:: ppc %integer>float ( dst src -- )
196    HEX: 4330 scratch-reg LIS
197    scratch-reg 1 0 scratch@ STW
198    scratch-reg src MR
199    scratch-reg dup HEX: 8000 XORIS
200    scratch-reg 1 4 scratch@ STW
201    dst 1 0 scratch@ LFD
202    scratch-reg 4503601774854144.0 %load-reference
203    fp-scratch-reg scratch-reg float-offset LFD
204    dst dst fp-scratch-reg FSUB ;
205
206M:: ppc %float>integer ( dst src -- )
207    fp-scratch-reg src FCTIWZ
208    fp-scratch-reg 1 0 scratch@ STFD
209    dst 1 4 scratch@ LWZ ;
210
211M: ppc %copy ( dst src rep -- )
212    2over eq? [ 3drop ] [
213        {
214            { tagged-rep [ MR ] }
215            { int-rep [ MR ] }
216            { double-rep [ FMR ] }
217        } case
218    ] if ;
219
220GENERIC: float-function-param* ( dst src -- )
221
222M: spill-slot float-function-param* [ 1 ] dip n>> spill@ LFD ;
223M: integer float-function-param* FMR ;
224
225: float-function-param ( i src -- )
226    [ float-regs cdecl param-regs at nth ] dip float-function-param* ;
227
228: float-function-return ( reg -- )
229    float-regs return-regs at first double-rep %copy ;
230
231M:: ppc %unary-float-function ( dst src func -- )
232    0 src float-function-param
233    func f %c-invoke
234    dst float-function-return ;
235
236M:: ppc %binary-float-function ( dst src1 src2 func -- )
237    0 src1 float-function-param
238    1 src2 float-function-param
239    func f %c-invoke
240    dst float-function-return ;
241
242! Internal format is always double-precision on PowerPC
243M: ppc %single>double-float double-rep %copy ;
244M: ppc %double>single-float FRSP ;
245
246M: ppc %unbox-alien ( dst src -- )
247    alien-offset LWZ ;
248
249M:: ppc %unbox-any-c-ptr ( dst src -- )
250    [
251        "end" define-label
252        0 dst LI
253        ! Is the object f?
254        0 src \ f type-number CMPI
255        "end" get BEQ
256        ! Compute tag in dst register
257        dst src tag-mask get ANDI
258        ! Is the object an alien?
259        0 dst alien type-number CMPI
260        ! Add an offset to start of byte array's data
261        dst src byte-array-offset ADDI
262        "end" get BNE
263        ! If so, load the offset and add it to the address
264        dst src alien-offset LWZ
265        "end" resolve-label
266    ] with-scope ;
267
268: alien@ ( n -- n' ) cells alien type-number - ;
269
270M:: ppc %box-alien ( dst src temp -- )
271    [
272        "f" define-label
273        dst \ f type-number %load-immediate
274        0 src 0 CMPI
275        "f" get BEQ
276        dst 5 cells alien temp %allot
277        temp \ f type-number %load-immediate
278        temp dst 1 alien@ STW
279        temp dst 2 alien@ STW
280        src dst 3 alien@ STW
281        src dst 4 alien@ STW
282        "f" resolve-label
283    ] with-scope ;
284
285:: %box-displaced-alien/f ( dst displacement base -- )
286    base dst 1 alien@ STW
287    displacement dst 3 alien@ STW
288    displacement dst 4 alien@ STW ;
289
290:: %box-displaced-alien/alien ( dst displacement base temp -- )
291    ! Set new alien's base to base.base
292    temp base 1 alien@ LWZ
293    temp dst 1 alien@ STW
294
295    ! Compute displacement
296    temp base 3 alien@ LWZ
297    temp temp displacement ADD
298    temp dst 3 alien@ STW
299
300    ! Compute address
301    temp base 4 alien@ LWZ
302    temp temp displacement ADD
303    temp dst 4 alien@ STW ;
304
305:: %box-displaced-alien/byte-array ( dst displacement base temp -- )
306    base dst 1 alien@ STW
307    displacement dst 3 alien@ STW
308    temp base byte-array-offset ADDI
309    temp temp displacement ADD
310    temp dst 4 alien@ STW ;
311
312:: %box-displaced-alien/dynamic ( dst displacement base temp -- )
313    "not-f" define-label
314    "not-alien" define-label
315
316    ! Is base f?
317    0 base \ f type-number CMPI
318    "not-f" get BNE
319
320    ! Yes, it is f. Fill in new object
321    dst displacement base %box-displaced-alien/f
322
323    "end" get B
324
325    "not-f" resolve-label
326
327    ! Check base type
328    temp base tag-mask get ANDI
329
330    ! Is base an alien?
331    0 temp alien type-number CMPI
332    "not-alien" get BNE
333
334    dst displacement base temp %box-displaced-alien/alien
335
336    ! We are done
337    "end" get B
338
339    ! Is base a byte array? It has to be, by now...
340    "not-alien" resolve-label
341
342    dst displacement base temp %box-displaced-alien/byte-array ;
343
344M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- )
345    ! This is ridiculous
346    [
347        "end" define-label
348
349        ! If displacement is zero, return the base
350        dst base MR
351        0 displacement 0 CMPI
352        "end" get BEQ
353
354        ! Displacement is non-zero, we're going to be allocating a new
355        ! object
356        dst 5 cells alien temp %allot
357
358        ! Set expired to f
359        temp \ f type-number %load-immediate
360        temp dst 2 alien@ STW
361
362        dst displacement base temp
363        {
364            { [ base-class \ f class<= ] [ drop %box-displaced-alien/f ] }
365            { [ base-class \ alien class<= ] [ %box-displaced-alien/alien ] }
366            { [ base-class \ byte-array class<= ] [ %box-displaced-alien/byte-array ] }
367            [ %box-displaced-alien/dynamic ]
368        } cond
369
370        "end" resolve-label
371    ] with-scope ;
372
373: (%memory) ( val base displacement scale offset rep c-type -- base val displacement rep c-type )
374    [ [ 0 assert= ] bi@ swapd ] 2dip ; inline
375
376M: ppc %load-memory-imm ( dst base offset rep c-type -- )
377    [
378        {
379            { c:char   [ [ dup ] 2dip LBZ dup EXTSB ] }
380            { c:uchar  [ LBZ ] }
381            { c:short  [ LHA ] }
382            { c:ushort [ LHZ ] }
383            { c:int    [ LWZ ] }
384            { c:uint   [ LWZ ] }
385        } case
386    ] [
387        {
388            { int-rep [ LWZ ] }
389            { float-rep [ LFS ] }
390            { double-rep [ LFD ] }
391        } case
392    ] ?if ;
393
394M: ppc %load-memory ( dst base displacement scale offset rep c-type -- )
395    (%memory) [
396        {
397            { c:char   [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
398            { c:uchar  [ LBZX ] }
399            { c:short  [ LHAX ] }
400            { c:ushort [ LHZX ] }
401            { c:int    [ LWZX ] }
402            { c:uint   [ LWZX ] }
403        } case
404    ] [
405        {
406            { int-rep [ LWZX ] }
407            { float-rep [ LFSX ] }
408            { double-rep [ LFDX ] }
409        } case
410    ] ?if ;
411
412M: ppc %store-memory-imm ( src base offset rep c-type -- )
413    [
414        {
415            { c:char   [ STB ] }
416            { c:uchar  [ STB ] }
417            { c:short  [ STH ] }
418            { c:ushort [ STH ] }
419            { c:int    [ STW ] }
420            { c:uint   [ STW ] }
421        } case
422    ] [
423        {
424            { int-rep [ STW ] }
425            { float-rep [ STFS ] }
426            { double-rep [ STFD ] }
427        } case
428    ] ?if ;
429
430M: ppc %store-memory ( src base displacement scale offset rep c-type -- )
431    (%memory) [
432        {
433            { c:char   [ STBX ] }
434            { c:uchar  [ STBX ] }
435            { c:short  [ STHX ] }
436            { c:ushort [ STHX ] }
437            { c:int    [ STWX ] }
438            { c:uint   [ STWX ] }
439        } case
440    ] [
441        {
442            { int-rep [ STWX ] }
443            { float-rep [ STFSX ] }
444            { double-rep [ STFDX ] }
445        } case
446    ] ?if ;
447
448: load-zone-ptr ( reg -- )
449    vm-reg "nursery" vm-field-offset ADDI ;
450
451: load-allot-ptr ( nursery-ptr allot-ptr -- )
452    [ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ;
453
454:: inc-allot-ptr ( nursery-ptr allot-ptr n -- )
455    scratch-reg allot-ptr n data-alignment get align ADDI
456    scratch-reg nursery-ptr 0 STW ;
457
458:: store-header ( dst class -- )
459    class type-number tag-header scratch-reg LI
460    scratch-reg dst 0 STW ;
461
462: store-tagged ( dst tag -- )
463    dupd type-number ORI ;
464
465M:: ppc %allot ( dst size class nursery-ptr -- )
466    nursery-ptr dst load-allot-ptr
467    nursery-ptr dst size inc-allot-ptr
468    dst class store-header
469    dst class store-tagged ;
470
471: load-cards-offset ( dst -- )
472    0 swap LOAD32 rc-absolute-ppc-2/2 rel-cards-offset ;
473
474: load-decks-offset ( dst -- )
475    0 swap LOAD32 rc-absolute-ppc-2/2 rel-decks-offset ;
476
477:: (%write-barrier) ( temp1 temp2 -- )
478    card-mark scratch-reg LI
479
480    ! Mark the card
481    temp1 temp1 card-bits SRWI
482    temp2 load-cards-offset
483    temp1 scratch-reg temp2 STBX
484
485    ! Mark the card deck
486    temp1 temp1 deck-bits card-bits - SRWI
487    temp2 load-decks-offset
488    temp1 scratch-reg temp2 STBX ;
489
490M:: ppc %write-barrier ( src slot scale tag temp1 temp2 -- )
491    scale 0 assert= tag 0 assert=
492    temp1 src slot ADD
493    temp1 temp2 (%write-barrier) ;
494
495M:: ppc %write-barrier-imm ( src slot tag temp1 temp2 -- )
496    temp1 src slot tag slot-offset ADDI
497    temp1 temp2 (%write-barrier) ;
498
499M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- )
500    temp1 vm-reg "nursery" vm-field-offset LWZ
501    temp2 vm-reg "nursery" vm-field-offset 2 cells + LWZ
502    temp1 temp1 size ADDI
503    ! is here >= end?
504    temp1 0 temp2 CMP
505    cc {
506        { cc<= [ label BLE ] }
507        { cc/<= [ label BGT ] }
508    } case ;
509
510: gc-root-offsets ( seq -- seq' )
511    [ n>> spill@ ] map f like ;
512
513M: ppc %call-gc ( gc-roots -- )
514    3 swap gc-root-offsets %load-reference
515    4 %load-vm-addr
516    "inline_gc" f %c-invoke ;
517
518M: ppc %prologue ( n -- )
519    0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
520    0 MFLR
521    {
522        [ [ 1 1 ] dip neg ADDI ]
523        [ [ 11 1 ] dip xt-save STW ]
524        [ 11 LI ]
525        [ [ 11 1 ] dip next-save STW ]
526        [ [ 0 1 ] dip lr-save + STW ]
527    } cleave ;
528
529M: ppc %epilogue ( n -- )
530    #! At the end of each word that calls a subroutine, we store
531    #! the previous link register value in r0 by popping it off
532    #! the stack, set the link register to the contents of r0,
533    #! and jump to the link register.
534    [ [ 0 1 ] dip lr-save + LWZ ]
535    [ [ 1 1 ] dip ADDI ] bi
536    0 MTLR ;
537
538:: (%boolean) ( dst temp branch1 branch2 -- )
539    "end" define-label
540    dst \ f type-number %load-immediate
541    "end" get branch1 execute( label -- )
542    branch2 [ "end" get branch2 execute( label -- ) ] when
543    dst \ t %load-reference
544    "end" get resolve-label ; inline
545
546:: %boolean ( dst cc temp -- )
547    cc negate-cc order-cc {
548        { cc<  [ dst temp \ BLT f (%boolean) ] }
549        { cc<= [ dst temp \ BLE f (%boolean) ] }
550        { cc>  [ dst temp \ BGT f (%boolean) ] }
551        { cc>= [ dst temp \ BGE f (%boolean) ] }
552        { cc=  [ dst temp \ BEQ f (%boolean) ] }
553        { cc/= [ dst temp \ BNE f (%boolean) ] }
554    } case ;
555
556: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
557
558: (%compare-integer-imm) ( src1 src2 -- )
559    [ 0 ] 2dip CMPI ; inline
560
561: (%compare-imm) ( src1 src2 -- )
562    [ tag-fixnum ] [ \ f type-number ] if* (%compare-integer-imm) ; inline
563
564: (%compare-float-unordered) ( src1 src2 -- )
565    [ 0 ] dip FCMPU ; inline
566
567: (%compare-float-ordered) ( src1 src2 -- )
568    [ 0 ] dip FCMPO ; inline
569
570:: (%compare-float) ( src1 src2 cc compare -- branch1 branch2 )
571    cc {
572        { cc<    [ src1 src2 \ compare execute( a b -- ) \ BLT f     ] }
573        { cc<=   [ src1 src2 \ compare execute( a b -- ) \ BLT \ BEQ ] }
574        { cc>    [ src1 src2 \ compare execute( a b -- ) \ BGT f     ] }
575        { cc>=   [ src1 src2 \ compare execute( a b -- ) \ BGT \ BEQ ] }
576        { cc=    [ src1 src2 \ compare execute( a b -- ) \ BEQ f     ] }
577        { cc<>   [ src1 src2 \ compare execute( a b -- ) \ BLT \ BGT ] }
578        { cc<>=  [ src1 src2 \ compare execute( a b -- ) \ BNO f     ] }
579        { cc/<   [ src1 src2 \ compare execute( a b -- ) \ BGE f     ] }
580        { cc/<=  [ src1 src2 \ compare execute( a b -- ) \ BGT \ BO  ] }
581        { cc/>   [ src1 src2 \ compare execute( a b -- ) \ BLE f     ] }
582        { cc/>=  [ src1 src2 \ compare execute( a b -- ) \ BLT \ BO  ] }
583        { cc/=   [ src1 src2 \ compare execute( a b -- ) \ BNE f     ] }
584        { cc/<>  [ src1 src2 \ compare execute( a b -- ) \ BEQ \ BO  ] }
585        { cc/<>= [ src1 src2 \ compare execute( a b -- ) \ BO  f     ] }
586    } case ; inline
587
588M: ppc %compare [ (%compare) ] 2dip %boolean ;
589
590M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
591
592M: ppc %compare-integer-imm [ (%compare-integer-imm) ] 2dip %boolean ;
593
594M:: ppc %compare-float-ordered ( dst src1 src2 cc temp -- )
595    src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
596    dst temp branch1 branch2 (%boolean) ;
597
598M:: ppc %compare-float-unordered ( dst src1 src2 cc temp -- )
599    src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
600    dst temp branch1 branch2 (%boolean) ;
601
602:: %branch ( label cc -- )
603    cc order-cc {
604        { cc<  [ label BLT ] }
605        { cc<= [ label BLE ] }
606        { cc>  [ label BGT ] }
607        { cc>= [ label BGE ] }
608        { cc=  [ label BEQ ] }
609        { cc/= [ label BNE ] }
610    } case ;
611
612M:: ppc %compare-branch ( label src1 src2 cc -- )
613    src1 src2 (%compare)
614    label cc %branch ;
615
616M:: ppc %compare-imm-branch ( label src1 src2 cc -- )
617    src1 src2 (%compare-imm)
618    label cc %branch ;
619
620M:: ppc %compare-integer-imm-branch ( label src1 src2 cc -- )
621    src1 src2 (%compare-integer-imm)
622    label cc %branch ;
623
624:: (%branch) ( label branch1 branch2 -- )
625    label branch1 execute( label -- )
626    branch2 [ label branch2 execute( label -- ) ] when ; inline
627
628M:: ppc %compare-float-ordered-branch ( label src1 src2 cc -- )
629    src1 src2 cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
630    label branch1 branch2 (%branch) ;
631
632M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
633    src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
634    label branch1 branch2 (%branch) ;
635
636: load-from-frame ( dst n rep -- )
637    {
638        { int-rep [ [ 1 ] dip LWZ ] }
639        { tagged-rep [ [ 1 ] dip LWZ ] }
640        { float-rep [ [ 1 ] dip LFS ] }
641        { double-rep [ [ 1 ] dip LFD ] }
642        { stack-params [ [ 0 1 ] dip LWZ [ 0 1 ] dip param@ STW ] }
643    } case ;
644
645: next-param@ ( n -- reg x )
646    [ 17 ] dip param@ ;
647
648: store-to-frame ( src n rep -- )
649    {
650        { int-rep [ [ 1 ] dip STW ] }
651        { tagged-rep [ [ 1 ] dip STW ] }
652        { float-rep [ [ 1 ] dip STFS ] }
653        { double-rep [ [ 1 ] dip STFD ] }
654        { stack-params [ [ [ 0 ] dip next-param@ LWZ 0 1 ] dip STW ] }
655    } case ;
656
657M: ppc %spill ( src rep dst -- )
658    swap [ n>> spill@ ] dip store-to-frame ;
659
660M: ppc %reload ( dst rep src -- )
661    swap [ n>> spill@ ] dip load-from-frame ;
662
663M: ppc %loop-entry ;
664
665M: ppc return-regs
666    {
667        { int-regs { 3 4 5 6 } }
668        { float-regs { 1 } }
669    } ;
670
671M:: ppc %save-param-reg ( stack reg rep -- )
672    reg stack local@ rep store-to-frame ;
673
674M:: ppc %load-param-reg ( stack reg rep -- )
675    reg stack local@ rep load-from-frame ;
676
677GENERIC: load-param ( reg src -- )
678
679M: integer load-param int-rep %copy ;
680
681M: spill-slot load-param [ 1 ] dip n>> spill@ LWZ ;
682
683GENERIC: store-param ( reg dst -- )
684
685M: integer store-param swap int-rep %copy ;
686
687M: spill-slot store-param [ 1 ] dip n>> spill@ STW ;
688
689:: call-unbox-func ( src func -- )
690    3 src load-param
691    4 %load-vm-addr
692    func f %c-invoke ;
693
694M:: ppc %unbox ( src n rep func -- )
695    src func call-unbox-func
696    ! Store the return value on the C stack
697    n [ rep reg-class-of return-regs at first rep %save-param-reg ] when* ;
698
699M:: ppc %unbox-long-long ( src n func -- )
700    src func call-unbox-func
701    ! Store the return value on the C stack
702    n [
703        3 1 n local@ STW
704        4 1 n cell + local@ STW
705    ] when ;
706
707M:: ppc %unbox-large-struct ( src n c-type -- )
708    4 src load-param
709    3 1 n local@ ADDI
710    c-type heap-size 5 LI
711    "memcpy" "libc" load-library %c-invoke ;
712
713M:: ppc %box ( dst n rep func -- )
714    n [ 0 rep reg-class-of cdecl param-reg rep %load-param-reg ] when*
715    rep double-rep? 5 4 ? %load-vm-addr
716    func f %c-invoke
717    3 dst store-param ;
718
719M:: ppc %box-long-long ( dst n func -- )
720    n [
721        3 1 n local@ LWZ
722        4 1 n cell + local@ LWZ
723    ] when
724    5 %load-vm-addr
725    func f %c-invoke
726    3 dst store-param ;
727
728: struct-return@ ( n -- n )
729    [ stack-frame get params>> ] unless* local@ ;
730
731M: ppc %prepare-box-struct ( -- )
732    #! Compute target address for value struct return
733    3 1 f struct-return@ ADDI
734    3 1 0 local@ STW ;
735
736M:: ppc %box-large-struct ( dst n c-type -- )
737    ! If n = f, then we're boxing a returned struct
738    ! Compute destination address and load struct size
739    3 1 n struct-return@ ADDI
740    c-type heap-size 4 LI
741    5 %load-vm-addr
742    ! Call the function
743    "from_value_struct" f %c-invoke
744    3 dst store-param ;
745
746M:: ppc %restore-context ( temp1 temp2 -- )
747    temp1 %context
748    ds-reg temp1 "datastack" context-field-offset LWZ
749    rs-reg temp1 "retainstack" context-field-offset LWZ ;
750
751M:: ppc %save-context ( temp1 temp2 -- )
752    temp1 %context
753    1 temp1 "callstack-top" context-field-offset STW
754    ds-reg temp1 "datastack" context-field-offset STW
755    rs-reg temp1 "retainstack" context-field-offset STW ;
756
757M: ppc %c-invoke ( symbol dll -- )
758    [ 11 ] 2dip %alien-global 11 MTLR BLRL ;
759
760M: ppc %alien-indirect ( src -- )
761    [ 11 ] dip load-param 11 MTLR BLRL ;
762
763M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
764
765M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
766
767M: ppc immediate-store? drop f ;
768
769M: ppc return-struct-in-registers? ( c-type -- ? )
770    c-type return-in-registers?>> ;
771
772M:: ppc %box-small-struct ( dst c-type -- )
773    #! Box a <= 16-byte struct returned in r3:r4:r5:r6
774    c-type heap-size 7 LI
775    8 %load-vm-addr
776    "from_medium_struct" f %c-invoke
777    3 dst store-param ;
778
779: %unbox-struct-1 ( -- )
780    ! Alien must be in r3.
781    3 3 0 LWZ ;
782
783: %unbox-struct-2 ( -- )
784    ! Alien must be in r3.
785    4 3 4 LWZ
786    3 3 0 LWZ ;
787
788: %unbox-struct-4 ( -- )
789    ! Alien must be in r3.
790    6 3 12 LWZ
791    5 3 8 LWZ
792    4 3 4 LWZ
793    3 3 0 LWZ ;
794
795M:: ppc %unbox-small-struct ( src c-type -- )
796    src 3 load-param
797    c-type heap-size {
798        { [ dup 4 <= ] [ drop %unbox-struct-1 ] }
799        { [ dup 8 <= ] [ drop %unbox-struct-2 ] }
800        { [ dup 16 <= ] [ drop %unbox-struct-4 ] }
801    } cond ;
802
803M: ppc %begin-callback ( -- )
804    3 %load-vm-addr
805    "begin_callback" f %c-invoke ;
806
807M: ppc %alien-callback ( quot -- )
808    3 swap %load-reference
809    4 3 quot-entry-point-offset LWZ
810    4 MTLR
811    BLRL ;
812
813M: ppc %end-callback ( -- )
814    3 %load-vm-addr
815    "end_callback" f %c-invoke ;
816
817enable-float-functions
818
819USE: vocabs.loader
820
821{
822    { [ os macosx? ] [ "cpu.ppc.macosx" require ] }
823    { [ os linux? ] [ "cpu.ppc.linux" require ] }
824} cond
825
826complex-double c-type t >>return-in-registers? drop