IN: bootstrap.image
: arch ( os cpu -- arch )
- [ dup "winnt" = "winnt" "unix" ? ] dip
- {
- { "ppc" [ drop "-ppc" append ] }
- { "x86.32" [ nip "-x86.32" append ] }
- { "x86.64" [ nip "-x86.64" append ] }
- } case ;
+ [ "winnt" = "winnt" "unix" ? ] dip "-" glue ;
: my-arch ( -- arch )
os name>> cpu name>> arch ;
{
"winnt-x86.32" "unix-x86.32"
"winnt-x86.64" "unix-x86.64"
- "linux-ppc" "macosx-ppc"
} ;
<PRIVATE
+++ /dev/null
-IN: cpu.arm.assembler.tests
-USING: cpu.arm.assembler math tools.test namespaces make
-sequences kernel quotations ;
-FROM: cpu.arm.assembler => B ;
-
-: test-opcode ( expect quot -- ) [ { } make first ] curry unit-test ;
-
-[ HEX: ea000000 ] [ 0 B ] test-opcode
-[ HEX: eb000000 ] [ 0 BL ] test-opcode
-! [ HEX: e12fff30 ] [ R0 BLX ] test-opcode
-
-[ HEX: e24cc004 ] [ IP IP 4 SUB ] test-opcode
-[ HEX: e24cb004 ] [ FP IP 4 SUB ] test-opcode
-[ HEX: e087e3ac ] [ LR R7 IP 7 <LSR> ADD ] test-opcode
-[ HEX: e08c0109 ] [ R0 IP R9 2 <LSL> ADD ] test-opcode
-[ HEX: 02850004 ] [ R0 R5 4 EQ ADD ] test-opcode
-[ HEX: 00000000 ] [ R0 R0 R0 EQ AND ] test-opcode
-
-[ HEX: e1a0c00c ] [ IP IP MOV ] test-opcode
-[ HEX: e1a0c00d ] [ IP SP MOV ] test-opcode
-[ HEX: e3a03003 ] [ R3 3 MOV ] test-opcode
-[ HEX: e1a00003 ] [ R0 R3 MOV ] test-opcode
-[ HEX: e1e01c80 ] [ R1 R0 25 <LSL> MVN ] test-opcode
-[ HEX: e1e00ca1 ] [ R0 R1 25 <LSR> MVN ] test-opcode
-[ HEX: 11a021ac ] [ R2 IP 3 <LSR> NE MOV ] test-opcode
-
-[ HEX: e3530007 ] [ R3 7 CMP ] test-opcode
-
-[ HEX: e008049a ] [ R8 SL R4 MUL ] test-opcode
-
-[ HEX: e5151004 ] [ R1 R5 4 <-> LDR ] test-opcode
-[ HEX: e41c2004 ] [ R2 IP 4 <-!> LDR ] test-opcode
-[ HEX: e50e2004 ] [ R2 LR 4 <-> STR ] test-opcode
-
-[ HEX: e7910002 ] [ R0 R1 R2 <+> LDR ] test-opcode
-[ HEX: e7910102 ] [ R0 R1 R2 2 <LSL> <+> LDR ] test-opcode
-
-[ HEX: e1d310bc ] [ R1 R3 12 <+> LDRH ] test-opcode
-[ HEX: e1d310fc ] [ R1 R3 12 <+> LDRSH ] test-opcode
-[ HEX: e1d310dc ] [ R1 R3 12 <+> LDRSB ] test-opcode
-[ HEX: e1c310bc ] [ R1 R3 12 <+> STRH ] test-opcode
-[ HEX: e19310b4 ] [ R1 R3 R4 <+> LDRH ] test-opcode
-[ HEX: e1f310fc ] [ R1 R3 12 <!+> LDRSH ] test-opcode
-[ HEX: e1b310d4 ] [ R1 R3 R4 <!+> LDRSB ] test-opcode
-[ HEX: e0c317bb ] [ R1 R3 123 <+!> STRH ] test-opcode
-[ HEX: e08310b4 ] [ R1 R3 R4 <+!> STRH ] test-opcode
+++ /dev/null
-! Copyright (C) 2007, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators kernel make math math.bitwise
-namespaces sequences words words.symbol parser ;
-IN: cpu.arm.assembler
-
-! Registers
-<<
-
-SYMBOL: registers
-
-V{ } registers set-global
-
-SYNTAX: REGISTER:
- CREATE-WORD
- [ define-symbol ]
- [ registers get length "register" set-word-prop ]
- [ registers get push ]
- tri ;
-
->>
-
-REGISTER: R0
-REGISTER: R1
-REGISTER: R2
-REGISTER: R3
-REGISTER: R4
-REGISTER: R5
-REGISTER: R6
-REGISTER: R7
-REGISTER: R8
-REGISTER: R9
-REGISTER: R10
-REGISTER: R11
-REGISTER: R12
-REGISTER: R13
-REGISTER: R14
-REGISTER: R15
-
-ALIAS: SL R10 ALIAS: FP R11 ALIAS: IP R12
-ALIAS: SP R13 ALIAS: LR R14 ALIAS: PC R15
-
-<PRIVATE
-
-PREDICATE: register < word register >boolean ;
-
-GENERIC: register ( register -- n )
-M: word register "register" word-prop ;
-M: f register drop 0 ;
-
-PRIVATE>
-
-! Condition codes
-SYMBOL: cond-code
-
-: >CC ( n -- )
- cond-code set ;
-
-: CC> ( -- n )
- #! Default value is BIN: 1110 AL (= always)
- cond-code [ f ] change BIN: 1110 or ;
-
-: EQ ( -- ) BIN: 0000 >CC ;
-: NE ( -- ) BIN: 0001 >CC ;
-: CS ( -- ) BIN: 0010 >CC ;
-: CC ( -- ) BIN: 0011 >CC ;
-: LO ( -- ) BIN: 0100 >CC ;
-: PL ( -- ) BIN: 0101 >CC ;
-: VS ( -- ) BIN: 0110 >CC ;
-: VC ( -- ) BIN: 0111 >CC ;
-: HI ( -- ) BIN: 1000 >CC ;
-: LS ( -- ) BIN: 1001 >CC ;
-: GE ( -- ) BIN: 1010 >CC ;
-: LT ( -- ) BIN: 1011 >CC ;
-: GT ( -- ) BIN: 1100 >CC ;
-: LE ( -- ) BIN: 1101 >CC ;
-: AL ( -- ) BIN: 1110 >CC ;
-: NV ( -- ) BIN: 1111 >CC ;
-
-<PRIVATE
-
-: (insn) ( n -- ) CC> 28 shift bitor , ;
-
-: insn ( bitspec -- ) bitfield (insn) ; inline
-
-! Branching instructions
-GENERIC# (B) 1 ( target l -- )
-
-M: integer (B) { 24 { 1 25 } { 0 26 } { 1 27 } 0 } insn ;
-
-PRIVATE>
-
-: B ( target -- ) 0 (B) ;
-: BL ( target -- ) 1 (B) ;
-
-! Data processing instructions
-<PRIVATE
-
-SYMBOL: updates-cond-code
-
-PRIVATE>
-
-: S ( -- ) updates-cond-code on ;
-
-: S> ( -- ? ) updates-cond-code [ f ] change ;
-
-<PRIVATE
-
-: sinsn ( bitspec -- )
- bitfield S> [ 20 2^ bitor ] when (insn) ; inline
-
-GENERIC# shift-imm/reg 2 ( shift-imm/Rs Rm shift -- n )
-
-M: integer shift-imm/reg ( shift-imm Rm shift -- n )
- { { 0 4 } 5 { register 0 } 7 } bitfield ;
-
-M: register shift-imm/reg ( Rs Rm shift -- n )
- {
- { 1 4 }
- { 0 7 }
- 5
- { register 8 }
- { register 0 }
- } bitfield ;
-
-PRIVATE>
-
-TUPLE: IMM immed rotate ;
-C: <IMM> IMM
-
-TUPLE: shifter Rm by shift ;
-C: <shifter> shifter
-
-<PRIVATE
-
-GENERIC: shifter-op ( shifter-op -- n )
-
-M: IMM shifter-op
- [ immed>> ] [ rotate>> ] bi { { 1 25 } 8 0 } bitfield ;
-
-M: shifter shifter-op
- [ by>> ] [ Rm>> ] [ shift>> ] tri shift-imm/reg ;
-
-PRIVATE>
-
-: <LSL> ( Rm shift-imm/Rs -- shifter-op ) BIN: 00 <shifter> ;
-: <LSR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 01 <shifter> ;
-: <ASR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 10 <shifter> ;
-: <ROR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 11 <shifter> ;
-: <RRX> ( Rm -- shifter-op ) 0 <ROR> ;
-
-M: register shifter-op 0 <LSL> shifter-op ;
-M: integer shifter-op 0 <IMM> shifter-op ;
-
-<PRIVATE
-
-: addr1 ( Rd Rn shifter-op opcode -- )
- {
- 21 ! opcode
- { shifter-op 0 }
- { register 16 } ! Rn
- { register 12 } ! Rd
- } sinsn ;
-
-PRIVATE>
-
-: AND ( Rd Rn shifter-op -- ) BIN: 0000 addr1 ;
-: EOR ( Rd Rn shifter-op -- ) BIN: 0001 addr1 ;
-: SUB ( Rd Rn shifter-op -- ) BIN: 0010 addr1 ;
-: RSB ( Rd Rn shifter-op -- ) BIN: 0011 addr1 ;
-: ADD ( Rd Rn shifter-op -- ) BIN: 0100 addr1 ;
-: ADC ( Rd Rn shifter-op -- ) BIN: 0101 addr1 ;
-: SBC ( Rd Rn shifter-op -- ) BIN: 0110 addr1 ;
-: RSC ( Rd Rn shifter-op -- ) BIN: 0111 addr1 ;
-: ORR ( Rd Rn shifter-op -- ) BIN: 1100 addr1 ;
-: BIC ( Rd Rn shifter-op -- ) BIN: 1110 addr1 ;
-
-: MOV ( Rd shifter-op -- ) [ f ] dip BIN: 1101 addr1 ;
-: MVN ( Rd shifter-op -- ) [ f ] dip BIN: 1111 addr1 ;
-
-! These always update the condition code flags
-<PRIVATE
-
-: (CMP) ( Rn shifter-op opcode -- ) [ f ] 3dip S addr1 ;
-
-PRIVATE>
-
-: TST ( Rn shifter-op -- ) BIN: 1000 (CMP) ;
-: TEQ ( Rn shifter-op -- ) BIN: 1001 (CMP) ;
-: CMP ( Rn shifter-op -- ) BIN: 1010 (CMP) ;
-: CMN ( Rn shifter-op -- ) BIN: 1011 (CMP) ;
-
-! Multiply instructions
-<PRIVATE
-
-: (MLA) ( Rd Rm Rs Rn a -- )
- {
- 21
- { register 12 }
- { register 8 }
- { register 0 }
- { register 16 }
- { 1 7 }
- { 1 4 }
- } sinsn ;
-
-: (S/UMLAL) ( RdLo RdHi Rm Rs s a -- )
- {
- { 1 23 }
- 22
- 21
- { register 8 }
- { register 0 }
- { register 16 }
- { register 12 }
- { 1 7 }
- { 1 4 }
- } sinsn ;
-
-PRIVATE>
-
-: MUL ( Rd Rm Rs -- ) f 0 (MLA) ;
-: MLA ( Rd Rm Rs Rn -- ) 1 (MLA) ;
-
-: SMLAL ( RdLo RdHi Rm Rs -- ) 1 1 (S/UMLAL) ;
-: SMULL ( RdLo RdHi Rm Rs -- ) 1 0 (S/UMLAL) ;
-: UMLAL ( RdLo RdHi Rm Rs -- ) 0 1 (S/UMLAL) ;
-: UMULL ( RdLo RdHi Rm Rs -- ) 0 0 (S/UMLAL) ;
-
-! Miscellaneous arithmetic instructions
-: CLZ ( Rd Rm -- )
- {
- { 1 24 }
- { 1 22 }
- { 1 21 }
- { BIN: 111 16 }
- { BIN: 1111 8 }
- { 1 4 }
- { register 0 }
- { register 12 }
- } sinsn ;
-
-! Status register acess instructions
-
-! Load and store instructions
-<PRIVATE
-
-GENERIC: addressing-mode-2 ( addressing-mode -- n )
-
-TUPLE: addressing base p u w ;
-C: <addressing> addressing
-
-M: addressing addressing-mode-2
- { [ p>> ] [ u>> ] [ w>> ] [ base>> addressing-mode-2 ] } cleave
- { 0 21 23 24 } bitfield ;
-
-M: integer addressing-mode-2 ;
-
-M: object addressing-mode-2 shifter-op { { 1 25 } 0 } bitfield ;
-
-: addr2 ( Rd Rn addressing-mode b l -- )
- {
- { 1 26 }
- 20
- 22
- { addressing-mode-2 0 }
- { register 16 }
- { register 12 }
- } insn ;
-
-PRIVATE>
-
-! Offset
-: <+> ( base -- addressing ) 1 1 0 <addressing> ;
-: <-> ( base -- addressing ) 1 0 0 <addressing> ;
-
-! Pre-indexed
-: <!+> ( base -- addressing ) 1 1 1 <addressing> ;
-: <!-> ( base -- addressing ) 1 0 1 <addressing> ;
-
-! Post-indexed
-: <+!> ( base -- addressing ) 0 1 0 <addressing> ;
-: <-!> ( base -- addressing ) 0 0 0 <addressing> ;
-
-: LDR ( Rd Rn addressing-mode -- ) 0 1 addr2 ;
-: LDRB ( Rd Rn addressing-mode -- ) 1 1 addr2 ;
-: STR ( Rd Rn addressing-mode -- ) 0 0 addr2 ;
-: STRB ( Rd Rn addressing-mode -- ) 1 0 addr2 ;
-
-! We might have to simulate these instructions since older ARM
-! chips don't have them.
-SYMBOL: have-BX?
-SYMBOL: have-BLX?
-
-<PRIVATE
-
-GENERIC# (BX) 1 ( Rm l -- )
-
-M: register (BX) ( Rm l -- )
- {
- { 1 24 }
- { 1 21 }
- { BIN: 1111 16 }
- { BIN: 1111 12 }
- { BIN: 1111 8 }
- 5
- { 1 4 }
- { register 0 }
- } insn ;
-
-PRIVATE>
-
-: BX ( Rm -- ) have-BX? get [ 0 (BX) ] [ [ PC ] dip MOV ] if ;
-
-: BLX ( Rm -- ) have-BLX? get [ 1 (BX) ] [ LR PC MOV BX ] if ;
-
-! More load and store instructions
-<PRIVATE
-
-GENERIC: addressing-mode-3 ( addressing-mode -- n )
-
-: b>n/n ( b -- n n ) [ -4 shift ] [ HEX: f bitand ] bi ;
-
-M: addressing addressing-mode-3
- { [ p>> ] [ u>> ] [ w>> ] [ base>> addressing-mode-3 ] } cleave
- { 0 21 23 24 } bitfield ;
-
-M: integer addressing-mode-3
- b>n/n {
- ! { 1 24 }
- { 1 22 }
- { 1 7 }
- { 1 4 }
- 0
- 8
- } bitfield ;
-
-M: object addressing-mode-3
- shifter-op {
- ! { 1 24 }
- { 1 7 }
- { 1 4 }
- 0
- } bitfield ;
-
-: addr3 ( Rn Rd addressing-mode h l s -- )
- {
- 6
- 20
- 5
- { addressing-mode-3 0 }
- { register 16 }
- { register 12 }
- } insn ;
-
-PRIVATE>
-
-: LDRH ( Rn Rd addressing-mode -- ) 1 1 0 addr3 ;
-: LDRSB ( Rn Rd addressing-mode -- ) 0 1 1 addr3 ;
-: LDRSH ( Rn Rd addressing-mode -- ) 1 1 1 addr3 ;
-: STRH ( Rn Rd addressing-mode -- ) 1 0 0 addr3 ;
-
-! Load and store multiple instructions
-
-! Semaphore instructions
-
-! Exception-generating instructions
+++ /dev/null
-Slava Pestov
+++ /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
{ "unix-x86.32" "x86/32/unix" }
{ "winnt-x86.64" "x86/64/winnt" }
{ "unix-x86.64" "x86/64/unix" }
- { "linux-ppc" "ppc/linux" }
- { "macosx-ppc" "ppc/macosx" }
- { "arm" "arm" }
} ?at [ "Bad architecture: " prepend throw ] unless
"vocab:cpu/" "/bootstrap.factor" surround parse-file
--- /dev/null
+IN: cpu.arm.assembler.tests
+USING: cpu.arm.assembler math tools.test namespaces make
+sequences kernel quotations ;
+FROM: cpu.arm.assembler => B ;
+
+: test-opcode ( expect quot -- ) [ { } make first ] curry unit-test ;
+
+[ HEX: ea000000 ] [ 0 B ] test-opcode
+[ HEX: eb000000 ] [ 0 BL ] test-opcode
+! [ HEX: e12fff30 ] [ R0 BLX ] test-opcode
+
+[ HEX: e24cc004 ] [ IP IP 4 SUB ] test-opcode
+[ HEX: e24cb004 ] [ FP IP 4 SUB ] test-opcode
+[ HEX: e087e3ac ] [ LR R7 IP 7 <LSR> ADD ] test-opcode
+[ HEX: e08c0109 ] [ R0 IP R9 2 <LSL> ADD ] test-opcode
+[ HEX: 02850004 ] [ R0 R5 4 EQ ADD ] test-opcode
+[ HEX: 00000000 ] [ R0 R0 R0 EQ AND ] test-opcode
+
+[ HEX: e1a0c00c ] [ IP IP MOV ] test-opcode
+[ HEX: e1a0c00d ] [ IP SP MOV ] test-opcode
+[ HEX: e3a03003 ] [ R3 3 MOV ] test-opcode
+[ HEX: e1a00003 ] [ R0 R3 MOV ] test-opcode
+[ HEX: e1e01c80 ] [ R1 R0 25 <LSL> MVN ] test-opcode
+[ HEX: e1e00ca1 ] [ R0 R1 25 <LSR> MVN ] test-opcode
+[ HEX: 11a021ac ] [ R2 IP 3 <LSR> NE MOV ] test-opcode
+
+[ HEX: e3530007 ] [ R3 7 CMP ] test-opcode
+
+[ HEX: e008049a ] [ R8 SL R4 MUL ] test-opcode
+
+[ HEX: e5151004 ] [ R1 R5 4 <-> LDR ] test-opcode
+[ HEX: e41c2004 ] [ R2 IP 4 <-!> LDR ] test-opcode
+[ HEX: e50e2004 ] [ R2 LR 4 <-> STR ] test-opcode
+
+[ HEX: e7910002 ] [ R0 R1 R2 <+> LDR ] test-opcode
+[ HEX: e7910102 ] [ R0 R1 R2 2 <LSL> <+> LDR ] test-opcode
+
+[ HEX: e1d310bc ] [ R1 R3 12 <+> LDRH ] test-opcode
+[ HEX: e1d310fc ] [ R1 R3 12 <+> LDRSH ] test-opcode
+[ HEX: e1d310dc ] [ R1 R3 12 <+> LDRSB ] test-opcode
+[ HEX: e1c310bc ] [ R1 R3 12 <+> STRH ] test-opcode
+[ HEX: e19310b4 ] [ R1 R3 R4 <+> LDRH ] test-opcode
+[ HEX: e1f310fc ] [ R1 R3 12 <!+> LDRSH ] test-opcode
+[ HEX: e1b310d4 ] [ R1 R3 R4 <!+> LDRSB ] test-opcode
+[ HEX: e0c317bb ] [ R1 R3 123 <+!> STRH ] test-opcode
+[ HEX: e08310b4 ] [ R1 R3 R4 <+!> STRH ] test-opcode
--- /dev/null
+! Copyright (C) 2007, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators kernel make math math.bitwise
+namespaces sequences words words.symbol parser ;
+IN: cpu.arm.assembler
+
+! Registers
+<<
+
+SYMBOL: registers
+
+V{ } registers set-global
+
+SYNTAX: REGISTER:
+ CREATE-WORD
+ [ define-symbol ]
+ [ registers get length "register" set-word-prop ]
+ [ registers get push ]
+ tri ;
+
+>>
+
+REGISTER: R0
+REGISTER: R1
+REGISTER: R2
+REGISTER: R3
+REGISTER: R4
+REGISTER: R5
+REGISTER: R6
+REGISTER: R7
+REGISTER: R8
+REGISTER: R9
+REGISTER: R10
+REGISTER: R11
+REGISTER: R12
+REGISTER: R13
+REGISTER: R14
+REGISTER: R15
+
+ALIAS: SL R10 ALIAS: FP R11 ALIAS: IP R12
+ALIAS: SP R13 ALIAS: LR R14 ALIAS: PC R15
+
+<PRIVATE
+
+PREDICATE: register < word register >boolean ;
+
+GENERIC: register ( register -- n )
+M: word register "register" word-prop ;
+M: f register drop 0 ;
+
+PRIVATE>
+
+! Condition codes
+SYMBOL: cond-code
+
+: >CC ( n -- )
+ cond-code set ;
+
+: CC> ( -- n )
+ #! Default value is BIN: 1110 AL (= always)
+ cond-code [ f ] change BIN: 1110 or ;
+
+: EQ ( -- ) BIN: 0000 >CC ;
+: NE ( -- ) BIN: 0001 >CC ;
+: CS ( -- ) BIN: 0010 >CC ;
+: CC ( -- ) BIN: 0011 >CC ;
+: LO ( -- ) BIN: 0100 >CC ;
+: PL ( -- ) BIN: 0101 >CC ;
+: VS ( -- ) BIN: 0110 >CC ;
+: VC ( -- ) BIN: 0111 >CC ;
+: HI ( -- ) BIN: 1000 >CC ;
+: LS ( -- ) BIN: 1001 >CC ;
+: GE ( -- ) BIN: 1010 >CC ;
+: LT ( -- ) BIN: 1011 >CC ;
+: GT ( -- ) BIN: 1100 >CC ;
+: LE ( -- ) BIN: 1101 >CC ;
+: AL ( -- ) BIN: 1110 >CC ;
+: NV ( -- ) BIN: 1111 >CC ;
+
+<PRIVATE
+
+: (insn) ( n -- ) CC> 28 shift bitor , ;
+
+: insn ( bitspec -- ) bitfield (insn) ; inline
+
+! Branching instructions
+GENERIC# (B) 1 ( target l -- )
+
+M: integer (B) { 24 { 1 25 } { 0 26 } { 1 27 } 0 } insn ;
+
+PRIVATE>
+
+: B ( target -- ) 0 (B) ;
+: BL ( target -- ) 1 (B) ;
+
+! Data processing instructions
+<PRIVATE
+
+SYMBOL: updates-cond-code
+
+PRIVATE>
+
+: S ( -- ) updates-cond-code on ;
+
+: S> ( -- ? ) updates-cond-code [ f ] change ;
+
+<PRIVATE
+
+: sinsn ( bitspec -- )
+ bitfield S> [ 20 2^ bitor ] when (insn) ; inline
+
+GENERIC# shift-imm/reg 2 ( shift-imm/Rs Rm shift -- n )
+
+M: integer shift-imm/reg ( shift-imm Rm shift -- n )
+ { { 0 4 } 5 { register 0 } 7 } bitfield ;
+
+M: register shift-imm/reg ( Rs Rm shift -- n )
+ {
+ { 1 4 }
+ { 0 7 }
+ 5
+ { register 8 }
+ { register 0 }
+ } bitfield ;
+
+PRIVATE>
+
+TUPLE: IMM immed rotate ;
+C: <IMM> IMM
+
+TUPLE: shifter Rm by shift ;
+C: <shifter> shifter
+
+<PRIVATE
+
+GENERIC: shifter-op ( shifter-op -- n )
+
+M: IMM shifter-op
+ [ immed>> ] [ rotate>> ] bi { { 1 25 } 8 0 } bitfield ;
+
+M: shifter shifter-op
+ [ by>> ] [ Rm>> ] [ shift>> ] tri shift-imm/reg ;
+
+PRIVATE>
+
+: <LSL> ( Rm shift-imm/Rs -- shifter-op ) BIN: 00 <shifter> ;
+: <LSR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 01 <shifter> ;
+: <ASR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 10 <shifter> ;
+: <ROR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 11 <shifter> ;
+: <RRX> ( Rm -- shifter-op ) 0 <ROR> ;
+
+M: register shifter-op 0 <LSL> shifter-op ;
+M: integer shifter-op 0 <IMM> shifter-op ;
+
+<PRIVATE
+
+: addr1 ( Rd Rn shifter-op opcode -- )
+ {
+ 21 ! opcode
+ { shifter-op 0 }
+ { register 16 } ! Rn
+ { register 12 } ! Rd
+ } sinsn ;
+
+PRIVATE>
+
+: AND ( Rd Rn shifter-op -- ) BIN: 0000 addr1 ;
+: EOR ( Rd Rn shifter-op -- ) BIN: 0001 addr1 ;
+: SUB ( Rd Rn shifter-op -- ) BIN: 0010 addr1 ;
+: RSB ( Rd Rn shifter-op -- ) BIN: 0011 addr1 ;
+: ADD ( Rd Rn shifter-op -- ) BIN: 0100 addr1 ;
+: ADC ( Rd Rn shifter-op -- ) BIN: 0101 addr1 ;
+: SBC ( Rd Rn shifter-op -- ) BIN: 0110 addr1 ;
+: RSC ( Rd Rn shifter-op -- ) BIN: 0111 addr1 ;
+: ORR ( Rd Rn shifter-op -- ) BIN: 1100 addr1 ;
+: BIC ( Rd Rn shifter-op -- ) BIN: 1110 addr1 ;
+
+: MOV ( Rd shifter-op -- ) [ f ] dip BIN: 1101 addr1 ;
+: MVN ( Rd shifter-op -- ) [ f ] dip BIN: 1111 addr1 ;
+
+! These always update the condition code flags
+<PRIVATE
+
+: (CMP) ( Rn shifter-op opcode -- ) [ f ] 3dip S addr1 ;
+
+PRIVATE>
+
+: TST ( Rn shifter-op -- ) BIN: 1000 (CMP) ;
+: TEQ ( Rn shifter-op -- ) BIN: 1001 (CMP) ;
+: CMP ( Rn shifter-op -- ) BIN: 1010 (CMP) ;
+: CMN ( Rn shifter-op -- ) BIN: 1011 (CMP) ;
+
+! Multiply instructions
+<PRIVATE
+
+: (MLA) ( Rd Rm Rs Rn a -- )
+ {
+ 21
+ { register 12 }
+ { register 8 }
+ { register 0 }
+ { register 16 }
+ { 1 7 }
+ { 1 4 }
+ } sinsn ;
+
+: (S/UMLAL) ( RdLo RdHi Rm Rs s a -- )
+ {
+ { 1 23 }
+ 22
+ 21
+ { register 8 }
+ { register 0 }
+ { register 16 }
+ { register 12 }
+ { 1 7 }
+ { 1 4 }
+ } sinsn ;
+
+PRIVATE>
+
+: MUL ( Rd Rm Rs -- ) f 0 (MLA) ;
+: MLA ( Rd Rm Rs Rn -- ) 1 (MLA) ;
+
+: SMLAL ( RdLo RdHi Rm Rs -- ) 1 1 (S/UMLAL) ;
+: SMULL ( RdLo RdHi Rm Rs -- ) 1 0 (S/UMLAL) ;
+: UMLAL ( RdLo RdHi Rm Rs -- ) 0 1 (S/UMLAL) ;
+: UMULL ( RdLo RdHi Rm Rs -- ) 0 0 (S/UMLAL) ;
+
+! Miscellaneous arithmetic instructions
+: CLZ ( Rd Rm -- )
+ {
+ { 1 24 }
+ { 1 22 }
+ { 1 21 }
+ { BIN: 111 16 }
+ { BIN: 1111 8 }
+ { 1 4 }
+ { register 0 }
+ { register 12 }
+ } sinsn ;
+
+! Status register acess instructions
+
+! Load and store instructions
+<PRIVATE
+
+GENERIC: addressing-mode-2 ( addressing-mode -- n )
+
+TUPLE: addressing base p u w ;
+C: <addressing> addressing
+
+M: addressing addressing-mode-2
+ { [ p>> ] [ u>> ] [ w>> ] [ base>> addressing-mode-2 ] } cleave
+ { 0 21 23 24 } bitfield ;
+
+M: integer addressing-mode-2 ;
+
+M: object addressing-mode-2 shifter-op { { 1 25 } 0 } bitfield ;
+
+: addr2 ( Rd Rn addressing-mode b l -- )
+ {
+ { 1 26 }
+ 20
+ 22
+ { addressing-mode-2 0 }
+ { register 16 }
+ { register 12 }
+ } insn ;
+
+PRIVATE>
+
+! Offset
+: <+> ( base -- addressing ) 1 1 0 <addressing> ;
+: <-> ( base -- addressing ) 1 0 0 <addressing> ;
+
+! Pre-indexed
+: <!+> ( base -- addressing ) 1 1 1 <addressing> ;
+: <!-> ( base -- addressing ) 1 0 1 <addressing> ;
+
+! Post-indexed
+: <+!> ( base -- addressing ) 0 1 0 <addressing> ;
+: <-!> ( base -- addressing ) 0 0 0 <addressing> ;
+
+: LDR ( Rd Rn addressing-mode -- ) 0 1 addr2 ;
+: LDRB ( Rd Rn addressing-mode -- ) 1 1 addr2 ;
+: STR ( Rd Rn addressing-mode -- ) 0 0 addr2 ;
+: STRB ( Rd Rn addressing-mode -- ) 1 0 addr2 ;
+
+! We might have to simulate these instructions since older ARM
+! chips don't have them.
+SYMBOL: have-BX?
+SYMBOL: have-BLX?
+
+<PRIVATE
+
+GENERIC# (BX) 1 ( Rm l -- )
+
+M: register (BX) ( Rm l -- )
+ {
+ { 1 24 }
+ { 1 21 }
+ { BIN: 1111 16 }
+ { BIN: 1111 12 }
+ { BIN: 1111 8 }
+ 5
+ { 1 4 }
+ { register 0 }
+ } insn ;
+
+PRIVATE>
+
+: BX ( Rm -- ) have-BX? get [ 0 (BX) ] [ [ PC ] dip MOV ] if ;
+
+: BLX ( Rm -- ) have-BLX? get [ 1 (BX) ] [ LR PC MOV BX ] if ;
+
+! More load and store instructions
+<PRIVATE
+
+GENERIC: addressing-mode-3 ( addressing-mode -- n )
+
+: b>n/n ( b -- n n ) [ -4 shift ] [ HEX: f bitand ] bi ;
+
+M: addressing addressing-mode-3
+ { [ p>> ] [ u>> ] [ w>> ] [ base>> addressing-mode-3 ] } cleave
+ { 0 21 23 24 } bitfield ;
+
+M: integer addressing-mode-3
+ b>n/n {
+ ! { 1 24 }
+ { 1 22 }
+ { 1 7 }
+ { 1 4 }
+ 0
+ 8
+ } bitfield ;
+
+M: object addressing-mode-3
+ shifter-op {
+ ! { 1 24 }
+ { 1 7 }
+ { 1 4 }
+ 0
+ } bitfield ;
+
+: addr3 ( Rn Rd addressing-mode h l s -- )
+ {
+ 6
+ 20
+ 5
+ { addressing-mode-3 0 }
+ { register 16 }
+ { register 12 }
+ } insn ;
+
+PRIVATE>
+
+: LDRH ( Rn Rd addressing-mode -- ) 1 1 0 addr3 ;
+: LDRSB ( Rn Rd addressing-mode -- ) 0 1 1 addr3 ;
+: LDRSH ( Rn Rd addressing-mode -- ) 1 1 1 addr3 ;
+: STRH ( Rn Rd addressing-mode -- ) 1 0 0 addr3 ;
+
+! Load and store multiple instructions
+
+! Semaphore instructions
+
+! Exception-generating instructions
--- /dev/null
+Slava Pestov
--- /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
{
{ "x86.32" "x86" }
{ "x86.64" "x86-64" }
- { "ppc" "PowerPC" }
}
: render-grid-header ( -- xml )
--- /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
projects / factor.git / commitdiff