ifdef CONFIG
CC = gcc
CPP = g++
- AR = ar
- LD = ld
VERSION = 0.94
@echo "freebsd-x86-64"
@echo "linux-x86-32"
@echo "linux-x86-64"
- @echo "linux-ppc"
+ @echo "linux-ppc-32"
+ @echo "linux-ppc-64"
@echo "linux-arm"
@echo "openbsd-x86-32"
@echo "openbsd-x86-64"
linux-x86-64:
$(MAKE) $(ALL) CONFIG=vm/Config.linux.x86.64
-linux-ppc:
- $(MAKE) $(ALL) CONFIG=vm/Config.linux.ppc
+linux-ppc-32:
+ $(MAKE) $(ALL) CONFIG=vm/Config.linux.ppc.32
+
+linux-ppc-64:
+ $(MAKE) $(ALL) CONFIG=vm/Config.linux.ppc.64
linux-arm:
$(MAKE) $(ALL) CONFIG=vm/Config.linux.arm
$(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
.S.o:
- $(TOOLCHAIN_PREFIX)$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
+ $(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) -o $@ $<
.mm.o:
$(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
\ uint c-type \ size_t typedef
] if
- cpu ppc? \ uint \ uchar ? c-type clone
+ cpu ppc? os macosx? and \ uint \ uchar ? c-type clone
[ >c-bool ] >>unboxer-quot
[ c-bool> ] >>boxer-quot
object >>boxed-class
: dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ;
+: dlsym-raw ( name dll -- alien ) [ string>symbol ] dip (dlsym-raw) ;
+
SYMBOL: libraries
libraries [ H{ } clone ] initialize
ERROR: no-such-symbol name library ;
: address-of ( name library -- value )
- 2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
+ 2dup load-library dlsym-raw [ 2nip ] [ no-such-symbol ] if* ;
SYMBOL: deploy-libraries
IN: bootstrap.image
: arch ( os cpu -- arch )
- [ "winnt" = "winnt" "unix" ? ] dip "-" glue ;
+ 2dup [ winnt? ] [ ppc? ] bi* or [
+ [ drop unix ] dip
+ ] unless
+ [ name>> ] [ name>> ] bi* "-" glue ;
: my-arch ( -- arch )
- os name>> cpu name>> arch ;
+ os cpu arch ;
: boot-image-name ( arch -- string )
"boot." ".image" surround ;
: images ( -- seq )
{
"winnt-x86.32" "unix-x86.32"
+ "linux-ppc.32" "linux-ppc.64"
"winnt-x86.64" "unix-x86.64"
} ;
: jit-dlsym ( name rc -- )
rt-dlsym jit-rel string>symbol jit-parameter f jit-parameter ;
+: jit-dlsym-toc ( name rc -- )
+ rt-dlsym-toc jit-rel string>symbol jit-parameter f jit-parameter ;
+
:: jit-conditional ( test-quot false-quot -- )
[ 0 test-quot call ] B{ } make length :> len
building get length jit-offset get + len +
{ y int }
{ x longlong } ;
- [ 12 ] [ ppc-align-test-2 heap-size ] unit-test
- [ 4 ] [ "x" ppc-align-test-2 offset-of ] unit-test
+ cpu ppc? 4 cell = and os macosx? and [
+ [ 12 ] [ ppc-align-test-2 heap-size ] unit-test
+ [ 4 ] [ "x" ppc-align-test-2 offset-of ] unit-test
+ ] [
+ [ 16 ] [ ppc-align-test-2 heap-size ] unit-test
+ [ 8 ] [ "x" ppc-align-test-2 offset-of ] unit-test
+ ] if
] when
STRUCT: struct-test-delegate
dup large-struct? [
heap-size cell f ^^local-allot [
'[ _ prefix ]
- [ int-rep struct-return-on-stack? 2array prefix ] bi*
+ [ int-rep struct-return-on-stack? f 3array prefix ] bi*
] keep
] [ drop f ] if ;
: (caller-parameters) ( vregs reps -- )
- [ first2 next-parameter ] 2each ;
+ [ first3 next-parameter ] 2each ;
: caller-parameters ( params -- reg-inputs stack-inputs )
[ abi>> ] [ parameters>> ] [ return>> ] tri
[ caller-return ]
bi ;
-: callee-parameter ( rep on-stack? -- dst )
- [ next-vreg dup ] 2dip next-parameter ;
+: callee-parameter ( rep on-stack? odd-register? -- dst )
+ [ next-vreg dup ] 3dip next-parameter ;
: prepare-struct-callee ( c-type -- vreg )
large-struct?
- [ int-rep struct-return-on-stack? callee-parameter ] [ f ] if ;
+ [ int-rep struct-return-on-stack? f callee-parameter ] [ f ] if ;
: (callee-parameters) ( params -- vregs reps )
[ flatten-parameter-type ] map
- [ [ [ first2 callee-parameter ] map ] map ]
+ [ [ [ first3 callee-parameter ] map ] map ]
[ [ keys ] map ]
bi ;
GENERIC: flatten-c-type ( c-type -- pairs )
M: c-type flatten-c-type
- rep>> f 2array 1array ;
+ rep>> f f 3array 1array ;
M: long-long-type flatten-c-type
- drop 2 [ int-rep long-long-on-stack? 2array ] replicate ;
+ drop 2 [ int-rep long-long-on-stack? f 3array ] replicate ;
HOOK: flatten-struct-type cpu ( type -- pairs )
+HOOK: flatten-struct-type-return cpu ( type -- pairs )
M: object flatten-struct-type
- heap-size cell align cell /i { int-rep f } <repetition> ;
+ heap-size cell align cell /i { int-rep f f } <repetition> ;
M: struct-c-type flatten-c-type
flatten-struct-type ;
+M: object flatten-struct-type-return
+ flatten-struct-type ;
+
: stack-size ( c-type -- n )
base-type flatten-c-type keys 0 [ rep-size + ] reduce ;
[| rep offset | src offset rep f ^^load-memory-imm ] 2map
reps ;
+:: explode-struct-return ( src c-type -- vregs reps )
+ c-type flatten-struct-type-return :> reps
+ reps keys dup component-offsets
+ [| rep offset | src offset rep f ^^load-memory-imm ] 2map
+ reps ;
+
:: implode-struct ( src vregs reps -- )
vregs reps dup component-offsets
[| vreg rep offset | vreg src offset rep f ##store-memory-imm ] 3each ;
[ swap ^^unbox ]
} case 1array
]
- [ drop f 2array 1array ] 2bi ;
+ [ drop f f 3array 1array ] 2bi ;
M: long-long-type unbox
[ next-vreg next-vreg 2dup ] 2dip unboxer>> ##unbox-long-long 2array
- int-rep long-long-on-stack? 2array dup 2array ;
+ int-rep long-long-on-stack? long-long-odd-register? 3array
+ int-rep long-long-on-stack? f 3array 2array ;
M: struct-c-type unbox ( src c-type -- vregs reps )
[ ^^unbox-any-c-ptr ] dip explode-struct ;
[ nip heap-size cell f ^^local-allot dup ]
[ [ ^^unbox-any-c-ptr ] dip explode-struct keys ] 2bi
implode-struct
- 1array { { int-rep f } }
+ 1array { { int-rep f f } }
] if ;
: store-return ( vregs reps -- triples )
[
[
[ [ { } assert-sequence= ] bi@ struct-return-area get ] dip
- explode-struct keys
+ explode-struct-return keys
] keep box
] if ;
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: cpu.architecture fry kernel layouts math math.order
-namespaces sequences vectors assocs arrays ;
+namespaces sequences vectors assocs arrays locals ;
IN: compiler.cfg.builder.alien.params
SYMBOL: stack-params
-: alloc-stack-param ( rep -- n )
+GENERIC: alloc-stack-param ( reg -- n )
+
+M: object alloc-stack-param ( rep -- n )
stack-params get
[ rep-size cell align stack-params +@ ] dip ;
+M: float-rep alloc-stack-param ( rep -- n )
+ stack-params get swap rep-size
+ [ cell align stack-params +@ ] keep
+ float-right-align-on-stack? [ + ] [ drop ] if ;
+
: ?dummy-stack-params ( rep -- )
dummy-stack-params? [ alloc-stack-param drop ] [ drop ] if ;
: ?dummy-fp-params ( rep -- )
drop dummy-fp-params? [ float-regs get [ pop* ] unless-empty ] when ;
-GENERIC: next-reg-param ( rep -- reg )
+GENERIC: next-reg-param ( odd-register? rep -- reg )
M: int-rep next-reg-param
- [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi
- int-regs get pop ;
+ [ nip ?dummy-stack-params ]
+ [ nip ?dummy-fp-params ]
+ [ drop [
+ int-regs get last even?
+ [ int-regs get pop* ] when
+ ] when ]
+ 2tri int-regs get pop ;
M: float-rep next-reg-param
- [ ?dummy-stack-params ] [ ?dummy-int-params ] bi
+ nip [ ?dummy-stack-params ] [ ?dummy-int-params ] bi
float-regs get pop ;
M: double-rep next-reg-param
- [ ?dummy-stack-params ] [ ?dummy-int-params ] bi
+ nip [ ?dummy-stack-params ] [ ?dummy-int-params ] bi
float-regs get pop ;
-: reg-class-full? ( reg-class -- ? ) get empty? ;
+:: reg-class-full? ( reg-class odd-register? -- ? )
+ reg-class get empty?
+ reg-class get length 1 = odd-register? and
+ dup [ reg-class get delete-all ] when or ;
: init-reg-class ( abi reg-class -- )
[ swap param-regs at <reversed> >vector ] keep set ;
SYMBOLS: stack-values reg-values ;
-: next-parameter ( vreg rep on-stack? -- )
- [ dup dup reg-class-of reg-class-full? ] dip or
- [ alloc-stack-param stack-values ] [ next-reg-param reg-values ] if
+:: next-parameter ( vreg rep on-stack? odd-register? -- )
+ vreg rep on-stack?
+ [ dup dup reg-class-of odd-register? reg-class-full? ] dip or
+ [ alloc-stack-param stack-values ] [ odd-register? swap next-reg-param reg-values ] if
[ 3array ] dip get push ;
: next-return-reg ( rep -- reg ) reg-class-of get pop ;
} value-numbering-step
] unit-test
- [
- {
- T{ ##peek f 0 D 0 }
- T{ ##load-integer f 2 2147483647 }
- T{ ##add-imm f 3 0 2147483647 }
- T{ ##add-imm f 4 3 2147483647 }
- }
- ] [
- {
- T{ ##peek f 0 D 0 }
- T{ ##load-integer f 2 2147483647 }
- T{ ##add f 3 0 2 }
- T{ ##add f 4 3 2 }
- } value-numbering-step
- ] unit-test
+ ! PPC ADDI can't hold immediates this big.
+ cpu ppc? [
+ [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 2 2147483647 }
+ T{ ##add-imm f 3 0 2147483647 }
+ T{ ##add-imm f 4 3 2147483647 }
+ }
+ ] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-integer f 2 2147483647 }
+ T{ ##add f 3 0 2 }
+ T{ ##add f 4 3 2 }
+ } value-numbering-step
+ ] unit-test
+ ] unless
] when
[
: rel-dlsym ( name dll class -- )
[ add-dlsym-parameters ] dip rt-dlsym rel-fixup ;
+: rel-dlsym-toc ( name dll class -- )
+ [ add-dlsym-parameters ] dip rt-dlsym-toc rel-fixup ;
+
: rel-word ( word class -- )
[ add-literal ] dip rt-entry-point rel-fixup ;
CONSTANT: rc-relative 2
CONSTANT: rc-absolute-ppc-2/2 3
CONSTANT: rc-absolute-ppc-2 4
-CONSTANT: rc-relative-ppc-2 5
-CONSTANT: rc-relative-ppc-3 6
+CONSTANT: rc-relative-ppc-2-pc 5
+CONSTANT: rc-relative-ppc-3-pc 6
CONSTANT: rc-relative-arm-3 7
CONSTANT: rc-indirect-arm 8
CONSTANT: rc-indirect-arm-pc 9
CONSTANT: rc-absolute-2 10
CONSTANT: rc-absolute-1 11
+CONSTANT: rc-absolute-ppc-2/2/2/2 12
! Relocation types
CONSTANT: rt-dlsym 0
CONSTANT: rt-cards-offset 10
CONSTANT: rt-decks-offset 11
CONSTANT: rt-exception-handler 12
+CONSTANT: rt-dlsym-toc 13
: rc-absolute? ( n -- ? )
${
! If t, long longs are never passed in param regs
HOOK: long-long-on-stack? cpu ( -- ? )
+! If t, long longs are aligned on an odd register. On Linux
+! 32-bit PPC, long longs are 8-byte aligned but passed in
+! registers so they need to be aligned on an odd numbered
+! (r3, r5, etc) register.
+HOOK: long-long-odd-register? cpu ( -- ? )
+
! If t, floats are never passed in param regs
HOOK: float-on-stack? cpu ( -- ? )
+! If t, put floats in the second word of a double word on the stack
+HOOK: float-right-align-on-stack? cpu ( -- ? )
+
! If t, the struct return pointer is never passed in a param reg
HOOK: struct-return-on-stack? cpu ( -- ? )
--- /dev/null
+! Copyright (C) 2011 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: cpu.ppc ;
--- /dev/null
+! Copyright (C) 2011 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser system kernel sequences math math.ranges
+cpu.ppc.assembler combinators compiler.constants
+bootstrap.image.private layouts namespaces ;
+IN: bootstrap.ppc
+
+4 \ cell set
+big-endian on
+
+: reserved-size ( -- n ) 24 ;
+: lr-save ( -- n ) 4 ;
+
+CONSTANT: ds-reg 14
+CONSTANT: rs-reg 15
+CONSTANT: vm-reg 16
+CONSTANT: ctx-reg 17
+CONSTANT: frame-reg 31
+: nv-int-regs ( -- seq ) 13 31 [a,b] ;
+
+: LOAD32 ( r n -- )
+ [ -16 shift HEX: ffff bitand LIS ]
+ [ [ dup ] dip HEX: ffff bitand ORI ] 2bi ;
+
+: jit-trap-null ( src -- ) drop ;
+: jit-load-vm ( dst -- )
+ 0 LOAD32 0 rc-absolute-ppc-2/2 jit-vm ;
+: jit-load-dlsym ( dst string -- )
+ [ 0 LOAD32 ] dip rc-absolute-ppc-2/2 jit-dlsym ;
+: jit-load-dlsym-toc ( string -- ) drop ;
+: jit-load-vm-arg ( dst -- )
+ 0 LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel ;
+: jit-load-entry-point-arg ( dst -- )
+ 0 LOAD32 rc-absolute-ppc-2/2 rt-entry-point jit-rel ;
+: jit-load-this-arg ( dst -- )
+ 0 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel ;
+: jit-load-literal-arg ( dst -- )
+ 0 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel ;
+: jit-load-dlsym-arg ( dst -- )
+ 0 LOAD32 rc-absolute-ppc-2/2 rt-dlsym jit-rel ;
+: jit-load-dlsym-toc-arg ( -- ) ;
+: jit-load-here-arg ( dst -- )
+ 0 LOAD32 rc-absolute-ppc-2/2 rt-here jit-rel ;
+: jit-load-megamorphic-cache-arg ( dst -- )
+ 0 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel ;
+: jit-load-cell ( dst src offset -- ) LWZ ;
+: jit-load-cell-x ( dst src offset -- ) LWZX ;
+: jit-load-cell-update ( dst src offset -- ) LWZU ;
+: jit-save-cell ( dst src offset -- ) STW ;
+: jit-save-cell-x ( dst src offset -- ) STWX ;
+: jit-save-cell-update ( dst src offset -- ) STWU ;
+: jit-load-int ( dst src offset -- ) LWZ ;
+: jit-save-int ( dst src offset -- ) STW ;
+: jit-shift-tag-bits ( dst src -- ) tag-bits get SRAWI ;
+: jit-mask-tag-bits ( dst src -- ) tag-bits get CLRRWI ;
+: jit-shift-fixnum-slot ( dst src -- ) 2 SRAWI ;
+: jit-class-hashcode ( dst src -- ) 1 SRAWI ;
+: jit-shift-left-logical ( dst src n -- ) SLW ;
+: jit-shift-left-logical-imm ( dst src n -- ) SLWI ;
+: jit-shift-right-algebraic ( dst src n -- ) SRAW ;
+: jit-divide ( dst ra rb -- ) DIVW ;
+: jit-multiply-low ( dst ra rb -- ) MULLW ;
+: jit-multiply-low-ov-rc ( dst ra rb -- ) MULLWO. ;
+: jit-compare-cell ( cr ra rb -- ) CMPW ;
+: jit-compare-cell-imm ( cr ra imm -- ) CMPWI ;
+
+: cell-size ( -- n ) 4 ;
+: factor-area-size ( -- n ) 16 ;
+: param-size ( -- n ) 32 ;
+: saved-int-regs-size ( -- n ) 96 ;
+
+<< "vocab:cpu/ppc/bootstrap.factor" parse-file suffix! >>
+call
--- /dev/null
+! Copyright (C) 2011 Erik Charlebois
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors system kernel layouts combinators
+compiler.cfg.builder.alien.boxing sequences arrays
+alien.c-types cpu.architecture cpu.ppc alien.complex ;
+IN: cpu.ppc.32.linux
+
+M: linux lr-save ( -- n ) 1 cells ;
+
+M: linux has-toc ( -- ? ) f ;
+
+M: linux reserved-area-size ( -- n ) 2 cells ;
+
+M: linux allows-null-dereference ( -- ? ) f ;
+
+M: ppc param-regs
+ drop {
+ { int-regs { 3 4 5 6 7 8 9 10 } }
+ { float-regs { 1 2 3 4 5 6 7 8 } }
+ } ;
+
+M: ppc value-struct?
+ c-type [ complex-double c-type = ]
+ [ complex-float c-type = ] bi or ;
+
+M: ppc dummy-stack-params? f ;
+
+M: ppc dummy-int-params? f ;
+
+M: ppc dummy-fp-params? f ;
+
+M: ppc long-long-on-stack? f ;
+
+M: ppc long-long-odd-register? t ;
+
+M: ppc float-right-align-on-stack? f ;
+
+M: ppc flatten-struct-type ( type -- seq )
+ {
+ { [ dup c-type complex-double c-type = ]
+ [ drop { { int-rep f f } { int-rep f f }
+ { int-rep f f } { int-rep f f } } ] }
+ { [ dup c-type complex-float c-type = ]
+ [ drop { { int-rep f f } { int-rep f f } } ] }
+ [ call-next-method [ first t f 3array ] map ]
+ } cond ;
--- /dev/null
+! Copyright (C) 2011 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: cpu.ppc ;
--- /dev/null
+! Copyright (C) 2011 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser system kernel sequences math math.ranges
+cpu.ppc.assembler combinators compiler.constants
+bootstrap.image.private layouts namespaces ;
+IN: bootstrap.ppc
+
+8 \ cell set
+big-endian on
+
+: reserved-size ( -- n ) 48 ;
+: lr-save ( -- n ) 16 ;
+
+CONSTANT: ds-reg 14
+CONSTANT: rs-reg 15
+CONSTANT: vm-reg 16
+CONSTANT: ctx-reg 17
+CONSTANT: frame-reg 31
+: nv-int-regs ( -- seq ) 13 31 [a,b] ;
+
+: LOAD64 ( r n -- )
+ [ dup ] dip {
+ [ nip -48 shift HEX: ffff bitand LIS ]
+ [ -32 shift HEX: ffff bitand ORI ]
+ [ drop 32 SLDI ]
+ [ -16 shift HEX: ffff bitand ORIS ]
+ [ HEX: ffff bitand ORI ]
+ } 3cleave ;
+
+: jit-trap-null ( src -- ) drop ;
+: jit-load-vm ( dst -- )
+ 0 LOAD64 0 rc-absolute-ppc-2/2/2/2 jit-vm ;
+: jit-load-dlsym ( dst string -- )
+ [ 0 LOAD64 ] dip rc-absolute-ppc-2/2/2/2 jit-dlsym ;
+: jit-load-dlsym-toc ( string -- )
+ [ 2 0 LOAD64 ] dip rc-absolute-ppc-2/2/2/2 jit-dlsym-toc ;
+: jit-load-vm-arg ( dst -- )
+ 0 LOAD64 rc-absolute-ppc-2/2/2/2 rt-vm jit-rel ;
+: jit-load-entry-point-arg ( dst -- )
+ 0 LOAD64 rc-absolute-ppc-2/2/2/2 rt-entry-point jit-rel ;
+: jit-load-this-arg ( dst -- )
+ 0 LOAD64 rc-absolute-ppc-2/2/2/2 rt-this jit-rel ;
+: jit-load-literal-arg ( dst -- )
+ 0 LOAD64 rc-absolute-ppc-2/2/2/2 rt-literal jit-rel ;
+: jit-load-dlsym-arg ( dst -- )
+ 0 LOAD64 rc-absolute-ppc-2/2/2/2 rt-dlsym jit-rel ;
+: jit-load-dlsym-toc-arg ( -- )
+ 2 0 LOAD64 rc-absolute-ppc-2/2/2/2 rt-dlsym-toc jit-rel ;
+: jit-load-here-arg ( dst -- )
+ 0 LOAD64 rc-absolute-ppc-2/2/2/2 rt-here jit-rel ;
+: jit-load-megamorphic-cache-arg ( dst -- )
+ 0 LOAD64 rc-absolute-ppc-2/2/2/2 rt-megamorphic-cache-hits jit-rel ;
+: jit-load-cell ( dst src offset -- ) LD ;
+: jit-load-cell-x ( dst src offset -- ) LDX ;
+: jit-load-cell-update ( dst src offset -- ) LDU ;
+: jit-save-cell ( dst src offset -- ) STD ;
+: jit-save-cell-x ( dst src offset -- ) STDX ;
+: jit-save-cell-update ( dst src offset -- ) STDU ;
+: jit-load-int ( dst src offset -- ) LD ;
+: jit-save-int ( dst src offset -- ) STD ;
+: jit-shift-tag-bits ( dst src -- ) tag-bits get SRADI ;
+: jit-mask-tag-bits ( dst src -- ) tag-bits get CLRRDI ;
+: jit-shift-fixnum-slot ( dst src -- ) 1 SRADI ;
+: jit-class-hashcode ( dst src -- ) 1 SRADI ;
+: jit-shift-left-logical ( dst src n -- ) SLD ;
+: jit-shift-left-logical-imm ( dst src n -- ) SLDI ;
+: jit-shift-right-algebraic ( dst src n -- ) SRAD ;
+: jit-divide ( dst ra rb -- ) DIVD ;
+: jit-multiply-low ( dst ra rb -- ) MULLD ;
+: jit-multiply-low-ov-rc ( dst ra rb -- ) MULLDO. ;
+: jit-compare-cell ( cr ra rb -- ) CMPD ;
+: jit-compare-cell-imm ( cr ra imm -- ) CMPDI ;
+
+: cell-size ( -- n ) 8 ;
+: factor-area-size ( -- n ) 32 ;
+: param-size ( -- n ) 64 ;
+: saved-int-regs-size ( -- n ) 192 ;
+
+<< "vocab:cpu/ppc/bootstrap.factor" parse-file suffix! >>
+call
--- /dev/null
+! Copyright (C) 2011 Erik Charlebois
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors system kernel layouts combinators
+compiler.cfg.builder.alien.boxing sequences arrays math
+alien.c-types cpu.architecture cpu.ppc alien.complex ;
+IN: cpu.ppc.64.linux
+
+M: linux lr-save 2 cells ;
+
+M: linux has-toc ( -- ? ) t ;
+
+M: linux reserved-area-size ( -- n ) 6 cells ;
+
+M: linux allows-null-dereference ( -- ? ) f ;
+
+M: ppc param-regs
+ drop {
+ { int-regs { 3 4 5 6 7 8 9 10 } }
+ { float-regs { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
+ } ;
+
+M: ppc value-struct? drop t ;
+
+M: ppc dummy-stack-params? t ;
+
+M: ppc dummy-int-params? t ;
+
+M: ppc dummy-fp-params? f ;
+
+M: ppc long-long-on-stack? f ;
+
+M: ppc long-long-odd-register? f ;
+
+M: ppc float-right-align-on-stack? t ;
+
+M: ppc flatten-struct-type ( type -- seq )
+ {
+ { [ dup c-type complex-double c-type = ]
+ [ drop { { double-rep f f } { double-rep f f } } ] }
+ { [ dup c-type complex-float c-type = ]
+ [ drop { { float-rep f f } { float-rep f f } } ] }
+ [ heap-size cell align cell /i { int-rep f f } <repetition> ]
+ } cond ;
+
+M: ppc flatten-struct-type-return ( type -- seq )
+ {
+ { [ dup c-type complex-double c-type = ]
+ [ drop { { double-rep f f } { double-rep f f } } ] }
+ { [ dup c-type complex-float c-type = ]
+ [ drop { { float-rep f f } { float-rep f f } } ] }
+ [ heap-size cell align cell /i { int-rep t f } <repetition> ]
+ } cond ;
--- /dev/null
+! Copyright (C) 2011 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces words math math.order locals math.bitwise io.binary make ;
+IN: cpu.ppc.assembler
+
+! This vocabulary implements the V2.06B Power ISA found at http://www.power.org.
+! The names are standard and the operand order is the same as in the specification,
+! except that displacement in d-form and ds-form instructions come after the base
+! address register.
+!
+! For example, in assembler syntax, stores are written like:
+! stw r14,10(r15)
+! In Factor, we write:
+! 14 15 10 STW
+
+: insn ( operand opcode -- )
+ { 26 0 } bitfield 4 >be % ;
+
+: a-insn ( rt ra rb rc xo rc opcode -- )
+ [ { 0 1 6 11 16 21 } bitfield ] dip insn ;
+
+: b-insn ( bo bi bd aa lk opcode -- )
+ [ { 0 1 2 16 21 } bitfield ] dip insn ;
+
+: d-insn ( rt ra d opcode -- )
+ [ HEX: ffff bitand { 0 16 21 } bitfield ] dip insn ;
+
+: ds-insn ( rt ra ds rc opcode -- )
+ [ [ HEX: 3fff bitand ] dip { 0 2 16 21 } bitfield ] dip insn ;
+
+: evx-insn ( rt ra rb xo opcode -- )
+ [ { 0 11 16 21 } bitfield ] dip insn ;
+
+: i-insn ( li aa lk opcode -- )
+ [ { 0 1 2 } bitfield ] dip insn ;
+
+: m-insn ( rs ra sh mb me rc opcode -- )
+ [ { 0 1 6 11 16 21 } bitfield ] dip insn ;
+
+:: md-insn ( rs ra sh mb xo sh5 rc opcode -- )
+ mb [ HEX: 1f bitand 1 shift ] [ -5 shift ] bi bitor :> mb
+ rs ra sh mb xo sh5 rc opcode
+ [ { 0 1 2 5 11 16 21 } bitfield ] dip insn ;
+
+:: mds-insn ( rs ra rb mb xo rc opcode -- )
+ mb [ HEX: 1f bitand 1 shift ] [ -5 shift ] bi bitor :> mb
+ rs ra rb mb xo rc opcode
+ [ { 0 1 5 11 16 21 } bitfield ] dip insn ;
+
+: sc-insn ( lev opcode -- )
+ [ 1 { 1 5 } bitfield ] dip insn ;
+
+: va-insn ( vrt vra vrb vrc xo opcode -- )
+ [ { 0 6 11 16 21 } bitfield ] dip insn ;
+
+: vc-insn ( vrt vra vrb rc xo opcode -- )
+ [ { 0 10 11 16 21 } bitfield ] dip insn ;
+
+: vx-insn ( vrt vra vrb xo opcode -- )
+ [ { 0 11 16 21 } bitfield ] dip insn ;
+
+: x-insn ( rt ra rb xo rc opcode -- )
+ [ { 0 1 11 16 21 } bitfield ] dip insn ;
+
+: xfl-insn ( l flm w frb xo rc opcode -- )
+ [ { 0 1 11 16 17 25 } bitfield ] dip insn ;
+
+: xfx-insn ( rs spr xo rc opcode -- )
+ [ { 0 1 11 21 } bitfield ] dip insn ;
+
+: xl-insn ( bo bi bb xo lk opcode -- )
+ [ { 0 1 11 16 21 } bitfield ] dip insn ;
+
+: xo-insn ( rt ra rb oe xo rc opcode -- )
+ [ { 0 1 10 11 16 21 } bitfield ] dip insn ;
+
+: xs-insn ( rs ra sh xo sh5 rc opcode -- )
+ [ { 0 1 2 11 16 21 } bitfield ] dip insn ;
+
+:: xx1-insn ( rt ra rb xo opcode -- )
+ rt HEX: 1f bitand ra rb xo rt -5 shift
+ { 0 1 11 16 21 } bitfield opcode insn ;
+
+:: xx2-insn ( rt ra rb xo opcode -- )
+ rt HEX: 1f bitand ra rb HEX: 1f bitand xo
+ rb -5 shift rt -5 shift
+ { 0 1 2 11 16 21 } bitfield opcode insn ;
+
+:: xx3-insn ( rt ra rb xo opcode -- )
+ rt HEX: 1f bitand ra HEX: 1f bitand rb HEX: 1f bitand
+ xo ra -5 shift rb -5 shift rt -5 shift
+ { 0 1 2 3 11 16 21 } bitfield opcode insn ;
+
+:: xx3-rc-insn ( rt ra rb rc xo opcode -- )
+ rt HEX: 1f bitand ra HEX: 1f bitand rb HEX: 1f bitand
+ rc xo ra -5 shift rb -5 shift rt -5 shift
+ { 0 1 2 3 10 11 16 21 } bitfield opcode insn ;
+
+:: xx3-rc-dm-insn ( rt ra rb rc dm xo opcode -- )
+ rt HEX: 1f bitand ra HEX: 1f bitand rb HEX: 1f bitand
+ rc dm xo ra -5 shift rb -5 shift rt -5 shift
+ { 0 1 2 3 8 10 11 16 21 } bitfield opcode insn ;
+
+:: xx4-insn ( rt ra rb rc xo opcode -- )
+ rt HEX: 1f bitand ra HEX: 1f bitand rb HEX: 1f bitand
+ rc HEX: 1f bitand xo rc -5 shift ra -5 shift rb
+ -5 shift rt -5 shift
+ { 0 1 2 3 4 6 11 16 21 } bitfield opcode insn ;
+
+: z22-insn ( bf fra dcm xo rc opcode -- )
+ [ { 0 1 10 16 21 } bitfield ] dip insn ;
+
+: z23-insn ( frt te frb rmc xo rc opcode -- )
+ [ { 0 1 9 11 16 21 } bitfield ] dip insn ;
+
+! 2.4 Branch Instructions
+GENERIC: B ( target_addr/label -- )
+M: integer B ( target_addr -- ) -2 shift 0 0 18 i-insn ;
+
+GENERIC: BL ( target_addr/label -- )
+M: integer BL ( target_addr -- ) -2 shift 0 1 18 i-insn ;
+
+: BA ( target_addr -- ) -2 shift 1 0 18 i-insn ;
+: BLA ( target_addr -- ) -2 shift 1 1 18 i-insn ;
+
+GENERIC: BC ( bo bi target_addr/label -- )
+M: integer BC ( bo bi target_addr -- ) -2 shift 0 0 16 b-insn ;
+
+: BCA ( bo bi target_addr -- ) -2 shift 1 0 16 b-insn ;
+: BCL ( bo bi target_addr -- ) -2 shift 0 1 16 b-insn ;
+: BCLA ( bo bi target_addr -- ) -2 shift 1 1 16 b-insn ;
+
+: BCLR ( bo bi bh -- ) 16 0 19 xl-insn ;
+: BCLRL ( bo bi bh -- ) 16 1 19 xl-insn ;
+: BCCTR ( bo bi bh -- ) 528 0 19 xl-insn ;
+: BCCTRL ( bo bi bh -- ) 528 1 19 xl-insn ;
+
+! 2.5.1 Condition Register Logical Instructions
+: CRAND ( bt ba bb -- ) 527 0 19 xl-insn ;
+: CRNAND ( bt ba bb -- ) 225 0 19 xl-insn ;
+: CROR ( bt ba bb -- ) 449 0 19 xl-insn ;
+: CRXOR ( bt ba bb -- ) 193 0 19 xl-insn ;
+: CRNOR ( bt ba bb -- ) 33 0 19 xl-insn ;
+: CREQV ( bt ba bb -- ) 289 0 19 xl-insn ;
+: CRANDC ( bt ba bb -- ) 129 0 19 xl-insn ;
+: CRORC ( bt ba bb -- ) 417 0 19 xl-insn ;
+
+! 2.5.2 Condition Register Field Instruction
+: MCRF ( bf bfa -- ) [ 2 shift ] bi@ 0 0 0 19 xl-insn ;
+
+! 2.6 System Call Instruction
+: SC ( lev -- ) 17 sc-insn ;
+
+! 3.3.2 Fixed-Point Load Instructions
+: LBZ ( rt ra d -- ) 34 d-insn ;
+: LBZU ( rt ra d -- ) 35 d-insn ;
+: LHZ ( rt ra d -- ) 40 d-insn ;
+: LHZU ( rt ra d -- ) 41 d-insn ;
+: LHA ( rt ra d -- ) 42 d-insn ;
+: LHAU ( rt ra d -- ) 43 d-insn ;
+: LWZ ( rt ra d -- ) 32 d-insn ;
+: LWZU ( rt ra d -- ) 33 d-insn ;
+: LBZX ( rt ra rb -- ) 87 0 31 x-insn ;
+: LBZUX ( rt ra rb -- ) 119 0 31 x-insn ;
+: LHZX ( rt ra rb -- ) 279 0 31 x-insn ;
+: LHZUX ( rt ra rb -- ) 311 0 31 x-insn ;
+: LHAX ( rt ra rb -- ) 343 0 31 x-insn ;
+: LHAUX ( rt ra rb -- ) 375 0 31 x-insn ;
+: LWZX ( rt ra rb -- ) 23 0 31 x-insn ;
+: LWZUX ( rt ra rb -- ) 55 0 31 x-insn ;
+
+! 3.3.2.1 64-bit Fixed-Point Load Instructions
+: LWA ( rt ra ds -- ) -2 shift 2 58 ds-insn ;
+: LD ( rt ra ds -- ) -2 shift 0 58 ds-insn ;
+: LDU ( rt ra ds -- ) -2 shift 1 58 ds-insn ;
+: LWAX ( rt ra rb -- ) 341 0 31 x-insn ;
+: LWAUX ( rt ra rb -- ) 373 0 31 x-insn ;
+: LDX ( rt ra rb -- ) 21 0 31 x-insn ;
+: LDUX ( rt ra rb -- ) 53 0 31 x-insn ;
+
+! 3.3.3 Fixed-Point Store Instructions
+: STB ( rs ra d -- ) 38 d-insn ;
+: STBU ( rs ra d -- ) 39 d-insn ;
+: STH ( rs ra d -- ) 44 d-insn ;
+: STHU ( rs ra d -- ) 45 d-insn ;
+: STW ( rs ra d -- ) 36 d-insn ;
+: STWU ( rs ra d -- ) 37 d-insn ;
+: STBX ( rs ra rb -- ) 215 0 31 x-insn ;
+: STBUX ( rs ra rb -- ) 247 0 31 x-insn ;
+: STHX ( rs ra rb -- ) 407 0 31 x-insn ;
+: STHUX ( rs ra rb -- ) 439 0 31 x-insn ;
+: STWX ( rs ra rb -- ) 151 0 31 x-insn ;
+: STWUX ( rs ra rb -- ) 183 0 31 x-insn ;
+
+! 3.3.3.1 64-bit Fixed-Point Store Instructions
+: STD ( rs ra ds -- ) -2 shift 0 62 ds-insn ;
+: STDU ( rs ra ds -- ) -2 shift 1 62 ds-insn ;
+: STDX ( rs ra rb -- ) 149 0 31 x-insn ;
+: STDUX ( rs ra rb -- ) 181 0 31 x-insn ;
+
+! 3.3.4 Fixed-Point Load and Store with Byte Reversal Instructions
+: LHBRX ( rt ra rb -- ) 790 0 31 x-insn ;
+: LWBRX ( rt ra rb -- ) 534 0 31 x-insn ;
+: STHBRX ( rs ra rb -- ) 918 0 31 x-insn ;
+: STWBRX ( rs ra rb -- ) 662 0 31 x-insn ;
+
+! 3.3.4.1 64-bit Fixed-Point Load and Store with Byte Reversal Instructions
+: LDBRX ( rt ra rb -- ) 532 0 31 x-insn ;
+: STDBRX ( rs ra rb -- ) 660 0 31 x-insn ;
+
+! 3.3.5 Fixed-Point Load and Store Multiple Instructions
+: LMW ( rt ra d -- ) 46 d-insn ;
+: STMW ( rs ra d -- ) 47 d-insn ;
+
+! 3.3.6 Fixed-Point Move Assist Instructions
+: LSWI ( rt ra nb -- ) 597 0 31 x-insn ;
+: LSWX ( rt ra rb -- ) 533 0 31 x-insn ;
+: STSWI ( rs ra nb -- ) 725 0 31 x-insn ;
+: STSWX ( rs ra rb -- ) 661 0 31 x-insn ;
+
+! 3.3.8 Fixed-Point Arithmetic Instructions
+: ADDI ( rt ra si -- ) 14 d-insn ;
+: ADDIS ( rt ra si -- ) 15 d-insn ;
+: ADDIC ( rt ra si -- ) 12 d-insn ;
+: ADDIC. ( rt ra si -- ) 13 d-insn ;
+: SUBFIC ( rt ra si -- ) 8 d-insn ;
+: MULLI ( rt ra si -- ) 7 d-insn ;
+: ADD ( rt ra rb -- ) 0 266 0 31 xo-insn ;
+: ADD. ( rt ra rb -- ) 0 266 1 31 xo-insn ;
+: ADDO ( rt ra rb -- ) 1 266 0 31 xo-insn ;
+: ADDO. ( rt ra rb -- ) 1 266 1 31 xo-insn ;
+: ADDC ( rt ra rb -- ) 0 10 0 31 xo-insn ;
+: ADDC. ( rt ra rb -- ) 0 10 1 31 xo-insn ;
+: ADDCO ( rt ra rb -- ) 1 10 0 31 xo-insn ;
+: ADDCO. ( rt ra rb -- ) 1 10 1 31 xo-insn ;
+: ADDE ( rt ra rb -- ) 0 138 0 31 xo-insn ;
+: ADDE. ( rt ra rb -- ) 0 138 1 31 xo-insn ;
+: ADDEO ( rt ra rb -- ) 1 138 0 31 xo-insn ;
+: ADDEO. ( rt ra rb -- ) 1 138 1 31 xo-insn ;
+: ADDME ( rt ra -- ) 0 0 234 0 31 xo-insn ;
+: ADDME. ( rt ra -- ) 0 0 234 1 31 xo-insn ;
+: ADDMEO ( rt ra -- ) 0 1 234 0 31 xo-insn ;
+: ADDMEO. ( rt ra -- ) 0 1 234 1 31 xo-insn ;
+: ADDZE ( rt ra -- ) 0 0 202 0 31 xo-insn ;
+: ADDZE. ( rt ra -- ) 0 0 202 1 31 xo-insn ;
+: ADDZEO ( rt ra -- ) 0 1 202 0 31 xo-insn ;
+: ADDZEO. ( rt ra -- ) 0 1 202 1 31 xo-insn ;
+: SUBF ( rt ra rb -- ) 0 40 0 31 xo-insn ;
+: SUBF. ( rt ra rb -- ) 0 40 1 31 xo-insn ;
+: SUBFO ( rt ra rb -- ) 1 40 0 31 xo-insn ;
+: SUBFO. ( rt ra rb -- ) 1 40 1 31 xo-insn ;
+: SUBFC ( rt ra rb -- ) 0 8 0 31 xo-insn ;
+: SUBFC. ( rt ra rb -- ) 0 8 1 31 xo-insn ;
+: SUBFCO ( rt ra rb -- ) 1 8 0 31 xo-insn ;
+: SUBFCO. ( rt ra rb -- ) 1 8 1 31 xo-insn ;
+: SUBFE ( rt ra rb -- ) 0 136 0 31 xo-insn ;
+: SUBFE. ( rt ra rb -- ) 0 136 1 31 xo-insn ;
+: SUBFEO ( rt ra rb -- ) 1 136 0 31 xo-insn ;
+: SUBFEO. ( rt ra rb -- ) 1 136 1 31 xo-insn ;
+: SUBFME ( rt ra -- ) 0 0 232 0 31 xo-insn ;
+: SUBFME. ( rt ra -- ) 0 0 232 1 31 xo-insn ;
+: SUBFMEO ( rt ra -- ) 0 1 232 0 31 xo-insn ;
+: SUBFMEO. ( rt ra -- ) 0 1 232 1 31 xo-insn ;
+: SUBFZE ( rt ra -- ) 0 0 200 0 31 xo-insn ;
+: SUBFZE. ( rt ra -- ) 0 0 200 1 31 xo-insn ;
+: SUBFZEO ( rt ra -- ) 0 1 200 0 31 xo-insn ;
+: SUBFZEO. ( rt ra -- ) 0 1 200 1 31 xo-insn ;
+: NEG ( rt ra -- ) 0 0 104 0 31 xo-insn ;
+: NEG. ( rt ra -- ) 0 0 104 1 31 xo-insn ;
+: NEGO ( rt ra -- ) 0 1 104 0 31 xo-insn ;
+: NEGO. ( rt ra -- ) 0 1 104 1 31 xo-insn ;
+: MULLW ( rt ra rb -- ) 0 235 0 31 xo-insn ;
+: MULLW. ( rt ra rb -- ) 0 235 1 31 xo-insn ;
+: MULLWO ( rt ra rb -- ) 1 235 0 31 xo-insn ;
+: MULLWO. ( rt ra rb -- ) 1 235 1 31 xo-insn ;
+: MULHW ( rt ra rb -- ) 0 75 0 31 xo-insn ;
+: MULHW. ( rt ra rb -- ) 0 75 1 31 xo-insn ;
+: MULHWU ( rt ra rb -- ) 0 11 0 31 xo-insn ;
+: MULHWU. ( rt ra rb -- ) 0 11 1 31 xo-insn ;
+: DIVW ( rt ra rb -- ) 0 491 0 31 xo-insn ;
+: DIVW. ( rt ra rb -- ) 0 491 1 31 xo-insn ;
+: DIVWO ( rt ra rb -- ) 1 491 0 31 xo-insn ;
+: DIVWO. ( rt ra rb -- ) 1 491 1 31 xo-insn ;
+: DIVWU ( rt ra rb -- ) 0 459 0 31 xo-insn ;
+: DIVWU. ( rt ra rb -- ) 0 459 1 31 xo-insn ;
+: DIVWUO ( rt ra rb -- ) 1 459 0 31 xo-insn ;
+: DIVWUO. ( rt ra rb -- ) 1 459 1 31 xo-insn ;
+: DIVWE ( rt ra rb -- ) 0 427 0 31 xo-insn ;
+: DIVWE. ( rt ra rb -- ) 0 427 1 31 xo-insn ;
+: DIVWEO ( rt ra rb -- ) 1 427 0 31 xo-insn ;
+: DIVWEO. ( rt ra rb -- ) 1 427 1 31 xo-insn ;
+: DIVWEU ( rt ra rb -- ) 0 395 0 31 xo-insn ;
+: DIVWEU. ( rt ra rb -- ) 0 395 1 31 xo-insn ;
+: DIVWEUO ( rt ra rb -- ) 1 395 0 31 xo-insn ;
+: DIVWEUO. ( rt ra rb -- ) 1 395 1 31 xo-insn ;
+
+! 3.3.8.1 64-bit Fixed-Point Arithmetic Instructions
+: MULLD ( rt ra rb -- ) 0 233 0 31 xo-insn ;
+: MULLD. ( rt ra rb -- ) 0 233 1 31 xo-insn ;
+: MULLDO ( rt ra rb -- ) 1 233 0 31 xo-insn ;
+: MULLDO. ( rt ra rb -- ) 1 233 1 31 xo-insn ;
+: MULHD ( rt ra rb -- ) 0 73 0 31 xo-insn ;
+: MULHD. ( rt ra rb -- ) 0 73 1 31 xo-insn ;
+: MULHDU ( rt ra rb -- ) 0 9 0 31 xo-insn ;
+: MULHDU. ( rt ra rb -- ) 0 9 1 31 xo-insn ;
+: DIVD ( rt ra rb -- ) 0 489 0 31 xo-insn ;
+: DIVD. ( rt ra rb -- ) 0 489 1 31 xo-insn ;
+: DIVDO ( rt ra rb -- ) 1 489 0 31 xo-insn ;
+: DIVDO. ( rt ra rb -- ) 1 489 1 31 xo-insn ;
+: DIVDU ( rt ra rb -- ) 0 457 0 31 xo-insn ;
+: DIVDU. ( rt ra rb -- ) 0 457 1 31 xo-insn ;
+: DIVDUO ( rt ra rb -- ) 1 457 0 31 xo-insn ;
+: DIVDUO. ( rt ra rb -- ) 1 457 1 31 xo-insn ;
+: DIVDE ( rt ra rb -- ) 0 425 0 31 xo-insn ;
+: DIVDE. ( rt ra rb -- ) 0 425 1 31 xo-insn ;
+: DIVDEO ( rt ra rb -- ) 1 425 0 31 xo-insn ;
+: DIVDEO. ( rt ra rb -- ) 1 425 1 31 xo-insn ;
+: DIVDEU ( rt ra rb -- ) 0 393 0 31 xo-insn ;
+: DIVDEU. ( rt ra rb -- ) 0 393 1 31 xo-insn ;
+: DIVDEUO ( rt ra rb -- ) 1 393 0 31 xo-insn ;
+: DIVDEUO. ( rt ra rb -- ) 1 393 1 31 xo-insn ;
+
+! 3.3.9 Fixed-Point Compare Instructions
+: CMPI ( bf l ra si -- ) [ [ 2 shift ] dip bitor ] 2dip 11 d-insn ;
+: CMPLI ( bf l ra ui -- ) [ [ 2 shift ] dip bitor ] 2dip 10 d-insn ;
+: CMP ( bf l ra rb -- ) [ [ 2 shift ] dip bitor ] 2dip 0 0 31 x-insn ;
+: CMPL ( bf l ra rb -- ) [ [ 2 shift ] dip bitor ] 2dip 32 0 31 x-insn ;
+
+! 3.3.10 Fixed-Point Trap Instructions
+: TWI ( to ra si -- ) 3 d-insn ;
+: TDI ( to ra si -- ) 2 d-insn ;
+: TW ( to ra rb -- ) 4 0 31 x-insn ;
+: TD ( to ra rb -- ) 68 0 31 x-insn ;
+
+! 3.3.11 Fixed-Point Select
+: ISEL ( rt ra rb bc -- ) 15 0 31 a-insn ;
+
+! 3.3.12 Fixed-Point Logical Instructions
+: ANDI. ( ra rs ui -- ) [ swap ] dip 28 d-insn ;
+: ANDIS. ( ra rs ui -- ) [ swap ] dip 29 d-insn ;
+: ORI ( ra rs ui -- ) [ swap ] dip 24 d-insn ;
+: ORIS ( ra rs ui -- ) [ swap ] dip 25 d-insn ;
+: XORI ( ra rs ui -- ) [ swap ] dip 26 d-insn ;
+: XORIS ( ra rs ui -- ) [ swap ] dip 27 d-insn ;
+: AND ( ra rs rb -- ) [ swap ] dip 28 0 31 x-insn ;
+: AND. ( ra rs rb -- ) [ swap ] dip 28 1 31 x-insn ;
+: OR ( ra rs rb -- ) [ swap ] dip 444 0 31 x-insn ;
+: OR. ( ra rs rb -- ) [ swap ] dip 444 1 31 x-insn ;
+: XOR ( ra rs rb -- ) [ swap ] dip 316 0 31 x-insn ;
+: XOR. ( ra rs rb -- ) [ swap ] dip 316 1 31 x-insn ;
+: NAND ( ra rs rb -- ) [ swap ] dip 476 0 31 x-insn ;
+: NAND. ( ra rs rb -- ) [ swap ] dip 476 1 31 x-insn ;
+: NOR ( ra rs rb -- ) [ swap ] dip 124 0 31 x-insn ;
+: NOR. ( ra rs rb -- ) [ swap ] dip 124 1 31 x-insn ;
+: ANDC ( ra rs rb -- ) [ swap ] dip 60 0 31 x-insn ;
+: ANDC. ( ra rs rb -- ) [ swap ] dip 60 1 31 x-insn ;
+: EQV ( ra rs rb -- ) [ swap ] dip 284 0 31 x-insn ;
+: EQV. ( ra rs rb -- ) [ swap ] dip 284 1 31 x-insn ;
+: ORC ( ra rs rb -- ) [ swap ] dip 412 0 31 x-insn ;
+: ORC. ( ra rs rb -- ) [ swap ] dip 412 1 31 x-insn ;
+: CMPB ( ra rs rb -- ) [ swap ] dip 508 0 31 x-insn ;
+: EXTSB ( ra rs -- ) swap 0 954 0 31 x-insn ;
+: EXTSB. ( ra rs -- ) swap 0 954 1 31 x-insn ;
+: EXTSH ( ra rs -- ) swap 0 922 0 31 x-insn ;
+: EXTSH. ( ra rs -- ) swap 0 922 1 31 x-insn ;
+: CNTLZW ( ra rs -- ) swap 0 26 0 31 x-insn ;
+: CNTLZW. ( ra rs -- ) swap 0 26 1 31 x-insn ;
+: POPCNTB ( ra rs -- ) swap 0 122 0 31 x-insn ;
+: POPCNTW ( ra rs -- ) swap 0 378 0 31 x-insn ;
+: PRTYD ( ra rs -- ) swap 0 186 0 31 x-insn ;
+: PRTYW ( ra rs -- ) swap 0 154 0 31 x-insn ;
+
+! 3.3.12.1 64-bit Fixed-Point Logical Instructions
+: EXTSW ( ra rs -- ) swap 0 986 0 31 x-insn ;
+: EXTSW. ( ra rs -- ) swap 0 986 1 31 x-insn ;
+: CNTLZD ( ra rs -- ) swap 0 58 0 31 x-insn ;
+: CNTLZD. ( ra rs -- ) swap 0 58 1 31 x-insn ;
+: POPCNTD ( ra rs -- ) swap 0 506 0 31 x-insn ;
+: BPERMD ( ra rs rb -- ) [ swap ] dip 252 0 31 x-insn ;
+
+! 3.3.13.1 Fixed-Point Rotate and Shift Instructions
+: RLWINM ( ra rs sh mb me -- ) [ swap ] 3dip 0 21 m-insn ;
+: RLWINM. ( ra rs sh mb me -- ) [ swap ] 3dip 1 21 m-insn ;
+: RLWNM ( ra rs rb mb me -- ) [ swap ] 3dip 0 23 m-insn ;
+: RLWNM. ( ra rs rb mb me -- ) [ swap ] 3dip 1 23 m-insn ;
+: RLWIMI ( ra rs sh mb me -- ) [ swap ] 3dip 0 20 m-insn ;
+: RLWIMI. ( ra rs sh mb me -- ) [ swap ] 3dip 1 20 m-insn ;
+
+! 3.3.13.1 64-bit Fixed-Point Rotate Instructions
+: RLDICL ( ra rs sh mb -- )
+ [ swap ] 2dip over [ HEX: 1f bitand ] [ ] [ -5 shift ]
+ tri* 0 swap 0 30 md-insn ;
+: RLDICL. ( ra rs sh mb -- )
+ [ swap ] 2dip over [ HEX: 1f bitand ] [ ] [ -5 shift ]
+ tri* 0 swap 1 30 md-insn ;
+: RLDICR ( ra rs sh me -- )
+ [ swap ] 2dip over [ HEX: 1f bitand ] [ ] [ -5 shift ]
+ tri* 1 swap 0 30 md-insn ;
+: RLDICR. ( ra rs sh me -- )
+ [ swap ] 2dip over [ HEX: 1f bitand ] [ ] [ -5 shift ]
+ tri* 1 swap 1 30 md-insn ;
+: RLDIC ( ra rs sh mb -- )
+ [ swap ] 2dip over [ HEX: 1f bitand ] [ ] [ -5 shift ]
+ tri* 2 swap 0 30 md-insn ;
+: RLDIC. ( ra rs sh mb -- )
+ [ swap ] 2dip over [ HEX: 1f bitand ] [ ] [ -5 shift ]
+ tri* 2 swap 1 30 md-insn ;
+: RLDCL ( ra rs rb mb -- ) [ swap ] 2dip 8 0 30 mds-insn ;
+: RLDCL. ( ra rs rb mb -- ) [ swap ] 2dip 8 1 30 mds-insn ;
+: RLDCR ( ra rs rb me -- ) [ swap ] 2dip 9 0 30 mds-insn ;
+: RLDCR. ( ra rs rb me -- ) [ swap ] 2dip 9 1 30 mds-insn ;
+: RLDIMI ( ra rs sh mb -- )
+ [ swap ] 2dip over [ HEX: 1f bitand ] [ ] [ -5 shift ]
+ tri* 3 swap 0 30 md-insn ;
+: RLDIMI. ( ra rs sh mb -- )
+ [ swap ] 2dip over [ HEX: 1f bitand ] [ ] [ -5 shift ]
+ tri* 3 swap 1 30 md-insn ;
+
+! 3.3.13.2 Fixed-Point Shift Instructions
+: SLW ( ra rs rb -- ) [ swap ] dip 24 0 31 x-insn ;
+: SLW. ( ra rs rb -- ) [ swap ] dip 24 1 31 x-insn ;
+: SRW ( ra rs rb -- ) [ swap ] dip 536 0 31 x-insn ;
+: SRW. ( ra rs rb -- ) [ swap ] dip 536 1 31 x-insn ;
+: SRAWI ( ra rs sh -- ) [ swap ] dip 824 0 31 x-insn ;
+: SRAWI. ( ra rs sh -- ) [ swap ] dip 824 1 31 x-insn ;
+: SRAW ( ra rs rb -- ) [ swap ] dip 792 0 31 x-insn ;
+: SRAW. ( ra rs rb -- ) [ swap ] dip 792 1 31 x-insn ;
+
+! 3.3.13.2.1 64-bit Fixed-Point Shift Instructions
+: SLD ( ra rs rb -- ) [ swap ] dip 27 0 31 x-insn ;
+: SLD. ( ra rs rb -- ) [ swap ] dip 27 1 31 x-insn ;
+: SRD ( ra rs rb -- ) [ swap ] dip 539 0 31 x-insn ;
+: SRD. ( ra rs rb -- ) [ swap ] dip 539 1 31 x-insn ;
+: SRAD ( ra rs rb -- ) [ swap ] dip 794 0 31 x-insn ;
+: SRAD. ( ra rs rb -- ) [ swap ] dip 794 1 31 x-insn ;
+: SRADI ( ra rs sh -- )
+ [ swap ] dip [ HEX: 1f bitand ] [ -5 shift ] bi
+ 413 swap 0 31 xs-insn ;
+: SRADI. ( ra rs sh -- )
+ [ swap ] dip [ HEX: 1f bitand ] [ -5 shift ] bi
+ 413 swap 1 31 xs-insn ;
+
+! 3.3.14 BCD Assist Instructions
+: CDTBCD ( ra rs -- ) swap 0 282 0 31 x-insn ;
+: CBCDTD ( ra rs -- ) swap 0 314 0 31 x-insn ;
+: ADDG6S ( rt ra rb -- ) 0 74 0 31 xo-insn ;
+
+! 3.3.15 Move To/From System Register Instructions
+: MTSPR ( spr rs -- ) swap 467 0 31 xfx-insn ;
+: MFSPR ( rt spr -- ) 339 0 31 xfx-insn ;
+: MTCRF ( fxm rs -- ) swap HEX: ff bitand 1 shift 144 0 31 xfx-insn ;
+: MFCR ( rt -- ) 0 19 0 31 xfx-insn ;
+
+! 3.3.15.1 Move To/From One Condition Register Field Instructions
+: MTOCRF ( fxm rs -- ) swap HEX: 100 bitor 1 shift 144 0 31 xfx-insn ;
+: MFOCRF ( rt fxm -- ) HEX: 100 bitor 1 shift 19 0 31 xfx-insn ;
+
+! 3.3.15.2 Move To/From System Registers (Category: Embedded)
+: MCRXR ( bf -- ) 2 shift 0 0 512 0 31 x-insn ;
+: MTDCRUX ( rs ra -- ) 0 419 0 31 x-insn ;
+: MFDCRUX ( rt ra -- ) 0 291 0 31 x-insn ;
+
+! 4.6.2 Floating-Point Load Instructions
+: LFS ( frt ra d -- ) 48 d-insn ;
+: LFSU ( frt ra d -- ) 49 d-insn ;
+: LFD ( frt ra d -- ) 50 d-insn ;
+: LFDU ( frt ra d -- ) 51 d-insn ;
+: LFSX ( frt ra rb -- ) 535 0 31 x-insn ;
+: LFSUX ( frt ra rb -- ) 567 0 31 x-insn ;
+: LFDX ( frt ra rb -- ) 599 0 31 x-insn ;
+: LFDUX ( frt ra rb -- ) 631 0 31 x-insn ;
+: LFIWAX ( frt ra rb -- ) 855 0 31 x-insn ;
+: LFIWZX ( frt ra rb -- ) 887 0 31 x-insn ;
+
+! 4.6.3 Floating-Point Store Instructions
+: STFS ( frs ra d -- ) 52 d-insn ;
+: STFSU ( frs ra d -- ) 53 d-insn ;
+: STFD ( frs ra d -- ) 54 d-insn ;
+: STFDU ( frs ra d -- ) 55 d-insn ;
+: STFSX ( frs ra rb -- ) 663 0 31 x-insn ;
+: STFSUX ( frs ra rb -- ) 695 0 31 x-insn ;
+: STFDX ( frs ra rb -- ) 727 0 31 x-insn ;
+: STFDUX ( frs ra rb -- ) 759 0 31 x-insn ;
+: STFIWX ( frs ra rb -- ) 983 0 31 x-insn ;
+
+! 4.6.4 Floating-Point Load Store Doubleword Pair Instructions
+: LFDP ( frtp ra ds -- ) 0 57 ds-insn ; deprecated
+: STFDP ( frsp ra ds -- ) 0 61 ds-insn ; deprecated
+: LFDPX ( frtp ra rb -- ) 791 0 31 x-insn ; deprecated
+: STFDPX ( frsp ra rb -- ) 919 0 31 x-insn ; deprecated
+
+! 4.6.5 Floating-Point Move Instructions
+: FMR ( frt frb -- ) [ 0 ] dip 72 0 63 x-insn ;
+: FMR. ( frt frb -- ) [ 0 ] dip 72 1 63 x-insn ;
+: FABS ( frt frb -- ) [ 0 ] dip 264 0 63 x-insn ;
+: FABS. ( frt frb -- ) [ 0 ] dip 264 1 63 x-insn ;
+: FNABS ( frt frb -- ) [ 0 ] dip 136 0 63 x-insn ;
+: FNABS. ( frt frb -- ) [ 0 ] dip 136 1 63 x-insn ;
+: FNEG ( frt frb -- ) [ 0 ] dip 40 0 63 x-insn ;
+: FNEG. ( frt frb -- ) [ 0 ] dip 40 1 63 x-insn ;
+: FCPSGN ( frt fra frb -- ) 8 0 63 x-insn ;
+: FCPSGN. ( frt fra frb -- ) 8 1 63 x-insn ;
+
+! 4.6.6.1 Floating-Point Elementary Arithmetic Instructions
+: FADD ( frt fra frb -- ) 0 21 0 63 a-insn ;
+: FADD. ( frt fra frb -- ) 0 21 1 63 a-insn ;
+: FADDS ( frt fra frb -- ) 0 21 0 59 a-insn ;
+: FADDS. ( frt fra frb -- ) 0 21 1 59 a-insn ;
+: FSUB ( frt fra frb -- ) 0 20 0 63 a-insn ;
+: FSUB. ( frt fra frb -- ) 0 20 1 63 a-insn ;
+: FSUBS ( frt fra frb -- ) 0 20 0 59 a-insn ;
+: FSUBS. ( frt fra frb -- ) 0 20 1 59 a-insn ;
+: FMUL ( frt fra frc -- ) 0 swap 25 0 63 a-insn ;
+: FMUL. ( frt fra frc -- ) 0 swap 25 1 63 a-insn ;
+: FMULS ( frt fra frb -- ) 0 25 0 59 a-insn ;
+: FMULS. ( frt fra frb -- ) 0 25 1 59 a-insn ;
+: FDIV ( frt fra frb -- ) 0 18 0 63 a-insn ;
+: FDIV. ( frt fra frb -- ) 0 18 1 63 a-insn ;
+: FDIVS ( frt fra frb -- ) 0 18 0 59 a-insn ;
+: FDIVS. ( frt fra frb -- ) 0 18 1 59 a-insn ;
+: FSQRT ( frt frb -- ) [ 0 ] dip 0 22 0 63 a-insn ;
+: FSQRT. ( frt frb -- ) [ 0 ] dip 0 22 1 63 a-insn ;
+: FSQRTS ( frt frb -- ) [ 0 ] dip 0 22 0 59 a-insn ;
+: FSQRTS. ( frt frb -- ) [ 0 ] dip 0 22 1 59 a-insn ;
+: FRE ( frt frb -- ) [ 0 ] dip 0 24 0 63 a-insn ;
+: FRE. ( frt frb -- ) [ 0 ] dip 0 24 1 63 a-insn ;
+: FRES ( frt frb -- ) [ 0 ] dip 0 24 0 59 a-insn ;
+: FRES. ( frt frb -- ) [ 0 ] dip 0 24 1 59 a-insn ;
+: FRSQRTE ( frt frb -- ) [ 0 ] dip 0 26 0 63 a-insn ;
+: FRSQRTE. ( frt frb -- ) [ 0 ] dip 0 26 1 63 a-insn ;
+: FRSQRTES ( frt frb -- ) [ 0 ] dip 0 26 0 59 a-insn ;
+: FRSQRTES. ( frt frb -- ) [ 0 ] dip 0 26 1 59 a-insn ;
+: FTDIV ( bf fra frb -- ) [ 2 shift ] 2dip 128 0 63 x-insn ;
+: FTSQRT ( bf frb -- ) [ 2 shift 0 ] dip 160 0 63 x-insn ;
+
+! 4.6.6.2 Floating-Point Multiply-Add Instructions
+: FMADD ( frt fra frc frb -- ) swap 29 0 63 a-insn ;
+: FMADD. ( frt fra frc frb -- ) swap 29 1 63 a-insn ;
+: FMADDS ( frt fra frc frb -- ) swap 29 0 59 a-insn ;
+: FMADDS. ( frt fra frc frb -- ) swap 29 1 59 a-insn ;
+: FMSUB ( frt fra frc frb -- ) swap 28 0 63 a-insn ;
+: FMSUB. ( frt fra frc frb -- ) swap 28 1 63 a-insn ;
+: FMSUBS ( frt fra frc frb -- ) swap 28 0 59 a-insn ;
+: FMSUBS. ( frt fra frc frb -- ) swap 28 1 59 a-insn ;
+: FNMADD ( frt fra frc frb -- ) swap 31 0 63 a-insn ;
+: FNMADD. ( frt fra frc frb -- ) swap 31 1 63 a-insn ;
+: FNMADDS ( frt fra frc frb -- ) swap 31 0 59 a-insn ;
+: FNMADDS. ( frt fra frc frb -- ) swap 31 1 59 a-insn ;
+: FNMSUB ( frt fra frc frb -- ) swap 30 0 63 a-insn ;
+: FNMSUB. ( frt fra frc frb -- ) swap 30 1 63 a-insn ;
+: FNMSUBS ( frt fra frc frb -- ) swap 30 0 59 a-insn ;
+: FNMSUBS. ( frt fra frc frb -- ) swap 30 1 59 a-insn ;
+
+! 4.6.7.1 Floating-Point Rounding Instruction
+: FRSP ( frt frb -- ) [ 0 ] dip 12 0 63 x-insn ;
+: FRSP. ( frt frb -- ) [ 0 ] dip 12 1 63 x-insn ;
+
+! 4.6.7.2 Floating-Point Convert To/From Integer Instructions
+: FCTID ( frt frb -- ) [ 0 ] dip 814 0 63 x-insn ;
+: FCTID. ( frt frb -- ) [ 0 ] dip 814 1 63 x-insn ;
+: FCTIDZ ( frt frb -- ) [ 0 ] dip 815 0 63 x-insn ;
+: FCTIDZ. ( frt frb -- ) [ 0 ] dip 815 1 63 x-insn ;
+: FCTIDU ( frt frb -- ) [ 0 ] dip 942 0 63 x-insn ;
+: FCTIDU. ( frt frb -- ) [ 0 ] dip 942 1 63 x-insn ;
+: FCTIDUZ ( frt frb -- ) [ 0 ] dip 943 0 63 x-insn ;
+: FCTIDUZ. ( frt frb -- ) [ 0 ] dip 943 1 63 x-insn ;
+: FCTIW ( frt frb -- ) [ 0 ] dip 14 0 63 x-insn ;
+: FCTIW. ( frt frb -- ) [ 0 ] dip 14 1 63 x-insn ;
+: FCTIWZ ( frt frb -- ) [ 0 ] dip 15 0 63 x-insn ;
+: FCTIWZ. ( frt frb -- ) [ 0 ] dip 15 1 63 x-insn ;
+: FCTIWU ( frt frb -- ) [ 0 ] dip 142 0 63 x-insn ;
+: FCTIWU. ( frt frb -- ) [ 0 ] dip 142 1 63 x-insn ;
+: FCTIWUZ ( frt frb -- ) [ 0 ] dip 143 0 63 x-insn ;
+: FCTIWUZ. ( frt frb -- ) [ 0 ] dip 143 1 63 x-insn ;
+: FCFID ( frt frb -- ) [ 0 ] dip 846 0 63 x-insn ;
+: FCFID. ( frt frb -- ) [ 0 ] dip 846 1 63 x-insn ;
+: FCFIDU ( frt frb -- ) [ 0 ] dip 974 0 63 x-insn ;
+: FCFIDU. ( frt frb -- ) [ 0 ] dip 974 1 63 x-insn ;
+: FCFIDS ( frt frb -- ) [ 0 ] dip 846 0 59 x-insn ;
+: FCFIDS. ( frt frb -- ) [ 0 ] dip 846 1 59 x-insn ;
+: FCFIDUS ( frt frb -- ) [ 0 ] dip 974 0 59 x-insn ;
+: FCFIDUS. ( frt frb -- ) [ 0 ] dip 974 1 59 x-insn ;
+
+! 4.6.7.3 Floating Round to Integer Instructions
+: FRIN ( frt frb -- ) [ 0 ] dip 392 0 63 x-insn ;
+: FRIN. ( frt frb -- ) [ 0 ] dip 392 1 63 x-insn ;
+: FRIZ ( frt frb -- ) [ 0 ] dip 424 0 63 x-insn ;
+: FRIZ. ( frt frb -- ) [ 0 ] dip 424 1 63 x-insn ;
+: FRIP ( frt frb -- ) [ 0 ] dip 456 0 63 x-insn ;
+: FRIP. ( frt frb -- ) [ 0 ] dip 456 1 63 x-insn ;
+: FRIM ( frt frb -- ) [ 0 ] dip 488 0 63 x-insn ;
+: FRIM. ( frt frb -- ) [ 0 ] dip 488 1 63 x-insn ;
+
+! 4.6.8 Floating-Point Compare Instructions
+: FCMPU ( bf fra frb -- ) [ 2 shift ] 2dip 0 0 63 x-insn ;
+: FCMPO ( bf fra frb -- ) [ 2 shift ] 2dip 32 0 63 x-insn ;
+
+! 4.6.9 Floating-Point Select Instruction
+: FSEL ( frt fra frc frb -- ) swap 23 0 63 a-insn ;
+: FSEL. ( frt fra frc frb -- ) swap 23 1 63 a-insn ;
+
+! 4.6.10 Floating-Point Status and Control Register Instructions
+: MFFS ( frt -- ) 0 0 583 0 63 x-insn ;
+: MFFS. ( frt -- ) 0 0 583 1 63 x-insn ;
+: MCRFS ( bf bfa -- ) [ 2 shift ] bi@ 0 64 0 63 x-insn ;
+: MTFSFI ( bf u w -- ) swap [ 2 shift ] [ 1 bitand ] [ 1 shift ]
+tri* 134 0 63 x-insn ;
+: MTFSFI. ( bf u w -- ) swap [ 2 shift ] [ 1 bitand ] [ 1 shift ]
+tri* 134 1 63 x-insn ;
+:: MTFSF ( flm frb l w -- ) l flm w frb 711 0 63 xfl-insn ;
+:: MTFSF. ( flm frb l w -- ) l flm w frb 711 1 63 xfl-insn ;
+: MTFSB0 ( bt -- ) 0 0 70 0 63 x-insn ;
+: MTFSB0. ( bt -- ) 0 0 70 1 63 x-insn ;
+: MTFSB1 ( bt -- ) 0 0 38 0 63 x-insn ;
+: MTFSB1. ( bt -- ) 0 0 38 1 63 x-insn ;
+
+! 5.6.1 DFP Arithmetic Instructions
+: DADD ( frt fra frb -- ) 2 0 59 x-insn ;
+: DADD. ( frt fra frb -- ) 2 1 59 x-insn ;
+: DADDQ ( frtp frap frbp -- ) 2 0 63 x-insn ;
+: DADDQ. ( frtp frap frbp -- ) 2 1 63 x-insn ;
+: DSUB ( frt fra frb -- ) 514 0 59 x-insn ;
+: DSUB. ( frt fra frb -- ) 514 1 59 x-insn ;
+: DSUBQ ( frtp frap frbp -- ) 514 0 63 x-insn ;
+: DSUBQ. ( frtp frap frbp -- ) 514 1 63 x-insn ;
+: DMUL ( frp fra frb -- ) 34 0 59 x-insn ;
+: DMUL. ( frt fra frb -- ) 34 1 59 x-insn ;
+: DMULQ ( frtp frap frbp -- ) 34 0 63 x-insn ;
+: DMULQ. ( frtp frap frbp -- ) 34 1 63 x-insn ;
+: DDIV ( frp fra frb -- ) 546 0 59 x-insn ;
+: DDIV. ( frt fra frb -- ) 546 1 59 x-insn ;
+: DDIVQ ( frtp frap frbp -- ) 546 0 63 x-insn ;
+: DDIVQ. ( frtp frap frbp -- ) 546 1 63 x-insn ;
+
+! 5.6.2 DFP Compare Instructions
+: DCMPU ( bf fra frb -- ) [ 2 shift ] 2dip 642 0 59 x-insn ;
+: DCMPUQ ( bf frap frbp -- ) [ 2 shift ] 2dip 642 0 63 x-insn ;
+: DCMPO ( bf fra frb -- ) [ 2 shift ] 2dip 130 0 59 x-insn ;
+: DCMPOQ ( bf frap frbp -- ) [ 2 shift ] 2dip 130 0 63 x-insn ;
+
+! 5.6.3 DFP Test Instructions
+: DTSTDC ( bf fra dcm -- ) [ 2 shift ] 2dip 194 0 59 z22-insn ;
+: DTSTDCQ ( bf frap dgm -- ) [ 2 shift ] 2dip 194 0 63 z22-insn ;
+: DTSTDG ( bf fra dcm -- ) [ 2 shift ] 2dip 226 0 59 z22-insn ;
+: DTSTDGQ ( bf frap dgm -- ) [ 2 shift ] 2dip 226 0 63 z22-insn ;
+: DTSTEX ( bf fra frb -- ) [ 2 shift ] 2dip 162 0 59 x-insn ;
+: DTSTEXQ ( bf frap frbp -- ) [ 2 shift ] 2dip 162 0 63 x-insn ;
+: DTSTSF ( bf fra frb -- ) [ 2 shift ] 2dip 674 0 59 x-insn ;
+: DTSTSFQ ( bf frap frbp -- ) [ 2 shift ] 2dip 674 0 63 x-insn ;
+
+! 5.6.4 DFP Quantum Adjustment Instructions
+: DQUAI ( te frt frb rmc -- ) [ swap ] 2dip 67 0 59 z23-insn ;
+: DQUAI. ( te frt frb rmc -- ) [ swap ] 2dip 67 1 59 z23-insn ;
+: DQUAIQ ( te frtp frbp rmc -- ) [ swap ] 2dip 67 0 63 z23-insn ;
+: DQUAIQ. ( te frtp frbp rmc -- ) [ swap ] 2dip 67 1 63 z23-insn ;
+: DQUA ( frt fra frb rmc -- ) 3 0 59 z23-insn ;
+: DQUA. ( frt fra frb rmc -- ) 3 1 59 z23-insn ;
+: DQUAQ ( frtp frap frbp rmc -- ) 3 0 63 z23-insn ;
+: DQUAQ. ( frtp frap frbp rmc -- ) 3 1 63 z23-insn ;
+: DRRND ( frt fra frb rmc -- ) 35 0 59 z23-insn ;
+: DRRND. ( frt fra frb rmc -- ) 35 1 59 z23-insn ;
+: DRRNDQ ( frtp frap frbp rmc -- ) 35 0 63 z23-insn ;
+: DRRNDQ. ( frtp frap frbp rmc -- ) 35 1 63 z23-insn ;
+: DRINTX ( r frt frb rmc -- ) [ swap ] 2dip 99 0 59 z23-insn ;
+: DRINTX. ( r frt frb rmc -- ) [ swap ] 2dip 99 1 59 z23-insn ;
+: DRINTXQ ( r frtp frbp rmc -- ) [ swap ] 2dip 99 0 63 z23-insn ;
+: DRINTXQ. ( r frtp frbp rmc -- ) [ swap ] 2dip 99 1 63 z23-insn ;
+: DRINTN ( r frt frb rmc -- ) [ swap ] 2dip 227 0 59 z23-insn ;
+: DRINTN. ( r frt frb rmc -- ) [ swap ] 2dip 227 1 59 z23-insn ;
+: DRINTNQ ( r frtp frbp rmc -- ) [ swap ] 2dip 227 0 63 z23-insn ;
+: DRINTNQ. ( r frtp frbp rmc -- ) [ swap ] 2dip 227 1 63 z23-insn ;
+
+! 5.6.5.1 DFP Data-Format Conversion Instructions
+: DCTDP ( frt frb -- ) 0 swap 258 0 59 x-insn ;
+: DCTDP. ( frt frb -- ) 0 swap 258 1 59 x-insn ;
+: DCTQPQ ( frtp frbp -- ) 0 swap 258 0 63 x-insn ;
+: DCTQPQ. ( frtp frbp -- ) 0 swap 258 1 63 x-insn ;
+: DSRP ( frt frb -- ) 0 swap 770 0 59 x-insn ;
+: DSRP. ( frt frb -- ) 0 swap 770 1 59 x-insn ;
+: DRDPQ ( frtp frbp -- ) 0 swap 770 0 63 x-insn ;
+: DRDPQ. ( frtp frbp -- ) 0 swap 770 1 63 x-insn ;
+
+! 5.6.5.2 DFP Data-Type Conversion Instructions
+: DCFFIX ( frt frb -- ) 0 swap 802 0 59 x-insn ;
+: DCFFIX. ( frt frb -- ) 0 swap 802 1 59 x-insn ;
+: DCFFIXQ ( frtp frbp -- ) 0 swap 802 0 63 x-insn ;
+: DCFFIXQ. ( frtp frbp -- ) 0 swap 802 1 63 x-insn ;
+: DCTFIX ( frt frb -- ) 0 swap 290 0 59 x-insn ;
+: DCTFIX. ( frt frb -- ) 0 swap 290 1 59 x-insn ;
+: DCTFIXQ ( frtp frbp -- ) 0 swap 290 0 63 x-insn ;
+: DCTFIXQ. ( frtp frbp -- ) 0 swap 290 1 63 x-insn ;
+
+! 5.6.6 DFP Format Instructions
+: DDEDPD ( sp frt frb -- ) [ swap 3 shift ] dip 322 0 59 x-insn ;
+: DDEDPD. ( sp frt frb -- ) [ swap 3 shift ] dip 322 1 59 x-insn ;
+: DDEDPDQ ( sp frtp frbp -- ) [ swap 3 shift ] dip 322 0 63 x-insn ;
+: DDEDPDQ. ( sp frtp frbp -- ) [ swap 3 shift ] dip 322 1 63 x-insn ;
+: DENBCD ( s frt frb -- ) [ swap 4 shift ] dip 834 0 59 x-insn ;
+: DENBCD. ( s frt frb -- ) [ swap 4 shift ] dip 834 1 59 x-insn ;
+: DENBCDQ ( s frtp frbp -- ) [ swap 4 shift ] dip 834 0 63 x-insn ;
+: DENBCDQ. ( s frtp frbp -- ) [ swap 4 shift ] dip 834 1 63 x-insn ;
+: DXEX ( frt frb -- ) 0 swap 354 0 59 x-insn ;
+: DXEX. ( frt frb -- ) 0 swap 354 1 59 x-insn ;
+: DXEXQ ( frtp frbp -- ) 0 swap 354 0 63 x-insn ;
+: DXEXQ. ( frtp frbp -- ) 0 swap 354 1 63 x-insn ;
+: DIEX ( frt fra frb -- ) 866 0 59 x-insn ;
+: DIEX. ( frt fra frb -- ) 866 1 59 x-insn ;
+: DIEXQ ( frtp frap frbp -- ) 866 0 63 x-insn ;
+: DIEXQ. ( frtp frap frbp -- ) 866 1 63 x-insn ;
+: DSCLI ( frt fra sh -- ) 66 0 59 z22-insn ;
+: DSCLI. ( frt fra sh -- ) 66 1 59 z22-insn ;
+: DSCLIQ ( frtp frap sh -- ) 66 0 63 z22-insn ;
+: DSCLIQ. ( frtp frap sh -- ) 66 1 63 z22-insn ;
+: DSCRI ( frt fra sh -- ) 98 0 59 z22-insn ;
+: DSCRI. ( frt fra sh -- ) 98 1 59 z22-insn ;
+: DSCRIQ ( frtp frap sh -- ) 98 0 63 z22-insn ;
+: DSCRIQ. ( frtp frap sh -- ) 98 1 63 z22-insn ;
+
+! 6.7.2 Vector Load Instructions
+: LVEBX ( vrt ra rb -- ) 7 0 31 x-insn ;
+: LVEHX ( vrt ra rb -- ) 39 0 31 x-insn ;
+: LVEWX ( vrt ra rb -- ) 71 0 31 x-insn ;
+: LVX ( vrt ra rb -- ) 103 0 31 x-insn ;
+: LVXL ( vrt ra rb -- ) 359 0 31 x-insn ;
+
+! 6.7.3 Vector Store Instructions
+: STVEBX ( vrs ra rb -- ) 135 0 31 x-insn ;
+: STVEHX ( vrs ra rb -- ) 167 0 31 x-insn ;
+: STVEWX ( vrs ra rb -- ) 199 0 31 x-insn ;
+: STVX ( vrs ra rb -- ) 231 0 31 x-insn ;
+: STVXL ( vrs ra rb -- ) 487 0 31 x-insn ;
+
+! 6.7.4 Vector Alignment Support Instructions
+: LVSL ( vrt ra rb -- ) 6 0 31 x-insn ;
+: LVSR ( vrt ra rb -- ) 38 0 31 x-insn ;
+
+! 6.8.1 Vector Pack and Unpack Instructions
+: VPKUHUM ( vrt vra vrb -- ) 14 4 vx-insn ;
+: VPKUWUM ( vrt vra vrb -- ) 78 4 vx-insn ;
+: VPKUHUS ( vrt vra vrb -- ) 142 4 vx-insn ;
+: VPKUWUS ( vrt vra vrb -- ) 206 4 vx-insn ;
+: VPKSHUS ( vrt vra vrb -- ) 270 4 vx-insn ;
+: VPKSWUS ( vrt vra vrb -- ) 334 4 vx-insn ;
+: VPKSHSS ( vrt vra vrb -- ) 398 4 vx-insn ;
+: VPKSWSS ( vrt vra vrb -- ) 462 4 vx-insn ;
+: VPKPX ( vrt vra vrb -- ) 782 4 vx-insn ;
+: VUPKHSB ( vrt vrb -- ) 0 swap 526 4 vx-insn ;
+: VUPKHSH ( vrt vrb -- ) 0 swap 590 4 vx-insn ;
+: VUPKLSB ( vrt vrb -- ) 0 swap 654 4 vx-insn ;
+: VUPKLSH ( vrt vrb -- ) 0 swap 718 4 vx-insn ;
+: VUPKHPX ( vrt vrb -- ) 0 swap 846 4 vx-insn ;
+: VUPKLPX ( vrt vrb -- ) 0 swap 974 4 vx-insn ;
+
+! 6.8.2 Vector Merge Instructions
+: VMRGHB ( vrt vra vrb -- ) 12 4 vx-insn ;
+: VMRGHH ( vrt vra vrb -- ) 76 4 vx-insn ;
+: VMRGHW ( vrt vra vrb -- ) 140 4 vx-insn ;
+: VMRGLB ( vrt vra vrb -- ) 268 4 vx-insn ;
+: VMRGLH ( vrt vra vrb -- ) 332 4 vx-insn ;
+: VMRGLW ( vrt vra vrb -- ) 396 4 vx-insn ;
+
+! 6.8.3 Vector Splat Instructions
+: VSPLTB ( vrt vrb uim -- ) swap 524 4 vx-insn ;
+: VSPLTH ( vrt vrb uim -- ) swap 588 4 vx-insn ;
+: VSPLTW ( vrt vrb uim -- ) swap 652 4 vx-insn ;
+: VSPLTISB ( vrt sim -- ) 0 780 4 vx-insn ;
+: VSPLTISH ( vrt sim -- ) 0 844 4 vx-insn ;
+: VSPLTISW ( vrt sim -- ) 0 908 4 vx-insn ;
+
+! 6.8.4 Vector Permute Instruction
+: VPERM ( vrt vra vrb vrc -- ) 43 4 va-insn ;
+
+! 6.8.5 Vector Select Instruction
+: VSEL ( vrt vra vrb vrc -- ) 42 4 va-insn ;
+
+! 6.8.6 Vector Shift Instructions
+: VSL ( vrt vra vrb -- ) 452 4 vx-insn ;
+: VSR ( vrt vra vrb -- ) 708 4 vx-insn ;
+: VSLO ( vrt vra vrb -- ) 1036 4 vx-insn ;
+: VSRO ( vrt vra vrb -- ) 1100 4 vx-insn ;
+: VSLDOI ( vrt vra vrb shb -- ) 44 4 va-insn ;
+
+! 6.9.1.1 Vector Integer Add Instructions
+: VADDCUW ( vrt vra vrb -- ) 384 4 vx-insn ;
+: VADDSHS ( vrt vra vrb -- ) 832 4 vx-insn ;
+: VADDSBS ( vrt vra vrb -- ) 768 4 vx-insn ;
+: VADDSWS ( vrt vra vrb -- ) 896 4 vx-insn ;
+: VADDUBM ( vrt vra vrb -- ) 0 4 vx-insn ;
+: VADDUHM ( vrt vra vrb -- ) 64 4 vx-insn ;
+: VADDUWM ( vrt vra vrb -- ) 128 4 vx-insn ;
+: VADDUBS ( vrt vra vrb -- ) 512 4 vx-insn ;
+: VADDUHS ( vrt vra vrb -- ) 576 4 vx-insn ;
+: VADDUWS ( vrt vra vrb -- ) 640 4 vx-insn ;
+
+! 6.9.1.2 Vector Integer Subtract Instructions
+: VSUBCUW ( vrt vra vrb -- ) 1408 4 vx-insn ;
+: VSUBSBS ( vrt vra vrb -- ) 1792 4 vx-insn ;
+: VSUBSHS ( vrt vra vrb -- ) 1856 4 vx-insn ;
+: VSUBSWS ( vrt vra vrb -- ) 1920 4 vx-insn ;
+: VSUBUBM ( vrt vra vrb -- ) 1024 4 vx-insn ;
+: VSUBUHM ( vrt vra vrb -- ) 1088 4 vx-insn ;
+: VSUBUWM ( vrt vra vrb -- ) 1152 4 vx-insn ;
+: VSUBUBS ( vrt vra vrb -- ) 1536 4 vx-insn ;
+: VSUBUHS ( vrt vra vrb -- ) 1600 4 vx-insn ;
+: VSUBUWS ( vrt vra vrb -- ) 1664 4 vx-insn ;
+
+! 6.9.1.3 Vector Integer Multiply Instructions
+: VMULESB ( vrt vra vrb -- ) 776 4 vx-insn ;
+: VMULESH ( vrt vra vrb -- ) 840 4 vx-insn ;
+: VMULEUB ( vrt vra vrb -- ) 520 4 vx-insn ;
+: VMULEUH ( vrt vra vrb -- ) 584 4 vx-insn ;
+: VMULOSB ( vrt vra vrb -- ) 264 4 vx-insn ;
+: VMULOSH ( vrt vra vrb -- ) 328 4 vx-insn ;
+: VMULOUB ( vrt vra vrb -- ) 8 4 vx-insn ;
+: VMULOUH ( vrt vra vrb -- ) 72 4 vx-insn ;
+
+! 6.9.1.4 Vector Integer Multiply-Add/Sum Instructions
+: VMHADDSHS ( vrt vra vrb vrc -- ) 32 4 va-insn ;
+: VMHRADDSHS ( vrt vra vrb vrc -- ) 33 4 va-insn ;
+: VMLADDUHM ( vrt vra vrb vrc -- ) 34 4 va-insn ;
+: VMSUMUBM ( vrt vra vrb vrc -- ) 36 4 va-insn ;
+: VMSUMMBM ( vrt vra vrb vrc -- ) 37 4 va-insn ;
+: VMSUMSHM ( vrt vra vrb vrc -- ) 40 4 va-insn ;
+: VMSUMSHS ( vrt vra vrb vrc -- ) 41 4 va-insn ;
+: VMSUMUHM ( vrt vra vrb vrc -- ) 38 4 va-insn ;
+: VMSUMUHS ( vrt vra vrb vrc -- ) 39 4 va-insn ;
+
+! 6.9.1.5 Vector Integer Sum-Across Intructions
+: VSUMSWS ( vrt vra vrb -- ) 1928 4 vx-insn ;
+: VSUM2SWS ( vrt vra vrb -- ) 1672 4 vx-insn ;
+: VSUM4SBS ( vrt vra vrb -- ) 1800 4 vx-insn ;
+: VSUM4UBS ( vrt vra vrb -- ) 1544 4 vx-insn ;
+: VSUM4SHS ( vrt vra vrb -- ) 1608 4 vx-insn ;
+
+! 6.9.1.6 Vector Integer Average Instructions
+: VAVGSB ( vrt vra vrb -- ) 1282 4 vx-insn ;
+: VAVGSH ( vrt vra vrb -- ) 1346 4 vx-insn ;
+: VAVGSW ( vrt vra vrb -- ) 1410 4 vx-insn ;
+: VAVGUB ( vrt vra vrb -- ) 1026 4 vx-insn ;
+: VAVGUH ( vrt vra vrb -- ) 1090 4 vx-insn ;
+: VAVGUW ( vrt vra vrb -- ) 1154 4 vx-insn ;
+
+! 6.9.1.7 Vector Integer Maximum and Minimum Instructions
+: VMAXSB ( vrt vra vrb -- ) 258 4 vx-insn ;
+: VMAXSH ( vrt vra vrb -- ) 322 4 vx-insn ;
+: VMAXSW ( vrt vra vrb -- ) 386 4 vx-insn ;
+: VMAXUB ( vrt vra vrb -- ) 2 4 vx-insn ;
+: VMAXUH ( vrt vra vrb -- ) 66 4 vx-insn ;
+: VMAXUW ( vrt vra vrb -- ) 130 4 vx-insn ;
+: VMINSB ( vrt vra vrb -- ) 770 4 vx-insn ;
+: VMINSH ( vrt vra vrb -- ) 834 4 vx-insn ;
+: VMINSW ( vrt vra vrb -- ) 898 4 vx-insn ;
+: VMINUB ( vrt vra vrb -- ) 514 4 vx-insn ;
+: VMINUH ( vrt vra vrb -- ) 578 4 vx-insn ;
+: VMINUW ( vrt vra vrb -- ) 642 4 vx-insn ;
+
+! 6.9.2 Vector Integer Compare Instructions
+: VCMPEQUB ( vrt vra vrb -- ) 0 6 4 vc-insn ;
+: VCMPEQUB. ( vrt vra vrb -- ) 1 6 4 vc-insn ;
+: VCMPEQUH ( vrt vra vrb -- ) 0 70 4 vc-insn ;
+: VCMPEQUH. ( vrt vra vrb -- ) 1 70 4 vc-insn ;
+: VCMPEQUW ( vrt vra vrb -- ) 0 134 4 vc-insn ;
+: VCMPEQUW. ( vrt vra vrb -- ) 1 134 4 vc-insn ;
+: VCMPGTSB ( vrt vra vrb -- ) 0 774 4 vc-insn ;
+: VCMPGTSB. ( vrt vra vrb -- ) 1 774 4 vc-insn ;
+: VCMPGTSH ( vrt vra vrb -- ) 0 838 4 vc-insn ;
+: VCMPGTSH. ( vrt vra vrb -- ) 1 838 4 vc-insn ;
+: VCMPGTSW ( vrt vra vrb -- ) 0 902 4 vc-insn ;
+: VCMPGTSW. ( vrt vra vrb -- ) 1 902 4 vc-insn ;
+: VCMPGTUB ( vrt vra vrb -- ) 0 518 4 vc-insn ;
+: VCMPGTUB. ( vrt vra vrb -- ) 1 518 4 vc-insn ;
+: VCMPGTUH ( vrt vra vrb -- ) 0 582 4 vc-insn ;
+: VCMPGTUH. ( vrt vra vrb -- ) 1 582 4 vc-insn ;
+: VCMPGTUW ( vrt vra vrb -- ) 0 646 4 vc-insn ;
+: VCMPGTUW. ( vrt vra vrb -- ) 1 646 4 vc-insn ;
+
+! 6.9.3 Vector Logical Instructions
+: VAND ( vrt vra vrb -- ) 1028 4 vx-insn ;
+: VANDC ( vrt vra vrb -- ) 1092 4 vx-insn ;
+: VNOR ( vrt vra vrb -- ) 1284 4 vx-insn ;
+: VOR ( vrt vra vrb -- ) 1156 4 vx-insn ;
+: VXOR ( vrt vra vrb -- ) 1220 4 vx-insn ;
+
+! 6.9.4 Vector Integer Rotate and Shift Instructions
+: VRLB ( vrt vra vrb -- ) 4 4 vx-insn ;
+: VRLH ( vrt vra vrb -- ) 68 4 vx-insn ;
+: VRLW ( vrt vra vrb -- ) 132 4 vx-insn ;
+: VSLB ( vrt vra vrb -- ) 260 4 vx-insn ;
+: VSLH ( vrt vra vrb -- ) 324 4 vx-insn ;
+: VSLW ( vrt vra vrb -- ) 388 4 vx-insn ;
+: VSRB ( vrt vra vrb -- ) 516 4 vx-insn ;
+: VSRH ( vrt vra vrb -- ) 580 4 vx-insn ;
+: VSRW ( vrt vra vrb -- ) 644 4 vx-insn ;
+: VSRAB ( vrt vra vrb -- ) 772 4 vx-insn ;
+: VSRAH ( vrt vra vrb -- ) 836 4 vx-insn ;
+: VSRAW ( vrt vra vrb -- ) 900 4 vx-insn ;
+
+! 6.10.1 Vector Floating-Point Arithmetic Instructions
+: VADDFP ( vrt vra vrb -- ) 10 4 vx-insn ;
+: VSUBFP ( vrt vra vrb -- ) 74 4 vx-insn ;
+: VMADDFP ( vrt vra vrb -- ) 46 4 vx-insn ;
+: VNMSUBFP ( vrt vra vrb -- ) 47 4 vx-insn ;
+
+! 6.10.2 Vector Floating-Point Maximum and Minimum Instructions
+: VMAXFP ( vrt vra vrb -- ) 1034 4 vx-insn ;
+: VMINFP ( vrt vra vrb -- ) 1098 4 vx-insn ;
+
+! 6.10.3 Vector Floating-Point Rounding and Conversion Instructions
+: VCTSXS ( vrt vrb uim -- ) swap 970 4 vx-insn ;
+: VCTUXS ( vrt vrb uim -- ) swap 906 4 vx-insn ;
+: VCFSX ( vrt vrb uim -- ) swap 842 4 vx-insn ;
+: VCFUX ( vrt vrb uim -- ) swap 778 4 vx-insn ;
+: VRFIM ( vrt vrb -- ) 0 swap 714 4 vx-insn ;
+: VRFIN ( vrt vrb -- ) 0 swap 522 4 vx-insn ;
+: VRFIP ( vrt vrb -- ) 0 swap 650 4 vx-insn ;
+: VRFIX ( vrt vrb -- ) 0 swap 586 4 vx-insn ;
+
+! 6.10.4 Vector Floating-Point Compare Instructions
+: VCMPBFP ( vrt vra vrb -- ) 0 966 4 vc-insn ;
+: VCMPBFP. ( vrt vra vrb -- ) 1 966 4 vc-insn ;
+: VCMPEQFP ( vrt vra vrb -- ) 0 198 4 vc-insn ;
+: VCMPEQFP. ( vrt vra vrb -- ) 1 198 4 vc-insn ;
+: VCMPGEFP ( vrt vra vrb -- ) 0 454 4 vc-insn ;
+: VCMPGEFP. ( vrt vra vrb -- ) 1 454 4 vc-insn ;
+: VCMPGTFP ( vrt vra vrb -- ) 0 710 4 vc-insn ;
+: VCMPGTFP. ( vrt vra vrb -- ) 1 710 4 vc-insn ;
+
+! 6.10.5 Vector Floating-Point Estimate Instructions
+: VEXPTEFP ( vrt vrb -- ) 0 swap 394 4 vx-insn ;
+: VLOGEFP ( vrt vrb -- ) 0 swap 458 4 vx-insn ;
+: VREFP ( vrt vrb -- ) 0 swap 266 4 vx-insn ;
+: VRSQRTEFP ( vrt vrb -- ) 0 swap 330 4 vx-insn ;
+
+! 6.10.6 Vector Status and Control Register Instructions
+: MTVSCR ( vrb -- ) [ 0 0 ] dip 1604 4 vx-insn ;
+: MFVSCR ( vrt -- ) 0 0 1540 4 vx-insn ;
+
+! 7.7 VSX Instruction Descriptions
+: LXSDX ( xt ra rb -- ) 588 31 xx1-insn ;
+: LXVD2X ( xt ra rb -- ) 844 31 xx1-insn ;
+: LXVDSX ( xt ra rb -- ) 332 31 xx1-insn ;
+: LXVW4X ( xt ra rb -- ) 780 31 xx1-insn ;
+: STXSDX ( xs ra rb -- ) 716 31 xx1-insn ;
+: STXVD2X ( xs ra rb -- ) 972 31 xx1-insn ;
+: STXVW4X ( xs ra rb -- ) 908 31 xx1-insn ;
+: XSABSDP ( xt xb -- ) 0 swap 345 60 xx2-insn ;
+: XSADDDP ( xt xa xb -- ) 32 60 xx3-insn ;
+: XSCMPODP ( bf xa xb -- ) [ 2 shift ] 2dip 43 60 xx3-insn ;
+: XSCMPUDP ( bf xa xb -- ) [ 2 shift ] 2dip 35 60 xx3-insn ;
+: XSCPSGNDP ( xt xa xb -- ) 176 60 xx3-insn ;
+: XSCVDPSP ( xt xb -- ) 0 swap 265 60 xx2-insn ;
+: XSCVDPSXDS ( xt xb -- ) 0 swap 344 60 xx2-insn ;
+: XSCVDPSXWS ( xt xb -- ) 0 swap 88 60 xx2-insn ;
+: XSCVDPUXDS ( xt xb -- ) 0 swap 328 60 xx2-insn ;
+: XSCVDPUXWS ( xt xb -- ) 0 swap 72 60 xx2-insn ;
+: XSCVSPDP ( xt xb -- ) 0 swap 329 60 xx2-insn ;
+: XSCVSXDDP ( xt xb -- ) 0 swap 376 60 xx2-insn ;
+: XSCUXDDP ( xt xb -- ) 0 swap 360 60 xx2-insn ;
+: XSDIVDP ( xt xa xb -- ) 56 60 xx3-insn ;
+: XSMADDADP ( xt xa xb -- ) 33 60 xx3-insn ;
+: XSMADDMDP ( xt xa xb -- ) 41 60 xx3-insn ;
+: XSMAXDP ( xt xa xb -- ) 160 60 xx3-insn ;
+: XSMINDP ( xt xa xb -- ) 168 60 xx3-insn ;
+: XSMSUBADP ( xt xa xb -- ) 49 60 xx3-insn ;
+: XSMSUBMDP ( xt xa xb -- ) 57 60 xx3-insn ;
+: XSMULDP ( xt xa xb -- ) 48 60 xx3-insn ;
+: XSNABSDP ( xt xb -- ) 0 swap 361 60 xx2-insn ;
+: XSNEGDP ( xt xb -- ) 0 swap 377 60 xx2-insn ;
+: XSNMADDADP ( xt xa xb -- ) 161 60 xx3-insn ;
+: XSNMADDMDP ( xt xa xb -- ) 169 60 xx3-insn ;
+: XSNMSUBADP ( xt xa xb -- ) 177 60 xx3-insn ;
+: XSNMSUBMDP ( xt xa xb -- ) 185 60 xx3-insn ;
+: XSRDPI ( xt xb -- ) 0 swap 73 60 xx2-insn ;
+: XSRDPIC ( xt xb -- ) 0 swap 107 60 xx2-insn ;
+: XSRDPIM ( xt xb -- ) 0 swap 121 60 xx2-insn ;
+: XSRDPIP ( xt xb -- ) 0 swap 105 60 xx2-insn ;
+: XSRDPIZ ( xt xb -- ) 0 swap 89 60 xx2-insn ;
+: XSREDP ( xt xb -- ) 0 swap 90 60 xx2-insn ;
+: XSRSQRTEDP ( xt xb -- ) 0 swap 74 60 xx2-insn ;
+: XSSQRTDP ( xt xb -- ) 0 swap 75 60 xx2-insn ;
+: XSSUBDP ( xt xa xb -- ) 40 60 xx3-insn ;
+: XSTDIVDP ( bf xa xb -- ) [ 2 shift ] 2dip 61 60 xx3-insn ;
+: XSTSQRTDP ( bf xb -- ) [ 2 shift ] dip 0 swap 106 60 xx2-insn ;
+: XVABSDP ( xt xb -- ) 0 swap 473 60 xx2-insn ;
+: XVABSSP ( xt xb -- ) 0 swap 409 60 xx2-insn ;
+: XVADDDP ( xt xa xb -- ) 96 60 xx3-insn ;
+: XVADDSP ( xt xa xb -- ) 64 60 xx3-insn ;
+: XVCMPEQDP ( xt xa xb -- ) 0 99 60 xx3-rc-insn ;
+: XVCMPEQDP. ( xt xa xb -- ) 1 99 60 xx3-rc-insn ;
+: XVCMPEQSP ( xt xa xb -- ) 0 67 60 xx3-rc-insn ;
+: XVCMPEQSP. ( xt xa xb -- ) 1 67 60 xx3-rc-insn ;
+: XVCMPGEDP ( xt xa xb -- ) 0 115 60 xx3-rc-insn ;
+: XVCMPGEDP. ( xt xa xb -- ) 1 115 60 xx3-rc-insn ;
+: XVCMPGESP ( xt xa xb -- ) 0 83 60 xx3-rc-insn ;
+: XVCMPGESP. ( xt xa xb -- ) 1 83 60 xx3-rc-insn ;
+: XVCMPGTDP ( xt xa xb -- ) 0 107 60 xx3-rc-insn ;
+: XVCMPGTDP. ( xt xa xb -- ) 1 107 60 xx3-rc-insn ;
+: XVCMPGTSP ( xt xa xb -- ) 0 75 60 xx3-rc-insn ;
+: XVCMPGTSP. ( xt xa xb -- ) 1 75 60 xx3-rc-insn ;
+: XVCPSGNDP ( xt xa xb -- ) 240 60 xx3-insn ;
+: XVCPSGNSP ( xt xa xb -- ) 208 60 xx3-insn ;
+: XVCVDPSP ( xt xb -- ) 0 swap 393 60 xx2-insn ;
+: XVCVDPSXDS ( xt xb -- ) 0 swap 472 60 xx2-insn ;
+: XVCVDPSXWS ( xt xb -- ) 0 swap 216 60 xx2-insn ;
+: XVCVDPUXDS ( xt xb -- ) 0 swap 456 60 xx2-insn ;
+: XVCVDPUXWS ( xt xb -- ) 0 swap 200 60 xx2-insn ;
+: XVCVSPDP ( xt xb -- ) 0 swap 457 60 xx2-insn ;
+: XVCVSPSXDS ( xt xb -- ) 0 swap 408 60 xx2-insn ;
+: XVCVSPSXWS ( xt xb -- ) 0 swap 152 60 xx2-insn ;
+: XVCVSPUXDS ( xt xb -- ) 0 swap 392 60 xx2-insn ;
+: XVCVSPUXWS ( xt xb -- ) 0 swap 136 60 xx2-insn ;
+: XVCVSXDDP ( xt xb -- ) 0 swap 504 60 xx2-insn ;
+: XVCVSXDSP ( xt xb -- ) 0 swap 440 60 xx2-insn ;
+: XVCVSXWDP ( xt xb -- ) 0 swap 248 60 xx2-insn ;
+: XVCVSXWSP ( xt xb -- ) 0 swap 184 60 xx2-insn ;
+: XVCVUXDDP ( xt xb -- ) 0 swap 488 60 xx2-insn ;
+: XVCVUXDSP ( xt xb -- ) 0 swap 424 60 xx2-insn ;
+: XVCVUXWDP ( xt xb -- ) 0 swap 232 60 xx2-insn ;
+: XVCVUXWSP ( xt xb -- ) 0 swap 168 60 xx2-insn ;
+: XVDIVDP ( xt xa xb -- ) 120 60 xx3-insn ;
+: XVDIVSP ( xt xa xb -- ) 88 60 xx3-insn ;
+: XVMADDADP ( xt xa xb -- ) 97 60 xx3-insn ;
+: XVMADDMDP ( xt xa xb -- ) 105 60 xx3-insn ;
+: XVMADDASP ( xt xa xb -- ) 65 60 xx3-insn ;
+: XVMADDMSP ( xt xa xb -- ) 73 60 xx3-insn ;
+: XVMAXDP ( xt xa xb -- ) 224 60 xx3-insn ;
+: XVMAXSP ( xt xa xb -- ) 192 60 xx3-insn ;
+: XVMINDP ( xt xa xb -- ) 232 60 xx3-insn ;
+: XVMINSP ( xt xa xb -- ) 200 60 xx3-insn ;
+: XVMSUBADP ( xt xa xb -- ) 113 60 xx3-insn ;
+: XVMSUBMDP ( xt xa xb -- ) 121 60 xx3-insn ;
+: XVMSUBASP ( xt xa xb -- ) 81 60 xx3-insn ;
+: XVMSUBMSP ( xt xa xb -- ) 89 60 xx3-insn ;
+: XVMULDP ( xt xa xb -- ) 112 60 xx3-insn ;
+: XVMULSP ( xt xa xb -- ) 80 60 xx3-insn ;
+: XVNABSDP ( xt xb -- ) 0 swap 489 60 xx2-insn ;
+: XVNABSSP ( xt xb -- ) 0 swap 425 60 xx2-insn ;
+: XVNEGDP ( xt xb -- ) 0 swap 505 60 xx2-insn ;
+: XVNEGSP ( xt xb -- ) 0 swap 441 60 xx2-insn ;
+: XVNMADDADP ( xt xa xb -- ) 225 60 xx3-insn ;
+: XVNMADDMDP ( xt xa xb -- ) 233 60 xx3-insn ;
+: XVNMADDASP ( xt xa xb -- ) 193 60 xx3-insn ;
+: XVNMADDMSP ( xt xa xb -- ) 201 60 xx3-insn ;
+: XVNMSUBADP ( xt xa xb -- ) 241 60 xx3-insn ;
+: XVNMSUBMDP ( xt xa xb -- ) 249 60 xx3-insn ;
+: XVNMSUBASP ( xt xa xb -- ) 209 60 xx3-insn ;
+: XVNMSUBMSP ( xt xa xb -- ) 217 60 xx3-insn ;
+: XVRDPI ( xt xb -- ) 0 swap 201 60 xx2-insn ;
+: XVRDPIC ( xt xb -- ) 0 swap 235 60 xx2-insn ;
+: XVRDPIM ( xt xb -- ) 0 swap 249 60 xx2-insn ;
+: XVRDPIP ( xt xb -- ) 0 swap 233 60 xx2-insn ;
+: XVRDPIZ ( xt xb -- ) 0 swap 217 60 xx2-insn ;
+: XVREDP ( xt xb -- ) 0 swap 218 60 xx2-insn ;
+: XVRESP ( xt xb -- ) 0 swap 154 60 xx2-insn ;
+: XVRSPI ( xt xb -- ) 0 swap 137 60 xx2-insn ;
+: XVRSPIC ( xt xb -- ) 0 swap 171 60 xx2-insn ;
+: XVRSPIM ( xt xb -- ) 0 swap 185 60 xx2-insn ;
+: XVRSPIP ( xt xb -- ) 0 swap 169 60 xx2-insn ;
+: XVRSPIZ ( xt xb -- ) 0 swap 153 60 xx2-insn ;
+: XVRSQRTEDP ( xt xb -- ) 0 swap 202 60 xx2-insn ;
+: XVRSQRTESP ( xt xb -- ) 0 swap 138 60 xx2-insn ;
+: XVSQRTDP ( xt xb -- ) 0 swap 203 60 xx2-insn ;
+: XVSQRTSP ( xt xb -- ) 0 swap 139 60 xx2-insn ;
+: XVSUBDP ( xt xb -- ) 0 swap 104 60 xx2-insn ;
+: XVSUBSP ( xt xb -- ) 0 swap 72 60 xx2-insn ;
+: XVTDIVDP ( bf xa xb -- ) [ 2 shift ] 2dip 125 60 xx3-insn ;
+: XVTDIVSP ( bf xa xb -- ) [ 2 shift ] 2dip 93 60 xx3-insn ;
+: XVTSQRTDP ( bf xa xb -- ) [ 2 shift ] 2dip 234 60 xx3-insn ;
+: XVTSQRTSP ( bf xa xb -- ) [ 2 shift ] 2dip 170 60 xx3-insn ;
+: XXLAND ( xt xa xb -- ) 130 60 xx3-insn ;
+: XXLANDC ( xt xa xb -- ) 138 60 xx3-insn ;
+: XXLNOR ( xt xa xb -- ) 162 60 xx3-insn ;
+: XXLOR ( xt xa xb -- ) 146 60 xx3-insn ;
+: XXLXOR ( xt xa xb -- ) 154 60 xx3-insn ;
+: XXMRGHW ( xt xa xb -- ) 18 60 xx3-insn ;
+: XXMRGLW ( xt xa xb -- ) 50 60 xx3-insn ;
+: XXPERMDI ( xt xa xb dm -- ) 0 swap 10 60 xx3-rc-dm-insn ;
+: XXSEL ( xt xa xb xc -- ) 3 60 xx4-insn ;
+: XXSLDWI ( xt xa xb sh -- ) 0 swap 2 60 xx3-rc-dm-insn ;
+: XVSPLTW ( xt xb uim -- ) swap 164 60 xx2-insn ;
+
+! 8.3.9 SPE Instruction Set
+: BRINC ( rt ra rb -- ) 527 4 evx-insn ;
+: EVABS ( rt ra -- ) 0 520 4 evx-insn ;
+: EVADDIW ( rt rb ui -- ) swap 514 4 evx-insn ;
+: EVADDSMIAAW ( rt ra -- ) 0 1225 4 evx-insn ;
+: EVADDSSIAAW ( rt ra -- ) 0 1217 4 evx-insn ;
+: EVADDUMIAAW ( rt ra -- ) 0 1224 4 evx-insn ;
+: EVADDUSIAWW ( rt ra -- ) 0 1216 4 evx-insn ;
+: EVADDW ( rt ra rb -- ) 512 4 evx-insn ;
+: EVAND ( rt ra rb -- ) 529 4 evx-insn ;
+: EVANDC ( rt ra rb -- ) 530 4 evx-insn ;
+: EVCMPEQ ( bf ra rb -- ) [ 2 shift ] 2dip 564 4 evx-insn ;
+: EVCMPGTS ( bf ra rb -- ) [ 2 shift ] 2dip 561 4 evx-insn ;
+: EVCMPGTU ( bf ra rb -- ) [ 2 shift ] 2dip 560 4 evx-insn ;
+: EVCMPLTS ( bf ra rb -- ) [ 2 shift ] 2dip 563 4 evx-insn ;
+: EVCMPLTU ( bf ra rb -- ) [ 2 shift ] 2dip 562 4 evx-insn ;
+: EVCNTLSW ( rt ra -- ) 0 526 4 evx-insn ;
+: EVCNTLZW ( rt ra -- ) 0 525 4 evx-insn ;
+: EVDIVWS ( rt ra rb -- ) 1222 4 evx-insn ;
+: EVDIVWU ( rt ra rb -- ) 1223 4 evx-insn ;
+: EVEQV ( rt ra rb -- ) 537 4 evx-insn ;
+: EVEXTSB ( rt ra -- ) 0 522 4 evx-insn ;
+: EVEXTSH ( rt ra -- ) 0 523 4 evx-insn ;
+: EVLDD ( rt ra d -- ) 769 4 evx-insn ;
+: EVLDDX ( rt ra rb -- ) 768 4 evx-insn ;
+: EVLDH ( rt ra d -- ) 773 4 evx-insn ;
+: EVLDHX ( rt ra rb -- ) 772 4 evx-insn ;
+: EVLDW ( rt ra d -- ) 771 4 evx-insn ;
+: EVLDWX ( rt ra rb -- ) 770 4 evx-insn ;
+: EVLHHESPLAT ( rt ra d -- ) 777 4 evx-insn ;
+: EVLHHESPLATX ( rt ra rb -- ) 776 4 evx-insn ;
+: EVLHHOSSPLAT ( rt ra d -- ) 783 4 evx-insn ;
+: EVLHHOSSPLATX ( rt ra rb -- ) 782 4 evx-insn ;
+: EVLHHOUSPLAT ( rt ra d -- ) 781 4 evx-insn ;
+: EVLHHOUSPLATX ( rt ra rb -- ) 780 4 evx-insn ;
+: EVLWHE ( rt ra d -- ) 785 4 evx-insn ;
+: EVLWHEX ( rt ra rb -- ) 784 4 evx-insn ;
+: EVLWHOS ( rt ra d -- ) 791 4 evx-insn ;
+: EVLWHOSX ( rt ra rb -- ) 790 4 evx-insn ;
+: EVLWHOU ( rt ra d -- ) 789 4 evx-insn ;
+: EVLWHOUX ( rt ra rb -- ) 788 4 evx-insn ;
+: EVLWHSPLAT ( rt ra d -- ) 797 4 evx-insn ;
+: EVLWHSPLATX ( rt ra rb -- ) 796 4 evx-insn ;
+: EVLWWSPLAT ( rt ra d -- ) 793 4 evx-insn ;
+: EVLWWSPLATX ( rt ra d -- ) 792 4 evx-insn ;
+: EVMERGEHI ( rt ra rb -- ) 556 4 evx-insn ;
+: EVMERGELO ( rt ra rb -- ) 557 4 evx-insn ;
+: EVMERGEHILO ( rt ra rb -- ) 558 4 evx-insn ;
+: EVMERGELOHI ( rt ra rb -- ) 559 4 evx-insn ;
+: EVMHEGSMFAA ( rt ra rb -- ) 1323 4 evx-insn ;
+: EVMHEGSMFAN ( rt ra rb -- ) 1451 4 evx-insn ;
+: EVMHEGSMIAA ( rt ra rb -- ) 1321 4 evx-insn ;
+: EVMHEGSMIAN ( rt ra rb -- ) 1449 4 evx-insn ;
+: EVMHEGUMIAA ( rt ra rb -- ) 1320 4 evx-insn ;
+: EVMHEGUMIAN ( rt ra rb -- ) 1448 4 evx-insn ;
+: EVMHESMF ( rt ra rb -- ) 1035 4 evx-insn ;
+: EVMHESMFA ( rt ra rb -- ) 1067 4 evx-insn ;
+: EVMHESMFAAW ( rt ra rb -- ) 1291 4 evx-insn ;
+: EVMHESMFANW ( rt ra rb -- ) 1419 4 evx-insn ;
+: EVMHESMI ( rt ra rb -- ) 1033 4 evx-insn ;
+: EVMHESMIA ( rt ra rb -- ) 1065 4 evx-insn ;
+: EVMHESMIAAW ( rt ra rb -- ) 1289 4 evx-insn ;
+: EVMHESMIANW ( rt ra rb -- ) 1417 4 evx-insn ;
+: EVMHESSF ( rt ra rb -- ) 1027 4 evx-insn ;
+: EVMHESSFA ( rt ra rb -- ) 1059 4 evx-insn ;
+: EVMHESSFAAW ( rt ra rb -- ) 1283 4 evx-insn ;
+: EVMHESSFANW ( rt ra rb -- ) 1411 4 evx-insn ;
+: EVMHESSIAAW ( rt ra rb -- ) 1281 4 evx-insn ;
+: EVMHESSIANW ( rt ra rb -- ) 1409 4 evx-insn ;
+: EVMHEUMI ( rt ra rb -- ) 1032 4 evx-insn ;
+: EVMHEUMIA ( rt ra rb -- ) 1064 4 evx-insn ;
+: EVMHEUMIAAW ( rt ra rb -- ) 1288 4 evx-insn ;
+: EVMHEUMIANW ( rt ra rb -- ) 1416 4 evx-insn ;
+: EVMHEUSIAAW ( rt ra rb -- ) 1280 4 evx-insn ;
+: EVMHEUSIANW ( rt ra rb -- ) 1408 4 evx-insn ;
+: EVMHOGSMFAA ( rt ra rb -- ) 1327 4 evx-insn ;
+: EVMHOGSMFAN ( rt ra rb -- ) 1455 4 evx-insn ;
+: EVMHOGSMIAA ( rt ra rb -- ) 1325 4 evx-insn ;
+: EVMHOGSMIAN ( rt ra rb -- ) 1453 4 evx-insn ;
+: EVMHOGUMIAA ( rt ra rb -- ) 1324 4 evx-insn ;
+: EVMHOGUMIAN ( rt ra rb -- ) 1452 4 evx-insn ;
+: EVMHOSMF ( rt ra rb -- ) 1039 4 evx-insn ;
+: EVMHOSMFA ( rt ra rb -- ) 1071 4 evx-insn ;
+: EVMHOSMFAAW ( rt ra rb -- ) 1295 4 evx-insn ;
+: EVMHOSMFANW ( rt ra rb -- ) 1423 4 evx-insn ;
+: EVMHOSMI ( rt ra rb -- ) 1037 4 evx-insn ;
+: EVMHOSMIA ( rt ra rb -- ) 1069 4 evx-insn ;
+: EVMHOSMIAAW ( rt ra rb -- ) 1293 4 evx-insn ;
+: EVMHOSMIANW ( rt ra rb -- ) 1421 4 evx-insn ;
+: EVMHOSSF ( rt ra rb -- ) 1031 4 evx-insn ;
+: EVMHOSSFA ( rt ra rb -- ) 1063 4 evx-insn ;
+: EVMHOSSFAAW ( rt ra rb -- ) 1287 4 evx-insn ;
+: EVMHOSSFANW ( rt ra rb -- ) 1415 4 evx-insn ;
+: EVMHOSSIAAW ( rt ra rb -- ) 1285 4 evx-insn ;
+: EVMHOSSIANW ( rt ra rb -- ) 1413 4 evx-insn ;
+: EVMHOUMI ( rt ra rb -- ) 1036 4 evx-insn ;
+: EVMHOUMIA ( rt ra rb -- ) 1068 4 evx-insn ;
+: EVMHOUMIAAW ( rt ra rb -- ) 1292 4 evx-insn ;
+: EVMHOUMIANW ( rt ra rb -- ) 1420 4 evx-insn ;
+: EVMHOUSIAAW ( rt ra rb -- ) 1284 4 evx-insn ;
+: EVMHOUSIANW ( rt ra rb -- ) 1412 4 evx-insn ;
+: EVMRA ( rt ra rb -- ) 1220 4 evx-insn ;
+: EVMWHSMF ( rt ra rb -- ) 1103 4 evx-insn ;
+: EVMWHSMFA ( rt ra rb -- ) 1135 4 evx-insn ;
+: EVMWHSMI ( rt ra rb -- ) 1101 4 evx-insn ;
+: EVMWHSMIA ( rt ra rb -- ) 1133 4 evx-insn ;
+: EVMWHSSF ( rt ra rb -- ) 1095 4 evx-insn ;
+: EVMWHSSFA ( rt ra rb -- ) 1127 4 evx-insn ;
+: EVMWHUMI ( rt ra rb -- ) 1100 4 evx-insn ;
+: EVMWHUMIA ( rt ra rb -- ) 1132 4 evx-insn ;
+: EVMWLSMIAAW ( rt ra rb -- ) 1353 4 evx-insn ;
+: EVMWLSMIANW ( rt ra rb -- ) 1481 4 evx-insn ;
+: EVMWLSSIAAW ( rt ra rb -- ) 1345 4 evx-insn ;
+: EVMWLSSIANW ( rt ra rb -- ) 1473 4 evx-insn ;
+: EVMWLUMI ( rt ra rb -- ) 1096 4 evx-insn ;
+: EVMWLUMIA ( rt ra rb -- ) 1128 4 evx-insn ;
+: EVMWLUMIAAW ( rt ra rb -- ) 1352 4 evx-insn ;
+: EVMWLUMIANW ( rt ra rb -- ) 1480 4 evx-insn ;
+: EVMWLUSIAAW ( rt ra rb -- ) 1344 4 evx-insn ;
+: EVMWLUSIANW ( rt ra rb -- ) 1472 4 evx-insn ;
+: EVMWSMF ( rt ra rb -- ) 1115 4 evx-insn ;
+: EVMWSMFA ( rt ra rb -- ) 1147 4 evx-insn ;
+: EVMWSMFAA ( rt ra rb -- ) 1371 4 evx-insn ;
+: EVMWSMFAN ( rt ra rb -- ) 1499 4 evx-insn ;
+: EVMWSMI ( rt ra rb -- ) 1113 4 evx-insn ;
+: EVMWSMIA ( rt ra rb -- ) 1145 4 evx-insn ;
+: EVMWSMIAA ( rt ra rb -- ) 1369 4 evx-insn ;
+: EVMWSMIAN ( rt ra rb -- ) 1497 4 evx-insn ;
+: EVMWSSF ( rt ra rb -- ) 1107 4 evx-insn ;
+: EVMWSSFA ( rt ra rb -- ) 1139 4 evx-insn ;
+: EVMWSSFAA ( rt ra rb -- ) 1363 4 evx-insn ;
+: EVMWSSFAN ( rt ra rb -- ) 1491 4 evx-insn ;
+: EVMWUMI ( rt ra rb -- ) 1112 4 evx-insn ;
+: EVMWUMIA ( rt ra rb -- ) 1144 4 evx-insn ;
+: EVMWUMIAA ( rt ra rb -- ) 1368 4 evx-insn ;
+: EVMWUMIAN ( rt ra rb -- ) 1496 4 evx-insn ;
+: EVNAND ( rt ra rb -- ) 542 4 evx-insn ;
+: EVNEG ( rt ra rb -- ) 521 4 evx-insn ;
+: EVNOR ( rt ra rb -- ) 536 4 evx-insn ;
+: EVOR ( rt ra rb -- ) 535 4 evx-insn ;
+: EVORC ( rt ra rb -- ) 539 4 evx-insn ;
+: EVRLW ( rt ra rb -- ) 552 4 evx-insn ;
+: EVRLWI ( rt ra rb -- ) 554 4 evx-insn ;
+: EVRNDW ( rt ra rb -- ) 524 4 evx-insn ;
+: EVSEL ( rt ra rb -- ) 79 4 evx-insn ;
+: EVSLW ( rt ra rb -- ) 548 4 evx-insn ;
+: EVSLWI ( rt ra rb -- ) 550 4 evx-insn ;
+: EVSPLATFI ( rt ra rb -- ) 555 4 evx-insn ;
+: EVSPLATI ( rt ra rb -- ) 553 4 evx-insn ;
+: EVSRWIS ( rt ra rb -- ) 547 4 evx-insn ;
+: EVSRWIU ( rt ra rb -- ) 546 4 evx-insn ;
+: EVSRWS ( rt ra rb -- ) 545 4 evx-insn ;
+: EVSRWU ( rt ra rb -- ) 544 4 evx-insn ;
+: EVSTDD ( rt ra d -- ) 801 4 evx-insn ;
+: EVSTDDX ( rt ra rb -- ) 800 4 evx-insn ;
+: EVSTDH ( rt ra d -- ) 805 4 evx-insn ;
+: EVSTDHX ( rt ra rb -- ) 804 4 evx-insn ;
+: EVSTDW ( rt ra d -- ) 803 4 evx-insn ;
+: EVSTDWX ( rt ra rb -- ) 802 4 evx-insn ;
+: EVSTWHE ( rt ra d -- ) 817 4 evx-insn ;
+: EVSTWHEX ( rt ra rb -- ) 816 4 evx-insn ;
+: EVSTWHO ( rt ra d -- ) 821 4 evx-insn ;
+: EVSTWHOX ( rt ra rb -- ) 820 4 evx-insn ;
+: EVSTWWE ( rt ra d -- ) 825 4 evx-insn ;
+: EVSTWWEX ( rt ra rb -- ) 824 4 evx-insn ;
+: EVSTWWO ( rt ra d -- ) 829 4 evx-insn ;
+: EVSTWWOX ( rt ra rb -- ) 828 4 evx-insn ;
+: EVSUBFSMIAAW ( rt ra -- ) 0 1227 4 evx-insn ;
+: EVSUBFSSIAAW ( rt ra -- ) 0 1219 4 evx-insn ;
+: EVSUBFUMIAAW ( rt ra -- ) 0 1226 4 evx-insn ;
+: EVSUBFUSIAAW ( rt ra -- ) 0 1218 4 evx-insn ;
+: EVSUBFW ( rt ra rb -- ) 516 4 evx-insn ;
+: EVSUBIFW ( rt ui rb -- ) 518 4 evx-insn ;
+: EVXOR ( rt ra rb -- ) 534 4 evx-insn ;
+
+! 9.3.2 SPE Embedded Float Vector Insturctions
+: EVFSABS ( rt ra -- ) 0 644 4 evx-insn ;
+: EVFSNABS ( rt ra -- ) 0 645 4 evx-insn ;
+: EVFSNEG ( rt ra -- ) 0 646 4 evx-insn ;
+: EVFSADD ( rt ra rb -- ) 640 4 evx-insn ;
+: EVFSSUB ( rt ra rb -- ) 641 4 evx-insn ;
+: EVFSMUL ( rt ra rb -- ) 648 4 evx-insn ;
+: EVFSDIV ( rt ra rb -- ) 649 4 evx-insn ;
+: EVFSCMPGT ( bf ra rb -- ) [ 2 shift ] 2dip 652 4 evx-insn ;
+: EVFSCMPLT ( bf ra rb -- ) [ 2 shift ] 2dip 653 4 evx-insn ;
+: EVFSCMPEQ ( bf ra rb -- ) [ 2 shift ] 2dip 654 4 evx-insn ;
+: EVFSTSTGT ( bf ra rb -- ) [ 2 shift ] 2dip 668 4 evx-insn ;
+: EVFSTSTLT ( bf ra rb -- ) [ 2 shift ] 2dip 669 4 evx-insn ;
+: EVFSTSTEQ ( bf ra rb -- ) [ 2 shift ] 2dip 670 4 evx-insn ;
+: EVFSCFSI ( rt rb -- ) 0 swap 657 4 evx-insn ;
+: EVFSCFUI ( rt rb -- ) 0 swap 656 4 evx-insn ;
+: EVFSCFSF ( rt rb -- ) 0 swap 659 4 evx-insn ;
+: EVFSCFUF ( rt rb -- ) 0 swap 658 4 evx-insn ;
+: EVFSCTSI ( rt rb -- ) 0 swap 661 4 evx-insn ;
+: EVFSCTSIZ ( rt rb -- ) 0 swap 666 4 evx-insn ;
+: EVFSCTUI ( rt rb -- ) 0 swap 660 4 evx-insn ;
+: EVFSCTUIZ ( rt rb -- ) 0 swap 664 4 evx-insn ;
+: EVFSCTSF ( rt rb -- ) 0 swap 663 4 evx-insn ;
+: EVFSCTUF ( rt rb -- ) 0 swap 662 4 evx-insn ;
+
+! 9.3.3 SPE Embedded Float Scalar Single Instructions
+: EFSABS ( rt ra -- ) 0 708 4 evx-insn ;
+: EFSNABS ( rt ra -- ) 0 709 4 evx-insn ;
+: EFSNEG ( rt ra -- ) 0 710 4 evx-insn ;
+: EFSADD ( rt ra rb -- ) 704 4 evx-insn ;
+: EFSSUB ( rt ra rb -- ) 705 4 evx-insn ;
+: EFSMUL ( rt ra rb -- ) 712 4 evx-insn ;
+: EFSDIV ( rt ra rb -- ) 713 4 evx-insn ;
+: EFSCMPGT ( bf ra rb -- ) [ 2 shift ] 2dip 716 4 evx-insn ;
+: EFSCMPLT ( bf ra rb -- ) [ 2 shift ] 2dip 717 4 evx-insn ;
+: EFSCMPEQ ( bf ra rb -- ) [ 2 shift ] 2dip 718 4 evx-insn ;
+: EFSTSTGT ( bf ra rb -- ) [ 2 shift ] 2dip 732 4 evx-insn ;
+: EFSTSTLT ( bf ra rb -- ) [ 2 shift ] 2dip 733 4 evx-insn ;
+: EFSTSTEQ ( bf ra rb -- ) [ 2 shift ] 2dip 734 4 evx-insn ;
+: EFSCFSI ( rt rb -- ) 0 swap 721 4 evx-insn ;
+: EFSCFUI ( rt rb -- ) 0 swap 720 4 evx-insn ;
+: EFSCFSF ( rt rb -- ) 0 swap 723 4 evx-insn ;
+: EFSCFUF ( rt rb -- ) 0 swap 722 4 evx-insn ;
+: EFSCTSI ( rt rb -- ) 0 swap 725 4 evx-insn ;
+: EFSCTUI ( rt rb -- ) 0 swap 724 4 evx-insn ;
+: EFSCTSIZ ( rt rb -- ) 0 swap 730 4 evx-insn ;
+: EFSCTUIZ ( rt rb -- ) 0 swap 728 4 evx-insn ;
+: EFSCTSF ( rt rb -- ) 0 swap 727 4 evx-insn ;
+: EFSCTUF ( rt rb -- ) 0 swap 726 4 evx-insn ;
+
+! 9.3.4 SPE Embedded Float Scalar Double Instructions
+: EFDABS ( rt ra -- ) 0 740 4 evx-insn ;
+: EFDNABS ( rt ra -- ) 0 741 4 evx-insn ;
+: EFDNEG ( rt ra -- ) 0 742 4 evx-insn ;
+: EFDADD ( rt ra rb -- ) 736 4 evx-insn ;
+: EFDSUB ( rt ra rb -- ) 737 4 evx-insn ;
+: EFDMUL ( rt ra rb -- ) 744 4 evx-insn ;
+: EFDDIV ( rt ra rb -- ) 745 4 evx-insn ;
+: EFDCMPGT ( bf ra rb -- ) [ 2 shift ] 2dip 748 4 evx-insn ;
+: EFDCMPLT ( bf ra rb -- ) [ 2 shift ] 2dip 749 4 evx-insn ;
+: EFDCMPEQ ( bf ra rb -- ) [ 2 shift ] 2dip 750 4 evx-insn ;
+: EFDTSTGT ( bf ra rb -- ) [ 2 shift ] 2dip 764 4 evx-insn ;
+: EFDTSTLT ( bf ra rb -- ) [ 2 shift ] 2dip 765 4 evx-insn ;
+: EFDTSTEQ ( bf ra rb -- ) [ 2 shift ] 2dip 766 4 evx-insn ;
+: EFDCFSI ( rt rb -- ) 0 swap 753 4 evx-insn ;
+: EFDCFUI ( rt rb -- ) 0 swap 752 4 evx-insn ;
+: EFDCFSID ( rt rb -- ) 0 swap 739 4 evx-insn ;
+: EFDCFUID ( rt rb -- ) 0 swap 738 4 evx-insn ;
+: EFDCFSF ( rt rb -- ) 0 swap 755 4 evx-insn ;
+: EFDCTSI ( rt rb -- ) 0 swap 757 4 evx-insn ;
+: EFDCFUF ( rt rb -- ) 0 swap 754 4 evx-insn ;
+: EFDCTUI ( rt rb -- ) 0 swap 756 4 evx-insn ;
+: EFDCTSIDZ ( rt rb -- ) 0 swap 747 4 evx-insn ;
+: EFDCTUIDZ ( rt rb -- ) 0 swap 746 4 evx-insn ;
+: EFDCTSIZ ( rt rb -- ) 0 swap 762 4 evx-insn ;
+: EFDCTUIZ ( rt rb -- ) 0 swap 760 4 evx-insn ;
+: EFDCTSF ( rt rb -- ) 0 swap 759 4 evx-insn ;
+: EFDCTUF ( rt rb -- ) 0 swap 758 4 evx-insn ;
+: EFDCFS ( rt rb -- ) 0 swap 751 4 evx-insn ;
+: EFSCFD ( rt rb -- ) 0 swap 719 4 evx-insn ;
+
+! 10.0 Legacy Move Assist Instruction
+: DLMZB ( ra rs rb -- ) [ swap ] dip 0 78 31 x-insn ; deprecated
+: DLMZB. ( ra rs rb -- ) [ swap ] dip 1 78 31 x-insn ; deprecated
+
+! 11.0 Legacy Integer Multiply-Accumulate Instructions
+: MACCHW ( rt ra rb -- ) 0 172 0 4 xo-insn ; deprecated
+: MACCHW. ( rt ra rb -- ) 0 172 1 4 xo-insn ; deprecated
+: MACCHWO ( rt ra rb -- ) 1 172 0 4 xo-insn ; deprecated
+: MACCHWO. ( rt ra rb -- ) 1 172 1 4 xo-insn ; deprecated
+: MACCHWS ( rt ra rb -- ) 0 236 0 4 xo-insn ; deprecated
+: MACCHWS. ( rt ra rb -- ) 0 236 1 4 xo-insn ; deprecated
+: MACCHWSO ( rt ra rb -- ) 1 236 0 4 xo-insn ; deprecated
+: MACCHWSO. ( rt ra rb -- ) 1 236 1 4 xo-insn ; deprecated
+: MACCHWU ( rt ra rb -- ) 0 140 0 4 xo-insn ; deprecated
+: MACCHWU. ( rt ra rb -- ) 0 140 1 4 xo-insn ; deprecated
+: MACCHWUO ( rt ra rb -- ) 1 140 0 4 xo-insn ; deprecated
+: MACCHWUO. ( rt ra rb -- ) 1 140 1 4 xo-insn ; deprecated
+: MACCHWSU ( rt ra rb -- ) 0 204 0 4 xo-insn ; deprecated
+: MACCHWSU. ( rt ra rb -- ) 0 204 1 4 xo-insn ; deprecated
+: MACCHWSUO ( rt ra rb -- ) 1 204 0 4 xo-insn ; deprecated
+: MACCHWSUO. ( rt ra rb -- ) 1 204 1 4 xo-insn ; deprecated
+: MACHHW ( rt ra rb -- ) 0 44 0 4 xo-insn ; deprecated
+: MACHHW. ( rt ra rb -- ) 0 44 1 4 xo-insn ; deprecated
+: MACHHWO ( rt ra rb -- ) 1 44 0 4 xo-insn ; deprecated
+: MACHHWO. ( rt ra rb -- ) 1 44 1 4 xo-insn ; deprecated
+: MACHHWS ( rt ra rb -- ) 0 108 0 4 xo-insn ; deprecated
+: MACHHWS. ( rt ra rb -- ) 0 108 1 4 xo-insn ; deprecated
+: MACHHWSO ( rt ra rb -- ) 1 108 0 4 xo-insn ; deprecated
+: MACHHWSO. ( rt ra rb -- ) 1 108 1 4 xo-insn ; deprecated
+: MACHHWU ( rt ra rb -- ) 0 12 0 4 xo-insn ; deprecated
+: MACHHWU. ( rt ra rb -- ) 0 12 1 4 xo-insn ; deprecated
+: MACHHWUO ( rt ra rb -- ) 1 12 0 4 xo-insn ; deprecated
+: MACHHWUO. ( rt ra rb -- ) 1 12 1 4 xo-insn ; deprecated
+: MACHHWSU ( rt ra rb -- ) 0 76 0 4 xo-insn ; deprecated
+: MACHHWSU. ( rt ra rb -- ) 0 76 1 4 xo-insn ; deprecated
+: MACHHWSUO ( rt ra rb -- ) 1 76 0 4 xo-insn ; deprecated
+: MACHHWSUO. ( rt ra rb -- ) 1 76 1 4 xo-insn ; deprecated
+: MACLHW ( rt ra rb -- ) 0 428 0 4 xo-insn ; deprecated
+: MACLHW. ( rt ra rb -- ) 0 428 1 4 xo-insn ; deprecated
+: MACLHWO ( rt ra rb -- ) 1 428 0 4 xo-insn ; deprecated
+: MACLHWO. ( rt ra rb -- ) 1 428 1 4 xo-insn ; deprecated
+: MACLHWS ( rt ra rb -- ) 0 492 0 4 xo-insn ; deprecated
+: MACLHWS. ( rt ra rb -- ) 0 492 1 4 xo-insn ; deprecated
+: MACLHWSO ( rt ra rb -- ) 1 492 0 4 xo-insn ; deprecated
+: MACLHWSO. ( rt ra rb -- ) 1 492 1 4 xo-insn ; deprecated
+: MACLHWU ( rt ra rb -- ) 0 396 0 4 xo-insn ; deprecated
+: MACLHWU. ( rt ra rb -- ) 0 396 1 4 xo-insn ; deprecated
+: MACLHWUO ( rt ra rb -- ) 1 396 0 4 xo-insn ; deprecated
+: MACLHWUO. ( rt ra rb -- ) 1 396 1 4 xo-insn ; deprecated
+: MACLHWSU ( rt ra rb -- ) 0 460 0 4 xo-insn ; deprecated
+: MACLHWSU. ( rt ra rb -- ) 0 460 1 4 xo-insn ; deprecated
+: MACLHWSUO ( rt ra rb -- ) 1 460 0 4 xo-insn ; deprecated
+: MACLHWSUO. ( rt ra rb -- ) 1 460 1 4 xo-insn ; deprecated
+: MULCHW ( rt ra rb -- ) 168 0 4 x-insn ; deprecated
+: MULCHW. ( rt ra rb -- ) 168 1 4 x-insn ; deprecated
+: MULCHWU ( rt ra rb -- ) 136 0 4 x-insn ; deprecated
+: MULCHWU. ( rt ra rb -- ) 136 1 4 x-insn ; deprecated
+: MULHHW ( rt ra rb -- ) 40 0 4 x-insn ; deprecated
+: MULHHW. ( rt ra rb -- ) 40 1 4 x-insn ; deprecated
+: MULHHWU ( rt ra rb -- ) 8 0 4 x-insn ; deprecated
+: MULHHWU. ( rt ra rb -- ) 8 1 4 x-insn ; deprecated
+: MULLHW ( rt ra rb -- ) 424 0 4 x-insn ; deprecated
+: MULLHW. ( rt ra rb -- ) 424 1 4 x-insn ; deprecated
+: MULLHWU ( rt ra rb -- ) 392 0 4 x-insn ; deprecated
+: MULLHWU. ( rt ra rb -- ) 392 1 4 x-insn ; deprecated
+: NMACCHW ( rt ra rb -- ) 0 174 0 4 xo-insn ; deprecated
+: NMACCHW. ( rt ra rb -- ) 0 174 1 4 xo-insn ; deprecated
+: NMACCHWO ( rt ra rb -- ) 1 174 0 4 xo-insn ; deprecated
+: NMACCHWO. ( rt ra rb -- ) 1 174 1 4 xo-insn ; deprecated
+: NMACCHWS ( rt ra rb -- ) 0 238 0 4 xo-insn ; deprecated
+: NMACCHWS. ( rt ra rb -- ) 0 238 1 4 xo-insn ; deprecated
+: NMACCHWSO ( rt ra rb -- ) 1 238 0 4 xo-insn ; deprecated
+: NMACCHWSO. ( rt ra rb -- ) 1 238 1 4 xo-insn ; deprecated
+: NMACHHW ( rt ra rb -- ) 0 46 0 4 xo-insn ; deprecated
+: NMACHHW. ( rt ra rb -- ) 0 46 1 4 xo-insn ; deprecated
+: NMACHHWO ( rt ra rb -- ) 1 46 0 4 xo-insn ; deprecated
+: NMACHHWO. ( rt ra rb -- ) 1 46 1 4 xo-insn ; deprecated
+: NMACHHWS ( rt ra rb -- ) 0 110 0 4 xo-insn ; deprecated
+: NMACHHWS. ( rt ra rb -- ) 0 110 1 4 xo-insn ; deprecated
+: NMACHHWSO ( rt ra rb -- ) 1 110 0 4 xo-insn ; deprecated
+: NMACHHWSO. ( rt ra rb -- ) 1 110 1 4 xo-insn ; deprecated
+: NMACHLW ( rt ra rb -- ) 0 430 0 4 xo-insn ; deprecated
+: NMACHLW. ( rt ra rb -- ) 0 430 1 4 xo-insn ; deprecated
+: NMACHLWO ( rt ra rb -- ) 1 430 0 4 xo-insn ; deprecated
+: NMACHLWO. ( rt ra rb -- ) 1 430 1 4 xo-insn ; deprecated
+: NMACHLWS ( rt ra rb -- ) 0 494 0 4 xo-insn ; deprecated
+: NMACHLWS. ( rt ra rb -- ) 0 494 1 4 xo-insn ; deprecated
+: NMACHLWSO ( rt ra rb -- ) 1 494 0 4 xo-insn ; deprecated
+: NMACHLWSO. ( rt ra rb -- ) 1 494 1 4 xo-insn ; deprecated
+
+! E.2.2 Simple Branch Mnemonics
+: BLR ( -- ) HEX: 14 0 0 BCLR ;
+: BCTR ( -- ) HEX: 14 0 0 BCCTR ;
+: BLRL ( -- ) HEX: 14 0 0 BCLRL ;
+: BCTRL ( -- ) HEX: 14 0 0 BCCTRL ;
+: BT ( bi target_addr -- ) [ HEX: C ] 2dip BC ;
+: BTA ( bi target_addr -- ) [ HEX: C ] 2dip BCA ;
+: BTLR ( bi target_addr -- ) [ HEX: C ] 2dip BCLR ;
+: BTCTR ( bi target_addr -- ) [ HEX: C ] 2dip BCCTR ;
+: BTL ( bi target_addr -- ) [ HEX: C ] 2dip BCL ;
+: BTLA ( bi target_addr -- ) [ HEX: C ] 2dip BCLA ;
+: BTLRL ( bi target_addr -- ) [ HEX: C ] 2dip BCLRL ;
+: BTCTRL ( bi target_addr -- ) [ HEX: C ] 2dip BCCTRL ;
+: BF ( bi target_addr -- ) [ HEX: 4 ] 2dip BC ;
+: BFA ( bi target_addr -- ) [ HEX: 4 ] 2dip BCA ;
+: BFLR ( bi target_addr -- ) [ HEX: 4 ] 2dip BCLR ;
+: BFCTR ( bi target_addr -- ) [ HEX: 4 ] 2dip BCCTR ;
+: BFL ( bi target_addr -- ) [ HEX: 4 ] 2dip BCL ;
+: BFLA ( bi target_addr -- ) [ HEX: 4 ] 2dip BCLA ;
+: BFLRL ( bi target_addr -- ) [ HEX: 4 ] 2dip BCLRL ;
+: BFCTRL ( bi target_addr -- ) [ HEX: 4 ] 2dip BCCTRL ;
+: BDNZ ( target_addr -- ) [ HEX: 10 0 ] dip BC ;
+: BDNZA ( target_addr -- ) [ HEX: 10 0 ] dip BCA ;
+: BDNZLR ( target_addr -- ) [ HEX: 10 0 ] dip BCLR ;
+: BDNZL ( target_addr -- ) [ HEX: 10 0 ] dip BCL ;
+: BDNZLA ( target_addr -- ) [ HEX: 10 0 ] dip BCLA ;
+: BDNZLRL ( target_addr -- ) [ HEX: 10 0 ] dip BCLRL ;
+: BDNZT ( bi target_addr -- ) [ HEX: 8 ] 2dip BC ;
+: BDNZTA ( bi target_addr -- ) [ HEX: 8 ] 2dip BCA ;
+: BDNZTLR ( bi target_addr -- ) [ HEX: 8 ] 2dip BCLR ;
+: BDNZTL ( bi target_addr -- ) [ HEX: 8 ] 2dip BCL ;
+: BDNZTLA ( bi target_addr -- ) [ HEX: 8 ] 2dip BCLA ;
+: BDNZTLRL ( bi target_addr -- ) [ HEX: 8 ] 2dip BCLRL ;
+: BDNZF ( bi target_addr -- ) [ HEX: 0 ] 2dip BC ;
+: BDNZFA ( bi target_addr -- ) [ HEX: 0 ] 2dip BCA ;
+: BDNZFLR ( bi target_addr -- ) [ HEX: 0 ] 2dip BCLR ;
+: BDNZFL ( bi target_addr -- ) [ HEX: 0 ] 2dip BCL ;
+: BDNZFLA ( bi target_addr -- ) [ HEX: 0 ] 2dip BCLA ;
+: BDNZFLRL ( bi target_addr -- ) [ HEX: 0 ] 2dip BCLRL ;
+: BDZ ( target_addr -- ) [ HEX: 12 0 ] dip BC ;
+: BDZA ( target_addr -- ) [ HEX: 12 0 ] dip BCA ;
+: BDZLR ( target_addr -- ) [ HEX: 12 0 ] dip BCLR ;
+: BDZL ( target_addr -- ) [ HEX: 12 0 ] dip BCL ;
+: BDZLA ( target_addr -- ) [ HEX: 12 0 ] dip BCLA ;
+: BDZLRL ( target_addr -- ) [ HEX: 12 0 ] dip BCLRL ;
+: BDZT ( bi target_addr -- ) [ HEX: A ] 2dip BC ;
+: BDZTA ( bi target_addr -- ) [ HEX: A ] 2dip BCA ;
+: BDZTLR ( bi target_addr -- ) [ HEX: A ] 2dip BCLR ;
+: BDZTL ( bi target_addr -- ) [ HEX: A ] 2dip BCL ;
+: BDZTLA ( bi target_addr -- ) [ HEX: A ] 2dip BCLA ;
+: BDZTLRL ( bi target_addr -- ) [ HEX: A ] 2dip BCLRL ;
+: BDZF ( bi target_addr -- ) [ HEX: 2 ] 2dip BC ;
+: BDZFA ( bi target_addr -- ) [ HEX: 2 ] 2dip BCA ;
+: BDZFLR ( bi target_addr -- ) [ HEX: 2 ] 2dip BCLR ;
+: BDZFL ( bi target_addr -- ) [ HEX: 2 ] 2dip BCL ;
+: BDZFLA ( bi target_addr -- ) [ HEX: 2 ] 2dip BCLA ;
+: BDZFLRL ( bi target_addr -- ) [ HEX: 2 ] 2dip BCLRL ;
+
+! E.2.3 Branch Mnemonics Incorporating Conditions
+: BLT ( cr target_addr -- ) [ 4 * 0 + ] dip [ 12 ] 2dip BC ;
+: BLTA ( cr target_addr -- ) [ 4 * 0 + ] dip [ 12 ] 2dip BCA ;
+: BLTLR ( cr target_addr -- ) [ 4 * 0 + ] dip [ 12 ] 2dip BCLR ;
+: BLTCTR ( cr target_addr -- ) [ 4 * 0 + ] dip [ 12 ] 2dip BCCTR ;
+: BLTL ( cr target_addr -- ) [ 4 * 0 + ] dip [ 12 ] 2dip BCL ;
+: BLTLA ( cr target_addr -- ) [ 4 * 0 + ] dip [ 12 ] 2dip BCLA ;
+: BLTLRL ( cr target_addr -- ) [ 4 * 0 + ] dip [ 12 ] 2dip BCLRL ;
+: BLTCTRL ( cr target_addr -- ) [ 4 * 0 + ] dip [ 12 ] 2dip BCCTRL ;
+: BGT ( cr target_addr -- ) [ 4 * 1 + ] dip [ 12 ] 2dip BC ;
+: BGTA ( cr target_addr -- ) [ 4 * 1 + ] dip [ 12 ] 2dip BCA ;
+: BGTLR ( cr target_addr -- ) [ 4 * 1 + ] dip [ 12 ] 2dip BCLR ;
+: BGTCTR ( cr target_addr -- ) [ 4 * 1 + ] dip [ 12 ] 2dip BCCTR ;
+: BGTL ( cr target_addr -- ) [ 4 * 1 + ] dip [ 12 ] 2dip BCL ;
+: BGTLA ( cr target_addr -- ) [ 4 * 1 + ] dip [ 12 ] 2dip BCLA ;
+: BGTLRL ( cr target_addr -- ) [ 4 * 1 + ] dip [ 12 ] 2dip BCLRL ;
+: BGTCTRL ( cr target_addr -- ) [ 4 * 1 + ] dip [ 12 ] 2dip BCCTRL ;
+: BEQ ( cr target_addr -- ) [ 4 * 2 + ] dip [ 12 ] 2dip BC ;
+: BEQA ( cr target_addr -- ) [ 4 * 2 + ] dip [ 12 ] 2dip BCA ;
+: BEQLR ( cr target_addr -- ) [ 4 * 2 + ] dip [ 12 ] 2dip BCLR ;
+: BEQCTR ( cr target_addr -- ) [ 4 * 2 + ] dip [ 12 ] 2dip BCCTR ;
+: BEQL ( cr target_addr -- ) [ 4 * 2 + ] dip [ 12 ] 2dip BCL ;
+: BEQLA ( cr target_addr -- ) [ 4 * 2 + ] dip [ 12 ] 2dip BCLA ;
+: BEQLRL ( cr target_addr -- ) [ 4 * 2 + ] dip [ 12 ] 2dip BCLRL ;
+: BEQCTRL ( cr target_addr -- ) [ 4 * 2 + ] dip [ 12 ] 2dip BCCTRL ;
+: BSO ( cr target_addr -- ) [ 4 * 3 + ] dip [ 12 ] 2dip BC ;
+: BSOA ( cr target_addr -- ) [ 4 * 3 + ] dip [ 12 ] 2dip BCA ;
+: BSOLR ( cr target_addr -- ) [ 4 * 3 + ] dip [ 12 ] 2dip BCLR ;
+: BSOCTR ( cr target_addr -- ) [ 4 * 3 + ] dip [ 12 ] 2dip BCCTR ;
+: BSOL ( cr target_addr -- ) [ 4 * 3 + ] dip [ 12 ] 2dip BCL ;
+: BSOLA ( cr target_addr -- ) [ 4 * 3 + ] dip [ 12 ] 2dip BCLA ;
+: BSOLRL ( cr target_addr -- ) [ 4 * 3 + ] dip [ 12 ] 2dip BCLRL ;
+: BSOCTRL ( cr target_addr -- ) [ 4 * 3 + ] dip [ 12 ] 2dip BCCTRL ;
+: BNL ( cr target_addr -- ) [ 4 * 0 + ] dip [ 4 ] 2dip BC ;
+: BNLA ( cr target_addr -- ) [ 4 * 0 + ] dip [ 4 ] 2dip BCA ;
+: BNLLR ( cr target_addr -- ) [ 4 * 0 + ] dip [ 4 ] 2dip BCLR ;
+: BNLCTR ( cr target_addr -- ) [ 4 * 0 + ] dip [ 4 ] 2dip BCCTR ;
+: BNLL ( cr target_addr -- ) [ 4 * 0 + ] dip [ 4 ] 2dip BCL ;
+: BNLLA ( cr target_addr -- ) [ 4 * 0 + ] dip [ 4 ] 2dip BCLA ;
+: BNLLRL ( cr target_addr -- ) [ 4 * 0 + ] dip [ 4 ] 2dip BCLRL ;
+: BNLCTRL ( cr target_addr -- ) [ 4 * 0 + ] dip [ 4 ] 2dip BCCTRL ;
+: BNG ( cr target_addr -- ) [ 4 * 1 + ] dip [ 4 ] 2dip BC ;
+: BNGA ( cr target_addr -- ) [ 4 * 1 + ] dip [ 4 ] 2dip BCA ;
+: BNGLR ( cr target_addr -- ) [ 4 * 1 + ] dip [ 4 ] 2dip BCLR ;
+: BNGCTR ( cr target_addr -- ) [ 4 * 1 + ] dip [ 4 ] 2dip BCCTR ;
+: BNGL ( cr target_addr -- ) [ 4 * 1 + ] dip [ 4 ] 2dip BCL ;
+: BNGLA ( cr target_addr -- ) [ 4 * 1 + ] dip [ 4 ] 2dip BCLA ;
+: BNGLRL ( cr target_addr -- ) [ 4 * 1 + ] dip [ 4 ] 2dip BCLRL ;
+: BNGCTRL ( cr target_addr -- ) [ 4 * 1 + ] dip [ 4 ] 2dip BCCTRL ;
+: BNE ( cr target_addr -- ) [ 4 * 2 + ] dip [ 4 ] 2dip BC ;
+: BNEA ( cr target_addr -- ) [ 4 * 2 + ] dip [ 4 ] 2dip BCA ;
+: BNELR ( cr target_addr -- ) [ 4 * 2 + ] dip [ 4 ] 2dip BCLR ;
+: BNECTR ( cr target_addr -- ) [ 4 * 2 + ] dip [ 4 ] 2dip BCCTR ;
+: BNEL ( cr target_addr -- ) [ 4 * 2 + ] dip [ 4 ] 2dip BCL ;
+: BNELA ( cr target_addr -- ) [ 4 * 2 + ] dip [ 4 ] 2dip BCLA ;
+: BNELRL ( cr target_addr -- ) [ 4 * 2 + ] dip [ 4 ] 2dip BCLRL ;
+: BNECTRL ( cr target_addr -- ) [ 4 * 2 + ] dip [ 4 ] 2dip BCCTRL ;
+: BNS ( cr target_addr -- ) [ 4 * 3 + ] dip [ 4 ] 2dip BC ;
+: BNSA ( cr target_addr -- ) [ 4 * 3 + ] dip [ 4 ] 2dip BCA ;
+: BNSLR ( cr target_addr -- ) [ 4 * 3 + ] dip [ 4 ] 2dip BCLR ;
+: BNSCTR ( cr target_addr -- ) [ 4 * 3 + ] dip [ 4 ] 2dip BCCTR ;
+: BNSL ( cr target_addr -- ) [ 4 * 3 + ] dip [ 4 ] 2dip BCL ;
+: BNSLA ( cr target_addr -- ) [ 4 * 3 + ] dip [ 4 ] 2dip BCLA ;
+: BNSLRL ( cr target_addr -- ) [ 4 * 3 + ] dip [ 4 ] 2dip BCLRL ;
+: BNSCTRL ( cr target_addr -- ) [ 4 * 3 + ] dip [ 4 ] 2dip BCCTRL ;
+: BUN ( cr target_addr -- ) BSO ;
+: BUNA ( cr target_addr -- ) BSOA ;
+: BUNLR ( cr target_addr -- ) BSOLR ;
+: BUNCTR ( cr target_addr -- ) BSOCTR ;
+: BUNL ( cr target_addr -- ) BSOL ;
+: BUNLA ( cr target_addr -- ) BSOLA ;
+: BUNLRL ( cr target_addr -- ) BSOLRL ;
+: BUNCTRL ( cr target_addr -- ) BSOCTRL ;
+: BNU ( cr target_addr -- ) BNS ;
+: BNUA ( cr target_addr -- ) BNSA ;
+: BNULR ( cr target_addr -- ) BNSLR ;
+: BNUCTR ( cr target_addr -- ) BNSCTR ;
+: BNUL ( cr target_addr -- ) BNSL ;
+: BNULA ( cr target_addr -- ) BNSLA ;
+: BNULRL ( cr target_addr -- ) BNSLRL ;
+: BNUCTRL ( cr target_addr -- ) BNSCTRL ;
+: BLE ( cr target_addr -- ) BNG ;
+: BLEA ( cr target_addr -- ) BNGA ;
+: BLELR ( cr target_addr -- ) BNGLR ;
+: BLECTR ( cr target_addr -- ) BNGCTR ;
+: BLEL ( cr target_addr -- ) BNGL ;
+: BLELA ( cr target_addr -- ) BNGLA ;
+: BLELRL ( cr target_addr -- ) BNGLRL ;
+: BLECTRL ( cr target_addr -- ) BNGCTRL ;
+: BGE ( cr target_addr -- ) BNL ;
+: BGEA ( cr target_addr -- ) BNLA ;
+: BGELR ( cr target_addr -- ) BNLLR ;
+: BGECTR ( cr target_addr -- ) BNLCTR ;
+: BGEL ( cr target_addr -- ) BNLL ;
+: BGELA ( cr target_addr -- ) BNLLA ;
+: BGELRL ( cr target_addr -- ) BNLLRL ;
+: BGECTRL ( cr target_addr -- ) BNLCTRL ;
+
+! E.2.4 Branch Prediction
+: BT+ ( bi target_addr -- ) [ HEX: F ] 2dip BC ;
+: BTA+ ( bi target_addr -- ) [ HEX: F ] 2dip BCA ;
+: BTLR+ ( bi target_addr -- ) [ HEX: F ] 2dip BCLR ;
+: BTCTR+ ( bi target_addr -- ) [ HEX: F ] 2dip BCCTR ;
+: BTL+ ( bi target_addr -- ) [ HEX: F ] 2dip BCL ;
+: BTLA+ ( bi target_addr -- ) [ HEX: F ] 2dip BCLA ;
+: BTLRL+ ( bi target_addr -- ) [ HEX: F ] 2dip BCLRL ;
+: BTCTRL+ ( bi target_addr -- ) [ HEX: F ] 2dip BCCTRL ;
+: BF+ ( bi target_addr -- ) [ HEX: 7 ] 2dip BC ;
+: BFA+ ( bi target_addr -- ) [ HEX: 7 ] 2dip BCA ;
+: BFLR+ ( bi target_addr -- ) [ HEX: 7 ] 2dip BCLR ;
+: BFCTR+ ( bi target_addr -- ) [ HEX: 7 ] 2dip BCCTR ;
+: BFL+ ( bi target_addr -- ) [ HEX: 7 ] 2dip BCL ;
+: BFLA+ ( bi target_addr -- ) [ HEX: 7 ] 2dip BCLA ;
+: BFLRL+ ( bi target_addr -- ) [ HEX: 7 ] 2dip BCLRL ;
+: BFCTRL+ ( bi target_addr -- ) [ HEX: 7 ] 2dip BCCTRL ;
+: BDNZ+ ( target_addr -- ) [ HEX: 19 0 ] dip BC ;
+: BDNZA+ ( target_addr -- ) [ HEX: 19 0 ] dip BCA ;
+: BDNZLR+ ( target_addr -- ) [ HEX: 19 0 ] dip BCLR ;
+: BDNZL+ ( target_addr -- ) [ HEX: 19 0 ] dip BCL ;
+: BDNZLA+ ( target_addr -- ) [ HEX: 19 0 ] dip BCLA ;
+: BDNZLRL+ ( target_addr -- ) [ HEX: 19 0 ] dip BCLRL ;
+: BDZ+ ( target_addr -- ) [ HEX: 1B 0 ] dip BC ;
+: BDZA+ ( target_addr -- ) [ HEX: 1B 0 ] dip BCA ;
+: BDZLR+ ( target_addr -- ) [ HEX: 1B 0 ] dip BCLR ;
+: BDZL+ ( target_addr -- ) [ HEX: 1B 0 ] dip BCL ;
+: BDZLA+ ( target_addr -- ) [ HEX: 1B 0 ] dip BCLA ;
+: BDZLRL+ ( target_addr -- ) [ HEX: 1B 0 ] dip BCLRL ;
+: BT- ( bi target_addr -- ) [ HEX: E ] 2dip BC ;
+: BTA- ( bi target_addr -- ) [ HEX: E ] 2dip BCA ;
+: BTLR- ( bi target_addr -- ) [ HEX: E ] 2dip BCLR ;
+: BTCTR- ( bi target_addr -- ) [ HEX: E ] 2dip BCCTR ;
+: BTL- ( bi target_addr -- ) [ HEX: E ] 2dip BCL ;
+: BTLA- ( bi target_addr -- ) [ HEX: E ] 2dip BCLA ;
+: BTLRL- ( bi target_addr -- ) [ HEX: E ] 2dip BCLRL ;
+: BTCTRL- ( bi target_addr -- ) [ HEX: E ] 2dip BCCTRL ;
+: BF- ( bi target_addr -- ) [ HEX: 6 ] 2dip BC ;
+: BFA- ( bi target_addr -- ) [ HEX: 6 ] 2dip BCA ;
+: BFLR- ( bi target_addr -- ) [ HEX: 6 ] 2dip BCLR ;
+: BFCTR- ( bi target_addr -- ) [ HEX: 6 ] 2dip BCCTR ;
+: BFL- ( bi target_addr -- ) [ HEX: 6 ] 2dip BCL ;
+: BFLA- ( bi target_addr -- ) [ HEX: 6 ] 2dip BCLA ;
+: BFLRL- ( bi target_addr -- ) [ HEX: 6 ] 2dip BCLRL ;
+: BFCTRL- ( bi target_addr -- ) [ HEX: 6 ] 2dip BCCTRL ;
+: BDNZ- ( target_addr -- ) [ HEX: 18 0 ] dip BC ;
+: BDNZA- ( target_addr -- ) [ HEX: 18 0 ] dip BCA ;
+: BDNZLR- ( target_addr -- ) [ HEX: 18 0 ] dip BCLR ;
+: BDNZL- ( target_addr -- ) [ HEX: 18 0 ] dip BCL ;
+: BDNZLA- ( target_addr -- ) [ HEX: 18 0 ] dip BCLA ;
+: BDNZLRL- ( target_addr -- ) [ HEX: 18 0 ] dip BCLRL ;
+: BDZ- ( target_addr -- ) [ HEX: 1A 0 ] dip BC ;
+: BDZA- ( target_addr -- ) [ HEX: 1A 0 ] dip BCA ;
+: BDZLR- ( target_addr -- ) [ HEX: 1A 0 ] dip BCLR ;
+: BDZL- ( target_addr -- ) [ HEX: 1A 0 ] dip BCL ;
+: BDZLA- ( target_addr -- ) [ HEX: 1A 0 ] dip BCLA ;
+: BDZLRL- ( target_addr -- ) [ HEX: 1A 0 ] dip BCLRL ;
+: BLT+ ( cr target_addr -- ) [ 4 * 0 + ] dip [ 15 ] 2dip BC ;
+: BLTA+ ( cr target_addr -- ) [ 4 * 0 + ] dip [ 15 ] 2dip BCA ;
+: BLTLR+ ( cr target_addr -- ) [ 4 * 0 + ] dip [ 15 ] 2dip BCLR ;
+: BLTCTR+ ( cr target_addr -- ) [ 4 * 0 + ] dip [ 15 ] 2dip BCCTR ;
+: BLTL+ ( cr target_addr -- ) [ 4 * 0 + ] dip [ 15 ] 2dip BCL ;
+: BLTLA+ ( cr target_addr -- ) [ 4 * 0 + ] dip [ 15 ] 2dip BCLA ;
+: BLTLRL+ ( cr target_addr -- ) [ 4 * 0 + ] dip [ 15 ] 2dip BCLRL ;
+: BLTCTRL+ ( cr target_addr -- ) [ 4 * 0 + ] dip [ 15 ] 2dip BCCTRL ;
+: BGT+ ( cr target_addr -- ) [ 4 * 1 + ] dip [ 15 ] 2dip BC ;
+: BGTA+ ( cr target_addr -- ) [ 4 * 1 + ] dip [ 15 ] 2dip BCA ;
+: BGTLR+ ( cr target_addr -- ) [ 4 * 1 + ] dip [ 15 ] 2dip BCLR ;
+: BGTCTR+ ( cr target_addr -- ) [ 4 * 1 + ] dip [ 15 ] 2dip BCCTR ;
+: BGTL+ ( cr target_addr -- ) [ 4 * 1 + ] dip [ 15 ] 2dip BCL ;
+: BGTLA+ ( cr target_addr -- ) [ 4 * 1 + ] dip [ 15 ] 2dip BCLA ;
+: BGTLRL+ ( cr target_addr -- ) [ 4 * 1 + ] dip [ 15 ] 2dip BCLRL ;
+: BGTCTRL+ ( cr target_addr -- ) [ 4 * 1 + ] dip [ 15 ] 2dip BCCTRL ;
+: BEQ+ ( cr target_addr -- ) [ 4 * 2 + ] dip [ 15 ] 2dip BC ;
+: BEQA+ ( cr target_addr -- ) [ 4 * 2 + ] dip [ 15 ] 2dip BCA ;
+: BEQLR+ ( cr target_addr -- ) [ 4 * 2 + ] dip [ 15 ] 2dip BCLR ;
+: BEQCTR+ ( cr target_addr -- ) [ 4 * 2 + ] dip [ 15 ] 2dip BCCTR ;
+: BEQL+ ( cr target_addr -- ) [ 4 * 2 + ] dip [ 15 ] 2dip BCL ;
+: BEQLA+ ( cr target_addr -- ) [ 4 * 2 + ] dip [ 15 ] 2dip BCLA ;
+: BEQLRL+ ( cr target_addr -- ) [ 4 * 2 + ] dip [ 15 ] 2dip BCLRL ;
+: BEQCTRL+ ( cr target_addr -- ) [ 4 * 2 + ] dip [ 15 ] 2dip BCCTRL ;
+: BSO+ ( cr target_addr -- ) [ 4 * 3 + ] dip [ 15 ] 2dip BC ;
+: BSOA+ ( cr target_addr -- ) [ 4 * 3 + ] dip [ 15 ] 2dip BCA ;
+: BSOLR+ ( cr target_addr -- ) [ 4 * 3 + ] dip [ 15 ] 2dip BCLR ;
+: BSOCTR+ ( cr target_addr -- ) [ 4 * 3 + ] dip [ 15 ] 2dip BCCTR ;
+: BSOL+ ( cr target_addr -- ) [ 4 * 3 + ] dip [ 15 ] 2dip BCL ;
+: BSOLA+ ( cr target_addr -- ) [ 4 * 3 + ] dip [ 15 ] 2dip BCLA ;
+: BSOLRL+ ( cr target_addr -- ) [ 4 * 3 + ] dip [ 15 ] 2dip BCLRL ;
+: BSOCTRL+ ( cr target_addr -- ) [ 4 * 3 + ] dip [ 15 ] 2dip BCCTRL ;
+: BNL+ ( cr target_addr -- ) [ 4 * 0 + ] dip [ 7 ] 2dip BC ;
+: BNLA+ ( cr target_addr -- ) [ 4 * 0 + ] dip [ 7 ] 2dip BCA ;
+: BNLLR+ ( cr target_addr -- ) [ 4 * 0 + ] dip [ 7 ] 2dip BCLR ;
+: BNLCTR+ ( cr target_addr -- ) [ 4 * 0 + ] dip [ 7 ] 2dip BCCTR ;
+: BNLL+ ( cr target_addr -- ) [ 4 * 0 + ] dip [ 7 ] 2dip BCL ;
+: BNLLA+ ( cr target_addr -- ) [ 4 * 0 + ] dip [ 7 ] 2dip BCLA ;
+: BNLLRL+ ( cr target_addr -- ) [ 4 * 0 + ] dip [ 7 ] 2dip BCLRL ;
+: BNLCTRL+ ( cr target_addr -- ) [ 4 * 0 + ] dip [ 7 ] 2dip BCCTRL ;
+: BNG+ ( cr target_addr -- ) [ 4 * 1 + ] dip [ 7 ] 2dip BC ;
+: BNGA+ ( cr target_addr -- ) [ 4 * 1 + ] dip [ 7 ] 2dip BCA ;
+: BNGLR+ ( cr target_addr -- ) [ 4 * 1 + ] dip [ 7 ] 2dip BCLR ;
+: BNGCTR+ ( cr target_addr -- ) [ 4 * 1 + ] dip [ 7 ] 2dip BCCTR ;
+: BNGL+ ( cr target_addr -- ) [ 4 * 1 + ] dip [ 7 ] 2dip BCL ;
+: BNGLA+ ( cr target_addr -- ) [ 4 * 1 + ] dip [ 7 ] 2dip BCLA ;
+: BNGLRL+ ( cr target_addr -- ) [ 4 * 1 + ] dip [ 7 ] 2dip BCLRL ;
+: BNGCTRL+ ( cr target_addr -- ) [ 4 * 1 + ] dip [ 7 ] 2dip BCCTRL ;
+: BNE+ ( cr target_addr -- ) [ 4 * 2 + ] dip [ 7 ] 2dip BC ;
+: BNEA+ ( cr target_addr -- ) [ 4 * 2 + ] dip [ 7 ] 2dip BCA ;
+: BNELR+ ( cr target_addr -- ) [ 4 * 2 + ] dip [ 7 ] 2dip BCLR ;
+: BNECTR+ ( cr target_addr -- ) [ 4 * 2 + ] dip [ 7 ] 2dip BCCTR ;
+: BNEL+ ( cr target_addr -- ) [ 4 * 2 + ] dip [ 7 ] 2dip BCL ;
+: BNELA+ ( cr target_addr -- ) [ 4 * 2 + ] dip [ 7 ] 2dip BCLA ;
+: BNELRL+ ( cr target_addr -- ) [ 4 * 2 + ] dip [ 7 ] 2dip BCLRL ;
+: BNECTRL+ ( cr target_addr -- ) [ 4 * 2 + ] dip [ 7 ] 2dip BCCTRL ;
+: BNS+ ( cr target_addr -- ) [ 4 * 3 + ] dip [ 7 ] 2dip BC ;
+: BNSA+ ( cr target_addr -- ) [ 4 * 3 + ] dip [ 7 ] 2dip BCA ;
+: BNSLR+ ( cr target_addr -- ) [ 4 * 3 + ] dip [ 7 ] 2dip BCLR ;
+: BNSCTR+ ( cr target_addr -- ) [ 4 * 3 + ] dip [ 7 ] 2dip BCCTR ;
+: BNSL+ ( cr target_addr -- ) [ 4 * 3 + ] dip [ 7 ] 2dip BCL ;
+: BNSLA+ ( cr target_addr -- ) [ 4 * 3 + ] dip [ 7 ] 2dip BCLA ;
+: BNSLRL+ ( cr target_addr -- ) [ 4 * 3 + ] dip [ 7 ] 2dip BCLRL ;
+: BNSCTRL+ ( cr target_addr -- ) [ 4 * 3 + ] dip [ 7 ] 2dip BCCTRL ;
+: BUN+ ( cr target_addr -- ) BSO+ ;
+: BUNA+ ( cr target_addr -- ) BSOA+ ;
+: BUNLR+ ( cr target_addr -- ) BSOLR+ ;
+: BUNCTR+ ( cr target_addr -- ) BSOCTR+ ;
+: BUNL+ ( cr target_addr -- ) BSOL+ ;
+: BUNLA+ ( cr target_addr -- ) BSOLA+ ;
+: BUNLRL+ ( cr target_addr -- ) BSOLRL+ ;
+: BUNCTRL+ ( cr target_addr -- ) BSOCTRL+ ;
+: BNU+ ( cr target_addr -- ) BNS+ ;
+: BNUA+ ( cr target_addr -- ) BNSA+ ;
+: BNULR+ ( cr target_addr -- ) BNSLR+ ;
+: BNUCTR+ ( cr target_addr -- ) BNSCTR+ ;
+: BNUL+ ( cr target_addr -- ) BNSL+ ;
+: BNULA+ ( cr target_addr -- ) BNSLA+ ;
+: BNULRL+ ( cr target_addr -- ) BNSLRL+ ;
+: BNUCTRL+ ( cr target_addr -- ) BNSCTRL+ ;
+: BLE+ ( cr target_addr -- ) BNG+ ;
+: BLEA+ ( cr target_addr -- ) BNGA+ ;
+: BLELR+ ( cr target_addr -- ) BNGLR+ ;
+: BLECTR+ ( cr target_addr -- ) BNGCTR+ ;
+: BLEL+ ( cr target_addr -- ) BNGL+ ;
+: BLELA+ ( cr target_addr -- ) BNGLA+ ;
+: BLELRL+ ( cr target_addr -- ) BNGLRL+ ;
+: BLECTRL+ ( cr target_addr -- ) BNGCTRL+ ;
+: BGE+ ( cr target_addr -- ) BNL+ ;
+: BGEA+ ( cr target_addr -- ) BNLA+ ;
+: BGELR+ ( cr target_addr -- ) BNLLR+ ;
+: BGECTR+ ( cr target_addr -- ) BNLCTR+ ;
+: BGEL+ ( cr target_addr -- ) BNLL+ ;
+: BGELA+ ( cr target_addr -- ) BNLLA+ ;
+: BGELRL+ ( cr target_addr -- ) BNLLRL+ ;
+: BGECTRL+ ( cr target_addr -- ) BNLCTRL+ ;
+: BLT- ( cr target_addr -- ) [ 4 * 0 + ] dip [ 14 ] 2dip BC ;
+: BLTA- ( cr target_addr -- ) [ 4 * 0 + ] dip [ 14 ] 2dip BCA ;
+: BLTLR- ( cr target_addr -- ) [ 4 * 0 + ] dip [ 14 ] 2dip BCLR ;
+: BLTCTR- ( cr target_addr -- ) [ 4 * 0 + ] dip [ 14 ] 2dip BCCTR ;
+: BLTL- ( cr target_addr -- ) [ 4 * 0 + ] dip [ 14 ] 2dip BCL ;
+: BLTLA- ( cr target_addr -- ) [ 4 * 0 + ] dip [ 14 ] 2dip BCLA ;
+: BLTLRL- ( cr target_addr -- ) [ 4 * 0 + ] dip [ 14 ] 2dip BCLRL ;
+: BLTCTRL- ( cr target_addr -- ) [ 4 * 0 + ] dip [ 14 ] 2dip BCCTRL ;
+: BGT- ( cr target_addr -- ) [ 4 * 1 + ] dip [ 14 ] 2dip BC ;
+: BGTA- ( cr target_addr -- ) [ 4 * 1 + ] dip [ 14 ] 2dip BCA ;
+: BGTLR- ( cr target_addr -- ) [ 4 * 1 + ] dip [ 14 ] 2dip BCLR ;
+: BGTCTR- ( cr target_addr -- ) [ 4 * 1 + ] dip [ 14 ] 2dip BCCTR ;
+: BGTL- ( cr target_addr -- ) [ 4 * 1 + ] dip [ 14 ] 2dip BCL ;
+: BGTLA- ( cr target_addr -- ) [ 4 * 1 + ] dip [ 14 ] 2dip BCLA ;
+: BGTLRL- ( cr target_addr -- ) [ 4 * 1 + ] dip [ 14 ] 2dip BCLRL ;
+: BGTCTRL- ( cr target_addr -- ) [ 4 * 1 + ] dip [ 14 ] 2dip BCCTRL ;
+: BEQ- ( cr target_addr -- ) [ 4 * 2 + ] dip [ 14 ] 2dip BC ;
+: BEQA- ( cr target_addr -- ) [ 4 * 2 + ] dip [ 14 ] 2dip BCA ;
+: BEQLR- ( cr target_addr -- ) [ 4 * 2 + ] dip [ 14 ] 2dip BCLR ;
+: BEQCTR- ( cr target_addr -- ) [ 4 * 2 + ] dip [ 14 ] 2dip BCCTR ;
+: BEQL- ( cr target_addr -- ) [ 4 * 2 + ] dip [ 14 ] 2dip BCL ;
+: BEQLA- ( cr target_addr -- ) [ 4 * 2 + ] dip [ 14 ] 2dip BCLA ;
+: BEQLRL- ( cr target_addr -- ) [ 4 * 2 + ] dip [ 14 ] 2dip BCLRL ;
+: BEQCTRL- ( cr target_addr -- ) [ 4 * 2 + ] dip [ 14 ] 2dip BCCTRL ;
+: BSO- ( cr target_addr -- ) [ 4 * 3 + ] dip [ 14 ] 2dip BC ;
+: BSOA- ( cr target_addr -- ) [ 4 * 3 + ] dip [ 14 ] 2dip BCA ;
+: BSOLR- ( cr target_addr -- ) [ 4 * 3 + ] dip [ 14 ] 2dip BCLR ;
+: BSOCTR- ( cr target_addr -- ) [ 4 * 3 + ] dip [ 14 ] 2dip BCCTR ;
+: BSOL- ( cr target_addr -- ) [ 4 * 3 + ] dip [ 14 ] 2dip BCL ;
+: BSOLA- ( cr target_addr -- ) [ 4 * 3 + ] dip [ 14 ] 2dip BCLA ;
+: BSOLRL- ( cr target_addr -- ) [ 4 * 3 + ] dip [ 14 ] 2dip BCLRL ;
+: BSOCTRL- ( cr target_addr -- ) [ 4 * 3 + ] dip [ 14 ] 2dip BCCTRL ;
+: BNL- ( cr target_addr -- ) [ 4 * 0 + ] dip [ 6 ] 2dip BC ;
+: BNLA- ( cr target_addr -- ) [ 4 * 0 + ] dip [ 6 ] 2dip BCA ;
+: BNLLR- ( cr target_addr -- ) [ 4 * 0 + ] dip [ 6 ] 2dip BCLR ;
+: BNLCTR- ( cr target_addr -- ) [ 4 * 0 + ] dip [ 6 ] 2dip BCCTR ;
+: BNLL- ( cr target_addr -- ) [ 4 * 0 + ] dip [ 6 ] 2dip BCL ;
+: BNLLA- ( cr target_addr -- ) [ 4 * 0 + ] dip [ 6 ] 2dip BCLA ;
+: BNLLRL- ( cr target_addr -- ) [ 4 * 0 + ] dip [ 6 ] 2dip BCLRL ;
+: BNLCTRL- ( cr target_addr -- ) [ 4 * 0 + ] dip [ 6 ] 2dip BCCTRL ;
+: BNG- ( cr target_addr -- ) [ 4 * 1 + ] dip [ 6 ] 2dip BC ;
+: BNGA- ( cr target_addr -- ) [ 4 * 1 + ] dip [ 6 ] 2dip BCA ;
+: BNGLR- ( cr target_addr -- ) [ 4 * 1 + ] dip [ 6 ] 2dip BCLR ;
+: BNGCTR- ( cr target_addr -- ) [ 4 * 1 + ] dip [ 6 ] 2dip BCCTR ;
+: BNGL- ( cr target_addr -- ) [ 4 * 1 + ] dip [ 6 ] 2dip BCL ;
+: BNGLA- ( cr target_addr -- ) [ 4 * 1 + ] dip [ 6 ] 2dip BCLA ;
+: BNGLRL- ( cr target_addr -- ) [ 4 * 1 + ] dip [ 6 ] 2dip BCLRL ;
+: BNGCTRL- ( cr target_addr -- ) [ 4 * 1 + ] dip [ 6 ] 2dip BCCTRL ;
+: BNE- ( cr target_addr -- ) [ 4 * 2 + ] dip [ 6 ] 2dip BC ;
+: BNEA- ( cr target_addr -- ) [ 4 * 2 + ] dip [ 6 ] 2dip BCA ;
+: BNELR- ( cr target_addr -- ) [ 4 * 2 + ] dip [ 6 ] 2dip BCLR ;
+: BNECTR- ( cr target_addr -- ) [ 4 * 2 + ] dip [ 6 ] 2dip BCCTR ;
+: BNEL- ( cr target_addr -- ) [ 4 * 2 + ] dip [ 6 ] 2dip BCL ;
+: BNELA- ( cr target_addr -- ) [ 4 * 2 + ] dip [ 6 ] 2dip BCLA ;
+: BNELRL- ( cr target_addr -- ) [ 4 * 2 + ] dip [ 6 ] 2dip BCLRL ;
+: BNECTRL- ( cr target_addr -- ) [ 4 * 2 + ] dip [ 6 ] 2dip BCCTRL ;
+: BNS- ( cr target_addr -- ) [ 4 * 3 + ] dip [ 6 ] 2dip BC ;
+: BNSA- ( cr target_addr -- ) [ 4 * 3 + ] dip [ 6 ] 2dip BCA ;
+: BNSLR- ( cr target_addr -- ) [ 4 * 3 + ] dip [ 6 ] 2dip BCLR ;
+: BNSCTR- ( cr target_addr -- ) [ 4 * 3 + ] dip [ 6 ] 2dip BCCTR ;
+: BNSL- ( cr target_addr -- ) [ 4 * 3 + ] dip [ 6 ] 2dip BCL ;
+: BNSLA- ( cr target_addr -- ) [ 4 * 3 + ] dip [ 6 ] 2dip BCLA ;
+: BNSLRL- ( cr target_addr -- ) [ 4 * 3 + ] dip [ 6 ] 2dip BCLRL ;
+: BNSCTRL- ( cr target_addr -- ) [ 4 * 3 + ] dip [ 6 ] 2dip BCCTRL ;
+: BUN- ( cr target_addr -- ) BSO- ;
+: BUNA- ( cr target_addr -- ) BSOA- ;
+: BUNLR- ( cr target_addr -- ) BSOLR- ;
+: BUNCTR- ( cr target_addr -- ) BSOCTR- ;
+: BUNL- ( cr target_addr -- ) BSOL- ;
+: BUNLA- ( cr target_addr -- ) BSOLA- ;
+: BUNLRL- ( cr target_addr -- ) BSOLRL- ;
+: BUNCTRL- ( cr target_addr -- ) BSOCTRL- ;
+: BNU- ( cr target_addr -- ) BNS- ;
+: BNUA- ( cr target_addr -- ) BNSA- ;
+: BNULR- ( cr target_addr -- ) BNSLR- ;
+: BNUCTR- ( cr target_addr -- ) BNSCTR- ;
+: BNUL- ( cr target_addr -- ) BNSL- ;
+: BNULA- ( cr target_addr -- ) BNSLA- ;
+: BNULRL- ( cr target_addr -- ) BNSLRL- ;
+: BNUCTRL- ( cr target_addr -- ) BNSCTRL- ;
+: BLE- ( cr target_addr -- ) BNG- ;
+: BLEA- ( cr target_addr -- ) BNGA- ;
+: BLELR- ( cr target_addr -- ) BNGLR- ;
+: BLECTR- ( cr target_addr -- ) BNGCTR- ;
+: BLEL- ( cr target_addr -- ) BNGL- ;
+: BLELA- ( cr target_addr -- ) BNGLA- ;
+: BLELRL- ( cr target_addr -- ) BNGLRL- ;
+: BLECTRL- ( cr target_addr -- ) BNGCTRL- ;
+: BGE- ( cr target_addr -- ) BNL- ;
+: BGEA- ( cr target_addr -- ) BNLA- ;
+: BGELR- ( cr target_addr -- ) BNLLR- ;
+: BGECTR- ( cr target_addr -- ) BNLCTR- ;
+: BGEL- ( cr target_addr -- ) BNLL- ;
+: BGELA- ( cr target_addr -- ) BNLLA- ;
+: BGELRL- ( cr target_addr -- ) BNLLRL- ;
+: BGECTRL- ( cr target_addr -- ) BNLCTRL- ;
+
+! E.3 Condition Register Logical Mnemonics
+: CRSET ( bx -- ) dup dup CREQV ;
+: CRCLR ( bx -- ) dup dup CRXOR ;
+: CRMOVE ( bx by -- ) dup CROR ;
+: CRNOT ( bx by -- ) dup CRNOR ;
+
+! E.4.1 Subtract Immediate
+: SUBI ( dst src1 src2 -- ) neg ADDI ;
+: SUBIS ( dst src1 src2 -- ) neg ADDIS ;
+: SUBIC ( dst src1 src2 -- ) neg ADDIC ;
+: SUBIC. ( dst src1 src2 -- ) neg ADDIC. ;
+
+! E.4.2 Subtract
+: SUB ( rx ry rz -- ) swap SUBF ;
+: SUB. ( rx ry rz -- ) swap SUBF. ;
+: SUBO ( rx ry rz -- ) swap SUBFO ;
+: SUBO. ( rx ry rz -- ) swap SUBFO. ;
+: SUBC ( rx ry rz -- ) swap SUBFC ;
+: SUBC. ( rx ry rz -- ) swap SUBFC. ;
+: SUBCO ( rx ry rz -- ) swap SUBFCO ;
+: SUBCO. ( rx ry rz -- ) swap SUBFCO. ;
+
+! E.5.1 Double Word Comparisons
+: CMPDI ( bf ra si -- ) [ 1 ] 2dip CMPI ;
+: CMPD ( bf ra rb -- ) [ 1 ] 2dip CMP ;
+: CMPLDI ( bf ra ui -- ) [ 1 ] 2dip CMPLI ;
+: CMPLD ( bf ra rb -- ) [ 1 ] 2dip CMPL ;
+
+! E.5.2 Word Comparisons
+: CMPWI ( bf ra si -- ) [ 0 ] 2dip CMPI ;
+: CMPW ( bf ra rb -- ) [ 0 ] 2dip CMP ;
+: CMPLWI ( bf ra ui -- ) [ 0 ] 2dip CMPLI ;
+: CMPLW ( bf ra rb -- ) [ 0 ] 2dip CMPL ;
+
+! E.6 Trap Mnemonics
+: TRAP ( -- ) 31 0 0 TW ;
+: TDUI ( rx n -- ) [ 31 ] 2dip TDI ;
+: TDU ( rx ry -- ) [ 31 ] 2dip TD ;
+: TWUI ( rx n -- ) [ 31 ] 2dip TWI ;
+: TWU ( rx ry -- ) [ 31 ] 2dip TW ;
+: TDLTI ( rx n -- ) [ 16 ] 2dip TDI ;
+: TDLT ( rx ry -- ) [ 16 ] 2dip TD ;
+: TWLTI ( rx n -- ) [ 16 ] 2dip TWI ;
+: TWLT ( rx ry -- ) [ 16 ] 2dip TW ;
+: TDLEI ( rx n -- ) [ 20 ] 2dip TDI ;
+: TDLE ( rx ry -- ) [ 20 ] 2dip TD ;
+: TWLEI ( rx n -- ) [ 20 ] 2dip TWI ;
+: TWLE ( rx ry -- ) [ 20 ] 2dip TW ;
+: TDEQI ( rx n -- ) [ 4 ] 2dip TDI ;
+: TDEQ ( rx ry -- ) [ 4 ] 2dip TD ;
+: TWEQI ( rx n -- ) [ 4 ] 2dip TWI ;
+: TWEQ ( rx ry -- ) [ 4 ] 2dip TW ;
+: TDGEI ( rx n -- ) [ 12 ] 2dip TDI ;
+: TDGE ( rx ry -- ) [ 12 ] 2dip TD ;
+: TWGEI ( rx n -- ) [ 12 ] 2dip TWI ;
+: TWGE ( rx ry -- ) [ 12 ] 2dip TW ;
+: TDGTI ( rx n -- ) [ 8 ] 2dip TDI ;
+: TDGT ( rx ry -- ) [ 8 ] 2dip TD ;
+: TWGTI ( rx n -- ) [ 8 ] 2dip TWI ;
+: TWGT ( rx ry -- ) [ 8 ] 2dip TW ;
+: TDNLI ( rx n -- ) [ 12 ] 2dip TDI ;
+: TDNL ( rx ry -- ) [ 12 ] 2dip TD ;
+: TWNLI ( rx n -- ) [ 12 ] 2dip TWI ;
+: TWNL ( rx ry -- ) [ 12 ] 2dip TW ;
+: TDNEI ( rx n -- ) [ 24 ] 2dip TDI ;
+: TDNE ( rx ry -- ) [ 24 ] 2dip TD ;
+: TWNEI ( rx n -- ) [ 24 ] 2dip TWI ;
+: TWNE ( rx ry -- ) [ 24 ] 2dip TW ;
+: TDNGI ( rx n -- ) [ 20 ] 2dip TDI ;
+: TDNG ( rx ry -- ) [ 20 ] 2dip TD ;
+: TWNGI ( rx n -- ) [ 20 ] 2dip TWI ;
+: TWNG ( rx ry -- ) [ 20 ] 2dip TW ;
+: TDLLTI ( rx n -- ) [ 2 ] 2dip TDI ;
+: TDLLT ( rx ry -- ) [ 2 ] 2dip TD ;
+: TWLLTI ( rx n -- ) [ 2 ] 2dip TWI ;
+: TWLLT ( rx ry -- ) [ 2 ] 2dip TW ;
+: TDLLEI ( rx n -- ) [ 6 ] 2dip TDI ;
+: TDLLE ( rx ry -- ) [ 6 ] 2dip TD ;
+: TWLLEI ( rx n -- ) [ 6 ] 2dip TWI ;
+: TWLLE ( rx ry -- ) [ 6 ] 2dip TW ;
+: TDLGEI ( rx n -- ) [ 5 ] 2dip TDI ;
+: TDLGE ( rx ry -- ) [ 5 ] 2dip TD ;
+: TWLGEI ( rx n -- ) [ 5 ] 2dip TWI ;
+: TWLGE ( rx ry -- ) [ 5 ] 2dip TW ;
+: TDLGTI ( rx n -- ) [ 1 ] 2dip TDI ;
+: TDLGT ( rx ry -- ) [ 1 ] 2dip TD ;
+: TWLGTI ( rx n -- ) [ 1 ] 2dip TWI ;
+: TWLGT ( rx ry -- ) [ 1 ] 2dip TW ;
+: TDLNLI ( rx n -- ) [ 5 ] 2dip TDI ;
+: TDLNL ( rx ry -- ) [ 5 ] 2dip TD ;
+: TWLNLI ( rx n -- ) [ 5 ] 2dip TWI ;
+: TWLNL ( rx ry -- ) [ 5 ] 2dip TW ;
+: TDLNGI ( rx n -- ) [ 6 ] 2dip TDI ;
+: TDLNG ( rx ry -- ) [ 6 ] 2dip TD ;
+: TWLNGI ( rx n -- ) [ 6 ] 2dip TWI ;
+: TWLNG ( rx ry -- ) [ 6 ] 2dip TW ;
+
+! E.7.1 Operations on Doublewords
+: EXTLDI ( ra rs n b -- ) swap 1 - RLDICR ;
+: EXTLDI. ( ra rs n b -- ) swap 1 - RLDICR. ;
+: EXTRDI ( ra rs n b -- ) [ + ] [ drop 64 swap - ] 2bi RLDICL ;
+: EXTRDI. ( ra rs n b -- ) [ + ] [ drop 64 swap - ] 2bi RLDICL. ;
+: INSRDI ( ra rs n b -- ) [ + 64 swap - ] [ nip ] 2bi RLDIMI ;
+: INSRDI. ( ra rs n b -- ) [ + 64 swap - ] [ nip ] 2bi RLDIMI. ;
+: ROTLDI ( ra rs n -- ) 0 RLDICL ;
+: ROTLDI. ( ra rs n -- ) 0 RLDICL. ;
+: ROTRDI ( ra rs n -- ) 64 swap - 0 RLDICL ;
+: ROTRDI. ( ra rs n -- ) 64 swap - 0 RLDICL. ;
+: ROTLD ( ra rs rb -- ) 0 RLDCL ;
+: ROTLD. ( ra rs rb -- ) 0 RLDCL. ;
+: SLDI ( ra rs n -- ) dup 63 swap - RLDICR ;
+: SLDI. ( ra rs n -- ) dup 63 swap - RLDICR. ;
+: SRDI ( ra rs n -- ) dup [ 64 swap - ] dip RLDICL ;
+: SRDI. ( ra rs n -- ) dup [ 64 swap - ] dip RLDICL. ;
+: CLRLDI ( ra rs n -- ) 0 swap RLDICL ;
+: CLRLDI. ( ra rs n -- ) 0 swap RLDICL. ;
+: CLRRDI ( ra rs n -- ) 0 swap 63 swap - RLDICR ;
+: CLRRDI. ( ra rs n -- ) 0 swap 63 swap - RLDICR. ;
+: CLRLSLDI ( ra rs b n -- ) swap over - RLDIC ;
+: CLRLSLDI. ( ra rs b n -- ) swap over - RLDIC. ;
+
+! E.7.2 Operations on Words
+: EXTLWI ( ra rs n b -- ) swap 0 1 - RLWINM ;
+: EXTLWI. ( ra rs n b -- ) swap 0 1 - RLWINM. ;
+: EXTRWI ( ra rs n b -- ) swap dup [ + ] dip 32 swap - 31 RLWINM ;
+: EXTRWI. ( ra rs n b -- ) swap dup [ + ] dip 32 swap - 31 RLWINM. ;
+: INSLWI ( ra rs n b -- ) [ [ drop 32 ] dip - ] [ nip ] [ + 1 - ] 2tri RLWIMI ;
+: INSLWI. ( ra rs n b -- ) [ [ drop 32 ] dip - ] [ nip ] [ + 1 - ] 2tri RLWIMI. ;
+: INSRWI ( ra rs n b -- ) [ + 32 swap - ] [ nip ] [ + 1 - ] 2tri RLWIMI ;
+: INSRWI. ( ra rs n b -- ) [ + 32 swap - ] [ nip ] [ + 1 - ] 2tri RLWIMI. ;
+: ROTLWI ( ra rs n -- ) 0 31 RLWINM ;
+: ROTLWI. ( ra rs n -- ) 0 31 RLWINM. ;
+: ROTRWI ( ra rs n -- ) 32 swap - 0 31 RLWINM ;
+: ROTRWI. ( ra rs n -- ) 32 swap - 0 31 RLWINM. ;
+: ROTLW ( ra rs rb -- ) 0 31 RLWNM ;
+: ROTLW. ( ra rs rb -- ) 0 31 RLWNM. ;
+: SLWI ( ra rs n -- ) 0 over 31 swap - RLWINM ;
+: SLWI. ( ra rs n -- ) 0 over 31 swap - RLWINM. ;
+: SRWI ( ra rs n -- ) [ 32 swap - ] [ ] bi 31 RLWINM ;
+: SRWI. ( ra rs n -- ) [ 32 swap - ] [ ] bi 31 RLWINM. ;
+: CLRLWI ( ra rs n -- ) 0 swap 31 RLWINM ;
+: CLRLWI. ( ra rs n -- ) 0 swap 31 RLWINM. ;
+: CLRRWI ( ra rs n -- ) [ 0 0 ] dip 31 swap - RLWINM ;
+: CLRRWI. ( ra rs n -- ) [ 0 0 ] dip 31 swap - RLWINM. ;
+: CLRLSLWI ( ra rs b n -- ) [ nip ] [ - ] [ nip 31 swap - ] 2tri RLWINM ;
+: CLRLSLWI. ( ra rs b n -- ) [ nip ] [ - ] [ nip 31 swap - ] 2tri RLWINM. ;
+
+! E.8 Move To/From Special Purpose Registers Mnemonics
+: MFXER ( rx -- ) 1 5 shift MFSPR ;
+: MFLR ( rx -- ) 8 5 shift MFSPR ;
+: MFCTR ( rx -- ) 9 5 shift MFSPR ;
+: MFUAMR ( rx -- ) 13 5 shift MFSPR ;
+: MFPPR ( rx -- ) 896 -5 shift MFSPR ;
+: MFPPR32 ( rx -- ) 898 -5 shift MFSPR ;
+: MTXER ( rx -- ) 1 5 shift swap MTSPR ;
+: MTLR ( rx -- ) 8 5 shift swap MTSPR ;
+: MTCTR ( rx -- ) 9 5 shift swap MTSPR ;
+: MTUAMR ( rx -- ) 13 5 shift swap MTSPR ;
+: MTPPR ( rx -- ) 896 -5 shift swap MTSPR ;
+: MTPPR32 ( rx -- ) 898 -5 shift swap MTSPR ;
+
+! E.9 Miscellaneous Mnemonics
+: NOP ( -- ) 0 0 0 ORI ;
+: XNOP ( -- ) 0 0 0 XORI ;
+: LI ( dst value -- ) 0 swap ADDI ;
+: LIS ( dst value -- ) 0 swap ADDIS ;
+: LA ( rx ry d -- ) ADDI ;
+: MR ( dst src -- ) dup OR ;
+: MR. ( dst src -- ) dup OR. ;
+: NOT ( dst src -- ) dup NOR ;
+: NOT. ( dst src -- ) dup NOR. ;
+: MTCR ( rx -- ) HEX: ff swap MTCRF ; deprecated
--- /dev/null
+Erik Charlebois
--- /dev/null
+! Copyright (C) 2011 Erik Charlebois
+! See http://factorcode.org/license.txt for BSD license.
+USING: bootstrap.image.private kernel kernel.private namespaces
+system cpu.ppc.assembler compiler.units compiler.constants math
+math.private math.ranges layouts words vocabs slots.private
+locals locals.backend generic.single.private fry sequences
+threads.private strings.private ;
+FROM: cpu.ppc.assembler => B ;
+IN: bootstrap.ppc
+
+: jit-call ( string -- )
+ dup
+ 0 swap jit-load-dlsym
+ 0 MTLR
+ jit-load-dlsym-toc
+ BLRL ;
+
+: jit-call-quot ( -- )
+ 4 quot-entry-point-offset LI
+ 4 3 4 jit-load-cell-x
+ 4 MTLR
+ BLRL ;
+
+: jit-jump-quot ( -- )
+ 4 quot-entry-point-offset LI
+ 4 3 4 jit-load-cell-x
+ 4 MTCTR
+ BCTR ;
+
+: stack-frame ( -- n )
+ reserved-size factor-area-size + 16 align ;
+
+: save-at ( m -- n ) reserved-size + param-size + ;
+
+: save-int ( reg off -- ) [ 1 ] dip save-at jit-save-int ;
+: save-fp ( reg off -- ) [ 1 ] dip save-at STFD ;
+: save-vec ( reg offt -- ) save-at 11 swap LI 11 1 STVXL ;
+: restore-int ( reg off -- ) [ 1 ] dip save-at jit-load-int ;
+: restore-fp ( reg off -- ) [ 1 ] dip save-at LFD ;
+: restore-vec ( reg offt -- ) save-at 11 swap LI 11 1 LVXL ;
+
+! Stop using intervals here.
+: nv-fp-regs ( -- seq ) 14 31 [a,b] ;
+: nv-vec-regs ( -- seq ) 20 31 [a,b] ;
+
+: saved-fp-regs-size ( -- n ) 144 ;
+: saved-vec-regs-size ( -- n ) 192 ;
+
+: callback-frame-size ( -- n )
+ reserved-size
+ param-size +
+ saved-int-regs-size +
+ saved-fp-regs-size +
+ saved-vec-regs-size +
+ 16 align ;
+
+: old-context-save-offset ( -- n )
+ cell-size 20 * saved-fp-regs-size + saved-vec-regs-size + save-at ;
+
+[
+ ! Save old stack pointer
+ 11 1 MR
+
+ 0 MFLR ! Get return address
+ 0 1 lr-save jit-save-cell ! Stash return address
+ 1 1 callback-frame-size neg jit-save-cell-update ! Bump stack pointer and set back chain
+
+ ! Save all non-volatile registers
+ nv-int-regs [ cell-size * save-int ] each-index
+ nv-fp-regs [ 8 * saved-int-regs-size + save-fp ] each-index
+ ! nv-vec-regs [ 16 * saved-int-regs-size saved-fp-regs-size + + save-vec ] each-index
+
+ ! Stick old stack pointer in the frame register so callbacks
+ ! can access their arguments
+ frame-reg 11 MR
+
+ ! Load VM into vm-reg
+ vm-reg jit-load-vm-arg
+
+ ! Save old context
+ 0 vm-reg vm-context-offset jit-load-cell
+ 0 1 old-context-save-offset jit-save-cell
+
+ ! Switch over to the spare context
+ 11 vm-reg vm-spare-context-offset jit-load-cell
+ 11 vm-reg vm-context-offset jit-save-cell
+
+ ! Save C callstack pointer and load Factor callstack
+ 1 11 context-callstack-save-offset jit-save-cell
+ 1 11 context-callstack-bottom-offset jit-load-cell
+
+ ! Load new data and retain stacks
+ rs-reg 11 context-retainstack-offset jit-load-cell
+ ds-reg 11 context-datastack-offset jit-load-cell
+
+ ! Call into Factor code
+ 0 jit-load-entry-point-arg
+ 0 MTLR
+ BLRL
+
+ ! Load VM again, pointlessly
+ vm-reg jit-load-vm-arg
+
+ ! Load C callstack pointer
+ 11 vm-reg vm-context-offset jit-load-cell
+ 1 11 context-callstack-save-offset jit-load-cell
+
+ ! Load old context
+ 0 1 old-context-save-offset jit-load-cell
+ 0 vm-reg vm-context-offset jit-save-cell
+
+ ! Restore non-volatile registers
+ ! nv-vec-regs [ 16 * saved-int-regs-size saved-float-regs-size + + restore-vec ] each-index
+ nv-fp-regs [ 8 * saved-int-regs-size + restore-fp ] each-index
+ nv-int-regs [ cell-size * restore-int ] each-index
+
+ 1 1 callback-frame-size ADDI ! Bump stack back up
+ 0 1 lr-save jit-load-cell ! Fetch return address
+ 0 MTLR ! Set up return
+ BLR ! Branch back
+] callback-stub jit-define
+
+: jit-conditional* ( test-quot false-quot -- )
+ [ '[ 4 + @ ] ] dip jit-conditional ; inline
+
+: jit-load-context ( -- )
+ ctx-reg vm-reg vm-context-offset jit-load-cell ;
+
+: jit-save-context ( -- )
+ jit-load-context
+ 1 ctx-reg context-callstack-top-offset jit-save-cell
+ ds-reg ctx-reg context-datastack-offset jit-save-cell
+ rs-reg ctx-reg context-retainstack-offset jit-save-cell ;
+
+: jit-restore-context ( -- )
+ ds-reg ctx-reg context-datastack-offset jit-load-cell
+ rs-reg ctx-reg context-retainstack-offset jit-load-cell ;
+
+[
+ 12 jit-load-literal-arg
+ 0 profile-count-offset LI
+ 11 12 0 jit-load-cell-x
+ 11 11 1 tag-fixnum ADDI
+ 11 12 0 jit-save-cell-x
+ 0 word-code-offset LI
+ 11 12 0 jit-load-cell-x
+ 11 11 compiled-header-size ADDI
+ 11 MTCTR
+ BCTR
+] jit-profiling jit-define
+
+[
+ 0 MFLR
+ 0 1 lr-save jit-save-cell
+ 0 jit-load-this-arg
+ 0 1 cell-size 2 * neg jit-save-cell
+ 0 stack-frame LI
+ 0 1 cell-size 1 * neg jit-save-cell
+ 1 1 stack-frame neg jit-save-cell-update
+] jit-prolog jit-define
+
+[
+ 3 jit-load-literal-arg
+ 3 ds-reg cell-size jit-save-cell-update
+] jit-push jit-define
+
+[
+ jit-save-context
+ 3 vm-reg MR
+ 4 jit-load-dlsym-arg
+ 4 MTLR
+ jit-load-dlsym-toc-arg ! Restore the TOC/GOT
+ BLRL
+ jit-restore-context
+] jit-primitive jit-define
+
+[ 0 BL rc-relative-ppc-3-pc rt-entry-point-pic jit-rel ] jit-word-call jit-define
+
+[
+ 6 jit-load-here-arg
+ 0 B rc-relative-ppc-3-pc rt-entry-point-pic-tail jit-rel
+] jit-word-jump jit-define
+
+[
+ 3 ds-reg 0 jit-load-cell
+ ds-reg dup cell-size SUBI
+ 0 3 \ f type-number jit-compare-cell-imm
+ [ 0 swap BEQ ] [ 0 B rc-relative-ppc-3-pc rt-entry-point jit-rel ] jit-conditional*
+ 0 B rc-relative-ppc-3-pc rt-entry-point jit-rel
+] jit-if jit-define
+
+: jit->r ( -- )
+ 4 ds-reg 0 jit-load-cell
+ ds-reg dup cell-size SUBI
+ 4 rs-reg cell-size jit-save-cell-update ;
+
+: jit-2>r ( -- )
+ 4 ds-reg 0 jit-load-cell
+ 5 ds-reg cell-size neg jit-load-cell
+ ds-reg dup 2 cell-size * SUBI
+ rs-reg dup 2 cell-size * ADDI
+ 4 rs-reg 0 jit-save-cell
+ 5 rs-reg cell-size neg jit-save-cell ;
+
+: jit-3>r ( -- )
+ 4 ds-reg 0 jit-load-cell
+ 5 ds-reg cell-size neg jit-load-cell
+ 6 ds-reg cell-size neg 2 * jit-load-cell
+ ds-reg dup 3 cell-size * SUBI
+ rs-reg dup 3 cell-size * ADDI
+ 4 rs-reg 0 jit-save-cell
+ 5 rs-reg cell-size neg jit-save-cell
+ 6 rs-reg cell-size neg 2 * jit-save-cell ;
+
+: jit-r> ( -- )
+ 4 rs-reg 0 jit-load-cell
+ rs-reg dup cell-size SUBI
+ 4 ds-reg cell-size jit-save-cell-update ;
+
+: jit-2r> ( -- )
+ 4 rs-reg 0 jit-load-cell
+ 5 rs-reg cell-size neg jit-load-cell
+ rs-reg dup 2 cell-size * SUBI
+ ds-reg dup 2 cell-size * ADDI
+ 4 ds-reg 0 jit-save-cell
+ 5 ds-reg cell-size neg jit-save-cell ;
+
+: jit-3r> ( -- )
+ 4 rs-reg 0 jit-load-cell
+ 5 rs-reg cell-size neg jit-load-cell
+ 6 rs-reg cell-size neg 2 * jit-load-cell
+ rs-reg dup 3 cell-size * SUBI
+ ds-reg dup 3 cell-size * ADDI
+ 4 ds-reg 0 jit-save-cell
+ 5 ds-reg cell-size neg jit-save-cell
+ 6 ds-reg cell-size neg 2 * jit-save-cell ;
+
+[
+ jit->r
+ 0 BL rc-relative-ppc-3-pc rt-entry-point jit-rel
+ jit-r>
+] jit-dip jit-define
+
+[
+ jit-2>r
+ 0 BL rc-relative-ppc-3-pc rt-entry-point jit-rel
+ jit-2r>
+] jit-2dip jit-define
+
+[
+ jit-3>r
+ 0 BL rc-relative-ppc-3-pc rt-entry-point jit-rel
+ jit-3r>
+] jit-3dip jit-define
+
+[
+ 1 1 stack-frame ADDI
+ 0 1 lr-save jit-load-cell
+ 0 MTLR
+] jit-epilog jit-define
+
+[ BLR ] jit-return jit-define
+
+! ! ! Polymorphic inline caches
+
+! Don't touch r6 here; it's used to pass the tail call site
+! address for tail PICs
+
+! Load a value from a stack position
+[
+ 4 ds-reg 0 jit-load-cell rc-absolute-ppc-2 rt-untagged jit-rel
+] pic-load jit-define
+
+[ 4 4 tag-mask get ANDI. ] pic-tag jit-define
+
+[
+ 3 4 MR
+ 4 4 tag-mask get ANDI.
+ 0 4 tuple type-number jit-compare-cell-imm
+ [ 0 swap BNE ]
+ [ 4 tuple-class-offset LI 4 3 4 jit-load-cell-x ]
+ jit-conditional*
+] pic-tuple jit-define
+
+[
+ 0 4 0 jit-compare-cell-imm rc-absolute-ppc-2 rt-untagged jit-rel
+] pic-check-tag jit-define
+
+[
+ 5 jit-load-literal-arg
+ 0 4 5 jit-compare-cell
+] pic-check-tuple jit-define
+
+[
+ [ 0 swap BNE ] [ 0 B rc-relative-ppc-3-pc rt-entry-point jit-rel ] jit-conditional*
+] pic-hit jit-define
+
+! Inline cache miss entry points
+: jit-load-return-address ( -- ) 6 MFLR ;
+
+! These are always in tail position with an existing stack
+! frame, and the stack. The frame setup takes this into account.
+: jit-inline-cache-miss ( -- )
+ jit-save-context
+ 3 6 MR
+ 4 vm-reg MR
+ ctx-reg 6 MR
+ "inline_cache_miss" jit-call
+ 6 ctx-reg MR
+ jit-load-context
+ jit-restore-context ;
+
+[ jit-load-return-address jit-inline-cache-miss ]
+[ 3 MTLR BLRL ]
+[ 3 MTCTR BCTR ]
+\ inline-cache-miss define-combinator-primitive
+
+[ jit-inline-cache-miss ]
+[ 3 MTLR BLRL ]
+[ 3 MTCTR BCTR ]
+\ inline-cache-miss-tail define-combinator-primitive
+
+! ! ! Megamorphic caches
+
+[
+ ! class = ...
+ 3 4 MR
+ 4 4 tag-mask get ANDI. ! Mask and...
+ 4 4 tag-bits get jit-shift-left-logical-imm ! shift tag bits to fixnum
+ 0 4 tuple type-number tag-fixnum jit-compare-cell-imm
+ [ 0 swap BNE ]
+ [ 4 tuple-class-offset LI 4 3 4 jit-load-cell-x ]
+ jit-conditional*
+ ! cache = ...
+ 3 jit-load-literal-arg
+ ! key = hashcode(class)
+ 5 4 jit-class-hashcode
+ ! key &= cache.length - 1
+ 5 5 mega-cache-size get 1 - 4 * ANDI.
+ ! cache += array-start-offset
+ 3 3 array-start-offset ADDI
+ ! cache += key
+ 3 3 5 ADD
+ ! if(get(cache) == class)
+ 6 3 0 jit-load-cell
+ 0 6 4 jit-compare-cell
+ [ 0 swap BNE ]
+ [
+ ! megamorphic_cache_hits++
+ 4 jit-load-megamorphic-cache-arg
+ 5 4 0 jit-load-cell
+ 5 5 1 ADDI
+ 5 4 0 jit-save-cell
+ ! ... goto get(cache + cell-size)
+ 5 word-entry-point-offset LI
+ 3 3 cell-size jit-load-cell
+ 3 3 5 jit-load-cell-x
+ 3 MTCTR
+ BCTR
+ ]
+ jit-conditional*
+ ! fall-through on miss
+] mega-lookup jit-define
+
+! ! ! Sub-primitives
+
+! Quotations and words
+[
+ 3 ds-reg 0 jit-load-cell
+ ds-reg dup cell-size SUBI
+]
+[ jit-call-quot ]
+[ jit-jump-quot ] \ (call) define-combinator-primitive
+
+[
+ 3 ds-reg 0 jit-load-cell
+ ds-reg dup cell-size SUBI
+ 4 word-entry-point-offset LI
+ 4 3 4 jit-load-cell-x
+]
+[ 4 MTLR BLRL ]
+[ 4 MTCTR BCTR ] \ (execute) define-combinator-primitive
+
+[
+ 3 ds-reg 0 jit-load-cell
+ ds-reg dup cell-size SUBI
+ 4 word-entry-point-offset LI
+ 4 3 4 jit-load-cell-x
+ 4 MTCTR BCTR
+] jit-execute jit-define
+
+! Special primitives
+[
+ frame-reg 3 MR
+
+ 3 vm-reg MR
+ "begin_callback" jit-call
+
+ jit-load-context
+ jit-restore-context
+
+ ! Call quotation
+ 3 frame-reg MR
+ jit-call-quot
+
+ jit-save-context
+
+ 3 vm-reg MR
+ "end_callback" jit-call
+] \ c-to-factor define-sub-primitive
+
+[
+ ! Unwind stack frames
+ 1 4 MR
+
+ ! Load VM pointer into vm-reg, since we're entering from
+ ! C code
+ vm-reg jit-load-vm
+
+ ! Load ds and rs registers
+ jit-load-context
+ jit-restore-context
+
+ ! We have changed the stack; load return address again
+ 0 1 lr-save jit-load-cell
+ 0 MTLR
+
+ ! Call quotation
+ jit-jump-quot
+] \ unwind-native-frames define-sub-primitive
+
+[
+ 7 0 LI
+ 7 1 lr-save jit-save-cell
+
+ ! Load callstack object
+ 6 ds-reg 0 jit-load-cell
+ ds-reg ds-reg cell-size SUBI
+ ! Get ctx->callstack_bottom
+ jit-load-context
+ 3 ctx-reg context-callstack-bottom-offset jit-load-cell
+ ! Get top of callstack object -- 'src' for memcpy
+ 4 6 callstack-top-offset ADDI
+ ! Get callstack length, in bytes --- 'len' for memcpy
+ 7 callstack-length-offset LI
+ 5 6 7 jit-load-cell-x
+ 5 5 jit-shift-tag-bits
+ ! Compute new stack pointer -- 'dst' for memcpy
+ 3 3 5 SUB
+ ! Install new stack pointer
+ 1 3 MR
+ ! Call memcpy; arguments are now in the correct registers
+ 1 1 -16 cell-size * jit-save-cell-update
+ "factor_memcpy" jit-call
+ 1 1 0 jit-load-cell
+ ! Return with new callstack
+ 0 1 lr-save jit-load-cell
+ 0 MTLR
+ BLR
+] \ set-callstack define-sub-primitive
+
+[
+ jit-save-context
+ 4 vm-reg MR
+ "lazy_jit_compile" jit-call
+]
+[ jit-call-quot ]
+[ jit-jump-quot ]
+\ lazy-jit-compile define-combinator-primitive
+
+! Objects
+[
+ 3 ds-reg 0 jit-load-cell
+ 3 3 tag-mask get ANDI.
+ 3 3 tag-bits get jit-shift-left-logical-imm
+ 3 ds-reg 0 jit-save-cell
+] \ tag define-sub-primitive
+
+[
+ 3 ds-reg 0 jit-load-cell ! Load m
+ 4 ds-reg cell-size neg jit-load-cell-update ! Load obj
+ 3 3 jit-shift-fixnum-slot ! Shift to a cell-size multiple
+ 4 4 jit-mask-tag-bits ! Clear tag bits on obj
+ 3 4 3 jit-load-cell-x ! Load cell at &obj[m]
+ 3 ds-reg 0 jit-save-cell ! Push the result to the stack
+] \ slot define-sub-primitive
+
+[
+ ! load string index from stack
+ 3 ds-reg cell-size neg jit-load-cell
+ 3 3 jit-shift-tag-bits
+ ! load string from stack
+ 4 ds-reg 0 jit-load-cell
+ ! load character
+ 4 4 string-offset ADDI
+ 3 3 4 LBZX
+ 3 3 tag-bits get jit-shift-left-logical-imm
+ ! store character to stack
+ ds-reg ds-reg cell-size SUBI
+ 3 ds-reg 0 jit-save-cell
+] \ string-nth-fast define-sub-primitive
+
+! Shufflers
+[
+ ds-reg dup cell-size SUBI
+] \ drop define-sub-primitive
+
+[
+ ds-reg dup 2 cell-size * SUBI
+] \ 2drop define-sub-primitive
+
+[
+ ds-reg dup 3 cell-size * SUBI
+] \ 3drop define-sub-primitive
+
+[
+ 3 ds-reg 0 jit-load-cell
+ 3 ds-reg cell-size jit-save-cell-update
+] \ dup define-sub-primitive
+
+[
+ 3 ds-reg 0 jit-load-cell
+ 4 ds-reg cell-size neg jit-load-cell
+ ds-reg dup 2 cell-size * ADDI
+ 3 ds-reg 0 jit-save-cell
+ 4 ds-reg cell-size neg jit-save-cell
+] \ 2dup define-sub-primitive
+
+[
+ 3 ds-reg 0 jit-load-cell
+ 4 ds-reg cell-size neg jit-load-cell
+ 5 ds-reg cell-size neg 2 * jit-load-cell
+ ds-reg dup cell-size 3 * ADDI
+ 3 ds-reg 0 jit-save-cell
+ 4 ds-reg cell-size neg jit-save-cell
+ 5 ds-reg cell-size neg 2 * jit-save-cell
+] \ 3dup define-sub-primitive
+
+[
+ 3 ds-reg 0 jit-load-cell
+ ds-reg dup cell-size SUBI
+ 3 ds-reg 0 jit-save-cell
+] \ nip define-sub-primitive
+
+[
+ 3 ds-reg 0 jit-load-cell
+ ds-reg dup cell-size 2 * SUBI
+ 3 ds-reg 0 jit-save-cell
+] \ 2nip define-sub-primitive
+
+[
+ 3 ds-reg cell-size neg jit-load-cell
+ 3 ds-reg cell-size jit-save-cell-update
+] \ over define-sub-primitive
+
+[
+ 3 ds-reg cell-size neg 2 * jit-load-cell
+ 3 ds-reg cell-size jit-save-cell-update
+] \ pick define-sub-primitive
+
+[
+ 3 ds-reg 0 jit-load-cell
+ 4 ds-reg cell-size neg jit-load-cell
+ 4 ds-reg 0 jit-save-cell
+ 3 ds-reg cell-size jit-save-cell-update
+] \ dupd define-sub-primitive
+
+[
+ 3 ds-reg 0 jit-load-cell
+ 4 ds-reg cell-size neg jit-load-cell
+ 3 ds-reg cell-size neg jit-save-cell
+ 4 ds-reg 0 jit-save-cell
+] \ swap define-sub-primitive
+
+[
+ 3 ds-reg cell-size neg jit-load-cell
+ 4 ds-reg cell-size neg 2 * jit-load-cell
+ 3 ds-reg cell-size neg 2 * jit-save-cell
+ 4 ds-reg cell-size neg jit-save-cell
+] \ swapd define-sub-primitive
+
+[
+ 3 ds-reg 0 jit-load-cell
+ 4 ds-reg cell-size neg jit-load-cell
+ 5 ds-reg cell-size neg 2 * jit-load-cell
+ 4 ds-reg cell-size neg 2 * jit-save-cell
+ 3 ds-reg cell-size neg jit-save-cell
+ 5 ds-reg 0 jit-save-cell
+] \ rot define-sub-primitive
+
+[
+ 3 ds-reg 0 jit-load-cell
+ 4 ds-reg cell-size neg jit-load-cell
+ 5 ds-reg cell-size neg 2 * jit-load-cell
+ 3 ds-reg cell-size neg 2 * jit-save-cell
+ 5 ds-reg cell-size neg jit-save-cell
+ 4 ds-reg 0 jit-save-cell
+] \ -rot define-sub-primitive
+
+[ jit->r ] \ load-local define-sub-primitive
+
+! Comparisons
+: jit-compare ( insn -- )
+ t jit-literal
+ 3 jit-load-literal-arg
+ 4 ds-reg 0 jit-load-cell
+ 5 ds-reg cell-size neg jit-load-cell-update
+ 0 5 4 jit-compare-cell
+ [ 0 8 ] dip execute( cr offset -- )
+ 3 \ f type-number LI
+ 3 ds-reg 0 jit-save-cell ;
+
+: define-jit-compare ( insn word -- )
+ [ [ jit-compare ] curry ] dip define-sub-primitive ;
+
+\ BEQ \ eq? define-jit-compare
+\ BGE \ fixnum>= define-jit-compare
+\ BLE \ fixnum<= define-jit-compare
+\ BGT \ fixnum> define-jit-compare
+\ BLT \ fixnum< define-jit-compare
+
+! Math
+[
+ 3 ds-reg 0 jit-load-cell
+ ds-reg ds-reg cell-size SUBI
+ 4 ds-reg 0 jit-load-cell
+ 3 3 4 OR
+ 3 3 tag-mask get ANDI.
+ 4 \ f type-number LI
+ 0 3 0 jit-compare-cell-imm
+ [ 0 swap BNE ] [ 4 1 tag-fixnum LI ] jit-conditional*
+ 4 ds-reg 0 jit-save-cell
+] \ both-fixnums? define-sub-primitive
+
+: jit-math ( insn -- )
+ 3 ds-reg 0 jit-load-cell
+ 4 ds-reg cell-size neg jit-load-cell-update
+ [ 5 3 4 ] dip execute( dst src1 src2 -- )
+ 5 ds-reg 0 jit-save-cell ;
+
+[ \ ADD jit-math ] \ fixnum+fast define-sub-primitive
+
+[ \ SUBF jit-math ] \ fixnum-fast define-sub-primitive
+
+[
+ 3 ds-reg 0 jit-load-cell
+ 4 ds-reg cell-size neg jit-load-cell-update
+ 4 4 jit-shift-tag-bits
+ 5 3 4 jit-multiply-low
+ 5 ds-reg 0 jit-save-cell
+] \ fixnum*fast define-sub-primitive
+
+[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive
+
+[ \ OR jit-math ] \ fixnum-bitor define-sub-primitive
+
+[ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive
+
+[
+ 3 ds-reg 0 jit-load-cell
+ 3 3 NOT
+ 3 3 tag-mask get XORI
+ 3 ds-reg 0 jit-save-cell
+] \ fixnum-bitnot define-sub-primitive
+
+[
+ 3 ds-reg 0 jit-load-cell ! Load amount to shift
+ 3 3 jit-shift-tag-bits ! Shift out tag bits
+ ds-reg ds-reg cell-size SUBI
+ 4 ds-reg 0 jit-load-cell ! Load value to shift
+ 5 4 3 jit-shift-left-logical ! Shift left
+ 6 3 NEG ! Negate shift amount
+ 7 4 6 jit-shift-right-algebraic ! Shift right
+ 7 7 jit-mask-tag-bits ! Mask out tag bits
+ 0 3 0 jit-compare-cell-imm
+ [ 0 swap BGT ] [ 5 7 MR ] jit-conditional*
+ 5 ds-reg 0 jit-save-cell
+] \ fixnum-shift-fast define-sub-primitive
+
+[
+ 3 ds-reg 0 jit-load-cell
+ ds-reg ds-reg cell-size SUBI
+ 4 ds-reg 0 jit-load-cell
+ 5 4 3 jit-divide
+ 6 5 3 jit-multiply-low
+ 7 4 6 SUB
+ 7 ds-reg 0 jit-save-cell
+] \ fixnum-mod define-sub-primitive
+
+[
+ 3 ds-reg 0 jit-load-cell
+ ds-reg ds-reg cell-size SUBI
+ 4 ds-reg 0 jit-load-cell
+ 5 4 3 jit-divide
+ 5 5 tag-bits get jit-shift-left-logical-imm
+ 5 ds-reg 0 jit-save-cell
+] \ fixnum/i-fast define-sub-primitive
+
+[
+ 3 ds-reg 0 jit-load-cell
+ 4 ds-reg cell-size neg jit-load-cell
+ 5 4 3 jit-divide
+ 6 5 3 jit-multiply-low
+ 7 4 6 SUB
+ 5 5 tag-bits get jit-shift-left-logical-imm
+ 5 ds-reg cell-size neg jit-save-cell
+ 7 ds-reg 0 jit-save-cell
+] \ fixnum/mod-fast define-sub-primitive
+
+[
+ 3 ds-reg 0 jit-load-cell
+ 3 3 jit-shift-fixnum-slot
+ 3 rs-reg 3 jit-load-cell-x
+ 3 ds-reg 0 jit-save-cell
+] \ get-local define-sub-primitive
+
+[
+ 3 ds-reg 0 jit-load-cell
+ ds-reg ds-reg cell-size SUBI
+ 3 3 jit-shift-fixnum-slot
+ rs-reg rs-reg 3 SUB
+] \ drop-locals define-sub-primitive
+
+! Overflowing fixnum arithmetic
+:: jit-overflow ( insn func -- )
+ ds-reg ds-reg cell-size SUBI
+ jit-save-context
+ 3 ds-reg 0 jit-load-cell
+ 4 ds-reg cell-size jit-load-cell
+ 0 0 LI
+ 0 MTXER
+ 6 4 3 insn call( d a s -- )
+ 6 ds-reg 0 jit-save-cell
+ [ 0 swap BNS ]
+ [
+ 5 vm-reg MR
+ func jit-call
+ ]
+ jit-conditional* ;
+
+[ [ ADDO. ] "overflow_fixnum_add" jit-overflow ] \ fixnum+ define-sub-primitive
+
+[ [ SUBFO. ] "overflow_fixnum_subtract" jit-overflow ] \ fixnum- define-sub-primitive
+
+[
+ ds-reg ds-reg cell-size SUBI
+ jit-save-context
+ 3 ds-reg 0 jit-load-cell
+ 3 3 jit-shift-tag-bits
+ 4 ds-reg cell-size jit-load-cell
+ 0 0 LI
+ 0 MTXER
+ 6 3 4 jit-multiply-low-ov-rc
+ 6 ds-reg 0 jit-save-cell
+ [ 0 swap BNS ]
+ [
+ 4 4 jit-shift-tag-bits
+ 5 vm-reg MR
+ "overflow_fixnum_multiply" jit-call
+ ]
+ jit-conditional*
+] \ fixnum* define-sub-primitive
+
+! Contexts
+:: jit-switch-context ( reg -- )
+ 7 0 LI
+ 7 1 lr-save jit-save-cell
+
+ ! Make the new context the current one
+ ctx-reg reg MR
+ ctx-reg vm-reg vm-context-offset jit-save-cell
+
+ ! Load new stack pointer
+ 1 ctx-reg context-callstack-top-offset jit-load-cell
+
+ ! Load new ds, rs registers
+ jit-restore-context ;
+
+: jit-pop-context-and-param ( -- )
+ 3 ds-reg 0 jit-load-cell
+ 4 alien-offset LI
+ 3 3 4 jit-load-cell-x
+ 4 ds-reg cell-size neg jit-load-cell
+ ds-reg ds-reg cell-size 2 * SUBI ;
+
+: jit-push-param ( -- )
+ ds-reg ds-reg cell-size ADDI
+ 4 ds-reg 0 jit-save-cell ;
+
+: jit-set-context ( -- )
+ jit-pop-context-and-param
+ jit-save-context
+ 3 jit-switch-context
+ jit-push-param ;
+
+[ jit-set-context ] \ (set-context) define-sub-primitive
+
+: jit-pop-quot-and-param ( -- )
+ 3 ds-reg 0 jit-load-cell
+ 4 ds-reg cell-size neg jit-load-cell
+ ds-reg ds-reg cell-size 2 * SUBI ;
+
+: jit-start-context ( -- )
+ ! Create the new context in return-reg. Have to save context
+ ! twice, first before calling new_context() which may GC,
+ ! and again after popping the two parameters from the stack.
+ jit-save-context
+ 3 vm-reg MR
+ "new_context" jit-call
+
+ 6 3 MR
+ jit-pop-quot-and-param
+ jit-save-context
+ 6 jit-switch-context
+ jit-push-param
+ jit-jump-quot ;
+
+[ jit-start-context ] \ (start-context) define-sub-primitive
+
+: jit-delete-current-context ( -- )
+ jit-load-context
+ 3 vm-reg MR
+ 4 ctx-reg MR
+ "delete_context" jit-call ;
+
+[
+ jit-delete-current-context
+ jit-set-context
+] \ (set-context-and-delete) define-sub-primitive
+
+: jit-start-context-and-delete ( -- )
+ jit-load-context
+ 3 vm-reg MR
+ 4 ctx-reg MR
+ "reset_context" jit-call
+ jit-pop-quot-and-param
+ ctx-reg jit-switch-context
+ jit-push-param
+ jit-jump-quot ;
+
+[
+ jit-start-context-and-delete
+] \ (start-context-and-delete) define-sub-primitive
+
+[ "bootstrap.ppc" forget-vocab ] with-compilation-unit
--- /dev/null
+! Copyright (C) 2011 Erik Charlebois
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs sequences kernel combinators
+classes.algebra byte-arrays make math math.order math.ranges
+system namespaces locals layouts words alien alien.accessors
+alien.c-types alien.complex alien.data alien.libraries
+literals cpu.architecture cpu.ppc.assembler
+compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.comparisons compiler.codegen.fixup
+compiler.cfg.intrinsics compiler.cfg.stack-frame
+compiler.cfg.build-stack-frame compiler.units compiler.constants
+compiler.codegen vm memory fry io prettyprint ;
+QUALIFIED-WITH: alien.c-types c
+FROM: cpu.ppc.assembler => B ;
+FROM: layouts => cell ;
+FROM: math => float ;
+IN: cpu.ppc
+
+! PowerPC register assignments:
+! r0: reserved for function prolog/epilogues
+! r1: call stack register
+! r2: toc register / system reserved
+! r3-r12: integer vregs
+! r13: reserved by OS
+! r14: data stack
+! r15: retain stack
+! r16: VM pointer
+! r17-r29: integer vregs
+! r30: integer scratch
+! r31: frame register
+! f0-f29: float vregs
+! f30: float scratch
+! f31: ?
+
+HOOK: lr-save os ( -- n )
+HOOK: has-toc os ( -- ? )
+HOOK: reserved-area-size os ( -- n )
+HOOK: allows-null-dereference os ( -- ? )
+
+M: label B ( label -- ) [ 0 B ] dip rc-relative-ppc-3-pc label-fixup ;
+M: label BL ( label -- ) [ 0 BL ] dip rc-relative-ppc-3-pc label-fixup ;
+M: label BC ( bo bi label -- ) [ 0 BC ] dip rc-relative-ppc-2-pc label-fixup ;
+
+CONSTANT: scratch-reg 30
+CONSTANT: fp-scratch-reg 30
+CONSTANT: ds-reg 14
+CONSTANT: rs-reg 15
+CONSTANT: vm-reg 16
+
+enable-float-intrinsics
+
+M: ppc vector-regs ( -- reg-class )
+ float-regs ;
+
+M: ppc machine-registers ( -- assoc )
+ {
+ { int-regs $[ 3 12 [a,b] 17 29 [a,b] append ] }
+ { float-regs $[ 0 29 [a,b] ] }
+ } ;
+
+M: ppc frame-reg ( -- reg ) 31 ;
+M: ppc.32 vm-stack-space ( -- n ) 16 ;
+M: ppc.64 vm-stack-space ( -- n ) 32 ;
+M: ppc complex-addressing? ( -- ? ) f ;
+
+! PW1-PW8 parameter save slots
+: param-save-size ( -- n ) 8 cells ; foldable
+! here be spill slots
+! xt, size
+: factor-area-size ( -- n ) 2 cells ; foldable
+
+: spill@ ( n -- offset )
+ spill-offset reserved-area-size + param-save-size + ;
+
+: param@ ( n -- offset )
+ reserved-area-size + ;
+
+M: ppc gc-root-offset ( spill-slot -- n )
+ n>> spill@ cell /i ;
+
+: LOAD32 ( r n -- )
+ [ -16 shift HEX: ffff bitand LIS ]
+ [ [ dup ] dip HEX: ffff bitand ORI ] 2bi ;
+
+: LOAD64 ( r n -- )
+ [ dup ] dip {
+ [ nip -48 shift HEX: ffff bitand LIS ]
+ [ -32 shift HEX: ffff bitand ORI ]
+ [ drop 32 SLDI ]
+ [ -16 shift HEX: ffff bitand ORIS ]
+ [ HEX: ffff bitand ORI ]
+ } 3cleave ;
+
+HOOK: %clear-tag-bits cpu ( dst src -- )
+M: ppc.32 %clear-tag-bits tag-bits get CLRRWI ;
+M: ppc.64 %clear-tag-bits tag-bits get CLRRDI ;
+
+HOOK: %store-cell cpu ( dst src offset -- )
+M: ppc.32 %store-cell STW ;
+M: ppc.64 %store-cell STD ;
+
+HOOK: %store-cell-x cpu ( dst src offset -- )
+M: ppc.32 %store-cell-x STWX ;
+M: ppc.64 %store-cell-x STDX ;
+
+HOOK: %store-cell-update cpu ( dst src offset -- )
+M: ppc.32 %store-cell-update STWU ;
+M: ppc.64 %store-cell-update STDU ;
+
+HOOK: %load-cell cpu ( dst src offset -- )
+M: ppc.32 %load-cell LWZ ;
+M: ppc.64 %load-cell LD ;
+
+HOOK: %trap-null cpu ( src -- )
+M: ppc.32 %trap-null
+ allows-null-dereference [ 0 TWEQI ] [ drop ] if ;
+M: ppc.64 %trap-null
+ allows-null-dereference [ 0 TDEQI ] [ drop ] if ;
+
+HOOK: %load-cell-x cpu ( dst src offset -- )
+M: ppc.32 %load-cell-x LWZX ;
+M: ppc.64 %load-cell-x LDX ;
+
+HOOK: %load-cell-imm cpu ( dst imm -- )
+M: ppc.32 %load-cell-imm LOAD32 ;
+M: ppc.64 %load-cell-imm LOAD64 ;
+
+HOOK: %compare-cell cpu ( cr lhs rhs -- )
+M: ppc.32 %compare-cell CMPW ;
+M: ppc.64 %compare-cell CMPD ;
+
+HOOK: %compare-cell-imm cpu ( cr lhs imm -- )
+M: ppc.32 %compare-cell-imm CMPWI ;
+M: ppc.64 %compare-cell-imm CMPDI ;
+
+HOOK: %load-cell-imm-rc cpu ( -- rel-class )
+M: ppc.32 %load-cell-imm-rc rc-absolute-ppc-2/2 ;
+M: ppc.64 %load-cell-imm-rc rc-absolute-ppc-2/2/2/2 ;
+
+M: ppc.32 %load-immediate ( reg val -- )
+ dup HEX: -8000 HEX: 7fff between? [ LI ] [ LOAD32 ] if ;
+M: ppc.64 %load-immediate ( reg val -- )
+ dup HEX: -8000 HEX: 7fff between? [ LI ] [ LOAD64 ] if ;
+
+M: ppc %load-reference ( reg obj -- )
+ [ [ 0 %load-cell-imm ] [ %load-cell-imm-rc rel-literal ] bi* ]
+ [ \ f type-number LI ]
+ if* ;
+
+M:: ppc %load-float ( dst val -- )
+ scratch-reg 0 %load-cell-imm val %load-cell-imm-rc rel-binary-literal
+ dst scratch-reg 0 LFS ;
+
+M:: ppc %load-double ( dst val -- )
+ scratch-reg 0 %load-cell-imm val %load-cell-imm-rc rel-binary-literal
+ dst scratch-reg 0 LFD ;
+
+M:: ppc %load-vector ( dst val rep -- )
+ scratch-reg 0 %load-cell-imm val %load-cell-imm-rc rel-binary-literal
+ dst 0 scratch-reg LVX ;
+
+GENERIC: loc-reg ( loc -- reg )
+M: ds-loc loc-reg drop ds-reg ;
+M: rs-loc loc-reg drop rs-reg ;
+
+! Load value at stack location loc into vreg.
+M: ppc %peek ( vreg loc -- )
+ [ loc-reg ] [ n>> cells neg ] bi %load-cell ;
+
+! Replace value at stack location loc with value in vreg.
+M: ppc %replace ( vreg loc -- )
+ [ loc-reg ] [ n>> cells neg ] bi %store-cell ;
+
+! Replace value at stack location with an immediate value.
+M:: ppc %replace-imm ( src loc -- )
+ loc loc-reg :> reg
+ loc n>> cells neg :> offset
+ src {
+ { [ dup not ] [
+ drop scratch-reg \ f type-number LI ] }
+ { [ dup fixnum? ] [
+ [ scratch-reg ] dip tag-fixnum LI ] }
+ [ scratch-reg 0 LI rc-absolute rel-literal ]
+ } cond
+ scratch-reg reg offset %store-cell ;
+
+! Increment data stack pointer by n cells.
+M: ppc %inc-d ( n -- )
+ [ ds-reg ds-reg ] dip cells ADDI ;
+
+! Increment retain stack pointer by n cells.
+M: ppc %inc-r ( n -- )
+ [ rs-reg rs-reg ] dip cells ADDI ;
+
+M: ppc stack-frame-size ( stack-frame -- i )
+ (stack-frame-size)
+ reserved-area-size +
+ param-save-size +
+ factor-area-size +
+ 16 align ;
+
+M: ppc %call ( word -- )
+ 0 BL rc-relative-ppc-3-pc rel-word-pic ;
+
+: instrs ( n -- b ) 4 * ; inline
+
+M: ppc %jump ( word -- )
+ 6 0 %load-cell-imm 1 instrs %load-cell-imm-rc rel-here
+ 0 B rc-relative-ppc-3-pc rel-word-pic-tail ;
+
+M: ppc %dispatch ( src temp -- )
+ [ nip 0 %load-cell-imm 3 instrs %load-cell-imm-rc rel-here ]
+ [ swap dupd %load-cell-x ]
+ [ nip MTCTR ] 2tri BCTR ;
+
+M: ppc %slot ( dst obj slot scale tag -- )
+ [ 0 assert= ] bi@ %load-cell-x ;
+
+M: ppc %slot-imm ( dst obj slot tag -- )
+ slot-offset scratch-reg swap LI
+ scratch-reg %load-cell-x ;
+
+M: ppc %set-slot ( src obj slot scale tag -- )
+ [ 0 assert= ] bi@ %store-cell-x ;
+
+M: ppc %set-slot-imm ( src obj slot tag -- )
+ slot-offset [ scratch-reg ] dip LI scratch-reg %store-cell-x ;
+
+M: ppc %jump-label B ;
+M: ppc %return BLR ;
+M: ppc %add ADD ;
+M: ppc %add-imm ADDI ;
+M: ppc %sub SUB ;
+M: ppc %sub-imm SUBI ;
+M: ppc.32 %mul MULLW ;
+M: ppc.64 %mul MULLD ;
+M: ppc %mul-imm MULLI ;
+M: ppc %and AND ;
+M: ppc %and-imm ANDI. ;
+M: ppc %or OR ;
+M: ppc %or-imm ORI ;
+M: ppc %xor XOR ;
+M: ppc %xor-imm XORI ;
+M: ppc.32 %shl SLW ;
+M: ppc.64 %shl SLD ;
+M: ppc.32 %shl-imm SLWI ;
+M: ppc.64 %shl-imm SLDI ;
+M: ppc.32 %shr SRW ;
+M: ppc.64 %shr SRD ;
+M: ppc.32 %shr-imm SRWI ;
+M: ppc.64 %shr-imm SRDI ;
+M: ppc.32 %sar SRAW ;
+M: ppc.64 %sar SRAD ;
+M: ppc.32 %sar-imm SRAWI ;
+M: ppc.64 %sar-imm SRADI ;
+M: ppc.32 %min [ 0 CMPW ] [ 0 ISEL ] 2bi ;
+M: ppc.64 %min [ 0 CMPD ] [ 0 ISEL ] 2bi ;
+M: ppc.32 %max [ 0 CMPW ] [ swap 0 ISEL ] 2bi ;
+M: ppc.64 %max [ 0 CMPD ] [ swap 0 ISEL ] 2bi ;
+M: ppc %not NOT ;
+M: ppc %neg NEG ;
+M: ppc.32 %log2 [ CNTLZW ] [ drop dup NEG ] [ drop dup 31 ADDI ] 2tri ;
+M: ppc.64 %log2 [ CNTLZD ] [ drop dup NEG ] [ drop dup 63 ADDI ] 2tri ;
+M: ppc.32 %bit-count POPCNTW ;
+M: ppc.64 %bit-count POPCNTD ;
+
+M: ppc %copy ( dst src rep -- )
+ 2over eq? [ 3drop ] [
+ {
+ { tagged-rep [ MR ] }
+ { int-rep [ MR ] }
+ { float-rep [ FMR ] }
+ { double-rep [ FMR ] }
+ { vector-rep [ dup VOR ] }
+ { scalar-rep [ dup VOR ] }
+ } case
+ ] if ;
+
+:: overflow-template ( label dst src1 src2 cc insn -- )
+ scratch-reg 0 LI
+ scratch-reg MTXER
+ dst src2 src1 insn call
+ cc {
+ { cc-o [ 0 label BSO ] }
+ { cc/o [ 0 label BNS ] }
+ } case ; inline
+
+M: ppc %fixnum-add ( label dst src1 src2 cc -- )
+ [ ADDO. ] overflow-template ;
+
+M: ppc %fixnum-sub ( label dst src1 src2 cc -- )
+ [ SUBFO. ] overflow-template ;
+
+M: ppc.32 %fixnum-mul ( label dst src1 src2 cc -- )
+ [ MULLWO. ] overflow-template ;
+M: ppc.64 %fixnum-mul ( label dst src1 src2 cc -- )
+ [ MULLDO. ] overflow-template ;
+
+M: ppc %add-float FADD ;
+M: ppc %sub-float FSUB ;
+M: ppc %mul-float FMUL ;
+M: ppc %div-float FDIV ;
+
+M: ppc %min-float ( dst src1 src2 -- )
+ 2dup [ scratch-reg ] 2dip FSUB
+ [ scratch-reg ] 2dip FSEL ;
+
+M: ppc %max-float ( dst src1 src2 -- )
+ 2dup [ scratch-reg ] 2dip FSUB
+ [ scratch-reg ] 2dip FSEL ;
+
+M: ppc %sqrt FSQRT ;
+M: ppc %single>double-float FMR ;
+M: ppc %double>single-float FRSP ;
+
+M: ppc integer-float-needs-stack-frame? t ;
+
+: scratch@ ( n -- offset )
+ reserved-area-size + ;
+
+M:: ppc.32 %integer>float ( dst src -- )
+ ! Sign extend to a doubleword and store.
+ scratch-reg src 31 %sar-imm
+ scratch-reg 1 0 scratch@ STW
+ src 1 4 scratch@ STW
+ ! Load back doubleword into FPR and convert from integer.
+ dst 1 0 scratch@ LFD
+ dst dst FCFID ;
+
+M:: ppc.64 %integer>float ( dst src -- )
+ src 1 0 scratch@ STD
+ dst 1 0 scratch@ LFD
+ dst dst FCFID ;
+
+M:: ppc.32 %float>integer ( dst src -- )
+ fp-scratch-reg src FRIZ
+ fp-scratch-reg fp-scratch-reg FCTIWZ
+ fp-scratch-reg 1 0 scratch@ STFD
+ dst 1 4 scratch@ LWZ ;
+
+M:: ppc.64 %float>integer ( dst src -- )
+ fp-scratch-reg src FRIZ
+ fp-scratch-reg fp-scratch-reg FCTID
+ fp-scratch-reg 1 0 scratch@ STFD
+ dst 1 0 scratch@ LD ;
+
+! Scratch registers by register class.
+: scratch-regs ( -- regs )
+ {
+ { int-regs { 30 } }
+ { float-regs { 30 } }
+ } ;
+
+! Return values of this class go here
+M: ppc return-regs ( -- regs )
+ {
+ { int-regs { 3 4 5 6 } }
+ { float-regs { 1 2 3 4 } }
+ } ;
+
+! Is this structure small enough to be returned in registers?
+M: ppc return-struct-in-registers? ( c-type -- ? )
+ c-type return-in-registers?>> ;
+
+! If t, floats are never passed in param regs
+M: ppc float-on-stack? ( -- ? ) f ;
+
+! If t, the struct return pointer is never passed in a param reg
+M: ppc struct-return-on-stack? ( -- ? ) f ;
+
+GENERIC: load-param ( reg src -- )
+M: integer load-param ( reg src -- ) int-rep %copy ;
+M: spill-slot load-param ( reg src -- ) [ 1 ] dip n>> spill@ %load-cell ;
+
+GENERIC: store-param ( reg dst -- )
+M: integer store-param ( reg dst -- ) swap int-rep %copy ;
+M: spill-slot store-param ( reg dst -- ) [ 1 ] dip n>> spill@ %store-cell ;
+
+M:: ppc %unbox ( dst src func rep -- )
+ 3 src load-param
+ 4 vm-reg MR
+ func f f %c-invoke
+ 3 dst store-param ;
+
+M:: ppc %unbox-long-long ( dst1 dst2 src func -- )
+ 3 src load-param
+ 4 vm-reg MR
+ func f f %c-invoke
+ 3 dst1 store-param
+ 4 dst2 store-param ;
+
+M:: ppc %local-allot ( dst size align offset -- )
+ dst 1 offset local-allot-offset reserved-area-size + ADDI ;
+
+: param-reg ( n rep -- reg )
+ reg-class-of cdecl param-regs at nth ;
+
+M:: ppc %box ( dst src func rep gc-map -- )
+ 3 src load-param
+ 4 vm-reg MR
+ func f gc-map %c-invoke
+ 3 dst store-param ;
+
+M:: ppc %box-long-long ( dst src1 src2 func gc-map -- )
+ 3 src1 load-param
+ 4 src2 load-param
+ 5 vm-reg MR
+ func f gc-map %c-invoke
+ 3 dst store-param ;
+
+M:: ppc %save-context ( temp1 temp2 -- )
+ temp1 %context
+ 1 temp1 "callstack-top" context-field-offset %store-cell
+ ds-reg temp1 "datastack" context-field-offset %store-cell
+ rs-reg temp1 "retainstack" context-field-offset %store-cell ;
+
+M:: ppc %c-invoke ( name dll gc-map -- )
+ 11 0 %load-cell-imm name dll %load-cell-imm-rc rel-dlsym
+ has-toc [
+ 2 0 %load-cell-imm name dll %load-cell-imm-rc rel-dlsym-toc
+ ] when
+ 11 MTCTR
+ BCTRL
+ gc-map gc-map-here ;
+
+: return-reg ( rep -- reg )
+ reg-class-of return-regs at first ;
+
+: scratch-reg-class ( rep -- reg )
+ reg-class-of scratch-regs at first ;
+
+:: store-stack-param ( vreg rep n -- )
+ rep scratch-reg-class rep vreg %reload
+ rep scratch-reg-class n param@ rep {
+ { int-rep [ [ 1 ] dip %store-cell ] }
+ { tagged-rep [ [ 1 ] dip %store-cell ] }
+ { float-rep [ [ 1 ] dip STFS ] }
+ { double-rep [ [ 1 ] dip STFD ] }
+ { vector-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
+ { scalar-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
+ } case ;
+
+:: store-reg-param ( vreg rep reg -- )
+ reg rep vreg %reload ;
+
+: discard-reg-param ( rep reg -- )
+ 2drop ;
+
+:: load-reg-param ( vreg rep reg -- )
+ reg rep vreg %spill ;
+
+:: load-stack-param ( vreg rep n -- )
+ rep scratch-reg-class n param@ rep {
+ { int-rep [ [ frame-reg ] dip %load-cell ] }
+ { tagged-rep [ [ frame-reg ] dip %load-cell ] }
+ { float-rep [ [ frame-reg ] dip LFS ] }
+ { double-rep [ [ frame-reg ] dip LFD ] }
+ { vector-rep [ scratch-reg swap LI frame-reg scratch-reg LVX ] }
+ { scalar-rep [ scratch-reg swap LI frame-reg scratch-reg LVX ] }
+ } case
+ rep scratch-reg-class rep vreg %spill ;
+
+:: emit-alien-insn ( reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size quot -- )
+ stack-inputs [ first3 store-stack-param ] each
+ reg-inputs [ first3 store-reg-param ] each
+ quot call
+ reg-outputs [ first3 load-reg-param ] each
+ dead-outputs [ first2 discard-reg-param ] each
+ ; inline
+
+M: ppc %alien-invoke ( reg-inputs stack-inputs reg-outputs
+ dead-outputs cleanup stack-size
+ symbols dll gc-map -- )
+ '[ _ _ _ %c-invoke ] emit-alien-insn ;
+
+M:: ppc %alien-indirect ( src reg-inputs stack-inputs
+ reg-outputs dead-outputs cleanup
+ stack-size gc-map -- )
+ reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size [
+ has-toc [
+ 11 src load-param
+ 2 11 1 cells %load-cell
+ 11 11 0 cells %load-cell
+ ] [
+ 11 src load-param
+ ] if
+ 11 MTCTR
+ BCTRL
+ gc-map gc-map-here
+ ] emit-alien-insn ;
+
+M: ppc %alien-assembly ( reg-inputs stack-inputs reg-outputs
+ dead-outputs cleanup stack-size quot
+ gc-map -- )
+ '[ _ _ gc-map set call( -- ) ] emit-alien-insn ;
+
+M: ppc %callback-inputs ( reg-outputs stack-outputs -- )
+ [ [ first3 load-reg-param ] each ]
+ [ [ first3 load-stack-param ] each ] bi*
+ 3 vm-reg MR
+ 4 0 LI
+ "begin_callback" f f %c-invoke ;
+
+M: ppc %callback-outputs ( reg-inputs -- )
+ 3 vm-reg MR
+ "end_callback" f f %c-invoke
+ [ first3 store-reg-param ] each ;
+
+M: ppc stack-cleanup ( stack-size return abi -- n )
+ 3drop 0 ;
+
+M: ppc fused-unboxing? f ;
+
+M: ppc %alien-global ( register symbol dll -- )
+ [ 0 %load-cell-imm ] 2dip %load-cell-imm-rc rel-dlsym ;
+
+M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip %load-cell ;
+M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip %store-cell ;
+
+M: ppc %unbox-alien ( dst src -- )
+ scratch-reg alien-offset LI scratch-reg %load-cell-x ;
+
+! Convert a c-ptr object to a raw C pointer.
+! if (src == F_TYPE)
+! dst = NULL;
+! else if ((src & tag_mask) == ALIEN_TYPE)
+! dst = ((alien*)src)->address;
+! else // Assume (src & tag_mask) == BYTE_ARRAY_TYPE
+! dst = ((byte_array*)src) + 1;
+M:: ppc %unbox-any-c-ptr ( dst src -- )
+ [
+ "end" define-label
+ ! Is the object f?
+ dst 0 LI
+ 0 src \ f type-number %compare-cell-imm
+ 0 "end" get BEQ
+
+ ! Is the object an alien?
+ dst src tag-mask get ANDI.
+ ! Assume unboxing a byte-array.
+ 0 dst alien type-number %compare-cell-imm
+ dst src byte-array-offset ADDI
+ 0 "end" get BNE
+
+ ! Unbox the alien.
+ scratch-reg alien-offset LI
+ dst src scratch-reg %load-cell-x
+ "end" resolve-label
+ ] with-scope ;
+
+! Be very careful with this. It cannot be used as an immediate
+! offset to a load or store.
+: alien@ ( n -- n' ) cells alien type-number - ;
+
+! Convert a raw C pointer to a c-ptr object.
+! if (src == NULL)
+! dst = F_TYPE;
+! else {
+! dst = allot_alien(NULL);
+! dst->base = F_TYPE;
+! dst->expired = F_TYPE;
+! dst->displacement = src;
+! dst->address = src;
+! }
+M:: ppc %box-alien ( dst src temp -- )
+ [
+ "f" define-label
+
+ ! Is the object f?
+ dst \ f type-number LI
+ 0 src 0 %compare-cell-imm
+ 0 "f" get BEQ
+
+ ! Allocate and initialize an alien object.
+ dst 5 cells alien temp %allot
+ temp \ f type-number LI
+ scratch-reg dst %clear-tag-bits
+ temp scratch-reg 1 cells %store-cell
+ temp scratch-reg 2 cells %store-cell
+ src scratch-reg 3 cells %store-cell
+ src scratch-reg 4 cells %store-cell
+
+ "f" resolve-label
+ ] with-scope ;
+
+! dst->base = base;
+! dst->displacement = displacement;
+! dst->displacement = displacement;
+:: box-displaced-alien/f ( dst displacement base -- )
+ scratch-reg dst %clear-tag-bits
+ base scratch-reg 1 cells %store-cell
+ displacement scratch-reg 3 cells %store-cell
+ displacement scratch-reg 4 cells %store-cell ;
+
+! dst->base = base->base;
+! dst->displacement = base->displacement + displacement;
+! dst->address = base->address + displacement;
+:: box-displaced-alien/alien ( dst displacement base temp -- )
+ ! Set new alien's base to base.base
+ scratch-reg 1 alien@ LI
+ temp base scratch-reg %load-cell-x
+ temp dst scratch-reg %store-cell-x
+
+ ! Compute displacement
+ scratch-reg 3 alien@ LI
+ temp base scratch-reg %load-cell-x
+ temp temp displacement ADD
+ temp dst scratch-reg %store-cell-x
+
+ ! Compute address
+ scratch-reg 4 alien@ LI
+ temp base scratch-reg %load-cell-x
+ temp temp displacement ADD
+ temp dst scratch-reg %store-cell-x ;
+
+! dst->base = base;
+! dst->displacement = displacement
+! dst->address = base + sizeof(byte_array) + displacement
+:: box-displaced-alien/byte-array ( dst displacement base temp -- )
+ scratch-reg dst %clear-tag-bits
+ base scratch-reg 1 cells %store-cell
+ displacement scratch-reg 3 cells %store-cell
+ temp base byte-array-offset ADDI
+ temp temp displacement ADD
+ temp scratch-reg 4 cells %store-cell ;
+
+! if (base == F_TYPE)
+! box_displaced_alien_f(dst, displacement, base);
+! else if ((base & tag_mask) == ALIEN_TYPE)
+! box_displaced_alien_alien(dst, displacement, base, temp);
+! else
+! box_displaced_alien_byte_array(dst, displacement, base, temp);
+:: box-displaced-alien/dynamic ( dst displacement base temp -- )
+ "not-f" define-label
+ "not-alien" define-label
+
+ ! Is base f?
+ 0 base \ f type-number %compare-cell-imm
+ 0 "not-f" get BNE
+ dst displacement base box-displaced-alien/f
+ "end" get B
+
+ ! Is base an alien?
+ "not-f" resolve-label
+ temp base tag-mask get ANDI.
+ 0 temp alien type-number %compare-cell-imm
+ 0 "not-alien" get BNE
+ dst displacement base temp box-displaced-alien/alien
+ "end" get B
+
+ ! Assume base is a byte array.
+ "not-alien" resolve-label
+ dst displacement base temp box-displaced-alien/byte-array ;
+
+! if (displacement == 0)
+! dst = base;
+! else {
+! dst = allot_alien(NULL);
+! dst->expired = F_TYPE;
+! if (is_subclass(base_class, F_TYPE))
+! box_displaced_alien_f(dst, displacement, base);
+! else if (is_subclass(base_class, ALIEN_TYPE))
+! box_displaced_alien_alien(dst, displacement, base, temp);
+! else if (is_subclass(base_class, BYTE_ARRAY_TYPE))
+! box_displaced_alien_byte_array(dst, displacement, base, temp);
+! else
+! box_displaced_alien_dynamic(dst, displacement, base, temp);
+! }
+M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- )
+ [
+ "end" define-label
+
+ ! If displacement is zero, return the base.
+ dst base MR
+ 0 displacement 0 %compare-cell-imm
+ 0 "end" get BEQ
+
+ ! Displacement is non-zero, we're going to be allocating a new
+ ! object
+ dst 5 cells alien temp %allot
+
+ ! Set expired to f
+ temp \ f type-number %load-immediate
+ scratch-reg 2 alien@ LI
+ temp dst scratch-reg %store-cell-x
+
+ dst displacement base temp
+ {
+ { [ base-class \ f class<= ] [ drop box-displaced-alien/f ] }
+ { [ base-class \ alien class<= ] [ box-displaced-alien/alien ] }
+ { [ base-class \ byte-array class<= ] [ box-displaced-alien/byte-array ] }
+ [ box-displaced-alien/dynamic ]
+ } cond
+
+ "end" resolve-label
+ ] with-scope ;
+
+M:: ppc.32 %convert-integer ( dst src c-type -- )
+ c-type {
+ { c:char [ dst src 24 CLRLWI dst dst EXTSB ] }
+ { c:uchar [ dst src 24 CLRLWI ] }
+ { c:short [ dst src 16 CLRLWI dst dst EXTSH ] }
+ { c:ushort [ dst src 16 CLRLWI ] }
+ { c:int [ ] }
+ { c:uint [ ] }
+ } case ;
+
+M:: ppc.64 %convert-integer ( dst src c-type -- )
+ c-type {
+ { c:char [ dst src 56 CLRLDI dst dst EXTSB ] }
+ { c:uchar [ dst src 56 CLRLDI ] }
+ { c:short [ dst src 48 CLRLDI dst dst EXTSH ] }
+ { c:ushort [ dst src 48 CLRLDI ] }
+ { c:int [ dst src 32 CLRLDI dst dst EXTSW ] }
+ { c:uint [ dst src 32 CLRLDI ] }
+ { c:longlong [ ] }
+ { c:ulonglong [ ] }
+ } case ;
+
+M: ppc.32 %load-memory-imm ( dst base offset rep c-type -- )
+ [
+ pick %trap-null
+ {
+ { c:char [ [ dup ] 2dip LBZ dup EXTSB ] }
+ { c:uchar [ LBZ ] }
+ { c:short [ LHA ] }
+ { c:ushort [ LHZ ] }
+ { c:int [ LWZ ] }
+ { c:uint [ LWZ ] }
+ } case
+ ] [
+ {
+ { int-rep [ LWZ ] }
+ { float-rep [ LFS ] }
+ { double-rep [ LFD ] }
+ } case
+ ] ?if ;
+
+M: ppc.64 %load-memory-imm ( dst base offset rep c-type -- )
+ [
+ pick %trap-null
+ {
+ { c:char [ [ dup ] 2dip LBZ dup EXTSB ] }
+ { c:uchar [ LBZ ] }
+ { c:short [ LHA ] }
+ { c:ushort [ LHZ ] }
+ { c:int [ LWZ ] }
+ { c:uint [ LWZ ] }
+ { c:longlong [ [ scratch-reg ] dip LI scratch-reg LDX ] }
+ { c:ulonglong [ [ scratch-reg ] dip LI scratch-reg LDX ] }
+ } case
+ ] [
+ {
+ { int-rep [ [ scratch-reg ] dip LI scratch-reg LDX ] }
+ { float-rep [ [ scratch-reg ] dip LI scratch-reg LFSX ] }
+ { double-rep [ [ scratch-reg ] dip LI scratch-reg LFDX ] }
+ } case
+ ] ?if ;
+
+
+M: ppc.32 %load-memory ( dst base displacement scale offset rep c-type -- )
+ [ [ 0 assert= ] bi@ ] 2dip
+ [
+ pick %trap-null
+ {
+ { c:char [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
+ { c:uchar [ LBZX ] }
+ { c:short [ LHAX ] }
+ { c:ushort [ LHZX ] }
+ { c:int [ LWZX ] }
+ { c:uint [ LWZX ] }
+ } case
+ ] [
+ {
+ { int-rep [ LWZX ] }
+ { float-rep [ LFSX ] }
+ { double-rep [ LFDX ] }
+ } case
+ ] ?if ;
+
+M: ppc.64 %load-memory ( dst base displacement scale offset rep c-type -- )
+ [ [ 0 assert= ] bi@ ] 2dip
+ [
+ pick %trap-null
+ {
+ { c:char [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
+ { c:uchar [ LBZX ] }
+ { c:short [ LHAX ] }
+ { c:ushort [ LHZX ] }
+ { c:int [ LWZX ] }
+ { c:uint [ LWZX ] }
+ { c:longlong [ LDX ] }
+ { c:ulonglong [ LDX ] }
+ } case
+ ] [
+ {
+ { int-rep [ LDX ] }
+ { float-rep [ LFSX ] }
+ { double-rep [ LFDX ] }
+ } case
+ ] ?if ;
+
+
+M: ppc.32 %store-memory-imm ( src base offset rep c-type -- )
+ [
+ {
+ { c:char [ STB ] }
+ { c:uchar [ STB ] }
+ { c:short [ STH ] }
+ { c:ushort [ STH ] }
+ { c:int [ STW ] }
+ { c:uint [ STW ] }
+ } case
+ ] [
+ {
+ { int-rep [ STW ] }
+ { float-rep [ STFS ] }
+ { double-rep [ STFD ] }
+ } case
+ ] ?if ;
+
+M: ppc.64 %store-memory-imm ( src base offset rep c-type -- )
+ [
+ {
+ { c:char [ STB ] }
+ { c:uchar [ STB ] }
+ { c:short [ STH ] }
+ { c:ushort [ STH ] }
+ { c:int [ STW ] }
+ { c:uint [ STW ] }
+ { c:longlong [ [ scratch-reg ] dip LI scratch-reg STDX ] }
+ { c:ulonglong [ [ scratch-reg ] dip LI scratch-reg STDX ] }
+ } case
+ ] [
+ {
+ { int-rep [ [ scratch-reg ] dip LI scratch-reg STDX ] }
+ { float-rep [ [ scratch-reg ] dip LI scratch-reg STFSX ] }
+ { double-rep [ [ scratch-reg ] dip LI scratch-reg STFDX ] }
+ } case
+ ] ?if ;
+
+M: ppc.32 %store-memory ( src base displacement scale offset rep c-type -- )
+ [ [ 0 assert= ] bi@ ] 2dip
+ [
+ {
+ { c:char [ STBX ] }
+ { c:uchar [ STBX ] }
+ { c:short [ STHX ] }
+ { c:ushort [ STHX ] }
+ { c:int [ STWX ] }
+ { c:uint [ STWX ] }
+ } case
+ ] [
+ {
+ { int-rep [ STWX ] }
+ { float-rep [ STFSX ] }
+ { double-rep [ STFDX ] }
+ } case
+ ] ?if ;
+
+M: ppc.64 %store-memory ( src base displacement scale offset rep c-type -- )
+ [ [ 0 assert= ] bi@ ] 2dip
+ [
+ {
+ { c:char [ STBX ] }
+ { c:uchar [ STBX ] }
+ { c:short [ STHX ] }
+ { c:ushort [ STHX ] }
+ { c:int [ STWX ] }
+ { c:uint [ STWX ] }
+ { c:longlong [ STDX ] }
+ { c:ulonglong [ STDX ] }
+ } case
+ ] [
+ {
+ { int-rep [ STDX ] }
+ { float-rep [ STFSX ] }
+ { double-rep [ STFDX ] }
+ } case
+ ] ?if ;
+
+M:: ppc %allot ( dst size class nursery-ptr -- )
+ ! dst = vm->nursery.here;
+ nursery-ptr vm-reg "nursery" vm-field-offset ADDI
+ dst nursery-ptr 0 %load-cell
+ ! vm->nursery.here += align(size, data_alignment);
+ scratch-reg dst size data-alignment get align ADDI
+ scratch-reg nursery-ptr 0 %store-cell
+ ! ((object*) dst)->header = type_number << 2;
+ scratch-reg class type-number tag-header LI
+ scratch-reg dst 0 %store-cell
+ ! dst |= type_number
+ dst dst class type-number ORI ;
+
+:: (%write-barrier) ( temp1 temp2 -- )
+ scratch-reg card-mark LI
+ ! *(char *)(cards_offset + ((cell)slot_ptr >> card_bits))
+ ! = card_mark_mask;
+ temp1 temp1 card-bits %shr-imm
+ temp2 0 %load-cell-imm %load-cell-imm-rc rel-cards-offset
+ scratch-reg temp1 temp2 STBX
+ ! *(char *)(decks_offset + ((cell)slot_ptr >> deck_bits))
+ ! = card_mark_mask;
+ temp1 temp1 deck-bits card-bits - %shr-imm
+ temp2 0 %load-cell-imm %load-cell-imm-rc rel-decks-offset
+ scratch-reg temp1 temp2 STBX ;
+
+M:: ppc %write-barrier ( src slot scale tag temp1 temp2 -- )
+ scale 0 assert= tag 0 assert=
+ temp1 src slot ADD
+ temp1 temp2 (%write-barrier) ;
+
+M:: ppc %write-barrier-imm ( src slot tag temp1 temp2 -- )
+ temp1 src slot tag slot-offset ADDI
+ temp1 temp2 (%write-barrier) ;
+
+M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- )
+ ! if (vm->nursery.here + size >= vm->nursery.end) ...
+ temp1 vm-reg "nursery" vm-field-offset %load-cell
+ temp2 vm-reg "nursery" vm-field-offset 2 cells + %load-cell
+ temp1 temp1 size ADDI
+ 0 temp1 temp2 %compare-cell
+ cc {
+ { cc<= [ 0 label BLE ] }
+ { cc/<= [ 0 label BGT ] }
+ } case ;
+
+M: ppc %call-gc ( gc-map -- )
+ \ minor-gc %call gc-map-here ;
+
+M:: ppc %prologue ( stack-size -- )
+ 0 MFLR
+ 0 1 lr-save %store-cell
+ 11 0 %load-cell-imm %load-cell-imm-rc rel-this
+ 11 1 2 cells neg %store-cell
+ 11 stack-size LI
+ 11 1 1 cells neg %store-cell
+ 1 1 stack-size neg %store-cell-update ;
+
+! At the end of each word that calls a subroutine, we store
+! the previous link register value in r0 by popping it off
+! the stack, set the link register to the contents of r0,
+! and jump to the link register.
+M:: ppc %epilogue ( stack-size -- )
+ 1 1 stack-size ADDI
+ 0 1 lr-save %load-cell
+ 0 MTLR ;
+
+:: (%boolean) ( dst temp branch1 branch2 -- )
+ "end" define-label
+ dst \ f type-number %load-immediate
+ 0 "end" get branch1 execute( n addr -- )
+ branch2 [ 0 "end" get branch2 execute( n addr -- ) ] when
+ dst \ t %load-reference
+ "end" get resolve-label ; inline
+
+:: %boolean ( dst cc temp -- )
+ cc negate-cc order-cc {
+ { cc< [ dst temp \ BLT f (%boolean) ] }
+ { cc<= [ dst temp \ BLE f (%boolean) ] }
+ { cc> [ dst temp \ BGT f (%boolean) ] }
+ { cc>= [ dst temp \ BGE f (%boolean) ] }
+ { cc= [ dst temp \ BEQ f (%boolean) ] }
+ { cc/= [ dst temp \ BNE f (%boolean) ] }
+ } case ;
+
+: (%compare) ( src1 src2 -- ) [ 0 ] 2dip %compare-cell ; inline
+
+: (%compare-integer-imm) ( src1 src2 -- )
+ [ 0 ] 2dip %compare-cell-imm ; inline
+
+: (%compare-imm) ( src1 src2 -- )
+ [ tag-fixnum ] [ \ f type-number ] if* (%compare-integer-imm) ; inline
+
+: (%compare-float-unordered) ( src1 src2 -- )
+ [ 0 ] 2dip FCMPU ; inline
+
+: (%compare-float-ordered) ( src1 src2 -- )
+ [ 0 ] 2dip FCMPO ; inline
+
+:: (%compare-float) ( src1 src2 cc compare -- branch1 branch2 )
+ cc {
+ { cc< [ src1 src2 \ compare execute( a b -- ) \ BLT f ] }
+ { cc<= [ src1 src2 \ compare execute( a b -- ) \ BLT \ BEQ ] }
+ { cc> [ src1 src2 \ compare execute( a b -- ) \ BGT f ] }
+ { cc>= [ src1 src2 \ compare execute( a b -- ) \ BGT \ BEQ ] }
+ { cc= [ src1 src2 \ compare execute( a b -- ) \ BEQ f ] }
+ { cc<> [ src1 src2 \ compare execute( a b -- ) \ BLT \ BGT ] }
+ { cc<>= [ src1 src2 \ compare execute( a b -- ) \ BNS f ] }
+ { cc/< [ src1 src2 \ compare execute( a b -- ) \ BGE f ] }
+ { cc/<= [ src1 src2 \ compare execute( a b -- ) \ BGT \ BSO ] }
+ { cc/> [ src1 src2 \ compare execute( a b -- ) \ BLE f ] }
+ { cc/>= [ src1 src2 \ compare execute( a b -- ) \ BLT \ BSO ] }
+ { cc/= [ src1 src2 \ compare execute( a b -- ) \ BNE f ] }
+ { cc/<> [ src1 src2 \ compare execute( a b -- ) \ BEQ \ BSO ] }
+ { cc/<>= [ src1 src2 \ compare execute( a b -- ) \ BSO f ] }
+ } case ; inline
+
+M: ppc %compare [ (%compare) ] 2dip %boolean ;
+
+M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
+
+M: ppc %compare-integer-imm [ (%compare-integer-imm) ] 2dip %boolean ;
+
+M:: ppc %compare-float-ordered ( dst src1 src2 cc temp -- )
+ src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
+ dst temp branch1 branch2 (%boolean) ;
+
+M:: ppc %compare-float-unordered ( dst src1 src2 cc temp -- )
+ src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
+ dst temp branch1 branch2 (%boolean) ;
+
+:: %branch ( label cc -- )
+ cc order-cc {
+ { cc< [ 0 label BLT ] }
+ { cc<= [ 0 label BLE ] }
+ { cc> [ 0 label BGT ] }
+ { cc>= [ 0 label BGE ] }
+ { cc= [ 0 label BEQ ] }
+ { cc/= [ 0 label BNE ] }
+ } case ;
+
+M:: ppc %compare-branch ( label src1 src2 cc -- )
+ src1 src2 (%compare)
+ label cc %branch ;
+
+M:: ppc %compare-imm-branch ( label src1 src2 cc -- )
+ src1 src2 (%compare-imm)
+ label cc %branch ;
+
+M:: ppc %compare-integer-imm-branch ( label src1 src2 cc -- )
+ src1 src2 (%compare-integer-imm)
+ label cc %branch ;
+
+:: (%branch) ( label branch1 branch2 -- )
+ 0 label branch1 execute( cr label -- )
+ branch2 [ 0 label branch2 execute( cr label -- ) ] when ; inline
+
+M:: ppc %compare-float-ordered-branch ( label src1 src2 cc -- )
+ src1 src2 cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
+ label branch1 branch2 (%branch) ;
+
+M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
+ src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
+ label branch1 branch2 (%branch) ;
+
+M: ppc %spill ( src rep dst -- )
+ n>> spill@ swap {
+ { int-rep [ [ 1 ] dip %store-cell ] }
+ { tagged-rep [ [ 1 ] dip %store-cell ] }
+ { float-rep [ [ 1 ] dip STFS ] }
+ { double-rep [ [ 1 ] dip STFD ] }
+ { vector-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
+ { scalar-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
+ } case ;
+
+M: ppc %reload ( dst rep src -- )
+ n>> spill@ swap {
+ { int-rep [ [ 1 ] dip %load-cell ] }
+ { tagged-rep [ [ 1 ] dip %load-cell ] }
+ { float-rep [ [ 1 ] dip LFS ] }
+ { double-rep [ [ 1 ] dip LFD ] }
+ { vector-rep [ scratch-reg swap LI 1 scratch-reg LVX ] }
+ { scalar-rep [ scratch-reg swap LI 1 scratch-reg LVX ] }
+ } case ;
+
+M: ppc %loop-entry ( -- ) ;
+M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
+M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
+M: ppc immediate-store? ( n -- ? ) immediate-comparand? ;
+
+USE: vocabs.loader
+{
+ { [ os linux? ] [
+ {
+ { [ cpu ppc.32? ] [ "cpu.ppc.32.linux" require ] }
+ { [ cpu ppc.64? ] [ "cpu.ppc.64.linux" require ] }
+ [ ]
+ } cond
+ ] }
+ [ ]
+} cond
+
+complex-double c-type t >>return-in-registers? drop
--- /dev/null
+32-bit and 64-bit PowerPC compiler backends
M: x86.32 float-on-stack? t ;
M: x86.32 flatten-struct-type
- call-next-method [ first t 2array ] map ;
+ call-next-method [ first t f 3array ] map ;
M: x86.32 struct-return-on-stack? os linux? not ;
struct-types&offset split-struct [
[ c-type c-type-rep reg-class-of ] map
int-regs swap member? int-rep double-rep ?
- f 2array
+ f f 3array
] map ;
M: x86.64 flatten-struct-type ( c-type -- seq )
dup heap-size 16 <=
- [ flatten-small-struct ] [ call-next-method [ first t 2array ] map ] if ;
+ [ flatten-small-struct ] [ call-next-method [ first t f 3array ] map ] if ;
M: x86.64 return-struct-in-registers? ( c-type -- ? )
heap-size 2 cells <= ;
M: x86 value-struct? drop t ;
+M: x86 long-long-odd-register? f ;
+
+M: x86 float-right-align-on-stack? f ;
+
M: x86 immediate-arithmetic? ( n -- ? )
HEX: -80000000 HEX: 7fffffff between? ;
-USING: accessors alien.c-types alien.syntax arrays assocs
+USING: accessors alien alien.c-types alien.syntax arrays assocs
biassocs classes.struct combinators kernel literals math
-math.bitwise math.floats.env math.floats.env.private system ;
+math.bitwise math.floats.env math.floats.env.private system
+cpu.ppc.assembler ;
IN: math.floats.env.ppc
STRUCT: ppc-fpu-env
STRUCT: ppc-vmx-env
{ vscr uint } ;
-! defined in the vm, cpu-ppc*.S
-FUNCTION: void get_ppc_fpu_env ( ppc-fpu-env* env ) ;
-FUNCTION: void set_ppc_fpu_env ( ppc-fpu-env* env ) ;
-
-FUNCTION: void get_ppc_vmx_env ( ppc-vmx-env* env ) ;
-FUNCTION: void set_ppc_vmx_env ( ppc-vmx-env* env ) ;
+: get_ppc_fpu_env ( env -- )
+ void { void* } cdecl [
+ 0 MFFS
+ 0 3 0 STFD
+ ] alien-assembly ;
+
+: set_ppc_fpu_env ( env -- )
+ void { void* } cdecl [
+ 0 3 0 LFD
+ HEX: ff 0 0 0 MTFSF
+ ] alien-assembly ;
+
+: get_ppc_vmx_env ( env -- )
+ void { void* } cdecl [
+ 0 MFVSCR
+ 4 1 16 SUBI
+ 5 HEX: f LI
+ 4 4 5 ANDC
+ 0 0 4 STVXL
+ 5 HEX: c LI
+ 6 5 4 LWZX
+ 6 3 0 STW
+ ] alien-assembly ;
+
+: set_ppc_vmx_env ( env -- )
+ void { void* } cdecl [
+ 3 1 16 SUBI
+ 5 HEX: f LI
+ 4 4 5 ANDC
+ 5 HEX: c LI
+ 6 3 0 LWZ
+ 6 5 4 STWX
+ 0 0 4 LVXL
+ 0 MTVSCR
+ ] alien-assembly ;
: <ppc-fpu-env> ( -- ppc-fpu-env )
ppc-fpu-env (struct)
set_ppc_vmx_env ;
M: ppc (fp-env-registers)
- <ppc-fpu-env> <ppc-vmx-env> 2array ;
+ <ppc-fpu-env> 1array ;
CONSTANT: ppc-exception-flag-bits HEX: fff8,0700
CONSTANT: ppc-exception-flag>bit
\ (code-blocks) { } { array } define-primitive \ (code-blocks) make-flushable
\ (dlopen) { byte-array } { dll } define-primitive
\ (dlsym) { byte-array object } { c-ptr } define-primitive
+\ (dlsym-raw) { byte-array object } { c-ptr } define-primitive
\ (exists?) { string } { object } define-primitive
\ (exit) { integer } { } define-primitive
\ (format-float) { float byte-array } { byte-array } define-primitive \ (format-float) make-foldable
MAKE_IMAGE_TARGET=macosx-ppc
MAKE_TARGET=macosx-ppc
elif [[ $OS == linux && $ARCH == ppc ]] ; then
- MAKE_IMAGE_TARGET=linux-ppc
- MAKE_TARGET=linux-ppc
+ MAKE_IMAGE_TARGET=linux-ppc.32
+ MAKE_TARGET=linux-ppc-32
elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then
MAKE_IMAGE_TARGET=winnt-x86.64
MAKE_TARGET=winnt-x86-64
architecture get {
{ "winnt-x86.32" "x86/32/winnt" }
- { "unix-x86.32" "x86/32/unix" }
+ { "unix-x86.32" "x86/32/unix" }
{ "winnt-x86.64" "x86/64/winnt" }
- { "unix-x86.64" "x86/64/unix" }
+ { "unix-x86.64" "x86/64/unix" }
+ { "linux-ppc.32" "ppc/32/linux" }
+ { "linux-ppc.64" "ppc/64/linux" }
} ?at [ "Bad architecture: " prepend throw ] unless
"vocab:cpu/" "/bootstrap.factor" surround parse-file
{ "set-alien-unsigned-cell" "alien.accessors" "primitive_set_alien_unsigned_cell" (( value c-ptr n -- )) }
{ "(dlopen)" "alien.libraries" "primitive_dlopen" (( path -- dll )) }
{ "(dlsym)" "alien.libraries" "primitive_dlsym" (( name dll -- alien )) }
+ { "(dlsym-raw)" "alien.libraries" "primitive_dlsym_raw" (( name dll -- alien )) }
{ "dlclose" "alien.libraries" "primitive_dlclose" (( dll -- )) }
{ "dll-valid?" "alien.libraries" "primitive_dll_validp" (( dll -- ? )) }
{ "current-callback" "alien.private" "primitive_current_callback" (( -- n )) }
init splitting assocs system.private layouts words ;
IN: system
-SINGLETONS: x86.32 x86.64 arm ppc ;
+SINGLETONS: x86.32 x86.64 arm ppc.32 ppc.64 ;
UNION: x86 x86.32 x86.64 ;
+UNION: ppc ppc.32 ppc.64 ;
: cpu ( -- class ) \ cpu get-global ; foldable
{ "x86.32" x86.32 }
{ "x86.64" x86.64 }
{ "arm" arm }
- { "ppc" ppc }
+ { "ppc.32" ppc.32 }
+ { "ppc.64" ppc.64 }
} at ;
: string>os ( str -- class )
+++ /dev/null
-USING: cpu.ppc.assembler tools.test arrays kernel namespaces
-make vocabs sequences byte-arrays.hex ;
-FROM: cpu.ppc.assembler => B ;
-IN: cpu.ppc.assembler.tests
-
-: test-assembler ( expected quot -- )
- [ 1array ] [ [ B{ } make ] curry ] bi* unit-test ;
-
-HEX{ 38 22 00 03 } [ 1 2 3 ADDI ] test-assembler
-HEX{ 3c 22 00 03 } [ 1 2 3 ADDIS ] test-assembler
-HEX{ 30 22 00 03 } [ 1 2 3 ADDIC ] test-assembler
-HEX{ 34 22 00 03 } [ 1 2 3 ADDIC. ] test-assembler
-HEX{ 38 40 00 01 } [ 1 2 LI ] test-assembler
-HEX{ 3c 40 00 01 } [ 1 2 LIS ] test-assembler
-HEX{ 38 22 ff fd } [ 1 2 3 SUBI ] test-assembler
-HEX{ 1c 22 00 03 } [ 1 2 3 MULI ] test-assembler
-HEX{ 7c 22 1a 14 } [ 1 2 3 ADD ] test-assembler
-HEX{ 7c 22 1a 15 } [ 1 2 3 ADD. ] test-assembler
-HEX{ 7c 22 1e 14 } [ 1 2 3 ADDO ] test-assembler
-HEX{ 7c 22 1e 15 } [ 1 2 3 ADDO. ] test-assembler
-HEX{ 7c 22 18 14 } [ 1 2 3 ADDC ] test-assembler
-HEX{ 7c 22 18 15 } [ 1 2 3 ADDC. ] test-assembler
-HEX{ 7c 22 1e 14 } [ 1 2 3 ADDO ] test-assembler
-HEX{ 7c 22 1c 15 } [ 1 2 3 ADDCO. ] test-assembler
-HEX{ 7c 22 19 14 } [ 1 2 3 ADDE ] test-assembler
-HEX{ 7c 41 18 38 } [ 1 2 3 AND ] test-assembler
-HEX{ 7c 41 18 39 } [ 1 2 3 AND. ] test-assembler
-HEX{ 7c 22 1b d6 } [ 1 2 3 DIVW ] test-assembler
-HEX{ 7c 22 1b 96 } [ 1 2 3 DIVWU ] test-assembler
-HEX{ 7c 41 1a 38 } [ 1 2 3 EQV ] test-assembler
-HEX{ 7c 41 1b b8 } [ 1 2 3 NAND ] test-assembler
-HEX{ 7c 41 18 f8 } [ 1 2 3 NOR ] test-assembler
-HEX{ 7c 41 10 f8 } [ 1 2 NOT ] test-assembler
-HEX{ 60 41 00 03 } [ 1 2 3 ORI ] test-assembler
-HEX{ 64 41 00 03 } [ 1 2 3 ORIS ] test-assembler
-HEX{ 7c 41 1b 78 } [ 1 2 3 OR ] test-assembler
-HEX{ 7c 41 13 78 } [ 1 2 MR ] test-assembler
-HEX{ 7c 22 18 96 } [ 1 2 3 MULHW ] test-assembler
-HEX{ 1c 22 00 03 } [ 1 2 3 MULLI ] test-assembler
-HEX{ 7c 22 18 16 } [ 1 2 3 MULHWU ] test-assembler
-HEX{ 7c 22 19 d6 } [ 1 2 3 MULLW ] test-assembler
-HEX{ 7c 41 18 30 } [ 1 2 3 SLW ] test-assembler
-HEX{ 7c 41 1e 30 } [ 1 2 3 SRAW ] test-assembler
-HEX{ 7c 41 1c 30 } [ 1 2 3 SRW ] test-assembler
-HEX{ 7c 41 1e 70 } [ 1 2 3 SRAWI ] test-assembler
-HEX{ 7c 22 18 50 } [ 1 2 3 SUBF ] test-assembler
-HEX{ 7c 22 18 10 } [ 1 2 3 SUBFC ] test-assembler
-HEX{ 7c 22 19 10 } [ 1 2 3 SUBFE ] test-assembler
-HEX{ 7c 41 07 74 } [ 1 2 EXTSB ] test-assembler
-HEX{ 68 41 00 03 } [ 1 2 3 XORI ] test-assembler
-HEX{ 7c 41 1a 78 } [ 1 2 3 XOR ] test-assembler
-HEX{ 7c 22 00 d0 } [ 1 2 NEG ] test-assembler
-HEX{ 2c 22 00 03 } [ 1 2 3 CMPI ] test-assembler
-HEX{ 28 22 00 03 } [ 1 2 3 CMPLI ] test-assembler
-HEX{ 7c 41 18 00 } [ 1 2 3 CMP ] test-assembler
-HEX{ 54 22 19 0a } [ 1 2 3 4 5 RLWINM ] test-assembler
-HEX{ 54 22 18 38 } [ 1 2 3 SLWI ] test-assembler
-HEX{ 54 22 e8 fe } [ 1 2 3 SRWI ] test-assembler
-HEX{ 88 22 00 03 } [ 1 2 3 LBZ ] test-assembler
-HEX{ 8c 22 00 03 } [ 1 2 3 LBZU ] test-assembler
-HEX{ a8 22 00 03 } [ 1 2 3 LHA ] test-assembler
-HEX{ ac 22 00 03 } [ 1 2 3 LHAU ] test-assembler
-HEX{ a0 22 00 03 } [ 1 2 3 LHZ ] test-assembler
-HEX{ a4 22 00 03 } [ 1 2 3 LHZU ] test-assembler
-HEX{ 80 22 00 03 } [ 1 2 3 LWZ ] test-assembler
-HEX{ 84 22 00 03 } [ 1 2 3 LWZU ] test-assembler
-HEX{ 7c 41 18 ae } [ 1 2 3 LBZX ] test-assembler
-HEX{ 7c 41 18 ee } [ 1 2 3 LBZUX ] test-assembler
-HEX{ 7c 41 1a ae } [ 1 2 3 LHAX ] test-assembler
-HEX{ 7c 41 1a ee } [ 1 2 3 LHAUX ] test-assembler
-HEX{ 7c 41 1a 2e } [ 1 2 3 LHZX ] test-assembler
-HEX{ 7c 41 1a 6e } [ 1 2 3 LHZUX ] test-assembler
-HEX{ 7c 41 18 2e } [ 1 2 3 LWZX ] test-assembler
-HEX{ 7c 41 18 6e } [ 1 2 3 LWZUX ] test-assembler
-HEX{ 7c 41 1c 2e } [ 1 2 3 LFSX ] test-assembler
-HEX{ 7c 41 1c 6e } [ 1 2 3 LFSUX ] test-assembler
-HEX{ 7c 41 1c ae } [ 1 2 3 LFDX ] test-assembler
-HEX{ 7c 41 1c ee } [ 1 2 3 LFDUX ] test-assembler
-HEX{ 7c 41 1d 2e } [ 1 2 3 STFSX ] test-assembler
-HEX{ 7c 41 1d 6e } [ 1 2 3 STFSUX ] test-assembler
-HEX{ 7c 41 1d ae } [ 1 2 3 STFDX ] test-assembler
-HEX{ 7c 41 1d ee } [ 1 2 3 STFDUX ] test-assembler
-HEX{ 48 00 00 01 } [ 1 B ] test-assembler
-HEX{ 48 00 00 01 } [ 1 BL ] test-assembler
-HEX{ 41 80 00 04 } [ 1 BLT ] test-assembler
-HEX{ 41 81 00 04 } [ 1 BGT ] test-assembler
-HEX{ 40 81 00 04 } [ 1 BLE ] test-assembler
-HEX{ 40 80 00 04 } [ 1 BGE ] test-assembler
-HEX{ 41 80 00 04 } [ 1 BLT ] test-assembler
-HEX{ 40 82 00 04 } [ 1 BNE ] test-assembler
-HEX{ 41 82 00 04 } [ 1 BEQ ] test-assembler
-HEX{ 41 83 00 04 } [ 1 BO ] test-assembler
-HEX{ 40 83 00 04 } [ 1 BNO ] test-assembler
-HEX{ 4c 20 00 20 } [ 1 BCLR ] test-assembler
-HEX{ 4e 80 00 20 } [ BLR ] test-assembler
-HEX{ 4e 80 00 21 } [ BLRL ] test-assembler
-HEX{ 4c 20 04 20 } [ 1 BCCTR ] test-assembler
-HEX{ 4e 80 04 20 } [ BCTR ] test-assembler
-HEX{ 7c 61 02 a6 } [ 3 MFXER ] test-assembler
-HEX{ 7c 68 02 a6 } [ 3 MFLR ] test-assembler
-HEX{ 7c 69 02 a6 } [ 3 MFCTR ] test-assembler
-HEX{ 7c 61 03 a6 } [ 3 MTXER ] test-assembler
-HEX{ 7c 68 03 a6 } [ 3 MTLR ] test-assembler
-HEX{ 7c 69 03 a6 } [ 3 MTCTR ] test-assembler
-HEX{ 7c 61 02 a6 } [ 3 MFXER ] test-assembler
-HEX{ 7c 68 02 a6 } [ 3 MFLR ] test-assembler
-HEX{ c0 22 00 03 } [ 1 2 3 LFS ] test-assembler
-HEX{ c4 22 00 03 } [ 1 2 3 LFSU ] test-assembler
-HEX{ c8 22 00 03 } [ 1 2 3 LFD ] test-assembler
-HEX{ cc 22 00 03 } [ 1 2 3 LFDU ] test-assembler
-HEX{ d0 22 00 03 } [ 1 2 3 STFS ] test-assembler
-HEX{ d4 22 00 03 } [ 1 2 3 STFSU ] test-assembler
-HEX{ d8 22 00 03 } [ 1 2 3 STFD ] test-assembler
-HEX{ dc 22 00 03 } [ 1 2 3 STFDU ] test-assembler
-HEX{ fc 20 10 90 } [ 1 2 FMR ] test-assembler
-HEX{ fc 40 08 90 } [ 2 1 FMR ] test-assembler
-HEX{ fc 20 10 91 } [ 1 2 FMR. ] test-assembler
-HEX{ fc 40 08 91 } [ 2 1 FMR. ] test-assembler
-HEX{ fc 20 10 1e } [ 1 2 FCTIWZ ] test-assembler
-HEX{ fc 22 18 2a } [ 1 2 3 FADD ] test-assembler
-HEX{ fc 22 18 2b } [ 1 2 3 FADD. ] test-assembler
-HEX{ fc 22 18 28 } [ 1 2 3 FSUB ] test-assembler
-HEX{ fc 22 00 f2 } [ 1 2 3 FMUL ] test-assembler
-HEX{ fc 22 18 24 } [ 1 2 3 FDIV ] test-assembler
-HEX{ fc 20 10 2c } [ 1 2 FSQRT ] test-assembler
-HEX{ fc 41 18 00 } [ 1 2 3 FCMPU ] test-assembler
-HEX{ fc 41 18 40 } [ 1 2 3 FCMPO ] test-assembler
-HEX{ 3c 60 12 34 60 63 56 78 } [ HEX: 12345678 3 LOAD ] test-assembler
+++ /dev/null
-! Copyright (C) 2005, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces words math math.order locals
-cpu.ppc.assembler.backend ;
-IN: cpu.ppc.assembler
-
-! See the Motorola or IBM documentation for details. The opcode
-! names are standard, and the operand order is the same as in
-! the docs, except a few differences, namely, in IBM/Motorola
-! assembler syntax, loads and stores are written like:
-!
-! stw r14,10(r15)
-!
-! In Factor, we write:
-!
-! 14 15 10 STW
-
-! D-form
-D: ADDI 14
-D: ADDIC 12
-D: ADDIC. 13
-D: ADDIS 15
-D: CMPI 11
-D: CMPLI 10
-D: LBZ 34
-D: LBZU 35
-D: LFD 50
-D: LFDU 51
-D: LFS 48
-D: LFSU 49
-D: LHA 42
-D: LHAU 43
-D: LHZ 40
-D: LHZU 41
-D: LWZ 32
-D: LWZU 33
-D: MULI 7
-D: MULLI 7
-D: STB 38
-D: STBU 39
-D: STFD 54
-D: STFDU 55
-D: STFS 52
-D: STFSU 53
-D: STH 44
-D: STHU 45
-D: STW 36
-D: STWU 37
-
-! SD-form
-SD: ANDI 28
-SD: ANDIS 29
-SD: ORI 24
-SD: ORIS 25
-SD: XORI 26
-SD: XORIS 27
-
-! X-form
-X: AND 0 28 31
-X: AND. 1 28 31
-X: CMP 0 0 31
-X: CMPL 0 32 31
-X: EQV 0 284 31
-X: EQV. 1 284 31
-X: FCMPO 0 32 63
-X: FCMPU 0 0 63
-X: LBZUX 0 119 31
-X: LBZX 0 87 31
-X: LFDUX 0 631 31
-X: LFDX 0 599 31
-X: LFSUX 0 567 31
-X: LFSX 0 535 31
-X: LHAUX 0 375 31
-X: LHAX 0 343 31
-X: LHZUX 0 311 31
-X: LHZX 0 279 31
-X: LWZUX 0 55 31
-X: LWZX 0 23 31
-X: NAND 0 476 31
-X: NAND. 1 476 31
-X: NOR 0 124 31
-X: NOR. 1 124 31
-X: OR 0 444 31
-X: OR. 1 444 31
-X: ORC 0 412 31
-X: ORC. 1 412 31
-X: SLW 0 24 31
-X: SLW. 1 24 31
-X: SRAW 0 792 31
-X: SRAW. 1 792 31
-X: SRAWI 0 824 31
-X: SRW 0 536 31
-X: SRW. 1 536 31
-X: STBUX 0 247 31
-X: STBX 0 215 31
-X: STFDUX 0 759 31
-X: STFDX 0 727 31
-X: STFSUX 0 695 31
-X: STFSX 0 663 31
-X: STHUX 0 439 31
-X: STHX 0 407 31
-X: STWUX 0 183 31
-X: STWX 0 151 31
-X: XOR 0 316 31
-X: XOR. 1 316 31
-X1: EXTSB 0 954 31
-X1: EXTSB. 1 954 31
-: FRSP ( a s -- ) [ 0 ] 2dip 0 12 63 x-insn ;
-: FRSP. ( a s -- ) [ 0 ] 2dip 1 12 63 x-insn ;
-: FMR ( a s -- ) [ 0 ] 2dip 0 72 63 x-insn ;
-: FMR. ( a s -- ) [ 0 ] 2dip 1 72 63 x-insn ;
-: FCTIWZ ( a s -- ) [ 0 ] 2dip 0 15 63 x-insn ;
-: FCTIWZ. ( a s -- ) [ 0 ] 2dip 1 15 63 x-insn ;
-
-! XO-form
-XO: ADD 0 0 266 31
-XO: ADD. 0 1 266 31
-XO: ADDC 0 0 10 31
-XO: ADDC. 0 1 10 31
-XO: ADDCO 1 0 10 31
-XO: ADDCO. 1 1 10 31
-XO: ADDE 0 0 138 31
-XO: ADDE. 0 1 138 31
-XO: ADDEO 1 0 138 31
-XO: ADDEO. 1 1 138 31
-XO: ADDO 1 0 266 31
-XO: ADDO. 1 1 266 31
-XO: DIVW 0 0 491 31
-XO: DIVW. 0 1 491 31
-XO: DIVWO 1 0 491 31
-XO: DIVWO. 1 1 491 31
-XO: DIVWU 0 0 459 31
-XO: DIVWU. 0 1 459 31
-XO: DIVWUO 1 0 459 31
-XO: DIVWUO. 1 1 459 31
-XO: MULHW 0 0 75 31
-XO: MULHW. 0 1 75 31
-XO: MULHWU 0 0 11 31
-XO: MULHWU. 0 1 11 31
-XO: MULLW 0 0 235 31
-XO: MULLW. 0 1 235 31
-XO: MULLWO 1 0 235 31
-XO: MULLWO. 1 1 235 31
-XO: SUBF 0 0 40 31
-XO: SUBF. 0 1 40 31
-XO: SUBFC 0 0 8 31
-XO: SUBFC. 0 1 8 31
-XO: SUBFCO 1 0 8 31
-XO: SUBFCO. 1 1 8 31
-XO: SUBFE 0 0 136 31
-XO: SUBFE. 0 1 136 31
-XO: SUBFEO 1 0 136 31
-XO: SUBFEO. 1 1 136 31
-XO: SUBFO 1 0 40 31
-XO: SUBFO. 1 1 40 31
-XO1: NEG 0 0 104 31
-XO1: NEG. 0 1 104 31
-XO1: NEGO 1 0 104 31
-XO1: NEGO. 1 1 104 31
-
-! A-form
-: RLWINM ( d a b c xo -- ) 0 21 a-insn ;
-: RLWINM. ( d a b c xo -- ) 1 21 a-insn ;
-: FADD ( d a b -- ) 0 21 0 63 a-insn ;
-: FADD. ( d a b -- ) 0 21 1 63 a-insn ;
-: FSUB ( d a b -- ) 0 20 0 63 a-insn ;
-: FSUB. ( d a b -- ) 0 20 1 63 a-insn ;
-: FMUL ( d a c -- ) 0 swap 25 0 63 a-insn ;
-: FMUL. ( d a c -- ) 0 swap 25 1 63 a-insn ;
-: FDIV ( d a b -- ) 0 18 0 63 a-insn ;
-: FDIV. ( d a b -- ) 0 18 1 63 a-insn ;
-: FSQRT ( d b -- ) 0 swap 0 22 0 63 a-insn ;
-: FSQRT. ( d b -- ) 0 swap 0 22 1 63 a-insn ;
-
-! Branches
-: B ( dest -- ) 0 0 (B) ;
-: BL ( dest -- ) 0 1 (B) ;
-BC: LT 12 0
-BC: GE 4 0
-BC: GT 12 1
-BC: LE 4 1
-BC: EQ 12 2
-BC: NE 4 2
-BC: O 12 3
-BC: NO 4 3
-B: CLR 0 8 0 0 19
-B: CLRL 0 8 0 1 19
-B: CCTR 0 264 0 0 19
-: BLR ( -- ) 20 BCLR ;
-: BLRL ( -- ) 20 BCLRL ;
-: BCTR ( -- ) 20 BCCTR ;
-
-! Special registers
-MFSPR: XER 1
-MFSPR: LR 8
-MFSPR: CTR 9
-MTSPR: XER 1
-MTSPR: LR 8
-MTSPR: CTR 9
-
-! Pseudo-instructions
-: LI ( value dst -- ) swap [ 0 ] dip ADDI ; inline
-: SUBI ( dst src1 src2 -- ) neg ADDI ; inline
-: LIS ( value dst -- ) swap [ 0 ] dip ADDIS ; inline
-: SUBIC ( dst src1 src2 -- ) neg ADDIC ; inline
-: SUBIC. ( dst src1 src2 -- ) neg ADDIC. ; inline
-: NOT ( dst src -- ) dup NOR ; inline
-: NOT. ( dst src -- ) dup NOR. ; inline
-: MR ( dst src -- ) dup OR ; inline
-: MR. ( dst src -- ) dup OR. ; inline
-: (SLWI) ( d a b -- d a b x y ) 0 31 pick - ; inline
-: SLWI ( d a b -- ) (SLWI) RLWINM ;
-: SLWI. ( d a b -- ) (SLWI) RLWINM. ;
-: (SRWI) ( d a b -- d a b x y ) 32 over - swap 31 ; inline
-: SRWI ( d a b -- ) (SRWI) RLWINM ;
-: SRWI. ( d a b -- ) (SRWI) RLWINM. ;
-:: LOAD32 ( n r -- )
- n -16 shift HEX: ffff bitand r LIS
- r r n HEX: ffff bitand ORI ;
-: immediate? ( n -- ? ) HEX: -8000 HEX: 7fff between? ;
-: LOAD ( n r -- ) over immediate? [ LI ] [ LOAD32 ] if ;
-
-! Altivec/VMX instructions
-VA: VMHADDSHS 32 4
-VA: VMHRADDSHS 33 4
-VA: VMLADDUHM 34 4
-VA: VMSUMUBM 36 4
-VA: VMSUMMBM 37 4
-VA: VMSUMUHM 38 4
-VA: VMSUMUHS 39 4
-VA: VMSUMSHM 40 4
-VA: VMSUMSHS 41 4
-VA: VSEL 42 4
-VA: VPERM 43 4
-VA: VSLDOI 44 4
-VA: VMADDFP 46 4
-VA: VNMSUBFP 47 4
-
-VX: VADDUBM 0 4
-VX: VADDUHM 64 4
-VX: VADDUWM 128 4
-VX: VADDCUW 384 4
-VX: VADDUBS 512 4
-VX: VADDUHS 576 4
-VX: VADDUWS 640 4
-VX: VADDSBS 768 4
-VX: VADDSHS 832 4
-VX: VADDSWS 896 4
-
-VX: VSUBUBM 1024 4
-VX: VSUBUHM 1088 4
-VX: VSUBUWM 1152 4
-VX: VSUBCUW 1408 4
-VX: VSUBUBS 1536 4
-VX: VSUBUHS 1600 4
-VX: VSUBUWS 1664 4
-VX: VSUBSBS 1792 4
-VX: VSUBSHS 1856 4
-VX: VSUBSWS 1920 4
-
-VX: VMAXUB 2 4
-VX: VMAXUH 66 4
-VX: VMAXUW 130 4
-VX: VMAXSB 258 4
-VX: VMAXSH 322 4
-VX: VMAXSW 386 4
-
-VX: VMINUB 514 4
-VX: VMINUH 578 4
-VX: VMINUW 642 4
-VX: VMINSB 770 4
-VX: VMINSH 834 4
-VX: VMINSW 898 4
-
-VX: VAVGUB 1026 4
-VX: VAVGUH 1090 4
-VX: VAVGUW 1154 4
-VX: VAVGSB 1282 4
-VX: VAVGSH 1346 4
-VX: VAVGSW 1410 4
-
-VX: VRLB 4 4
-VX: VRLH 68 4
-VX: VRLW 132 4
-VX: VSLB 260 4
-VX: VSLH 324 4
-VX: VSLW 388 4
-VX: VSL 452 4
-VX: VSRB 516 4
-VX: VSRH 580 4
-VX: VSRW 644 4
-VX: VSR 708 4
-VX: VSRAB 772 4
-VX: VSRAH 836 4
-VX: VSRAW 900 4
-
-VX: VAND 1028 4
-VX: VANDC 1092 4
-VX: VOR 1156 4
-VX: VNOR 1284 4
-VX: VXOR 1220 4
-
-VXD: MFVSCR 1540 4
-VXB: MTVSCR 1604 4
-
-VX: VMULOUB 8 4
-VX: VMULOUH 72 4
-VX: VMULOSB 264 4
-VX: VMULOSH 328 4
-VX: VMULEUB 520 4
-VX: VMULEUH 584 4
-VX: VMULESB 776 4
-VX: VMULESH 840 4
-VX: VSUM4UBS 1544 4
-VX: VSUM4SBS 1800 4
-VX: VSUM4SHS 1608 4
-VX: VSUM2SWS 1672 4
-VX: VSUMSWS 1928 4
-
-VX: VADDFP 10 4
-VX: VSUBFP 74 4
-
-VXDB: VREFP 266 4
-VXDB: VRSQRTEFP 330 4
-VXDB: VEXPTEFP 394 4
-VXDB: VLOGEFP 458 4
-VXDB: VRFIN 522 4
-VXDB: VRFIZ 586 4
-VXDB: VRFIP 650 4
-VXDB: VRFIM 714 4
-
-VX: VCFUX 778 4
-VX: VCFSX 842 4
-VX: VCTUXS 906 4
-VX: VCTSXS 970 4
-
-VX: VMAXFP 1034 4
-VX: VMINFP 1098 4
-
-VX: VMRGHB 12 4
-VX: VMRGHH 76 4
-VX: VMRGHW 140 4
-VX: VMRGLB 268 4
-VX: VMRGLH 332 4
-VX: VMRGLW 396 4
-
-VX: VSPLTB 524 4
-VX: VSPLTH 588 4
-VX: VSPLTW 652 4
-
-VXA: VSPLTISB 780 4
-VXA: VSPLTISH 844 4
-VXA: VSPLTISW 908 4
-
-VX: VSLO 1036 4
-VX: VSRO 1100 4
-
-VX: VPKUHUM 14 4
-VX: VPKUWUM 78 4
-VX: VPKUHUS 142 4
-VX: VPKUWUS 206 4
-VX: VPKSHUS 270 4
-VX: VPKSWUS 334 4
-VX: VPKSHSS 398 4
-VX: VPKSWSS 462 4
-VX: VPKPX 782 4
-
-VXDB: VUPKHSB 526 4
-VXDB: VUPKHSH 590 4
-VXDB: VUPKLSB 654 4
-VXDB: VUPKLSH 718 4
-VXDB: VUPKHPX 846 4
-VXDB: VUPKLPX 974 4
-
-: -T ( strm a b -- strm-t a b ) [ 16 bitor ] 2dip ;
-
-XD: DST 0 342 31
-: DSTT ( strm a b -- ) -T DST ;
-
-XD: DSTST 0 374 31
-: DSTSTT ( strm a b -- ) -T DSTST ;
-
-XD: (DSS) 0 822 31
-: DSS ( strm -- ) 0 0 (DSS) ;
-: DSSALL ( -- ) 16 0 0 (DSS) ;
-
-XD: LVEBX 0 7 31
-XD: LVEHX 0 39 31
-XD: LVEWX 0 71 31
-XD: LVSL 0 6 31
-XD: LVSR 0 38 31
-XD: LVX 0 103 31
-XD: LVXL 0 359 31
-
-XD: STVEBX 0 135 31
-XD: STVEHX 0 167 31
-XD: STVEWX 0 199 31
-XD: STVX 0 231 31
-XD: STVXL 0 487 31
-
-VXR: VCMPBFP 0 966 4
-VXR: VCMPEQFP 0 198 4
-VXR: VCMPEQUB 0 6 4
-VXR: VCMPEQUH 0 70 4
-VXR: VCMPEQUW 0 134 4
-VXR: VCMPGEFP 0 454 4
-VXR: VCMPGTFP 0 710 4
-VXR: VCMPGTSB 0 774 4
-VXR: VCMPGTSH 0 838 4
-VXR: VCMPGTSW 0 902 4
-VXR: VCMPGTUB 0 518 4
-VXR: VCMPGTUH 0 582 4
-VXR: VCMPGTUW 0 646 4
-
-VXR: VCMPBFP. 1 966 4
-VXR: VCMPEQFP. 1 198 4
-VXR: VCMPEQUB. 1 6 4
-VXR: VCMPEQUH. 1 70 4
-VXR: VCMPEQUW. 1 134 4
-VXR: VCMPGEFP. 1 454 4
-VXR: VCMPGTFP. 1 710 4
-VXR: VCMPGTSB. 1 774 4
-VXR: VCMPGTSH. 1 838 4
-VXR: VCMPGTSW. 1 902 4
-VXR: VCMPGTUB. 1 518 4
-VXR: VCMPGTUH. 1 582 4
-VXR: VCMPGTUW. 1 646 4
-
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces make sequences words math
-math.bitwise io.binary parser lexer fry ;
-IN: cpu.ppc.assembler.backend
-
-: insn ( operand opcode -- ) { 26 0 } bitfield 4 >be % ;
-
-: a-insn ( d a b c xo rc opcode -- )
- [ { 0 1 6 11 16 21 } bitfield ] dip insn ;
-
-: b-insn ( bo bi bd aa lk opcode -- )
- [ { 0 1 2 16 21 } bitfield ] dip insn ;
-
-: s>u16 ( s -- u ) HEX: ffff bitand ;
-
-: d-insn ( d a simm opcode -- )
- [ s>u16 { 0 16 21 } bitfield ] dip insn ;
-
-: define-d-insn ( word opcode -- )
- [ d-insn ] curry (( d a simm -- )) define-declared ;
-
-SYNTAX: D: CREATE scan-word define-d-insn ;
-
-: sd-insn ( d a simm opcode -- )
- [ s>u16 { 0 21 16 } bitfield ] dip insn ;
-
-: define-sd-insn ( word opcode -- )
- [ sd-insn ] curry (( d a simm -- )) define-declared ;
-
-SYNTAX: SD: CREATE scan-word define-sd-insn ;
-
-: i-insn ( li aa lk opcode -- )
- [ { 0 1 0 } bitfield ] dip insn ;
-
-: x-insn ( a s b rc xo opcode -- )
- [ { 1 0 11 21 16 } bitfield ] dip insn ;
-
-: xd-insn ( d a b rc xo opcode -- )
- [ { 1 0 11 16 21 } bitfield ] dip insn ;
-
-: (X) ( -- word quot )
- CREATE scan-word scan-word scan-word [ x-insn ] 3curry ;
-
-: (XD) ( -- word quot )
- CREATE scan-word scan-word scan-word [ xd-insn ] 3curry ;
-
-SYNTAX: X: (X) (( a s b -- )) define-declared ;
-SYNTAX: XD: (XD) (( d a b -- )) define-declared ;
-
-: (1) ( quot -- quot' ) [ 0 ] prepose ;
-
-SYNTAX: X1: (X) (1) (( a s -- )) define-declared ;
-
-: xfx-insn ( d spr xo opcode -- )
- [ { 1 11 21 } bitfield ] dip insn ;
-
-: CREATE-MF ( -- word ) scan "MF" prepend create-in ;
-
-SYNTAX: MFSPR:
- CREATE-MF scan-word 5 shift [ 339 31 xfx-insn ] curry
- (( d -- )) define-declared ;
-
-: CREATE-MT ( -- word ) scan "MT" prepend create-in ;
-
-SYNTAX: MTSPR:
- CREATE-MT scan-word 5 shift [ 467 31 xfx-insn ] curry
- (( d -- )) define-declared ;
-
-: xo-insn ( d a b oe rc xo opcode -- )
- [ { 1 0 10 11 16 21 } bitfield ] dip insn ;
-
-: (XO) ( -- word quot )
- CREATE scan-word scan-word scan-word scan-word
- [ xo-insn ] 2curry 2curry ;
-
-SYNTAX: XO: (XO) (( d a b -- )) define-declared ;
-
-SYNTAX: XO1: (XO) (1) (( d a -- )) define-declared ;
-
-GENERIC# (B) 2 ( dest aa lk -- )
-M: integer (B) 18 i-insn ;
-
-GENERIC: BC ( a b c -- )
-M: integer BC 0 0 16 b-insn ;
-
-: CREATE-B ( -- word ) scan "B" prepend create-in ;
-
-SYNTAX: BC:
- CREATE-B scan-word scan-word
- '[ [ _ _ ] dip BC ] (( c -- )) define-declared ;
-
-SYNTAX: B:
- CREATE-B scan-word scan-word scan-word scan-word scan-word
- '[ _ _ _ _ _ b-insn ] (( bo -- )) define-declared ;
-
-: va-insn ( d a b c xo opcode -- )
- [ { 0 6 11 16 21 } bitfield ] dip insn ;
-
-: (VA) ( -- word quot )
- CREATE scan-word scan-word [ va-insn ] 2curry ;
-
-SYNTAX: VA: (VA) (( d a b c -- )) define-declared ;
-
-: vx-insn ( d a b xo opcode -- )
- [ { 0 11 16 21 } bitfield ] dip insn ;
-
-: (VX) ( -- word quot )
- CREATE scan-word scan-word [ vx-insn ] 2curry ;
-: (VXD) ( -- word quot )
- CREATE scan-word scan-word '[ 0 0 _ _ vx-insn ] ;
-: (VXA) ( -- word quot )
- CREATE scan-word scan-word '[ [ 0 ] dip 0 _ _ vx-insn ] ;
-: (VXB) ( -- word quot )
- CREATE scan-word scan-word '[ [ 0 0 ] dip _ _ vx-insn ] ;
-: (VXDB) ( -- word quot )
- CREATE scan-word scan-word '[ [ 0 ] dip _ _ vx-insn ] ;
-
-SYNTAX: VX: (VX) (( d a b -- )) define-declared ;
-SYNTAX: VXD: (VXD) (( d -- )) define-declared ;
-SYNTAX: VXA: (VXA) (( a -- )) define-declared ;
-SYNTAX: VXB: (VXB) (( b -- )) define-declared ;
-SYNTAX: VXDB: (VXDB) (( d b -- )) define-declared ;
-
-: vxr-insn ( d a b rc xo opcode -- )
- [ { 0 10 11 16 21 } bitfield ] dip insn ;
-
-: (VXR) ( -- word quot )
- CREATE scan-word scan-word scan-word [ vxr-insn ] 3curry ;
-
-SYNTAX: VXR: (VXR) (( d a b -- )) define-declared ;
-
+++ /dev/null
-PowerPC assembler
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2007, 2010 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: bootstrap.image.private kernel kernel.private namespaces\r
-system cpu.ppc.assembler compiler.units compiler.constants math\r
-math.private math.ranges layouts words vocabs slots.private\r
-locals locals.backend generic.single.private fry sequences\r
-threads.private strings.private ;\r
-FROM: cpu.ppc.assembler => B ;\r
-IN: bootstrap.ppc\r
-\r
-4 \ cell set\r
-big-endian on\r
-\r
-CONSTANT: ds-reg 13\r
-CONSTANT: rs-reg 14\r
-CONSTANT: vm-reg 15\r
-CONSTANT: ctx-reg 16\r
-CONSTANT: nv-reg 17\r
-\r
-: jit-call ( string -- )\r
- 0 2 LOAD32 rc-absolute-ppc-2/2 jit-dlsym\r
- 2 MTLR\r
- BLRL ;\r
-\r
-: jit-call-quot ( -- )\r
- 4 3 quot-entry-point-offset LWZ\r
- 4 MTLR\r
- BLRL ;\r
-\r
-: jit-jump-quot ( -- )\r
- 4 3 quot-entry-point-offset LWZ\r
- 4 MTCTR\r
- BCTR ;\r
-\r
-: factor-area-size ( -- n ) 16 ;\r
-\r
-: stack-frame ( -- n )\r
- reserved-size\r
- factor-area-size +\r
- 16 align ;\r
-\r
-: next-save ( -- n ) stack-frame 4 - ;\r
-: xt-save ( -- n ) stack-frame 8 - ;\r
-\r
-: param-size ( -- n ) 32 ;\r
-\r
-: save-at ( m -- n ) reserved-size + param-size + ;\r
-\r
-: save-int ( register offset -- ) [ 1 ] dip save-at STW ;\r
-: restore-int ( register offset -- ) [ 1 ] dip save-at LWZ ;\r
-\r
-: save-fp ( register offset -- ) [ 1 ] dip save-at STFD ;\r
-: restore-fp ( register offset -- ) [ 1 ] dip save-at LFD ;\r
-\r
-: save-vec ( register offset -- ) save-at 2 LI 2 1 STVXL ;\r
-: restore-vec ( register offset -- ) save-at 2 LI 2 1 LVXL ;\r
-\r
-: nv-int-regs ( -- seq ) 13 31 [a,b] ;\r
-: nv-fp-regs ( -- seq ) 14 31 [a,b] ;\r
-: nv-vec-regs ( -- seq ) 20 31 [a,b] ;\r
-\r
-: saved-int-regs-size ( -- n ) 96 ;\r
-: saved-fp-regs-size ( -- n ) 144 ;\r
-: saved-vec-regs-size ( -- n ) 208 ;\r
-\r
-: callback-frame-size ( -- n )\r
- reserved-size\r
- param-size +\r
- saved-int-regs-size +\r
- saved-fp-regs-size +\r
- saved-vec-regs-size +\r
- 4 +\r
- 16 align ;\r
-\r
-: old-context-save-offset ( -- n )\r
- 432 save-at ;\r
-\r
-[\r
- ! Save old stack pointer\r
- 11 1 MR\r
-\r
- ! Create stack frame\r
- 0 MFLR\r
- 1 1 callback-frame-size SUBI\r
- 0 1 callback-frame-size lr-save + STW\r
-\r
- ! Save all non-volatile registers\r
- nv-int-regs [ 4 * save-int ] each-index\r
- nv-fp-regs [ 8 * 80 + save-fp ] each-index\r
- nv-vec-regs [ 16 * 224 + save-vec ] each-index\r
-\r
- ! Stick old stack pointer in a non-volatile register so that\r
- ! callbacks can access their arguments\r
- nv-reg 11 MR\r
-\r
- ! Load VM into vm-reg\r
- 0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel\r
-\r
- ! Save old context\r
- 2 vm-reg vm-context-offset LWZ\r
- 2 1 old-context-save-offset STW\r
-\r
- ! Switch over to the spare context\r
- 2 vm-reg vm-spare-context-offset LWZ\r
- 2 vm-reg vm-context-offset STW\r
-\r
- ! Save C callstack pointer\r
- 1 2 context-callstack-save-offset STW\r
-\r
- ! Load Factor callstack pointer\r
- 1 2 context-callstack-bottom-offset LWZ\r
-\r
- ! Call into Factor code\r
- 0 2 LOAD32 rc-absolute-ppc-2/2 rt-entry-point jit-rel\r
- 2 MTLR\r
- BLRL\r
-\r
- ! Load VM again, pointlessly\r
- 0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel\r
-\r
- ! Load C callstack pointer\r
- 2 vm-reg vm-context-offset LWZ\r
- 1 2 context-callstack-save-offset LWZ\r
-\r
- ! Load old context\r
- 2 1 old-context-save-offset LWZ\r
- 2 vm-reg vm-context-offset STW\r
-\r
- ! Restore non-volatile registers\r
- nv-vec-regs [ 16 * 224 + restore-vec ] each-index\r
- nv-fp-regs [ 8 * 80 + restore-fp ] each-index\r
- nv-int-regs [ 4 * restore-int ] each-index\r
-\r
- ! Tear down stack frame and return\r
- 0 1 callback-frame-size lr-save + LWZ\r
- 1 1 callback-frame-size ADDI\r
- 0 MTLR\r
- BLR\r
-] callback-stub jit-define\r
-\r
-: jit-conditional* ( test-quot false-quot -- )\r
- [ '[ 4 /i 1 + @ ] ] dip jit-conditional ; inline\r
-\r
-: jit-load-context ( -- )\r
- ctx-reg vm-reg vm-context-offset LWZ ;\r
-\r
-: jit-save-context ( -- )\r
- jit-load-context\r
- 1 ctx-reg context-callstack-top-offset STW\r
- ds-reg ctx-reg context-datastack-offset STW\r
- rs-reg ctx-reg context-retainstack-offset STW ;\r
-\r
-: jit-restore-context ( -- )\r
- ds-reg ctx-reg context-datastack-offset LWZ\r
- rs-reg ctx-reg context-retainstack-offset LWZ ;\r
-\r
-[\r
- 0 12 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel\r
- 11 12 profile-count-offset LWZ\r
- 11 11 1 tag-fixnum ADDI\r
- 11 12 profile-count-offset STW\r
- 11 12 word-code-offset LWZ\r
- 11 11 compiled-header-size ADDI\r
- 11 MTCTR\r
- BCTR\r
-] jit-profiling jit-define\r
-\r
-[\r
- 0 2 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel\r
- 0 MFLR\r
- 1 1 stack-frame SUBI\r
- 2 1 xt-save STW\r
- stack-frame 2 LI\r
- 2 1 next-save STW\r
- 0 1 lr-save stack-frame + STW\r
-] jit-prolog jit-define\r
-\r
-[\r
- 0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel\r
- 3 ds-reg 4 STWU\r
-] jit-push jit-define\r
-\r
-[\r
- jit-save-context\r
- 3 vm-reg MR\r
- 0 4 LOAD32 rc-absolute-ppc-2/2 rt-dlsym jit-rel\r
- 4 MTLR\r
- BLRL\r
- jit-restore-context\r
-] jit-primitive jit-define\r
-\r
-[ 0 BL rc-relative-ppc-3 rt-entry-point-pic jit-rel ] jit-word-call jit-define\r
-\r
-[\r
- 0 6 LOAD32 rc-absolute-ppc-2/2 rt-here jit-rel\r
- 0 B rc-relative-ppc-3 rt-entry-point-pic-tail jit-rel\r
-] jit-word-jump jit-define\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- ds-reg dup 4 SUBI\r
- 0 3 \ f type-number CMPI\r
- [ BEQ ] [ 0 B rc-relative-ppc-3 rt-entry-point jit-rel ] jit-conditional*\r
- 0 B rc-relative-ppc-3 rt-entry-point jit-rel\r
-] jit-if jit-define\r
-\r
-: jit->r ( -- )\r
- 4 ds-reg 0 LWZ\r
- ds-reg dup 4 SUBI\r
- 4 rs-reg 4 STWU ;\r
-\r
-: jit-2>r ( -- )\r
- 4 ds-reg 0 LWZ\r
- 5 ds-reg -4 LWZ\r
- ds-reg dup 8 SUBI\r
- rs-reg dup 8 ADDI\r
- 4 rs-reg 0 STW\r
- 5 rs-reg -4 STW ;\r
-\r
-: jit-3>r ( -- )\r
- 4 ds-reg 0 LWZ\r
- 5 ds-reg -4 LWZ\r
- 6 ds-reg -8 LWZ\r
- ds-reg dup 12 SUBI\r
- rs-reg dup 12 ADDI\r
- 4 rs-reg 0 STW\r
- 5 rs-reg -4 STW\r
- 6 rs-reg -8 STW ;\r
-\r
-: jit-r> ( -- )\r
- 4 rs-reg 0 LWZ\r
- rs-reg dup 4 SUBI\r
- 4 ds-reg 4 STWU ;\r
-\r
-: jit-2r> ( -- )\r
- 4 rs-reg 0 LWZ\r
- 5 rs-reg -4 LWZ\r
- rs-reg dup 8 SUBI\r
- ds-reg dup 8 ADDI\r
- 4 ds-reg 0 STW\r
- 5 ds-reg -4 STW ;\r
-\r
-: jit-3r> ( -- )\r
- 4 rs-reg 0 LWZ\r
- 5 rs-reg -4 LWZ\r
- 6 rs-reg -8 LWZ\r
- rs-reg dup 12 SUBI\r
- ds-reg dup 12 ADDI\r
- 4 ds-reg 0 STW\r
- 5 ds-reg -4 STW\r
- 6 ds-reg -8 STW ;\r
-\r
-[\r
- jit->r\r
- 0 BL rc-relative-ppc-3 rt-entry-point jit-rel\r
- jit-r>\r
-] jit-dip jit-define\r
-\r
-[\r
- jit-2>r\r
- 0 BL rc-relative-ppc-3 rt-entry-point jit-rel\r
- jit-2r>\r
-] jit-2dip jit-define\r
-\r
-[\r
- jit-3>r\r
- 0 BL rc-relative-ppc-3 rt-entry-point jit-rel\r
- jit-3r>\r
-] jit-3dip jit-define\r
-\r
-[\r
- 0 1 lr-save stack-frame + LWZ\r
- 1 1 stack-frame ADDI\r
- 0 MTLR\r
-] jit-epilog jit-define\r
-\r
-[ BLR ] jit-return jit-define\r
-\r
-! ! ! Polymorphic inline caches\r
-\r
-! Don't touch r6 here; it's used to pass the tail call site\r
-! address for tail PICs\r
-\r
-! Load a value from a stack position\r
-[\r
- 4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel\r
-] pic-load jit-define\r
-\r
-[ 4 4 tag-mask get ANDI ] pic-tag jit-define\r
-\r
-[\r
- 3 4 MR\r
- 4 4 tag-mask get ANDI\r
- 0 4 tuple type-number CMPI\r
- [ BNE ]\r
- [ 4 3 tuple-class-offset LWZ ]\r
- jit-conditional*\r
-] pic-tuple jit-define\r
-\r
-[\r
- 0 4 0 CMPI rc-absolute-ppc-2 rt-untagged jit-rel\r
-] pic-check-tag jit-define\r
-\r
-[\r
- 0 5 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel\r
- 4 0 5 CMP\r
-] pic-check-tuple jit-define\r
-\r
-[\r
- [ BNE ] [ 0 B rc-relative-ppc-3 rt-entry-point jit-rel ] jit-conditional*\r
-] pic-hit jit-define\r
-\r
-! Inline cache miss entry points\r
-: jit-load-return-address ( -- ) 6 MFLR ;\r
-\r
-! These are always in tail position with an existing stack\r
-! frame, and the stack. The frame setup takes this into account.\r
-: jit-inline-cache-miss ( -- )\r
- jit-save-context\r
- 3 6 MR\r
- 4 vm-reg MR\r
- "inline_cache_miss" jit-call\r
- jit-load-context\r
- jit-restore-context ;\r
-\r
-[ jit-load-return-address jit-inline-cache-miss ]\r
-[ 3 MTLR BLRL ]\r
-[ 3 MTCTR BCTR ]\r
-\ inline-cache-miss define-combinator-primitive\r
-\r
-[ jit-inline-cache-miss ]\r
-[ 3 MTLR BLRL ]\r
-[ 3 MTCTR BCTR ]\r
-\ inline-cache-miss-tail define-combinator-primitive\r
-\r
-! ! ! Megamorphic caches\r
-\r
-[\r
- ! class = ...\r
- 3 4 MR\r
- 4 4 tag-mask get ANDI\r
- 4 4 tag-bits get SLWI\r
- 0 4 tuple type-number tag-fixnum CMPI\r
- [ BNE ]\r
- [ 4 3 tuple-class-offset LWZ ]\r
- jit-conditional*\r
- ! cache = ...\r
- 0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel\r
- ! key = hashcode(class)\r
- 5 4 1 SRAWI\r
- ! key &= cache.length - 1\r
- 5 5 mega-cache-size get 1 - 4 * ANDI\r
- ! cache += array-start-offset\r
- 3 3 array-start-offset ADDI\r
- ! cache += key\r
- 3 3 5 ADD\r
- ! if(get(cache) == class)\r
- 6 3 0 LWZ\r
- 6 0 4 CMP\r
- [ BNE ]\r
- [\r
- ! megamorphic_cache_hits++\r
- 0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel\r
- 5 4 0 LWZ\r
- 5 5 1 ADDI\r
- 5 4 0 STW\r
- ! ... goto get(cache + 4)\r
- 3 3 4 LWZ\r
- 3 3 word-entry-point-offset LWZ\r
- 3 MTCTR\r
- BCTR\r
- ]\r
- jit-conditional*\r
- ! fall-through on miss\r
-] mega-lookup jit-define\r
-\r
-! ! ! Sub-primitives\r
-\r
-! Quotations and words\r
-[\r
- 3 ds-reg 0 LWZ\r
- ds-reg dup 4 SUBI\r
-]\r
-[ jit-call-quot ]\r
-[ jit-jump-quot ] \ (call) define-combinator-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- ds-reg dup 4 SUBI\r
- 4 3 word-entry-point-offset LWZ\r
-]\r
-[ 4 MTLR BLRL ]\r
-[ 4 MTCTR BCTR ] \ (execute) define-combinator-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- ds-reg dup 4 SUBI\r
- 4 3 word-entry-point-offset LWZ\r
- 4 MTCTR BCTR\r
-] jit-execute jit-define\r
-\r
-! Special primitives\r
-[\r
- nv-reg 3 MR\r
-\r
- 3 vm-reg MR\r
- "begin_callback" jit-call\r
-\r
- jit-load-context\r
- jit-restore-context\r
-\r
- ! Call quotation\r
- 3 nv-reg MR\r
- jit-call-quot\r
-\r
- jit-save-context\r
-\r
- 3 vm-reg MR\r
- "end_callback" jit-call\r
-] \ c-to-factor define-sub-primitive\r
-\r
-[\r
- ! Unwind stack frames\r
- 1 4 MR\r
-\r
- ! Load VM pointer into vm-reg, since we're entering from\r
- ! C code\r
- 0 vm-reg LOAD32 0 rc-absolute-ppc-2/2 jit-vm\r
-\r
- ! Load ds and rs registers\r
- jit-load-context\r
- jit-restore-context\r
-\r
- ! We have changed the stack; load return address again\r
- 0 1 lr-save LWZ\r
- 0 MTLR\r
-\r
- ! Call quotation\r
- jit-call-quot\r
-] \ unwind-native-frames define-sub-primitive\r
-\r
-[\r
- ! Load callstack object\r
- 6 ds-reg 0 LWZ\r
- ds-reg ds-reg 4 SUBI\r
- ! Get ctx->callstack_bottom\r
- jit-load-context\r
- 3 ctx-reg context-callstack-bottom-offset LWZ\r
- ! Get top of callstack object -- 'src' for memcpy\r
- 4 6 callstack-top-offset ADDI\r
- ! Get callstack length, in bytes --- 'len' for memcpy\r
- 5 6 callstack-length-offset LWZ\r
- 5 5 tag-bits get SRAWI\r
- ! Compute new stack pointer -- 'dst' for memcpy\r
- 3 5 3 SUBF\r
- ! Install new stack pointer\r
- 1 3 MR\r
- ! Call memcpy; arguments are now in the correct registers\r
- 1 1 -64 STWU\r
- "factor_memcpy" jit-call\r
- 1 1 0 LWZ\r
- ! Return with new callstack\r
- 0 1 lr-save LWZ\r
- 0 MTLR\r
- BLR\r
-] \ set-callstack define-sub-primitive\r
-\r
-[\r
- jit-save-context\r
- 4 vm-reg MR\r
- "lazy_jit_compile" jit-call\r
-]\r
-[ jit-call-quot ]\r
-[ jit-jump-quot ]\r
-\ lazy-jit-compile define-combinator-primitive\r
-\r
-! Objects\r
-[\r
- 3 ds-reg 0 LWZ\r
- 3 3 tag-mask get ANDI\r
- 3 3 tag-bits get SLWI\r
- 3 ds-reg 0 STW\r
-] \ tag define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZU\r
- 3 3 2 SRAWI\r
- 4 4 0 0 31 tag-bits get - RLWINM\r
- 4 3 3 LWZX\r
- 3 ds-reg 0 STW\r
-] \ slot define-sub-primitive\r
-\r
-[\r
- ! load string index from stack\r
- 3 ds-reg -4 LWZ\r
- 3 3 tag-bits get SRAWI\r
- ! load string from stack\r
- 4 ds-reg 0 LWZ\r
- ! load character\r
- 4 4 string-offset ADDI\r
- 3 3 4 LBZX\r
- 3 3 tag-bits get SLWI\r
- ! store character to stack\r
- ds-reg ds-reg 4 SUBI\r
- 3 ds-reg 0 STW\r
-] \ string-nth-fast define-sub-primitive\r
-\r
-! Shufflers\r
-[\r
- ds-reg dup 4 SUBI\r
-] \ drop define-sub-primitive\r
-\r
-[\r
- ds-reg dup 8 SUBI\r
-] \ 2drop define-sub-primitive\r
-\r
-[\r
- ds-reg dup 12 SUBI\r
-] \ 3drop define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 3 ds-reg 4 STWU\r
-] \ dup define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZ\r
- ds-reg dup 8 ADDI\r
- 3 ds-reg 0 STW\r
- 4 ds-reg -4 STW\r
-] \ 2dup define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZ\r
- 5 ds-reg -8 LWZ\r
- ds-reg dup 12 ADDI\r
- 3 ds-reg 0 STW\r
- 4 ds-reg -4 STW\r
- 5 ds-reg -8 STW\r
-] \ 3dup define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- ds-reg dup 4 SUBI\r
- 3 ds-reg 0 STW\r
-] \ nip define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- ds-reg dup 8 SUBI\r
- 3 ds-reg 0 STW\r
-] \ 2nip define-sub-primitive\r
-\r
-[\r
- 3 ds-reg -4 LWZ\r
- 3 ds-reg 4 STWU\r
-] \ over define-sub-primitive\r
-\r
-[\r
- 3 ds-reg -8 LWZ\r
- 3 ds-reg 4 STWU\r
-] \ pick define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZ\r
- 4 ds-reg 0 STW\r
- 3 ds-reg 4 STWU\r
-] \ dupd define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZ\r
- 3 ds-reg -4 STW\r
- 4 ds-reg 0 STW\r
-] \ swap define-sub-primitive\r
-\r
-[\r
- 3 ds-reg -4 LWZ\r
- 4 ds-reg -8 LWZ\r
- 3 ds-reg -8 STW\r
- 4 ds-reg -4 STW\r
-] \ swapd define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZ\r
- 5 ds-reg -8 LWZ\r
- 4 ds-reg -8 STW\r
- 3 ds-reg -4 STW\r
- 5 ds-reg 0 STW\r
-] \ rot define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZ\r
- 5 ds-reg -8 LWZ\r
- 3 ds-reg -8 STW\r
- 5 ds-reg -4 STW\r
- 4 ds-reg 0 STW\r
-] \ -rot define-sub-primitive\r
-\r
-[ jit->r ] \ load-local define-sub-primitive\r
-\r
-! Comparisons\r
-: jit-compare ( insn -- )\r
- t jit-literal\r
- 0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel\r
- 4 ds-reg 0 LWZ\r
- 5 ds-reg -4 LWZU\r
- 5 0 4 CMP\r
- 2 swap execute( offset -- ) ! magic number\r
- \ f type-number 3 LI\r
- 3 ds-reg 0 STW ;\r
-\r
-: define-jit-compare ( insn word -- )\r
- [ [ jit-compare ] curry ] dip define-sub-primitive ;\r
-\r
-\ BEQ \ eq? define-jit-compare\r
-\ BGE \ fixnum>= define-jit-compare\r
-\ BLE \ fixnum<= define-jit-compare\r
-\ BGT \ fixnum> define-jit-compare\r
-\ BLT \ fixnum< define-jit-compare\r
-\r
-! Math\r
-[\r
- 3 ds-reg 0 LWZ\r
- ds-reg ds-reg 4 SUBI\r
- 4 ds-reg 0 LWZ\r
- 3 3 4 OR\r
- 3 3 tag-mask get ANDI\r
- \ f type-number 4 LI\r
- 0 3 0 CMPI\r
- [ BNE ] [ 1 tag-fixnum 4 LI ] jit-conditional*\r
- 4 ds-reg 0 STW\r
-] \ both-fixnums? define-sub-primitive\r
-\r
-: jit-math ( insn -- )\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZU\r
- [ 5 3 4 ] dip execute( dst src1 src2 -- )\r
- 5 ds-reg 0 STW ;\r
-\r
-[ \ ADD jit-math ] \ fixnum+fast define-sub-primitive\r
-\r
-[ \ SUBF jit-math ] \ fixnum-fast define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZU\r
- 4 4 tag-bits get SRAWI\r
- 5 3 4 MULLW\r
- 5 ds-reg 0 STW\r
-] \ fixnum*fast define-sub-primitive\r
-\r
-[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive\r
-\r
-[ \ OR jit-math ] \ fixnum-bitor define-sub-primitive\r
-\r
-[ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 3 3 NOT\r
- 3 3 tag-mask get XORI\r
- 3 ds-reg 0 STW\r
-] \ fixnum-bitnot define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 3 3 tag-bits get SRAWI\r
- ds-reg ds-reg 4 SUBI\r
- 4 ds-reg 0 LWZ\r
- 5 4 3 SLW\r
- 6 3 NEG\r
- 7 4 6 SRAW\r
- 7 7 0 0 31 tag-bits get - RLWINM\r
- 0 3 0 CMPI\r
- [ BGT ] [ 5 7 MR ] jit-conditional*\r
- 5 ds-reg 0 STW\r
-] \ fixnum-shift-fast define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- ds-reg ds-reg 4 SUBI\r
- 4 ds-reg 0 LWZ\r
- 5 4 3 DIVW\r
- 6 5 3 MULLW\r
- 7 6 4 SUBF\r
- 7 ds-reg 0 STW\r
-] \ fixnum-mod define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- ds-reg ds-reg 4 SUBI\r
- 4 ds-reg 0 LWZ\r
- 5 4 3 DIVW\r
- 5 5 tag-bits get SLWI\r
- 5 ds-reg 0 STW\r
-] \ fixnum/i-fast define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZ\r
- 5 4 3 DIVW\r
- 6 5 3 MULLW\r
- 7 6 4 SUBF\r
- 5 5 tag-bits get SLWI\r
- 5 ds-reg -4 STW\r
- 7 ds-reg 0 STW\r
-] \ fixnum/mod-fast define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 3 3 2 SRAWI\r
- rs-reg 3 3 LWZX\r
- 3 ds-reg 0 STW\r
-] \ get-local define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- ds-reg ds-reg 4 SUBI\r
- 3 3 2 SRAWI\r
- rs-reg 3 rs-reg SUBF\r
-] \ drop-locals define-sub-primitive\r
-\r
-! Overflowing fixnum arithmetic\r
-:: jit-overflow ( insn func -- )\r
- ds-reg ds-reg 4 SUBI\r
- jit-save-context\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg 4 LWZ\r
- 0 0 LI\r
- 0 MTXER\r
- 6 4 3 insn call( d a s -- )\r
- 6 ds-reg 0 STW\r
- [ BNO ]\r
- [\r
- 5 vm-reg MR\r
- func jit-call\r
- ]\r
- jit-conditional* ;\r
-\r
-[ [ ADDO. ] "overflow_fixnum_add" jit-overflow ] \ fixnum+ define-sub-primitive\r
-\r
-[ [ SUBFO. ] "overflow_fixnum_subtract" jit-overflow ] \ fixnum- define-sub-primitive\r
-\r
-[\r
- ds-reg ds-reg 4 SUBI\r
- jit-save-context\r
- 3 ds-reg 0 LWZ\r
- 3 3 tag-bits get SRAWI\r
- 4 ds-reg 4 LWZ\r
- 0 0 LI\r
- 0 MTXER\r
- 6 3 4 MULLWO.\r
- 6 ds-reg 0 STW\r
- [ BNO ]\r
- [\r
- 4 4 tag-bits get SRAWI\r
- 5 vm-reg MR\r
- "overflow_fixnum_multiply" jit-call\r
- ]\r
- jit-conditional*\r
-] \ fixnum* define-sub-primitive\r
-\r
-! Contexts\r
-: jit-switch-context ( reg -- )\r
- ! Save ds, rs registers\r
- jit-save-context\r
-\r
- ! Make the new context the current one\r
- ctx-reg swap MR\r
- ctx-reg vm-reg vm-context-offset STW\r
-\r
- ! Load new stack pointer\r
- 1 ctx-reg context-callstack-top-offset LWZ\r
-\r
- ! Load new ds, rs registers\r
- jit-restore-context ;\r
-\r
-: jit-pop-context-and-param ( -- )\r
- 3 ds-reg 0 LWZ\r
- 3 3 alien-offset LWZ\r
- 4 ds-reg -4 LWZ\r
- ds-reg ds-reg 8 SUBI ;\r
-\r
-: jit-push-param ( -- )\r
- ds-reg ds-reg 4 ADDI\r
- 4 ds-reg 0 STW ;\r
-\r
-: jit-set-context ( -- )\r
- jit-pop-context-and-param\r
- 3 jit-switch-context\r
- jit-push-param ;\r
-\r
-[ jit-set-context ] \ (set-context) define-sub-primitive\r
-\r
-: jit-pop-quot-and-param ( -- )\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZ\r
- ds-reg ds-reg 8 SUBI ;\r
-\r
-: jit-start-context ( -- )\r
- ! Create the new context in return-reg\r
- 3 vm-reg MR\r
- "new_context" jit-call\r
- 6 3 MR\r
-\r
- jit-pop-quot-and-param\r
-\r
- 6 jit-switch-context\r
-\r
- jit-push-param\r
-\r
- jit-jump-quot ;\r
-\r
-[ jit-start-context ] \ (start-context) define-sub-primitive\r
-\r
-: jit-delete-current-context ( -- )\r
- jit-load-context\r
- 3 vm-reg MR\r
- 4 ctx-reg MR\r
- "delete_context" jit-call ;\r
-\r
-[\r
- jit-delete-current-context\r
- jit-set-context\r
-] \ (set-context-and-delete) define-sub-primitive\r
-\r
-[\r
- jit-delete-current-context\r
- jit-start-context\r
-] \ (start-context-and-delete) define-sub-primitive\r
-\r
-[ "bootstrap.ppc" forget-vocab ] with-compilation-unit\r
+++ /dev/null
-! Copyright (C) 2007, 2010 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: parser system kernel sequences ;
-IN: bootstrap.ppc
-
-: reserved-size ( -- n ) 24 ;
-: lr-save ( -- n ) 4 ;
-
-<< "vocab:cpu/ppc/bootstrap.factor" parse-file suffix! >>
-call
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors system kernel layouts
-alien.c-types cpu.architecture cpu.ppc ;
-IN: cpu.ppc.linux
-
-<<
-t "longlong" c-type stack-align?<<
-t "ulonglong" c-type stack-align?<<
->>
-
-M: linux reserved-area-size 2 cells ;
-
-M: linux lr-save 1 cells ;
-
-M: ppc param-regs
- drop {
- { int-regs { 3 4 5 6 7 8 9 10 } }
- { float-regs { 1 2 3 4 5 6 7 8 } }
- } ;
-
-M: ppc value-struct? drop f ;
-
-M: ppc dummy-stack-params? f ;
-
-M: ppc dummy-int-params? f ;
-
-M: ppc dummy-fp-params? f ;
+++ /dev/null
-Linux/PPC ABI support
+++ /dev/null
-not loaded
+++ /dev/null
-! Copyright (C) 2007, 2010 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: parser system kernel sequences ;
-IN: bootstrap.ppc
-
-: reserved-size ( -- n ) 24 ;
-: lr-save ( -- n ) 8 ;
-
-<< "vocab:cpu/ppc/bootstrap.factor" parse-file suffix! >>
-call
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors system kernel layouts
-alien.c-types cpu.architecture cpu.ppc ;
-IN: cpu.ppc.macosx
-
-M: macosx reserved-area-size 6 cells ;
-
-M: macosx lr-save 2 cells ;
-
-M: ppc param-regs
- drop {
- { int-regs { 3 4 5 6 7 8 9 10 } }
- { float-regs { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
- } ;
-
-M: ppc value-struct? drop t ;
-
-M: ppc dummy-stack-params? t ;
-
-M: ppc dummy-int-params? t ;
-
-M: ppc dummy-fp-params? f ;
+++ /dev/null
-Mac OS X/PPC ABI support
+++ /dev/null
-not loaded
+++ /dev/null
-! Copyright (C) 2005, 2010 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs sequences kernel combinators
-classes.algebra byte-arrays make math math.order math.ranges
-system namespaces locals layouts words alien alien.accessors
-alien.c-types alien.complex alien.data alien.libraries
-literals cpu.architecture cpu.ppc.assembler cpu.ppc.assembler.backend
-compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.comparisons compiler.codegen.fixup
-compiler.cfg.intrinsics compiler.cfg.stack-frame
-compiler.cfg.build-stack-frame compiler.units compiler.constants
-compiler.codegen vm ;
-QUALIFIED-WITH: alien.c-types c
-FROM: cpu.ppc.assembler => B ;
-FROM: layouts => cell ;
-FROM: math => float ;
-IN: cpu.ppc
-
-! PowerPC register assignments:
-! r2-r12: integer vregs
-! r13: data stack
-! r14: retain stack
-! r15: VM pointer
-! r16-r29: integer vregs
-! r30: integer scratch
-! f0-f29: float vregs
-! f30: float scratch
-
-! Add some methods to the assembler that are useful to us
-M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
-M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
-
-enable-float-intrinsics
-
-M: ppc machine-registers
- {
- { int-regs $[ 2 12 [a,b] 16 29 [a,b] append ] }
- { float-regs $[ 0 29 [a,b] ] }
- } ;
-
-CONSTANT: scratch-reg 30
-CONSTANT: fp-scratch-reg 30
-
-M: ppc complex-addressing? f ;
-
-M: ppc fused-unboxing? f ;
-
-M: ppc %load-immediate ( reg n -- ) swap LOAD ;
-
-M: ppc %load-reference ( reg obj -- )
- [ [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-literal ] bi* ]
- [ \ f type-number swap LI ]
- if* ;
-
-M: ppc %alien-global ( register symbol dll -- )
- [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
-
-CONSTANT: ds-reg 13
-CONSTANT: rs-reg 14
-CONSTANT: vm-reg 15
-
-: %load-vm-addr ( reg -- ) vm-reg MR ;
-
-M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip LWZ ;
-
-M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip STW ;
-
-GENERIC: loc-reg ( loc -- reg )
-
-M: ds-loc loc-reg drop ds-reg ;
-M: rs-loc loc-reg drop rs-reg ;
-
-: loc>operand ( loc -- reg n )
- [ loc-reg ] [ n>> cells neg ] bi ; inline
-
-M: ppc %peek loc>operand LWZ ;
-M: ppc %replace loc>operand STW ;
-
-:: (%inc) ( n reg -- ) reg reg n cells ADDI ; inline
-
-M: ppc %inc-d ( n -- ) ds-reg (%inc) ;
-M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
-
-HOOK: reserved-area-size os ( -- n )
-
-! The start of the stack frame contains the size of this frame
-! as well as the currently executing code block
-: factor-area-size ( -- n ) 2 cells ; foldable
-: next-save ( n -- i ) cell - ; foldable
-: xt-save ( n -- i ) 2 cells - ; foldable
-
-! Next, we have the spill area as well as the FFI parameter area.
-! It is safe for them to overlap, since basic blocks with FFI calls
-! will never spill -- indeed, basic blocks with FFI calls do not
-! use vregs at all, and the FFI call is a stack analysis sync point.
-! In the future this will change and the stack frame logic will
-! need to be untangled somewhat.
-
-: param@ ( n -- x ) reserved-area-size + ; inline
-
-: param-save-size ( -- n ) 8 cells ; foldable
-
-: local@ ( n -- x )
- reserved-area-size param-save-size + + ; inline
-
-: spill@ ( n -- offset )
- spill-offset local@ ;
-
-! Some FP intrinsics need a temporary scratch area in the stack
-! frame, 8 bytes in size. This is in the param-save area so it
-! does not overlap with spill slots.
-: scratch@ ( n -- offset )
- factor-area-size + ;
-
-! Finally we have the linkage area
-HOOK: lr-save os ( -- n )
-
-M: ppc stack-frame-size ( stack-frame -- i )
- (stack-frame-size)
- param-save-size +
- reserved-area-size +
- factor-area-size +
- 4 cells align ;
-
-M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ;
-
-M: ppc %jump ( word -- )
- 0 6 LOAD32 4 rc-absolute-ppc-2/2 rel-here
- 0 B rc-relative-ppc-3 rel-word-pic-tail ;
-
-M: ppc %jump-label ( label -- ) B ;
-M: ppc %return ( -- ) BLR ;
-
-M:: ppc %dispatch ( src temp -- )
- 0 temp LOAD32
- 3 cells rc-absolute-ppc-2/2 rel-here
- temp temp src LWZX
- temp MTCTR
- BCTR ;
-
-: (%slot) ( dst obj slot scale tag -- obj dst slot )
- [ 0 assert= ] bi@ swapd ;
-
-M: ppc %slot ( dst obj slot scale tag -- ) (%slot) LWZX ;
-M: ppc %slot-imm ( dst obj slot tag -- ) slot-offset LWZ ;
-M: ppc %set-slot ( src obj slot scale tag -- ) (%slot) STWX ;
-M: ppc %set-slot-imm ( src obj slot tag -- ) slot-offset STW ;
-
-M: ppc %add ADD ;
-M: ppc %add-imm ADDI ;
-M: ppc %sub swap SUBF ;
-M: ppc %sub-imm SUBI ;
-M: ppc %mul MULLW ;
-M: ppc %mul-imm MULLI ;
-M: ppc %and AND ;
-M: ppc %and-imm ANDI ;
-M: ppc %or OR ;
-M: ppc %or-imm ORI ;
-M: ppc %xor XOR ;
-M: ppc %xor-imm XORI ;
-M: ppc %shl SLW ;
-M: ppc %shl-imm swapd SLWI ;
-M: ppc %shr SRW ;
-M: ppc %shr-imm swapd SRWI ;
-M: ppc %sar SRAW ;
-M: ppc %sar-imm SRAWI ;
-M: ppc %not NOT ;
-M: ppc %neg NEG ;
-
-:: overflow-template ( label dst src1 src2 cc insn -- )
- 0 0 LI
- 0 MTXER
- dst src2 src1 insn call
- cc {
- { cc-o [ label BO ] }
- { cc/o [ label BNO ] }
- } case ; inline
-
-M: ppc %fixnum-add ( label dst src1 src2 cc -- )
- [ ADDO. ] overflow-template ;
-
-M: ppc %fixnum-sub ( label dst src1 src2 cc -- )
- [ SUBFO. ] overflow-template ;
-
-M: ppc %fixnum-mul ( label dst src1 src2 cc -- )
- [ MULLWO. ] overflow-template ;
-
-M: ppc %add-float FADD ;
-M: ppc %sub-float FSUB ;
-M: ppc %mul-float FMUL ;
-M: ppc %div-float FDIV ;
-
-M: ppc integer-float-needs-stack-frame? t ;
-
-M:: ppc %integer>float ( dst src -- )
- HEX: 4330 scratch-reg LIS
- scratch-reg 1 0 scratch@ STW
- scratch-reg src MR
- scratch-reg dup HEX: 8000 XORIS
- scratch-reg 1 4 scratch@ STW
- dst 1 0 scratch@ LFD
- scratch-reg 4503601774854144.0 %load-reference
- fp-scratch-reg scratch-reg float-offset LFD
- dst dst fp-scratch-reg FSUB ;
-
-M:: ppc %float>integer ( dst src -- )
- fp-scratch-reg src FCTIWZ
- fp-scratch-reg 1 0 scratch@ STFD
- dst 1 4 scratch@ LWZ ;
-
-M: ppc %copy ( dst src rep -- )
- 2over eq? [ 3drop ] [
- {
- { tagged-rep [ MR ] }
- { int-rep [ MR ] }
- { double-rep [ FMR ] }
- } case
- ] if ;
-
-GENERIC: float-function-param* ( dst src -- )
-
-M: spill-slot float-function-param* [ 1 ] dip n>> spill@ LFD ;
-M: integer float-function-param* FMR ;
-
-: float-function-param ( i src -- )
- [ float-regs cdecl param-regs at nth ] dip float-function-param* ;
-
-: float-function-return ( reg -- )
- float-regs return-regs at first double-rep %copy ;
-
-M:: ppc %unary-float-function ( dst src func -- )
- 0 src float-function-param
- func f %c-invoke
- dst float-function-return ;
-
-M:: ppc %binary-float-function ( dst src1 src2 func -- )
- 0 src1 float-function-param
- 1 src2 float-function-param
- func f %c-invoke
- dst float-function-return ;
-
-! Internal format is always double-precision on PowerPC
-M: ppc %single>double-float double-rep %copy ;
-M: ppc %double>single-float FRSP ;
-
-M: ppc %unbox-alien ( dst src -- )
- alien-offset LWZ ;
-
-M:: ppc %unbox-any-c-ptr ( dst src -- )
- [
- "end" define-label
- 0 dst LI
- ! Is the object f?
- 0 src \ f type-number CMPI
- "end" get BEQ
- ! Compute tag in dst register
- dst src tag-mask get ANDI
- ! Is the object an alien?
- 0 dst alien type-number CMPI
- ! Add an offset to start of byte array's data
- dst src byte-array-offset ADDI
- "end" get BNE
- ! If so, load the offset and add it to the address
- dst src alien-offset LWZ
- "end" resolve-label
- ] with-scope ;
-
-: alien@ ( n -- n' ) cells alien type-number - ;
-
-M:: ppc %box-alien ( dst src temp -- )
- [
- "f" define-label
- dst \ f type-number %load-immediate
- 0 src 0 CMPI
- "f" get BEQ
- dst 5 cells alien temp %allot
- temp \ f type-number %load-immediate
- temp dst 1 alien@ STW
- temp dst 2 alien@ STW
- src dst 3 alien@ STW
- src dst 4 alien@ STW
- "f" resolve-label
- ] with-scope ;
-
-:: %box-displaced-alien/f ( dst displacement base -- )
- base dst 1 alien@ STW
- displacement dst 3 alien@ STW
- displacement dst 4 alien@ STW ;
-
-:: %box-displaced-alien/alien ( dst displacement base temp -- )
- ! Set new alien's base to base.base
- temp base 1 alien@ LWZ
- temp dst 1 alien@ STW
-
- ! Compute displacement
- temp base 3 alien@ LWZ
- temp temp displacement ADD
- temp dst 3 alien@ STW
-
- ! Compute address
- temp base 4 alien@ LWZ
- temp temp displacement ADD
- temp dst 4 alien@ STW ;
-
-:: %box-displaced-alien/byte-array ( dst displacement base temp -- )
- base dst 1 alien@ STW
- displacement dst 3 alien@ STW
- temp base byte-array-offset ADDI
- temp temp displacement ADD
- temp dst 4 alien@ STW ;
-
-:: %box-displaced-alien/dynamic ( dst displacement base temp -- )
- "not-f" define-label
- "not-alien" define-label
-
- ! Is base f?
- 0 base \ f type-number CMPI
- "not-f" get BNE
-
- ! Yes, it is f. Fill in new object
- dst displacement base %box-displaced-alien/f
-
- "end" get B
-
- "not-f" resolve-label
-
- ! Check base type
- temp base tag-mask get ANDI
-
- ! Is base an alien?
- 0 temp alien type-number CMPI
- "not-alien" get BNE
-
- dst displacement base temp %box-displaced-alien/alien
-
- ! We are done
- "end" get B
-
- ! Is base a byte array? It has to be, by now...
- "not-alien" resolve-label
-
- dst displacement base temp %box-displaced-alien/byte-array ;
-
-M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- )
- ! This is ridiculous
- [
- "end" define-label
-
- ! If displacement is zero, return the base
- dst base MR
- 0 displacement 0 CMPI
- "end" get BEQ
-
- ! Displacement is non-zero, we're going to be allocating a new
- ! object
- dst 5 cells alien temp %allot
-
- ! Set expired to f
- temp \ f type-number %load-immediate
- temp dst 2 alien@ STW
-
- dst displacement base temp
- {
- { [ base-class \ f class<= ] [ drop %box-displaced-alien/f ] }
- { [ base-class \ alien class<= ] [ %box-displaced-alien/alien ] }
- { [ base-class \ byte-array class<= ] [ %box-displaced-alien/byte-array ] }
- [ %box-displaced-alien/dynamic ]
- } cond
-
- "end" resolve-label
- ] with-scope ;
-
-: (%memory) ( val base displacement scale offset rep c-type -- base val displacement rep c-type )
- [ [ 0 assert= ] bi@ swapd ] 2dip ; inline
-
-M: ppc %load-memory-imm ( dst base offset rep c-type -- )
- [
- {
- { c:char [ [ dup ] 2dip LBZ dup EXTSB ] }
- { c:uchar [ LBZ ] }
- { c:short [ LHA ] }
- { c:ushort [ LHZ ] }
- { c:int [ LWZ ] }
- { c:uint [ LWZ ] }
- } case
- ] [
- {
- { int-rep [ LWZ ] }
- { float-rep [ LFS ] }
- { double-rep [ LFD ] }
- } case
- ] ?if ;
-
-M: ppc %load-memory ( dst base displacement scale offset rep c-type -- )
- (%memory) [
- {
- { c:char [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
- { c:uchar [ LBZX ] }
- { c:short [ LHAX ] }
- { c:ushort [ LHZX ] }
- { c:int [ LWZX ] }
- { c:uint [ LWZX ] }
- } case
- ] [
- {
- { int-rep [ LWZX ] }
- { float-rep [ LFSX ] }
- { double-rep [ LFDX ] }
- } case
- ] ?if ;
-
-M: ppc %store-memory-imm ( src base offset rep c-type -- )
- [
- {
- { c:char [ STB ] }
- { c:uchar [ STB ] }
- { c:short [ STH ] }
- { c:ushort [ STH ] }
- { c:int [ STW ] }
- { c:uint [ STW ] }
- } case
- ] [
- {
- { int-rep [ STW ] }
- { float-rep [ STFS ] }
- { double-rep [ STFD ] }
- } case
- ] ?if ;
-
-M: ppc %store-memory ( src base displacement scale offset rep c-type -- )
- (%memory) [
- {
- { c:char [ STBX ] }
- { c:uchar [ STBX ] }
- { c:short [ STHX ] }
- { c:ushort [ STHX ] }
- { c:int [ STWX ] }
- { c:uint [ STWX ] }
- } case
- ] [
- {
- { int-rep [ STWX ] }
- { float-rep [ STFSX ] }
- { double-rep [ STFDX ] }
- } case
- ] ?if ;
-
-: load-zone-ptr ( reg -- )
- vm-reg "nursery" vm-field-offset ADDI ;
-
-: load-allot-ptr ( nursery-ptr allot-ptr -- )
- [ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ;
-
-:: inc-allot-ptr ( nursery-ptr allot-ptr n -- )
- scratch-reg allot-ptr n data-alignment get align ADDI
- scratch-reg nursery-ptr 0 STW ;
-
-:: store-header ( dst class -- )
- class type-number tag-header scratch-reg LI
- scratch-reg dst 0 STW ;
-
-: store-tagged ( dst tag -- )
- dupd type-number ORI ;
-
-M:: ppc %allot ( dst size class nursery-ptr -- )
- nursery-ptr dst load-allot-ptr
- nursery-ptr dst size inc-allot-ptr
- dst class store-header
- dst class store-tagged ;
-
-: load-cards-offset ( dst -- )
- 0 swap LOAD32 rc-absolute-ppc-2/2 rel-cards-offset ;
-
-: load-decks-offset ( dst -- )
- 0 swap LOAD32 rc-absolute-ppc-2/2 rel-decks-offset ;
-
-:: (%write-barrier) ( temp1 temp2 -- )
- card-mark scratch-reg LI
-
- ! Mark the card
- temp1 temp1 card-bits SRWI
- temp2 load-cards-offset
- temp1 scratch-reg temp2 STBX
-
- ! Mark the card deck
- temp1 temp1 deck-bits card-bits - SRWI
- temp2 load-decks-offset
- temp1 scratch-reg temp2 STBX ;
-
-M:: ppc %write-barrier ( src slot scale tag temp1 temp2 -- )
- scale 0 assert= tag 0 assert=
- temp1 src slot ADD
- temp1 temp2 (%write-barrier) ;
-
-M:: ppc %write-barrier-imm ( src slot tag temp1 temp2 -- )
- temp1 src slot tag slot-offset ADDI
- temp1 temp2 (%write-barrier) ;
-
-M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- )
- temp1 vm-reg "nursery" vm-field-offset LWZ
- temp2 vm-reg "nursery" vm-field-offset 2 cells + LWZ
- temp1 temp1 size ADDI
- ! is here >= end?
- temp1 0 temp2 CMP
- cc {
- { cc<= [ label BLE ] }
- { cc/<= [ label BGT ] }
- } case ;
-
-: gc-root-offsets ( seq -- seq' )
- [ n>> spill@ ] map f like ;
-
-M: ppc %call-gc ( gc-roots -- )
- 3 swap gc-root-offsets %load-reference
- 4 %load-vm-addr
- "inline_gc" f %c-invoke ;
-
-M: ppc %prologue ( n -- )
- 0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
- 0 MFLR
- {
- [ [ 1 1 ] dip neg ADDI ]
- [ [ 11 1 ] dip xt-save STW ]
- [ 11 LI ]
- [ [ 11 1 ] dip next-save STW ]
- [ [ 0 1 ] dip lr-save + STW ]
- } cleave ;
-
-M: ppc %epilogue ( n -- )
- #! At the end of each word that calls a subroutine, we store
- #! the previous link register value in r0 by popping it off
- #! the stack, set the link register to the contents of r0,
- #! and jump to the link register.
- [ [ 0 1 ] dip lr-save + LWZ ]
- [ [ 1 1 ] dip ADDI ] bi
- 0 MTLR ;
-
-:: (%boolean) ( dst temp branch1 branch2 -- )
- "end" define-label
- dst \ f type-number %load-immediate
- "end" get branch1 execute( label -- )
- branch2 [ "end" get branch2 execute( label -- ) ] when
- dst \ t %load-reference
- "end" get resolve-label ; inline
-
-:: %boolean ( dst cc temp -- )
- cc negate-cc order-cc {
- { cc< [ dst temp \ BLT f (%boolean) ] }
- { cc<= [ dst temp \ BLE f (%boolean) ] }
- { cc> [ dst temp \ BGT f (%boolean) ] }
- { cc>= [ dst temp \ BGE f (%boolean) ] }
- { cc= [ dst temp \ BEQ f (%boolean) ] }
- { cc/= [ dst temp \ BNE f (%boolean) ] }
- } case ;
-
-: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
-
-: (%compare-integer-imm) ( src1 src2 -- )
- [ 0 ] 2dip CMPI ; inline
-
-: (%compare-imm) ( src1 src2 -- )
- [ tag-fixnum ] [ \ f type-number ] if* (%compare-integer-imm) ; inline
-
-: (%compare-float-unordered) ( src1 src2 -- )
- [ 0 ] dip FCMPU ; inline
-
-: (%compare-float-ordered) ( src1 src2 -- )
- [ 0 ] dip FCMPO ; inline
-
-:: (%compare-float) ( src1 src2 cc compare -- branch1 branch2 )
- cc {
- { cc< [ src1 src2 \ compare execute( a b -- ) \ BLT f ] }
- { cc<= [ src1 src2 \ compare execute( a b -- ) \ BLT \ BEQ ] }
- { cc> [ src1 src2 \ compare execute( a b -- ) \ BGT f ] }
- { cc>= [ src1 src2 \ compare execute( a b -- ) \ BGT \ BEQ ] }
- { cc= [ src1 src2 \ compare execute( a b -- ) \ BEQ f ] }
- { cc<> [ src1 src2 \ compare execute( a b -- ) \ BLT \ BGT ] }
- { cc<>= [ src1 src2 \ compare execute( a b -- ) \ BNO f ] }
- { cc/< [ src1 src2 \ compare execute( a b -- ) \ BGE f ] }
- { cc/<= [ src1 src2 \ compare execute( a b -- ) \ BGT \ BO ] }
- { cc/> [ src1 src2 \ compare execute( a b -- ) \ BLE f ] }
- { cc/>= [ src1 src2 \ compare execute( a b -- ) \ BLT \ BO ] }
- { cc/= [ src1 src2 \ compare execute( a b -- ) \ BNE f ] }
- { cc/<> [ src1 src2 \ compare execute( a b -- ) \ BEQ \ BO ] }
- { cc/<>= [ src1 src2 \ compare execute( a b -- ) \ BO f ] }
- } case ; inline
-
-M: ppc %compare [ (%compare) ] 2dip %boolean ;
-
-M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
-
-M: ppc %compare-integer-imm [ (%compare-integer-imm) ] 2dip %boolean ;
-
-M:: ppc %compare-float-ordered ( dst src1 src2 cc temp -- )
- src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
- dst temp branch1 branch2 (%boolean) ;
-
-M:: ppc %compare-float-unordered ( dst src1 src2 cc temp -- )
- src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
- dst temp branch1 branch2 (%boolean) ;
-
-:: %branch ( label cc -- )
- cc order-cc {
- { cc< [ label BLT ] }
- { cc<= [ label BLE ] }
- { cc> [ label BGT ] }
- { cc>= [ label BGE ] }
- { cc= [ label BEQ ] }
- { cc/= [ label BNE ] }
- } case ;
-
-M:: ppc %compare-branch ( label src1 src2 cc -- )
- src1 src2 (%compare)
- label cc %branch ;
-
-M:: ppc %compare-imm-branch ( label src1 src2 cc -- )
- src1 src2 (%compare-imm)
- label cc %branch ;
-
-M:: ppc %compare-integer-imm-branch ( label src1 src2 cc -- )
- src1 src2 (%compare-integer-imm)
- label cc %branch ;
-
-:: (%branch) ( label branch1 branch2 -- )
- label branch1 execute( label -- )
- branch2 [ label branch2 execute( label -- ) ] when ; inline
-
-M:: ppc %compare-float-ordered-branch ( label src1 src2 cc -- )
- src1 src2 cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
- label branch1 branch2 (%branch) ;
-
-M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
- src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
- label branch1 branch2 (%branch) ;
-
-: load-from-frame ( dst n rep -- )
- {
- { int-rep [ [ 1 ] dip LWZ ] }
- { tagged-rep [ [ 1 ] dip LWZ ] }
- { float-rep [ [ 1 ] dip LFS ] }
- { double-rep [ [ 1 ] dip LFD ] }
- { stack-params [ [ 0 1 ] dip LWZ [ 0 1 ] dip param@ STW ] }
- } case ;
-
-: next-param@ ( n -- reg x )
- [ 17 ] dip param@ ;
-
-: store-to-frame ( src n rep -- )
- {
- { int-rep [ [ 1 ] dip STW ] }
- { tagged-rep [ [ 1 ] dip STW ] }
- { float-rep [ [ 1 ] dip STFS ] }
- { double-rep [ [ 1 ] dip STFD ] }
- { stack-params [ [ [ 0 ] dip next-param@ LWZ 0 1 ] dip STW ] }
- } case ;
-
-M: ppc %spill ( src rep dst -- )
- swap [ n>> spill@ ] dip store-to-frame ;
-
-M: ppc %reload ( dst rep src -- )
- swap [ n>> spill@ ] dip load-from-frame ;
-
-M: ppc %loop-entry ;
-
-M: ppc return-regs
- {
- { int-regs { 3 4 5 6 } }
- { float-regs { 1 } }
- } ;
-
-M:: ppc %save-param-reg ( stack reg rep -- )
- reg stack local@ rep store-to-frame ;
-
-M:: ppc %load-param-reg ( stack reg rep -- )
- reg stack local@ rep load-from-frame ;
-
-GENERIC: load-param ( reg src -- )
-
-M: integer load-param int-rep %copy ;
-
-M: spill-slot load-param [ 1 ] dip n>> spill@ LWZ ;
-
-GENERIC: store-param ( reg dst -- )
-
-M: integer store-param swap int-rep %copy ;
-
-M: spill-slot store-param [ 1 ] dip n>> spill@ STW ;
-
-:: call-unbox-func ( src func -- )
- 3 src load-param
- 4 %load-vm-addr
- func f %c-invoke ;
-
-M:: ppc %unbox ( src n rep func -- )
- src func call-unbox-func
- ! Store the return value on the C stack
- n [ rep reg-class-of return-regs at first rep %save-param-reg ] when* ;
-
-M:: ppc %unbox-long-long ( src n func -- )
- src func call-unbox-func
- ! Store the return value on the C stack
- n [
- 3 1 n local@ STW
- 4 1 n cell + local@ STW
- ] when ;
-
-M:: ppc %unbox-large-struct ( src n c-type -- )
- 4 src load-param
- 3 1 n local@ ADDI
- c-type heap-size 5 LI
- "memcpy" "libc" load-library %c-invoke ;
-
-M:: ppc %box ( dst n rep func -- )
- n [ 0 rep reg-class-of cdecl param-reg rep %load-param-reg ] when*
- rep double-rep? 5 4 ? %load-vm-addr
- func f %c-invoke
- 3 dst store-param ;
-
-M:: ppc %box-long-long ( dst n func -- )
- n [
- 3 1 n local@ LWZ
- 4 1 n cell + local@ LWZ
- ] when
- 5 %load-vm-addr
- func f %c-invoke
- 3 dst store-param ;
-
-: struct-return@ ( n -- n )
- [ stack-frame get params>> ] unless* local@ ;
-
-M: ppc %prepare-box-struct ( -- )
- #! Compute target address for value struct return
- 3 1 f struct-return@ ADDI
- 3 1 0 local@ STW ;
-
-M:: ppc %box-large-struct ( dst n c-type -- )
- ! If n = f, then we're boxing a returned struct
- ! Compute destination address and load struct size
- 3 1 n struct-return@ ADDI
- c-type heap-size 4 LI
- 5 %load-vm-addr
- ! Call the function
- "from_value_struct" f %c-invoke
- 3 dst store-param ;
-
-M:: ppc %restore-context ( temp1 temp2 -- )
- temp1 %context
- ds-reg temp1 "datastack" context-field-offset LWZ
- rs-reg temp1 "retainstack" context-field-offset LWZ ;
-
-M:: ppc %save-context ( temp1 temp2 -- )
- temp1 %context
- 1 temp1 "callstack-top" context-field-offset STW
- ds-reg temp1 "datastack" context-field-offset STW
- rs-reg temp1 "retainstack" context-field-offset STW ;
-
-M: ppc %c-invoke ( symbol dll -- )
- [ 11 ] 2dip %alien-global 11 MTLR BLRL ;
-
-M: ppc %alien-indirect ( src -- )
- [ 11 ] dip load-param 11 MTLR BLRL ;
-
-M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
-
-M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
-
-M: ppc immediate-store? drop f ;
-
-M: ppc return-struct-in-registers? ( c-type -- ? )
- c-type return-in-registers?>> ;
-
-M:: ppc %box-small-struct ( dst c-type -- )
- #! Box a <= 16-byte struct returned in r3:r4:r5:r6
- c-type heap-size 7 LI
- 8 %load-vm-addr
- "from_medium_struct" f %c-invoke
- 3 dst store-param ;
-
-: %unbox-struct-1 ( -- )
- ! Alien must be in r3.
- 3 3 0 LWZ ;
-
-: %unbox-struct-2 ( -- )
- ! Alien must be in r3.
- 4 3 4 LWZ
- 3 3 0 LWZ ;
-
-: %unbox-struct-4 ( -- )
- ! Alien must be in r3.
- 6 3 12 LWZ
- 5 3 8 LWZ
- 4 3 4 LWZ
- 3 3 0 LWZ ;
-
-M:: ppc %unbox-small-struct ( src c-type -- )
- src 3 load-param
- c-type heap-size {
- { [ dup 4 <= ] [ drop %unbox-struct-1 ] }
- { [ dup 8 <= ] [ drop %unbox-struct-2 ] }
- { [ dup 16 <= ] [ drop %unbox-struct-4 ] }
- } cond ;
-
-M: ppc %begin-callback ( -- )
- 3 %load-vm-addr
- "begin_callback" f %c-invoke ;
-
-M: ppc %alien-callback ( quot -- )
- 3 swap %load-reference
- 4 3 quot-entry-point-offset LWZ
- 4 MTLR
- BLRL ;
-
-M: ppc %end-callback ( -- )
- 3 %load-vm-addr
- "end_callback" f %c-invoke ;
-
-enable-float-functions
-
-USE: vocabs.loader
-
-{
- { [ os macosx? ] [ "cpu.ppc.macosx" require ] }
- { [ os linux? ] [ "cpu.ppc.linux" require ] }
-} cond
-
-complex-double c-type t >>return-in-registers? drop
+++ /dev/null
-32-bit PowerPC compiler backend
+++ /dev/null
-compiler
-not loaded
include vm/Config.unix
PLAF_DLL_OBJS += vm/os-genunix.o vm/os-freebsd.o vm/mvm-unix.o
-CFLAGS += -export-dynamic
-LIBS = -L/usr/local/lib/ -lm -lrt $(X11_UI_LIBS)
+LIBS = -L/usr/local/lib/ -lm -lrt $(X11_UI_LIBS) -Wl,--export-dynamic
include vm/Config.unix
PLAF_DLL_OBJS += vm/os-genunix.o vm/os-linux.o vm/mvm-unix.o
-CFLAGS += -export-dynamic
-LIBS = -ldl -lm -lrt -lpthread $(X11_UI_LIBS)
+LIBS = -ldl -lm -lrt -lpthread $(X11_UI_LIBS) -Wl,--export-dynamic
+++ /dev/null
-include vm/Config.linux
-include vm/Config.ppc
-CFLAGS += -mregnames
--- /dev/null
+include vm/Config.linux
+PLAF_DLL_OBJS += vm/cpu-ppc.linux.o
+CFLAGS += -m32
--- /dev/null
+include vm/Config.linux
+PLAF_DLL_OBJS += vm/cpu-ppc.linux.o
+CFLAGS += -m64
include vm/Config.macosx
-include vm/Config.ppc
+PLAF_DLL_OBJS += vm/cpu-ppc.macosx.o
CFLAGS += -arch ppc -force_cpusubtype_ALL
include vm/Config.unix
PLAF_DLL_OBJS += vm/os-genunix.o vm/os-netbsd.o vm/mvm-none.o
-CFLAGS += -export-dynamic
LIBPATH = -L/usr/X11R7/lib -Wl,-rpath,/usr/X11R7/lib -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib
-LIBS = -lm -lrt -lssl -lcrypto $(X11_UI_LIBS)
+LIBS = -lm -lrt -lssl -lcrypto $(X11_UI_LIBS) -Wl,--export-dynamic
PLAF_DLL_OBJS += vm/os-genunix.o vm/os-openbsd.o vm/mvm-unix.o
CC = egcc
CPP = eg++
-CFLAGS += -export-dynamic -fno-inline-functions
-LIBS = -L/usr/local/lib/ -lm $(X11_UI_LIBS) -lz -lssl -lcrypto -lpthread
+CFLAGS += -fno-inline-functions
+LIBS = -L/usr/local/lib/ -lm $(X11_UI_LIBS) -lz -lssl -lcrypto -lpthread -Wl,--export-dynamic
+++ /dev/null
-PLAF_DLL_OBJS += vm/cpu-ppc.o
include vm/Config.unix
PLAF_DLL_OBJS += vm/os-genunix.o vm/os-solaris.o
-CFLAGS += -D_STDC_C99 -Drestrict="" -export-dynamic
+CFLAGS += -D_STDC_C99 -Drestrict=""
LIBS += -ldl -lsocket -lnsl -lm -lrt -R/opt/PM/lib -R/opt/csw/lib \
-R/usr/local/lib -R/usr/sfw/lib -R/usr/X11R6/lib \
- -R/opt/sfw/lib $(X11_UI_LIBS)
+ -R/opt/sfw/lib $(X11_UI_LIBS) -Wl,--export-dynamic
ctx->push(allot_alien(ffi_dlsym(NULL,sym)));
}
+/* look up a symbol in a native library */
+void factor_vm::primitive_dlsym_raw()
+{
+ data_root<object> library(ctx->pop(),this);
+ data_root<byte_array> name(ctx->pop(),this);
+ name.untag_check(this);
+
+ symbol_char *sym = name->data<symbol_char>();
+
+ if(to_boolean(library.value()))
+ {
+ dll *d = untag_check<dll>(library.value());
+
+ if(d->handle == NULL)
+ ctx->push(false_object);
+ else
+ ctx->push(allot_alien(ffi_dlsym_raw(d,sym)));
+ }
+ else
+ ctx->push(allot_alien(ffi_dlsym_raw(NULL,sym)));
+}
+
+
/* close a native library handle */
void factor_vm::primitive_dlclose()
{
#else
asm ("bsr %1, %0;":"=r"(n):"r"(x));
#endif
-#elif defined(FACTOR_PPC)
- asm ("cntlzw %1, %0;":"=r"(n):"r"(x));
- n = (31 - n);
+#elif defined(FACTOR_PPC64)
+#if defined(__GNUC__)
+ n = (63 - __builtin_clzll(x));
+#else
+ #error Unsupported compiler
+#endif
+#elif defined(FACTOR_PPC32)
+#if defined(__GNUC__)
+ n = (31 - __builtin_clz(x));
+#else
+ #error Unsupported compiler
+#endif
#else
#error Unsupported CPU
#endif
inline cell popcount(cell x)
{
+#if defined(__GNUC__)
+#ifdef FACTOR_64
+ return __builtin_popcountll(x);
+#else
+ return __builtin_popcount(x);
+#endif
+#else
#ifdef FACTOR_64
u64 k1 = 0x5555555555555555ll;
u64 k2 = 0x3333333333333333ll;
x = (x * kf) >> ks; // returns 8 most significant bits of x + (x<<8) + (x<<16) + (x<<24) + ...
return x;
+#endif
}
inline bool bitmap_p(u8 *bitmap, cell index)
tagged<word> w(ctx->pop());
w.untag_check(this);
- ctx->push(allot_alien(callbacks->add(w.value(),return_rewind)->entry_point()));
+
+ void* func = callbacks->add(w.value(),return_rewind)->entry_point();
+ CODE_TO_FUNCTION_POINTER_CALLBACK(this, func);
+ ctx->push(allot_alien(func));
}
}
template<typename Iterator> void factor_vm::iterate_callstack_object(callstack *stack_, Iterator &iterator)
{
data_root<callstack> stack(stack_,this);
- fixnum frame_offset = untag_fixnum(stack->length) - sizeof(stack_frame);
+ fixnum frame_offset = factor::untag_fixnum(stack->length) - sizeof(stack_frame);
while(frame_offset >= 0)
{
dll *d = (to_boolean(library) ? untag<dll>(library) : NULL);
+ void* undefined_symbol = (void*)factor::undefined_symbol;
+ undefined_symbol = FUNCTION_CODE_POINTER(undefined_symbol);
if(d != NULL && !d->handle)
- return (cell)factor::undefined_symbol;
+ return (cell)undefined_symbol;
switch(tagged<object>(symbol).type())
{
if(sym)
return (cell)sym;
else
- return (cell)factor::undefined_symbol;
+ return (cell)undefined_symbol;
}
case ARRAY_TYPE:
{
if(sym)
return (cell)sym;
}
- return (cell)factor::undefined_symbol;
+ return (cell)undefined_symbol;
}
default:
critical_error("Bad symbol specifier",symbol);
- return (cell)factor::undefined_symbol;
+ return (cell)undefined_symbol;
}
}
+#ifdef FACTOR_PPC
+cell factor_vm::compute_dlsym_toc_address(array *literals, cell index)
+{
+ cell symbol = array_nth(literals,index);
+ cell library = array_nth(literals,index + 1);
+
+ dll *d = (to_boolean(library) ? untag<dll>(library) : NULL);
+
+ void* undefined_toc = (void*)factor::undefined_symbol;
+ undefined_toc = FUNCTION_TOC_POINTER(undefined_toc);
+ if(d != NULL && !d->handle)
+ return (cell)undefined_toc;
+
+ switch(tagged<object>(symbol).type())
+ {
+ case BYTE_ARRAY_TYPE:
+ {
+ symbol_char *name = alien_offset(symbol);
+ void* toc = ffi_dlsym_toc(d,name);
+ if(toc)
+ return (cell)toc;
+ else
+ return (cell)undefined_toc;
+ }
+ case ARRAY_TYPE:
+ {
+ array *names = untag<array>(symbol);
+ for(cell i = 0; i < array_capacity(names); i++)
+ {
+ symbol_char *name = alien_offset(array_nth(names,i));
+ void *toc = ffi_dlsym_toc(d,name);
+
+ if(toc)
+ return (cell)toc;
+ }
+ return (cell)undefined_toc;
+ }
+ default:
+ critical_error("Bad symbol specifier",symbol);
+ return (cell)undefined_toc;
+ }
+}
+#endif
+
+
cell factor_vm::compute_vm_address(cell arg)
{
return (cell)this + untag_fixnum(arg);
case RT_EXCEPTION_HANDLER:
op.store_value((cell)&factor::exception_handler);
break;
+#endif
+#ifdef FACTOR_PPC
+ case RT_DLSYM_TOC:
+ op.store_value(compute_dlsym_toc_address(parameters,index));
+ break;
#endif
default:
critical_error("Bad rel type in store_external_address()",op.rel_type());
+++ /dev/null
-#if defined(__APPLE__)
- #define MANGLE(sym) _##sym
- #define XX @
-#else
- #define MANGLE(sym) sym
- #define XX ;
-#endif
-
-/* The returns and args are just for documentation */
-#define DEF(returns,symbol,args) .globl MANGLE(symbol) XX \
-MANGLE(symbol)
-
-/* Thanks to Joshua Grams for this code.
-
-On PowerPC processors, we must flush the instruction cache manually
-after writing to the code heap. */
-
-DEF(void,flush_icache,(void*, int)):
- /* compute number of cache lines to flush */
- add r4,r4,r3
- /* align addr to next lower cache line boundary */
- clrrwi r3,r3,5
- /* then n_lines = (len + 0x1f) / 0x20 */
- sub r4,r4,r3
- addi r4,r4,0x1f
- /* note '.' suffix */
- srwi. r4,r4,5
- /* if n_lines == 0, just return. */
- beqlr
- /* flush cache lines */
- mtctr r4
- /* for each line... */
-0: dcbf 0,r3
- sync
- icbi 0,r3
- addi r3,r3,0x20
- bdnz 0b
- /* finish up */
- sync
- isync
- blr
-
-DEF(void,get_ppc_fpu_env,(void*)):
- mffs f0
- stfd f0,0(r3)
- blr
-
-DEF(void,set_ppc_fpu_env,(const void*)):
- lfd f0,0(r3)
- mtfsf 0xff,f0
- blr
-
-DEF(void,get_ppc_vmx_env,(void*)):
- mfvscr v0
- subi r4,r1,16
- li r5,0xf
- andc r4,r4,r5
- stvxl v0,0,r4
- li r5,0xc
- lwzx r6,r5,r4
- stw r6,0(r3)
- blr
-
-DEF(void,set_ppc_vmx_env,(const void*)):
- subi r4,r1,16
- li r5,0xf
- andc r4,r4,r5
- li r5,0xc
- lwz r6,0(r3)
- stwx r6,r5,r4
- lvxl v0,0,r4
- mtvscr v0
- blr
namespace factor
{
-#define FACTOR_CPU_STRING "ppc"
+#ifdef FACTOR_64
+#define FACTOR_CPU_STRING "ppc.64"
+#else
+#define FACTOR_CPU_STRING "ppc.32"
+#endif
#define CALLSTACK_BOTTOM(ctx) (stack_frame *)(ctx->callstack_seg->end - 32)
inline static void check_call_site(cell return_address)
{
- cell insn = *(cell *)return_address;
+ u32 insn = *(u32 *)return_address;
/* Check that absolute bit is 0 */
assert((insn & 0x2) == 0x0);
/* Check that instruction is branch */
assert((insn >> 26) == 0x12);
}
-static const cell b_mask = 0x3fffffc;
+static const u32 b_mask = 0x3fffffc;
inline static void *get_call_target(cell return_address)
{
- return_address -= sizeof(cell);
+ return_address -= 4;
check_call_site(return_address);
- cell insn = *(cell *)return_address;
- cell unsigned_addr = (insn & b_mask);
- fixnum signed_addr = (fixnum)(unsigned_addr << 6) >> 6;
+ u32 insn = *(u32 *)return_address;
+ u32 unsigned_addr = (insn & b_mask);
+ s32 signed_addr = (s32)(unsigned_addr << 6) >> 6;
return (void *)(signed_addr + return_address);
}
inline static void set_call_target(cell return_address, void *target)
{
- return_address -= sizeof(cell);
+ return_address -= 4;
check_call_site(return_address);
- cell insn = *(cell *)return_address;
+ u32 insn = *(u32 *)return_address;
fixnum relative_address = ((cell)target - return_address);
insn = ((insn & ~b_mask) | (relative_address & b_mask));
- *(cell *)return_address = insn;
+ *(u32 *)return_address = insn;
/* Flush the cache line containing the call we just patched */
__asm__ __volatile__ ("icbi 0, %0\n" "sync\n"::"r" (return_address):);
inline static bool tail_call_site_p(cell return_address)
{
- return_address -= sizeof(cell);
- cell insn = *(cell *)return_address;
+ return_address -= 4;
+ u32 insn = *(u32 *)return_address;
return (insn & 0x1) == 0;
}
--- /dev/null
+ .file "cpu-ppc.linux.S"
+ .section ".text"
+ .align 2
+ .globl flush_icache
+ .type flush_icache, @function
+flush_icache:
+ add 4,4,3 # end += ptr
+#ifdef _ARCH_PPC64
+ clrrdi 3,3,5 # ptr &= ~0x1f
+#else
+ clrrwi 3,3,5 # ptr &= ~0x1f
+#endif
+ sub 4,4,3 # end -= aligned_ptr
+ addi 4,4,0x1f # end += 0x1f
+#ifdef _ARCH_PPC64
+ srdi. 4,4,5 # end >>= 5, set cr
+#else
+ srwi. 4,4,5 # end >>= 5, set cr
+#endif
+ beqlr
+
+ # Loop over the buffer by cache line and flush the data cache.
+ mr 5,3
+ mtctr 4
+loop1:
+ dcbst 0,5
+ addi 5,5,0x20
+ bdnz loop1
+
+ # Synchronize to ensure the cache line flushes are complete.
+ sync
+
+ # Loop over the buffer by cache line and flush the instruction cache.
+ mr 5,3
+ mtctr 4
+loop2:
+ icbi 0,5
+ addi 5,5,0x20
+ bdnz loop2
+
+ # Clear instruction pipeline to force reloading of instructions.
+ isync
+ blr
+
+ .size flush_icache,.-flush_icache
+ .section .note.GNU-stack,"",@progbits
{
tagged<word> c_to_factor_word(special_objects[C_TO_FACTOR_WORD]);
code_block *c_to_factor_block = callbacks->add(c_to_factor_word.value(),0);
- c_to_factor_func = (c_to_factor_func_type)c_to_factor_block->entry_point();
+ void* func = c_to_factor_block->entry_point();
+ CODE_TO_FUNCTION_POINTER_CALLBACK(this, func);
+ c_to_factor_func = (c_to_factor_func_type)func;
}
-
c_to_factor_func(quot);
}
void factor_vm::unwind_native_frames(cell quot, stack_frame *to)
{
- get_entry_point<unwind_native_frames_func_type>(UNWIND_NATIVE_FRAMES_WORD)(quot,to);
+ tagged<word> entry_point_word(special_objects[UNWIND_NATIVE_FRAMES_WORD]);
+ void *func = entry_point_word->code->entry_point();
+ CODE_TO_FUNCTION_POINTER(func);
+ ((unwind_native_frames_func_type)func)(quot,to);
}
cell factor_vm::get_fpu_state()
{
- return get_entry_point<get_fpu_state_func_type>(GET_FPU_STATE_WORD)();
+ tagged<word> entry_point_word(special_objects[GET_FPU_STATE_WORD]);
+ void *func = entry_point_word->code->entry_point();
+ CODE_TO_FUNCTION_POINTER(func);
+ return ((get_fpu_state_func_type)func)();
}
void factor_vm::set_fpu_state(cell state)
{
- get_entry_point<set_fpu_state_func_type>(GET_FPU_STATE_WORD)(state);
+ tagged<word> entry_point_word(special_objects[SET_FPU_STATE_WORD]);
+ void *func = entry_point_word->code->entry_point();
+ CODE_TO_FUNCTION_POINTER(func);
+ ((set_fpu_state_func_type)func)(state);
}
}
char *factor_vm::factor_eval_string(char *string)
{
- char *(*callback)(char *) = (char *(*)(char *))alien_offset(special_objects[OBJ_EVAL_CALLBACK]);
- return callback(string);
+ void *func = alien_offset(special_objects[OBJ_EVAL_CALLBACK]);
+ CODE_TO_FUNCTION_POINTER(func);
+ return ((char *(*)(char *))func)(string);
}
void factor_vm::factor_eval_free(char *result)
void factor_vm::factor_yield()
{
- void (*callback)() = (void (*)())alien_offset(special_objects[OBJ_YIELD_CALLBACK]);
- callback();
+ void *func = alien_offset(special_objects[OBJ_YIELD_CALLBACK]);
+ CODE_TO_FUNCTION_POINTER(func);
+ ((void (*)())func)();
}
void factor_vm::factor_sleep(long us)
{
- void (*callback)(long) = (void (*)(long))alien_offset(special_objects[OBJ_SLEEP_CALLBACK]);
- callback(us);
+ void *func = alien_offset(special_objects[OBJ_SLEEP_CALLBACK]);
+ CODE_TO_FUNCTION_POINTER(func);
+ ((void (*)(long))func)(us);
}
void factor_vm::start_standalone_factor(int argc, vm_char **argv)
/* Load a 32-bit value from a PowerPC LIS/ORI sequence */
fixnum instruction_operand::load_value_2_2()
{
- cell *ptr = (cell *)pointer;
+ u32 *ptr = (u32 *)pointer;
cell hi = (ptr[-2] & 0xffff);
cell lo = (ptr[-1] & 0xffff);
return hi << 16 | lo;
}
+/* Load a 64-bit value from a PowerPC LIS/ORI/SLDI/ORIS/ORI sequence */
+fixnum instruction_operand::load_value_2_2_2_2()
+{
+ u32 *ptr = (u32 *)pointer;
+ u64 hhi = (ptr[-5] & 0xffff);
+ u64 hlo = (ptr[-4] & 0xffff);
+ u64 lhi = (ptr[-2] & 0xffff);
+ u64 llo = (ptr[-1] & 0xffff);
+ u64 val = hhi << 48 | hlo << 32 | lhi << 16 | llo;
+ return (cell)val;
+}
+
/* Load a value from a bitfield of a PowerPC instruction */
fixnum instruction_operand::load_value_masked(cell mask, cell bits, cell shift)
{
return load_value_2_2();
case RC_ABSOLUTE_PPC_2:
return load_value_masked(rel_absolute_ppc_2_mask,16,0);
- case RC_RELATIVE_PPC_2:
- return load_value_masked(rel_relative_ppc_2_mask,16,0) + relative_to - sizeof(cell);
- case RC_RELATIVE_PPC_3:
- return load_value_masked(rel_relative_ppc_3_mask,6,0) + relative_to - sizeof(cell);
+ case RC_RELATIVE_PPC_2_PC:
+ return load_value_masked(rel_relative_ppc_2_mask,16,0) + relative_to - 4;
+ case RC_RELATIVE_PPC_3_PC:
+ return load_value_masked(rel_relative_ppc_3_mask,6,0) + relative_to - 4;
case RC_RELATIVE_ARM_3:
return load_value_masked(rel_relative_arm_3_mask,6,2) + relative_to + sizeof(cell);
case RC_INDIRECT_ARM:
return *(u16 *)(pointer - sizeof(u16));
case RC_ABSOLUTE_1:
return *(u8 *)(pointer - sizeof(u8));
+ case RC_ABSOLUTE_PPC_2_2_2_2:
+ return load_value_2_2_2_2();
default:
critical_error("Bad rel class",rel.rel_class());
return 0;
/* Store a 32-bit value into a PowerPC LIS/ORI sequence */
void instruction_operand::store_value_2_2(fixnum value)
{
- cell *ptr = (cell *)pointer;
+ u32 *ptr = (u32 *)pointer;
ptr[-2] = ((ptr[-2] & ~0xffff) | ((value >> 16) & 0xffff));
ptr[-1] = ((ptr[-1] & ~0xffff) | (value & 0xffff));
}
+/* Store a 64-bit value into a PowerPC LIS/ORI/SLDI/ORIS/ORI sequence */
+void instruction_operand::store_value_2_2_2_2(fixnum value)
+{
+ u64 val = value;
+ u32 *ptr = (u32 *)pointer;
+ ptr[-5] = ((ptr[-5] & ~0xffff) | ((val >> 48) & 0xffff));
+ ptr[-4] = ((ptr[-4] & ~0xffff) | ((val >> 32) & 0xffff));
+ ptr[-2] = ((ptr[-2] & ~0xffff) | ((val >> 16) & 0xffff));
+ ptr[-1] = ((ptr[-1] & ~0xffff) | ((val >> 0) & 0xffff));
+}
+
/* Store a value into a bitfield of a PowerPC instruction */
void instruction_operand::store_value_masked(fixnum value, cell mask, cell shift)
{
case RC_ABSOLUTE_PPC_2:
store_value_masked(absolute_value,rel_absolute_ppc_2_mask,0);
break;
- case RC_RELATIVE_PPC_2:
- store_value_masked(relative_value + sizeof(cell),rel_relative_ppc_2_mask,0);
+ case RC_RELATIVE_PPC_2_PC:
+ store_value_masked(relative_value + 4,rel_relative_ppc_2_mask,0);
break;
- case RC_RELATIVE_PPC_3:
- store_value_masked(relative_value + sizeof(cell),rel_relative_ppc_3_mask,0);
+ case RC_RELATIVE_PPC_3_PC:
+ store_value_masked(relative_value + 4,rel_relative_ppc_3_mask,0);
break;
case RC_RELATIVE_ARM_3:
store_value_masked(relative_value - sizeof(cell),rel_relative_arm_3_mask,2);
case RC_ABSOLUTE_1:
*(u8 *)(pointer - sizeof(u8)) = (u8)absolute_value;
break;
+ case RC_ABSOLUTE_PPC_2_2_2_2:
+ store_value_2_2_2_2(absolute_value);
+ break;
default:
critical_error("Bad rel class",rel.rel_class());
break;
type since its used in a situation where relocation arguments cannot
be passed in, and so RT_DLSYM is inappropriate (Windows only) */
RT_EXCEPTION_HANDLER,
-
+ /* arg is a literal table index, holding a pair (symbol/dll) */
+ RT_DLSYM_TOC,
};
enum relocation_class {
/* absolute address in a PowerPC LWZ instruction */
RC_ABSOLUTE_PPC_2,
/* relative address in a PowerPC LWZ/STW/BC instruction */
- RC_RELATIVE_PPC_2,
+ RC_RELATIVE_PPC_2_PC,
/* relative address in a PowerPC B/BL instruction */
- RC_RELATIVE_PPC_3,
+ RC_RELATIVE_PPC_3_PC,
/* relative address in an ARM B/BL instruction */
RC_RELATIVE_ARM_3,
/* pointer to address in an ARM LDR/STR instruction */
RC_ABSOLUTE_2,
/* absolute address in a 1 byte location */
RC_ABSOLUTE_1,
+ /* absolute address in a PowerPC LIS/ORI/SLDI/ORIS/ORI sequence */
+ RC_ABSOLUTE_PPC_2_2_2_2,
};
-static const cell rel_absolute_ppc_2_mask = 0xffff;
-static const cell rel_relative_ppc_2_mask = 0xfffc;
-static const cell rel_relative_ppc_3_mask = 0x3fffffc;
-static const cell rel_indirect_arm_mask = 0xfff;
-static const cell rel_relative_arm_3_mask = 0xffffff;
+static const cell rel_absolute_ppc_2_mask = 0x0000ffff;
+static const cell rel_relative_ppc_2_mask = 0x0000fffc;
+static const cell rel_relative_ppc_3_mask = 0x03fffffc;
+static const cell rel_indirect_arm_mask = 0x00000fff;
+static const cell rel_relative_arm_3_mask = 0x00ffffff;
/* code relocation table consists of a table of entries for each fixup */
struct relocation_entry {
case RT_VM:
return 1;
case RT_DLSYM:
+ case RT_DLSYM_TOC:
return 2;
case RT_ENTRY_POINT:
case RT_ENTRY_POINT_PIC:
}
fixnum load_value_2_2();
+ fixnum load_value_2_2_2_2();
fixnum load_value_masked(cell mask, cell bits, cell shift);
fixnum load_value(cell relative_to);
fixnum load_value();
code_block *load_code_block();
void store_value_2_2(fixnum value);
+ void store_value_2_2_2_2(fixnum value);
void store_value_masked(fixnum value, cell mask, cell shift);
void store_value(fixnum value);
void store_code_block(code_block *compiled);
#ifndef __FACTOR_MASTER_H__
#define __FACTOR_MASTER_H__
+#ifndef _THREAD_SAFE
#define _THREAD_SAFE
+#endif
+
+#ifndef _REENTRANT
#define _REENTRANT
+#endif
#ifndef WINCE
#include <errno.h>
#include <string.h>
#include <time.h>
#include <wchar.h>
+#include <assert.h>
/* C++ headers */
#include <algorithm>
#include <iostream>
#include <iomanip>
-#define FACTOR_STRINGIZE(x) #x
+#define FACTOR_STRINGIZE_I(x) #x
+#define FACTOR_STRINGIZE(x) FACTOR_STRINGIZE_I(x)
/* Record compiler version */
#if defined(__clang__)
#define FACTOR_64
#elif defined(i386) || defined(__i386) || defined(__i386__) || defined(_M_IX86)
#define FACTOR_X86
+#elif (defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC)) && (defined(__PPC64__) || defined(__64BIT__))
+ #define FACTOR_PPC64
+ #define FACTOR_PPC
+ #define FACTOR_64
#elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC)
+ #define FACTOR_PPC32
#define FACTOR_PPC
#else
#error "Unsupported architecture"
#endif
#define UAP_STACK_POINTER_TYPE __register_t
+
+#define CODE_TO_FUNCTION_POINTER(code) (void)0
+#define CODE_TO_FUNCTION_POINTER_CALLBACK(vm, code) (void)0
+#define FUNCTION_CODE_POINTER(ptr) ptr
+#define FUNCTION_TOC_POINTER(ptr) ptr
+#define UAP_SET_TOC_POINTER(uap, ptr) (void)0
#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.arm_sp)
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.arm_pc)
+#define UAP_STACK_POINTER_TYPE greg_t
+#define UAP_SET_TOC_POINTER(uap, ptr) (void)0
+#define CODE_TO_FUNCTION_POINTER(code) (void)0
+#define CODE_TO_FUNCTION_POINTER_CALLBACK(vm, code) (void)0
+#define FUNCTION_CODE_POINTER(ptr) ptr
+#define FUNCTION_TOC_POINTER(ptr) ptr
}
--- /dev/null
+#include <ucontext.h>
+
+namespace factor
+{
+
+#define FRAME_RETURN_ADDRESS(frame,vm) *((void **)(vm->frame_successor(frame) + 1) + 1)
+#define UAP_STACK_POINTER(ucontext) ((ucontext_t *)ucontext)->uc_mcontext.uc_regs->gregs[1]
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.uc_regs->gregs[32])
+#define UAP_SET_TOC_POINTER(uap, ptr) (void)0
+
+#define CODE_TO_FUNCTION_POINTER(code) (void)0
+#define CODE_TO_FUNCTION_POINTER_CALLBACK(vm, code) (void)0
+#define FUNCTION_CODE_POINTER(ptr) ptr
+#define FUNCTION_TOC_POINTER(ptr) ptr
+
+#define UAP_STACK_POINTER_TYPE unsigned long
+
+inline static unsigned int uap_fpu_status(void *uap)
+{
+ union {
+ double as_double;
+ unsigned int as_uint[2];
+ } tmp;
+ tmp.as_double = ((ucontext_t*) uap)->uc_mcontext.uc_regs->fpregs.fpscr;
+ return tmp.as_uint[1];
+}
+
+inline static void uap_clear_fpu_status(void *uap)
+{
+ union {
+ double as_double;
+ unsigned int as_uint[2];
+ } tmp;
+ tmp.as_double = ((ucontext_t*) uap)->uc_mcontext.uc_regs->fpregs.fpscr;
+ tmp.as_uint[1] &= 0x0007f8ff;
+ ((ucontext_t*) uap)->uc_mcontext.uc_regs->fpregs.fpscr = tmp.as_double;
+}
+
+}
--- /dev/null
+#include <ucontext.h>
+
+namespace factor
+{
+
+#define FRAME_RETURN_ADDRESS(frame,vm) *((void **)(vm->frame_successor(frame) + 1) + 2)
+#define UAP_STACK_POINTER(ucontext) ((ucontext_t *)ucontext)->uc_mcontext.gp_regs[1]
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gp_regs[32])
+#define UAP_SET_TOC_POINTER(uap, ptr) (void)0
+
+#define FACTOR_PPC_TOC 1
+
+#define CODE_TO_FUNCTION_POINTER(code) \
+ void *desc[3]; \
+ code = fill_function_descriptor(desc, code)
+
+#define CODE_TO_FUNCTION_POINTER_CALLBACK(vm, code) \
+ code = fill_function_descriptor(new void*[3], code); \
+ vm->function_descriptors.push_back((void **)code)
+
+#define FUNCTION_CODE_POINTER(ptr) \
+ (function_descriptor_field((void *)ptr, 0))
+
+#define FUNCTION_TOC_POINTER(ptr) \
+ (function_descriptor_field((void *)ptr, 1))
+
+#define UAP_STACK_POINTER_TYPE unsigned long
+
+inline static unsigned int uap_fpu_status(void *uap)
+{
+ union {
+ double as_double;
+ unsigned int as_uint[2];
+ } tmp;
+ tmp.as_double = ((ucontext_t*) uap)->uc_mcontext.fp_regs[32];
+ return tmp.as_uint[1];
+}
+
+inline static void uap_clear_fpu_status(void *uap)
+{
+ union {
+ double as_double;
+ unsigned int as_uint[2];
+ } tmp;
+ tmp.as_double = ((ucontext_t*) uap)->uc_mcontext.fp_regs[32];
+ tmp.as_uint[1] &= 0x0007f8ff;
+ ((ucontext_t*) uap)->uc_mcontext.fp_regs[32] = tmp.as_double;
+}
+
+}
+++ /dev/null
-#include <ucontext.h>
-
-namespace factor
-{
-
-#define FRAME_RETURN_ADDRESS(frame,vm) *((void **)(vm->frame_successor(frame) + 1) + 1)
-#define UAP_STACK_POINTER(ucontext) ((ucontext_t *)ucontext)->uc_mcontext.uc_regs->gregs[PT_R1]
-#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.uc_regs->gregs[PT_NIP])
-
-}
#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[7])
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[14])
+#define UAP_SET_TOC_POINTER(uap, ptr) (void)0
+#define CODE_TO_FUNCTION_POINTER(code) (void)0
+#define CODE_TO_FUNCTION_POINTER_CALLBACK(vm, code) (void)0
+#define FUNCTION_CODE_POINTER(ptr) ptr
+#define FUNCTION_TOC_POINTER(ptr) ptr
+
+#define UAP_STACK_POINTER_TYPE greg_t
}
#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[15])
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[16])
+#define UAP_SET_TOC_POINTER(uap, ptr) (void)0
+#define CODE_TO_FUNCTION_POINTER(code) (void)0
+#define CODE_TO_FUNCTION_POINTER_CALLBACK(vm, code) (void)0
+#define FUNCTION_CODE_POINTER(ptr) ptr
+#define FUNCTION_TOC_POINTER(ptr) ptr
+
+#define UAP_STACK_POINTER_TYPE greg_t
}
VM_C_API int inotify_add_watch(int fd, const char *name, u32 mask);
VM_C_API int inotify_rm_watch(int fd, u32 wd);
-#define UAP_STACK_POINTER_TYPE greg_t
-
}
const char *default_image_path();
#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_stack.ss_sp)
+#define UAP_SET_TOC_POINTER(uap, ptr) (void)0
-#define UAP_STACK_POINTER_TYPE void*
+#define UAP_STACK_POINTER_TYPE void *
+
+#define CODE_TO_FUNCTION_POINTER(code) (void)0
+#define CODE_TO_FUNCTION_POINTER_CALLBACK(vm, code) (void)0
+#define FUNCTION_CODE_POINTER(ptr) ptr
+#define FUNCTION_TOC_POINTER(ptr) ptr
}
#define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap)
#define UAP_STACK_POINTER_TYPE __greg_t
+
+#define UAP_SET_TOC_POINTER(uap, ptr) (void)0
+#define CODE_TO_FUNCTION_POINTER(code) (void)0
+#define CODE_TO_FUNCTION_POINTER_CALLBACK(vm, code) (void)0
+#define FUNCTION_CODE_POINTER(ptr) ptr
+#define FUNCTION_TOC_POINTER(ptr) ptr
#define UAP_STACK_POINTER_TYPE __register_t
+
+#define UAP_SET_TOC_POINTER(uap, ptr) (void)0
+#define CODE_TO_FUNCTION_POINTER(code) (void)0
+#define CODE_TO_FUNCTION_POINTER_CALLBACK(vm, code) (void)0
+#define FUNCTION_CODE_POINTER(ptr) ptr
+#define FUNCTION_TOC_POINTER(ptr) ptr
#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[ESP])
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[EIP])
+#define UAP_SET_TOC_POINTER(uap, ptr) (void)0
+#define CODE_TO_FUNCTION_POINTER(code) (void)0
+#define CODE_TO_FUNCTION_POINTER_CALLBACK(vm, code) (void)0
+#define FUNCTION_CODE_POINTER(ptr) ptr
+#define FUNCTION_TOC_POINTER(ptr) ptr
}
#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[RSP])
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[RIP])
+#define UAP_SET_TOC_POINTER(uap, ptr) (void)0
+#define CODE_TO_FUNCTION_POINTER(code) (void)0
+#define CODE_TO_FUNCTION_POINTER_CALLBACK(vm, code) (void)0
+#define FUNCTION_CODE_POINTER(ptr) ptr
+#define FUNCTION_TOC_POINTER(ptr) ptr
}
dll->handle = dlopen(alien_offset(dll->path), RTLD_LAZY);
}
+void *factor_vm::ffi_dlsym_raw(dll *dll, symbol_char *symbol)
+{
+ return dlsym(dll ? dll->handle : null_dll, symbol);
+}
+
void *factor_vm::ffi_dlsym(dll *dll, symbol_char *symbol)
{
- void *handle = (dll == NULL ? null_dll : dll->handle);
- return dlsym(handle,symbol);
+ return FUNCTION_CODE_POINTER(ffi_dlsym_raw(dll, symbol));
+}
+
+#ifdef FACTOR_PPC
+void *factor_vm::ffi_dlsym_toc(dll *dll, symbol_char *symbol)
+{
+ return FUNCTION_TOC_POINTER(ffi_dlsym_raw(dll, symbol));
}
+#endif
void factor_vm::ffi_dlclose(dll *dll)
{
void factor_vm::dispatch_signal(void *uap, void (handler)())
{
UAP_STACK_POINTER(uap) = (UAP_STACK_POINTER_TYPE)fix_callstack_top((stack_frame *)UAP_STACK_POINTER(uap));
- UAP_PROGRAM_COUNTER(uap) = (cell)handler;
-
+ UAP_PROGRAM_COUNTER(uap) = (cell)FUNCTION_CODE_POINTER(handler);
+ UAP_SET_TOC_POINTER(uap, (cell)FUNCTION_TOC_POINTER(handler));
ctx->callstack_top = (stack_frame *)UAP_STACK_POINTER(uap);
}
sigaction_safe(SIGBUS,&memory_sigaction,NULL);
sigaction_safe(SIGSEGV,&memory_sigaction,NULL);
+ sigaction_safe(SIGTRAP,&memory_sigaction,NULL);
memset(&fpe_sigaction,0,sizeof(struct sigaction));
sigemptyset(&fpe_sigaction.sa_mask);
return (void *)GetProcAddress(dll ? (HMODULE)dll->handle : hFactorDll, symbol);
}
+void *factor_vm::ffi_dlsym_raw(dll *dll, symbol_char *symbol)
+{
+ return ffi_dlsym(dll, symbol);
+}
+
void factor_vm::ffi_dlclose(dll *dll)
{
FreeLibrary((HMODULE)dll->handle);
THREADHANDLE start_thread(void *(*start_routine)(void *),void *args);
inline static THREADHANDLE thread_id() { return GetCurrentThread(); }
+#define CODE_TO_FUNCTION_POINTER(code) (void)0
+#define CODE_TO_FUNCTION_POINTER_CALLBACK(vm, code) (void)0
+#define FUNCTION_CODE_POINTER(ptr) ptr
+#define FUNCTION_TOC_POINTER(ptr) ptr
}
#if defined(FACTOR_X86)
#include "os-linux-x86.32.hpp"
- #elif defined(FACTOR_PPC)
- #include "os-linux-ppc.hpp"
+ #elif defined(FACTOR_PPC64)
+ #include "os-linux-ppc.64.hpp"
+ #elif defined(FACTOR_PPC32)
+ #include "os-linux-ppc.32.hpp"
#elif defined(FACTOR_ARM)
#include "os-linux-arm.hpp"
#elif defined(FACTOR_AMD64)
_(dll_validp) \
_(dlopen) \
_(dlsym) \
+ _(dlsym_raw) \
_(double_bits) \
_(enable_gc_events) \
_(existsp) \
#endif
parameter(obj.value());
parameter(false_object);
+#ifdef FACTOR_PPC_TOC
+ parameter(obj.value());
+ parameter(false_object);
+#endif
emit(parent->special_objects[JIT_PRIMITIVE]);
i++;
namespace factor
{
+/* Fill in a PPC function descriptor */
+void *fill_function_descriptor(void *ptr, void *code)
+{
+ void **descriptor = (void **)ptr;
+ descriptor[0] = code;
+ descriptor[1] = NULL;
+ descriptor[2] = NULL;
+ return descriptor;
+}
+
+/* Get a field from a PPC function descriptor */
+void *function_descriptor_field(void *ptr, size_t idx)
+{
+ return ptr ? ((void **) ptr)[idx] : ptr;
+}
+
/* If memory allocation fails, bail out */
vm_char *safe_strdup(const vm_char *str)
{
#endif
}
+void *fill_function_descriptor(void *ptr, void *code);
+void *function_descriptor_field(void *ptr, size_t idx);
+
vm_char *safe_strdup(const vm_char *str);
cell read_cell_hex();
VM_C_API void *factor_memcpy(void *dst, void *src, size_t len);
delete signal_callstack_seg;
signal_callstack_seg = NULL;
}
+ std::list<void **>::const_iterator iter = function_descriptors.begin();
+ std::list<void **>::const_iterator end = function_descriptors.end();
+ while(iter != end)
+ {
+ delete [] *iter;
+ iter++;
+ }
}
}
/* Next callback ID */
int callback_id;
+ /* List of callback function descriptors for PPC */
+ std::list<void **> function_descriptors;
+
/* Pooling unused contexts to make context allocation cheaper */
std::list<context *> unused_contexts;
void update_word_references(code_block *compiled, bool reset_inline_caches);
void undefined_symbol();
cell compute_dlsym_address(array *literals, cell index);
+#ifdef FACTOR_PPC
+ cell compute_dlsym_toc_address(array *literals, cell index);
+#endif
cell compute_vm_address(cell arg);
void store_external_address(instruction_operand op);
cell compute_here_address(cell arg, cell offset, code_block *compiled);
void *alien_pointer();
void primitive_dlopen();
void primitive_dlsym();
+ void primitive_dlsym_raw();
void primitive_dlclose();
void primitive_dll_validp();
char *alien_offset(cell obj);
void init_ffi();
void ffi_dlopen(dll *dll);
void *ffi_dlsym(dll *dll, symbol_char *symbol);
+ void *ffi_dlsym_raw(dll *dll, symbol_char *symbol);
+ #ifdef FACTOR_PPC
+ void *ffi_dlsym_toc(dll *dll, symbol_char *symbol);
+ #endif
void ffi_dlclose(dll *dll);
void c_to_factor_toplevel(cell quot);
void init_signals();
projects / factor.git / commitdiff