Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2009-05-06 13:23:05 -05:00
commit 4cb6ecbc3c
38 changed files with 255 additions and 191 deletions

View File

@ -30,11 +30,12 @@ CONSTANT: rc-absolute-cell 0
CONSTANT: rc-absolute 1 CONSTANT: rc-absolute 1
CONSTANT: rc-relative 2 CONSTANT: rc-relative 2
CONSTANT: rc-absolute-ppc-2/2 3 CONSTANT: rc-absolute-ppc-2/2 3
CONSTANT: rc-relative-ppc-2 4 CONSTANT: rc-absolute-ppc-2 4
CONSTANT: rc-relative-ppc-3 5 CONSTANT: rc-relative-ppc-2 5
CONSTANT: rc-relative-arm-3 6 CONSTANT: rc-relative-ppc-3 6
CONSTANT: rc-indirect-arm 7 CONSTANT: rc-relative-arm-3 7
CONSTANT: rc-indirect-arm-pc 8 CONSTANT: rc-indirect-arm 8
CONSTANT: rc-indirect-arm-pc 9
! Relocation types ! Relocation types
CONSTANT: rt-primitive 0 CONSTANT: rt-primitive 0

View File

@ -3,114 +3,114 @@ USING: cpu.ppc.assembler tools.test arrays kernel namespaces
make vocabs sequences ; make vocabs sequences ;
: test-assembler ( expected quot -- ) : test-assembler ( expected quot -- )
[ 1array ] [ [ { } make ] curry ] bi* unit-test ; [ 1array ] [ [ B{ } make ] curry ] bi* unit-test ;
{ HEX: 38220003 } [ 1 2 3 ADDI ] test-assembler B{ HEX: 38 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDI ] test-assembler
{ HEX: 3c220003 } [ 1 2 3 ADDIS ] test-assembler B{ HEX: 3c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIS ] test-assembler
{ HEX: 30220003 } [ 1 2 3 ADDIC ] test-assembler B{ HEX: 30 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC ] test-assembler
{ HEX: 34220003 } [ 1 2 3 ADDIC. ] test-assembler B{ HEX: 34 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC. ] test-assembler
{ HEX: 38400001 } [ 1 2 LI ] test-assembler B{ HEX: 38 HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LI ] test-assembler
{ HEX: 3c400001 } [ 1 2 LIS ] test-assembler B{ HEX: 3c HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LIS ] test-assembler
{ HEX: 3822fffd } [ 1 2 3 SUBI ] test-assembler B{ HEX: 38 HEX: 22 HEX: ff HEX: fd } [ 1 2 3 SUBI ] test-assembler
{ HEX: 1c220003 } [ 1 2 3 MULI ] test-assembler B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULI ] test-assembler
{ HEX: 7c221a14 } [ 1 2 3 ADD ] test-assembler B{ HEX: 7c HEX: 22 HEX: 1a HEX: 14 } [ 1 2 3 ADD ] test-assembler
{ HEX: 7c221a15 } [ 1 2 3 ADD. ] test-assembler B{ HEX: 7c HEX: 22 HEX: 1a HEX: 15 } [ 1 2 3 ADD. ] test-assembler
{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler
{ HEX: 7c221e15 } [ 1 2 3 ADDO. ] test-assembler B{ HEX: 7c HEX: 22 HEX: 1e HEX: 15 } [ 1 2 3 ADDO. ] test-assembler
{ HEX: 7c221814 } [ 1 2 3 ADDC ] test-assembler B{ HEX: 7c HEX: 22 HEX: 18 HEX: 14 } [ 1 2 3 ADDC ] test-assembler
{ HEX: 7c221815 } [ 1 2 3 ADDC. ] test-assembler B{ HEX: 7c HEX: 22 HEX: 18 HEX: 15 } [ 1 2 3 ADDC. ] test-assembler
{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler
{ HEX: 7c221c15 } [ 1 2 3 ADDCO. ] test-assembler B{ HEX: 7c HEX: 22 HEX: 1c HEX: 15 } [ 1 2 3 ADDCO. ] test-assembler
{ HEX: 7c221914 } [ 1 2 3 ADDE ] test-assembler B{ HEX: 7c HEX: 22 HEX: 19 HEX: 14 } [ 1 2 3 ADDE ] test-assembler
{ HEX: 7c411838 } [ 1 2 3 AND ] test-assembler B{ HEX: 7c HEX: 41 HEX: 18 HEX: 38 } [ 1 2 3 AND ] test-assembler
{ HEX: 7c411839 } [ 1 2 3 AND. ] test-assembler B{ HEX: 7c HEX: 41 HEX: 18 HEX: 39 } [ 1 2 3 AND. ] test-assembler
{ HEX: 7c221bd6 } [ 1 2 3 DIVW ] test-assembler B{ HEX: 7c HEX: 22 HEX: 1b HEX: d6 } [ 1 2 3 DIVW ] test-assembler
{ HEX: 7c221b96 } [ 1 2 3 DIVWU ] test-assembler B{ HEX: 7c HEX: 22 HEX: 1b HEX: 96 } [ 1 2 3 DIVWU ] test-assembler
{ HEX: 7c411a38 } [ 1 2 3 EQV ] test-assembler B{ HEX: 7c HEX: 41 HEX: 1a HEX: 38 } [ 1 2 3 EQV ] test-assembler
{ HEX: 7c411bb8 } [ 1 2 3 NAND ] test-assembler B{ HEX: 7c HEX: 41 HEX: 1b HEX: b8 } [ 1 2 3 NAND ] test-assembler
{ HEX: 7c4118f8 } [ 1 2 3 NOR ] test-assembler B{ HEX: 7c HEX: 41 HEX: 18 HEX: f8 } [ 1 2 3 NOR ] test-assembler
{ HEX: 7c4110f8 } [ 1 2 NOT ] test-assembler B{ HEX: 7c HEX: 41 HEX: 10 HEX: f8 } [ 1 2 NOT ] test-assembler
{ HEX: 60410003 } [ 1 2 3 ORI ] test-assembler B{ HEX: 60 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORI ] test-assembler
{ HEX: 64410003 } [ 1 2 3 ORIS ] test-assembler B{ HEX: 64 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORIS ] test-assembler
{ HEX: 7c411b78 } [ 1 2 3 OR ] test-assembler B{ HEX: 7c HEX: 41 HEX: 1b HEX: 78 } [ 1 2 3 OR ] test-assembler
{ HEX: 7c411378 } [ 1 2 MR ] test-assembler B{ HEX: 7c HEX: 41 HEX: 13 HEX: 78 } [ 1 2 MR ] test-assembler
{ HEX: 7c221896 } [ 1 2 3 MULHW ] test-assembler B{ HEX: 7c HEX: 22 HEX: 18 HEX: 96 } [ 1 2 3 MULHW ] test-assembler
{ HEX: 1c220003 } [ 1 2 3 MULLI ] test-assembler B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULLI ] test-assembler
{ HEX: 7c221816 } [ 1 2 3 MULHWU ] test-assembler B{ HEX: 7c HEX: 22 HEX: 18 HEX: 16 } [ 1 2 3 MULHWU ] test-assembler
{ HEX: 7c2219d6 } [ 1 2 3 MULLW ] test-assembler B{ HEX: 7c HEX: 22 HEX: 19 HEX: d6 } [ 1 2 3 MULLW ] test-assembler
{ HEX: 7c411830 } [ 1 2 3 SLW ] test-assembler B{ HEX: 7c HEX: 41 HEX: 18 HEX: 30 } [ 1 2 3 SLW ] test-assembler
{ HEX: 7c411e30 } [ 1 2 3 SRAW ] test-assembler B{ HEX: 7c HEX: 41 HEX: 1e HEX: 30 } [ 1 2 3 SRAW ] test-assembler
{ HEX: 7c411c30 } [ 1 2 3 SRW ] test-assembler B{ HEX: 7c HEX: 41 HEX: 1c HEX: 30 } [ 1 2 3 SRW ] test-assembler
{ HEX: 7c411e70 } [ 1 2 3 SRAWI ] test-assembler B{ HEX: 7c HEX: 41 HEX: 1e HEX: 70 } [ 1 2 3 SRAWI ] test-assembler
{ HEX: 7c221850 } [ 1 2 3 SUBF ] test-assembler B{ HEX: 7c HEX: 22 HEX: 18 HEX: 50 } [ 1 2 3 SUBF ] test-assembler
{ HEX: 7c221810 } [ 1 2 3 SUBFC ] test-assembler B{ HEX: 7c HEX: 22 HEX: 18 HEX: 10 } [ 1 2 3 SUBFC ] test-assembler
{ HEX: 7c221910 } [ 1 2 3 SUBFE ] test-assembler B{ HEX: 7c HEX: 22 HEX: 19 HEX: 10 } [ 1 2 3 SUBFE ] test-assembler
{ HEX: 7c410774 } [ 1 2 EXTSB ] test-assembler B{ HEX: 7c HEX: 41 HEX: 07 HEX: 74 } [ 1 2 EXTSB ] test-assembler
{ HEX: 68410003 } [ 1 2 3 XORI ] test-assembler B{ HEX: 68 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 XORI ] test-assembler
{ HEX: 7c411a78 } [ 1 2 3 XOR ] test-assembler B{ HEX: 7c HEX: 41 HEX: 1a HEX: 78 } [ 1 2 3 XOR ] test-assembler
{ HEX: 7c2200d0 } [ 1 2 NEG ] test-assembler B{ HEX: 7c HEX: 22 HEX: 00 HEX: d0 } [ 1 2 NEG ] test-assembler
{ HEX: 2c220003 } [ 1 2 3 CMPI ] test-assembler B{ HEX: 2c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPI ] test-assembler
{ HEX: 28220003 } [ 1 2 3 CMPLI ] test-assembler B{ HEX: 28 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPLI ] test-assembler
{ HEX: 7c411800 } [ 1 2 3 CMP ] test-assembler B{ HEX: 7c HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 CMP ] test-assembler
{ HEX: 5422190a } [ 1 2 3 4 5 RLWINM ] test-assembler B{ HEX: 54 HEX: 22 HEX: 19 HEX: 0a } [ 1 2 3 4 5 RLWINM ] test-assembler
{ HEX: 54221838 } [ 1 2 3 SLWI ] test-assembler B{ HEX: 54 HEX: 22 HEX: 18 HEX: 38 } [ 1 2 3 SLWI ] test-assembler
{ HEX: 5422e8fe } [ 1 2 3 SRWI ] test-assembler B{ HEX: 54 HEX: 22 HEX: e8 HEX: fe } [ 1 2 3 SRWI ] test-assembler
{ HEX: 88220003 } [ 1 2 3 LBZ ] test-assembler B{ HEX: 88 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZ ] test-assembler
{ HEX: 8c220003 } [ 1 2 3 LBZU ] test-assembler B{ HEX: 8c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZU ] test-assembler
{ HEX: a8220003 } [ 1 2 3 LHA ] test-assembler B{ HEX: a8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHA ] test-assembler
{ HEX: ac220003 } [ 1 2 3 LHAU ] test-assembler B{ HEX: ac HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHAU ] test-assembler
{ HEX: a0220003 } [ 1 2 3 LHZ ] test-assembler B{ HEX: a0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZ ] test-assembler
{ HEX: a4220003 } [ 1 2 3 LHZU ] test-assembler B{ HEX: a4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZU ] test-assembler
{ HEX: 80220003 } [ 1 2 3 LWZ ] test-assembler B{ HEX: 80 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZ ] test-assembler
{ HEX: 84220003 } [ 1 2 3 LWZU ] test-assembler B{ HEX: 84 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZU ] test-assembler
{ HEX: 7c4118ae } [ 1 2 3 LBZX ] test-assembler B{ HEX: 7c HEX: 41 HEX: 18 HEX: ae } [ 1 2 3 LBZX ] test-assembler
{ HEX: 7c4118ee } [ 1 2 3 LBZUX ] test-assembler B{ HEX: 7c HEX: 41 HEX: 18 HEX: ee } [ 1 2 3 LBZUX ] test-assembler
{ HEX: 7c411aae } [ 1 2 3 LHAX ] test-assembler B{ HEX: 7c HEX: 41 HEX: 1a HEX: ae } [ 1 2 3 LHAX ] test-assembler
{ HEX: 7c411aee } [ 1 2 3 LHAUX ] test-assembler B{ HEX: 7c HEX: 41 HEX: 1a HEX: ee } [ 1 2 3 LHAUX ] test-assembler
{ HEX: 7c411a2e } [ 1 2 3 LHZX ] test-assembler B{ HEX: 7c HEX: 41 HEX: 1a HEX: 2e } [ 1 2 3 LHZX ] test-assembler
{ HEX: 7c411a6e } [ 1 2 3 LHZUX ] test-assembler B{ HEX: 7c HEX: 41 HEX: 1a HEX: 6e } [ 1 2 3 LHZUX ] test-assembler
{ HEX: 7c41182e } [ 1 2 3 LWZX ] test-assembler B{ HEX: 7c HEX: 41 HEX: 18 HEX: 2e } [ 1 2 3 LWZX ] test-assembler
{ HEX: 7c41186e } [ 1 2 3 LWZUX ] test-assembler B{ HEX: 7c HEX: 41 HEX: 18 HEX: 6e } [ 1 2 3 LWZUX ] test-assembler
{ HEX: 48000001 } [ 1 B ] test-assembler B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 B ] test-assembler
{ HEX: 48000001 } [ 1 BL ] test-assembler B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 BL ] test-assembler
{ HEX: 41800004 } [ 1 BLT ] test-assembler B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler
{ HEX: 41810004 } [ 1 BGT ] test-assembler B{ HEX: 41 HEX: 81 HEX: 00 HEX: 04 } [ 1 BGT ] test-assembler
{ HEX: 40810004 } [ 1 BLE ] test-assembler B{ HEX: 40 HEX: 81 HEX: 00 HEX: 04 } [ 1 BLE ] test-assembler
{ HEX: 40800004 } [ 1 BGE ] test-assembler B{ HEX: 40 HEX: 80 HEX: 00 HEX: 04 } [ 1 BGE ] test-assembler
{ HEX: 41800004 } [ 1 BLT ] test-assembler B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler
{ HEX: 40820004 } [ 1 BNE ] test-assembler B{ HEX: 40 HEX: 82 HEX: 00 HEX: 04 } [ 1 BNE ] test-assembler
{ HEX: 41820004 } [ 1 BEQ ] test-assembler B{ HEX: 41 HEX: 82 HEX: 00 HEX: 04 } [ 1 BEQ ] test-assembler
{ HEX: 41830004 } [ 1 BO ] test-assembler B{ HEX: 41 HEX: 83 HEX: 00 HEX: 04 } [ 1 BO ] test-assembler
{ HEX: 40830004 } [ 1 BNO ] test-assembler B{ HEX: 40 HEX: 83 HEX: 00 HEX: 04 } [ 1 BNO ] test-assembler
{ HEX: 4c200020 } [ 1 BCLR ] test-assembler B{ HEX: 4c HEX: 20 HEX: 00 HEX: 20 } [ 1 BCLR ] test-assembler
{ HEX: 4e800020 } [ BLR ] test-assembler B{ HEX: 4e HEX: 80 HEX: 00 HEX: 20 } [ BLR ] test-assembler
{ HEX: 4e800021 } [ BLRL ] test-assembler B{ HEX: 4e HEX: 80 HEX: 00 HEX: 21 } [ BLRL ] test-assembler
{ HEX: 4c200420 } [ 1 BCCTR ] test-assembler B{ HEX: 4c HEX: 20 HEX: 04 HEX: 20 } [ 1 BCCTR ] test-assembler
{ HEX: 4e800420 } [ BCTR ] test-assembler B{ HEX: 4e HEX: 80 HEX: 04 HEX: 20 } [ BCTR ] test-assembler
{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler
{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler
{ HEX: 7c6902a6 } [ 3 MFCTR ] test-assembler B{ HEX: 7c HEX: 69 HEX: 02 HEX: a6 } [ 3 MFCTR ] test-assembler
{ HEX: 7c6103a6 } [ 3 MTXER ] test-assembler B{ HEX: 7c HEX: 61 HEX: 03 HEX: a6 } [ 3 MTXER ] test-assembler
{ HEX: 7c6803a6 } [ 3 MTLR ] test-assembler B{ HEX: 7c HEX: 68 HEX: 03 HEX: a6 } [ 3 MTLR ] test-assembler
{ HEX: 7c6903a6 } [ 3 MTCTR ] test-assembler B{ HEX: 7c HEX: 69 HEX: 03 HEX: a6 } [ 3 MTCTR ] test-assembler
{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler
{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler
{ HEX: c0220003 } [ 1 2 3 LFS ] test-assembler B{ HEX: c0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFS ] test-assembler
{ HEX: c4220003 } [ 1 2 3 LFSU ] test-assembler B{ HEX: c4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFSU ] test-assembler
{ HEX: c8220003 } [ 1 2 3 LFD ] test-assembler B{ HEX: c8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFD ] test-assembler
{ HEX: cc220003 } [ 1 2 3 LFDU ] test-assembler B{ HEX: cc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFDU ] test-assembler
{ HEX: d0220003 } [ 1 2 3 STFS ] test-assembler B{ HEX: d0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFS ] test-assembler
{ HEX: d4220003 } [ 1 2 3 STFSU ] test-assembler B{ HEX: d4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFSU ] test-assembler
{ HEX: d8220003 } [ 1 2 3 STFD ] test-assembler B{ HEX: d8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFD ] test-assembler
{ HEX: dc220003 } [ 1 2 3 STFDU ] test-assembler B{ HEX: dc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFDU ] test-assembler
{ HEX: fc201048 } [ 1 2 FMR ] test-assembler B{ HEX: fc HEX: 20 HEX: 10 HEX: 48 } [ 1 2 FMR ] test-assembler
{ HEX: fc20101e } [ 1 2 FCTIWZ ] test-assembler B{ HEX: fc HEX: 20 HEX: 10 HEX: 1e } [ 1 2 FCTIWZ ] test-assembler
{ HEX: fc22182a } [ 1 2 3 FADD ] test-assembler B{ HEX: fc HEX: 22 HEX: 18 HEX: 2a } [ 1 2 3 FADD ] test-assembler
{ HEX: fc22182b } [ 1 2 3 FADD. ] test-assembler B{ HEX: fc HEX: 22 HEX: 18 HEX: 2b } [ 1 2 3 FADD. ] test-assembler
{ HEX: fc221828 } [ 1 2 3 FSUB ] test-assembler B{ HEX: fc HEX: 22 HEX: 18 HEX: 28 } [ 1 2 3 FSUB ] test-assembler
{ HEX: fc2200f2 } [ 1 2 3 FMUL ] test-assembler B{ HEX: fc HEX: 22 HEX: 00 HEX: f2 } [ 1 2 3 FMUL ] test-assembler
{ HEX: fc221824 } [ 1 2 3 FDIV ] test-assembler B{ HEX: fc HEX: 22 HEX: 18 HEX: 24 } [ 1 2 3 FDIV ] test-assembler
{ HEX: fc20102c } [ 1 2 FSQRT ] test-assembler B{ HEX: fc HEX: 20 HEX: 10 HEX: 2c } [ 1 2 FSQRT ] test-assembler
{ HEX: fc411800 } [ 1 2 3 FCMPU ] test-assembler B{ HEX: fc HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 FCMPU ] test-assembler
{ HEX: fc411840 } [ 1 2 3 FCMPO ] test-assembler B{ HEX: fc HEX: 41 HEX: 18 HEX: 40 } [ 1 2 3 FCMPO ] test-assembler
{ HEX: 3c601234 HEX: 60635678 } [ HEX: 12345678 3 LOAD ] test-assembler B{ HEX: 3c HEX: 60 HEX: 12 HEX: 34 HEX: 60 HEX: 63 HEX: 56 HEX: 78 } [ HEX: 12345678 3 LOAD ] test-assembler

View File

@ -1,11 +1,11 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: compiler.codegen.fixup cpu.architecture USING: compiler.codegen.fixup cpu.architecture
compiler.constants kernel namespaces make sequences words math compiler.constants kernel namespaces make sequences words math
math.bitwise io.binary parser lexer ; math.bitwise io.binary parser lexer ;
IN: cpu.ppc.assembler.backend IN: cpu.ppc.assembler.backend
: insn ( operand opcode -- ) { 26 0 } bitfield , ; : insn ( operand opcode -- ) { 26 0 } bitfield 4 >be % ;
: a-insn ( d a b c xo rc opcode -- ) : a-insn ( d a b c xo rc opcode -- )
[ { 0 1 6 11 16 21 } bitfield ] dip insn ; [ { 0 1 6 11 16 21 } bitfield ] dip insn ;

View File

@ -152,9 +152,6 @@ big-endian off
! ! ! Polymorphic inline caches ! ! ! Polymorphic inline caches
! temp0 contains the object being dispatched on
! temp1 contains its class
! Load a value from a stack position ! Load a value from a stack position
[ [
temp1 ds-reg HEX: ffffffff [+] MOV rc-absolute rt-untagged jit-rel temp1 ds-reg HEX: ffffffff [+] MOV rc-absolute rt-untagged jit-rel

View File

@ -5,7 +5,7 @@ compression.lzw constructors endian fry grouping images io
io.binary io.encodings.ascii io.encodings.binary io.binary io.encodings.ascii io.encodings.binary
io.encodings.string io.encodings.utf8 io.files kernel math io.encodings.string io.encodings.utf8 io.files kernel math
math.bitwise math.order math.parser pack prettyprint sequences math.bitwise math.order math.parser pack prettyprint sequences
strings math.vectors specialized-arrays.float ; strings math.vectors specialized-arrays.float locals ;
IN: images.tiff IN: images.tiff
TUPLE: tiff-image < image ; TUPLE: tiff-image < image ;
@ -184,7 +184,7 @@ samples-per-pixel new-subfile-type subfile-type orientation
software date-time photoshop exif-ifd sub-ifd inter-color-profile software date-time photoshop exif-ifd sub-ifd inter-color-profile
xmp iptc fill-order document-name page-number page-name xmp iptc fill-order document-name page-number page-name
x-position y-position host-computer copyright artist x-position y-position host-computer copyright artist
min-sample-value max-sample-value make model cell-width cell-length min-sample-value max-sample-value tiff-make tiff-model cell-width cell-length
gray-response-unit gray-response-curve color-map threshholding gray-response-unit gray-response-curve color-map threshholding
image-description free-offsets free-byte-counts tile-width tile-length image-description free-offsets free-byte-counts tile-width tile-length
matteing data-type image-depth tile-depth matteing data-type image-depth tile-depth
@ -243,10 +243,13 @@ ERROR: bad-tiff-magic bytes ;
ERROR: no-tag class ; ERROR: no-tag class ;
: find-tag ( idf class -- tag ) : find-tag* ( ifd class -- tag/class ? )
swap processed-tags>> ?at [ no-tag ] unless ; swap processed-tags>> ?at ;
: tag? ( idf class -- tag ) : find-tag ( ifd class -- tag )
find-tag* [ no-tag ] unless ;
: tag? ( ifd class -- tag )
swap processed-tags>> key? ; swap processed-tags>> key? ;
: read-strips ( ifd -- ifd ) : read-strips ( ifd -- ifd )
@ -339,8 +342,8 @@ ERROR: bad-small-ifd-type n ;
{ 266 [ fill-order ] } { 266 [ fill-order ] }
{ 269 [ ascii decode document-name ] } { 269 [ ascii decode document-name ] }
{ 270 [ ascii decode image-description ] } { 270 [ ascii decode image-description ] }
{ 271 [ ascii decode make ] } { 271 [ ascii decode tiff-make ] }
{ 272 [ ascii decode model ] } { 272 [ ascii decode tiff-model ] }
{ 273 [ strip-offsets ] } { 273 [ strip-offsets ] }
{ 274 [ orientation ] } { 274 [ orientation ] }
{ 277 [ samples-per-pixel ] } { 277 [ samples-per-pixel ] }
@ -350,7 +353,7 @@ ERROR: bad-small-ifd-type n ;
{ 281 [ max-sample-value ] } { 281 [ max-sample-value ] }
{ 282 [ first x-resolution ] } { 282 [ first x-resolution ] }
{ 283 [ first y-resolution ] } { 283 [ first y-resolution ] }
{ 284 [ planar-configuration ] } { 284 [ lookup-planar-configuration planar-configuration ] }
{ 285 [ page-name ] } { 285 [ page-name ] }
{ 286 [ x-position ] } { 286 [ x-position ] }
{ 287 [ y-position ] } { 287 [ y-position ] }
@ -437,8 +440,8 @@ ERROR: unhandled-compression compression ;
[ samples-per-pixel find-tag ] tri [ samples-per-pixel find-tag ] tri
[ * ] keep [ * ] keep
'[ '[
_ group [ _ group [ rest ] [ first ] bi _ group
[ v+ ] accumulate swap suffix concat ] map [ _ group unclip [ v+ ] accumulate swap suffix concat ] map
concat >byte-array concat >byte-array
] change-bitmap ; ] change-bitmap ;
@ -521,23 +524,39 @@ ERROR: unknown-component-order ifd ;
] with-tiff-endianness ] with-tiff-endianness
] with-file-reader ; ] with-file-reader ;
: process-tif-ifds ( parsed-tiff -- parsed-tiff ) : process-chunky-ifd ( ifd -- )
dup ifds>> [ read-strips
read-strips uncompress-strips
uncompress-strips strips>bitmap
strips>bitmap fix-bitmap-endianness
fix-bitmap-endianness strips-predictor
strips-predictor dup extra-samples tag? [ handle-alpha-data ] when
dup extra-samples tag? [ handle-alpha-data ] when drop ;
drop
] each ; : process-planar-ifd ( ifd -- )
"planar ifd not supported" throw ;
: dispatch-planar-configuration ( ifd planar-configuration -- )
{
{ planar-configuration-chunky [ process-chunky-ifd ] }
{ planar-configuration-planar [ process-planar-ifd ] }
} case ;
: process-ifd ( ifd -- )
dup planar-configuration find-tag* [
dispatch-planar-configuration
] [
drop "no planar configuration" throw
] if ;
: process-tif-ifds ( parsed-tiff -- )
ifds>> [ process-ifd ] each ;
: load-tiff ( path -- parsed-tiff ) : load-tiff ( path -- parsed-tiff )
[ load-tiff-ifds ] [ [ load-tiff-ifds dup ] keep
binary [ binary [
[ process-tif-ifds ] with-tiff-endianness [ process-tif-ifds ] with-tiff-endianness
] with-file-reader ] with-file-reader ;
] bi ;
! tiff files can store several images -- we just take the first for now ! tiff files can store several images -- we just take the first for now
M: tiff-image load-image* ( path tiff-image -- image ) M: tiff-image load-image* ( path tiff-image -- image )

View File

@ -7,7 +7,7 @@ TUPLE: bits { number read-only } { length read-only } ;
C: <bits> bits C: <bits> bits
: make-bits ( number -- bits ) : make-bits ( number -- bits )
dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1+ <bits> ] if ; inline dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1 + <bits> ] if ; inline
M: bits length length>> ; M: bits length length>> ;

View File

@ -13,10 +13,10 @@ IN: math.bitwise
: unmask? ( x n -- ? ) unmask 0 > ; inline : unmask? ( x n -- ? ) unmask 0 > ; inline
: mask ( x n -- ? ) bitand ; inline : mask ( x n -- ? ) bitand ; inline
: mask? ( x n -- ? ) mask 0 > ; inline : mask? ( x n -- ? ) mask 0 > ; inline
: wrap ( m n -- m' ) 1- bitand ; inline : wrap ( m n -- m' ) 1 - bitand ; inline
: bits ( m n -- m' ) 2^ wrap ; inline : bits ( m n -- m' ) 2^ wrap ; inline
: mask-bit ( m n -- m' ) 2^ mask ; inline : mask-bit ( m n -- m' ) 2^ mask ; inline
: on-bits ( n -- m ) 2^ 1- ; inline : on-bits ( n -- m ) 2^ 1 - ; inline
: toggle-bit ( m n -- m' ) 2^ bitxor ; inline : toggle-bit ( m n -- m' ) 2^ bitxor ; inline
: shift-mod ( n s w -- n ) : shift-mod ( n s w -- n )
@ -64,8 +64,8 @@ DEFER: byte-bit-count
<< <<
\ byte-bit-count \ byte-bit-count
256 [ 256 iota [
8 <bits> 0 [ [ 1+ ] when ] reduce 8 <bits> 0 [ [ 1 + ] when ] reduce
] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ] ] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ]
(( byte -- table )) define-declared (( byte -- table )) define-declared
@ -97,12 +97,12 @@ PRIVATE>
! Signed byte array to integer conversion ! Signed byte array to integer conversion
: signed-le> ( bytes -- x ) : signed-le> ( bytes -- x )
[ le> ] [ length 8 * 1- on-bits ] bi [ le> ] [ length 8 * 1 - on-bits ] bi
2dup > [ bitnot bitor ] [ drop ] if ; 2dup > [ bitnot bitor ] [ drop ] if ;
: signed-be> ( bytes -- x ) : signed-be> ( bytes -- x )
<reversed> signed-le> ; <reversed> signed-le> ;
: >signed ( x n -- y ) : >signed ( x n -- y )
2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ; 2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;

View File

@ -164,7 +164,7 @@ M: VECTOR element-type
M: VECTOR Vswap M: VECTOR Vswap
(prepare-swap) [ XSWAP ] 2dip ; (prepare-swap) [ XSWAP ] 2dip ;
M: VECTOR Viamax M: VECTOR Viamax
(prepare-nrm2) IXAMAX 1- ; (prepare-nrm2) IXAMAX 1 - ;
M: VECTOR (blas-vector-like) M: VECTOR (blas-vector-like)
drop <VECTOR> ; drop <VECTOR> ;

View File

@ -18,7 +18,7 @@ M: real sqrt
: factor-2s ( n -- r s ) : factor-2s ( n -- r s )
#! factor an integer into 2^r * s #! factor an integer into 2^r * s
dup 0 = [ 1 ] [ dup 0 = [ 1 ] [
0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] while 0 swap [ dup even? ] [ [ 1 + ] [ 2/ ] bi* ] while
] if ; inline ] if ; inline
<PRIVATE <PRIVATE
@ -216,17 +216,17 @@ M: real tanh ftanh ;
: coth ( x -- y ) tanh recip ; inline : coth ( x -- y ) tanh recip ; inline
: acosh ( x -- y ) : acosh ( x -- y )
dup sq 1- sqrt + log ; inline dup sq 1 - sqrt + log ; inline
: asech ( x -- y ) recip acosh ; inline : asech ( x -- y ) recip acosh ; inline
: asinh ( x -- y ) : asinh ( x -- y )
dup sq 1+ sqrt + log ; inline dup sq 1 + sqrt + log ; inline
: acosech ( x -- y ) recip asinh ; inline : acosech ( x -- y ) recip asinh ; inline
: atanh ( x -- y ) : atanh ( x -- y )
[ 1+ ] [ 1- neg ] bi / log 2 / ; inline [ 1 + ] [ 1 - neg ] bi / log 2 / ; inline
: acoth ( x -- y ) recip atanh ; inline : acoth ( x -- y ) recip atanh ; inline
@ -259,7 +259,7 @@ M: real atan fatan ;
: floor ( x -- y ) : floor ( x -- y )
dup 1 mod dup zero? dup 1 mod dup zero?
[ drop ] [ dup 0 < [ - 1- ] [ - ] if ] if ; foldable [ drop ] [ dup 0 < [ - 1 - ] [ - ] if ] if ; foldable
: ceiling ( x -- y ) neg floor neg ; foldable : ceiling ( x -- y ) neg floor neg ; foldable

View File

@ -380,7 +380,7 @@ SYMBOL: incomparable
[ [
to>> first 1 max dup most-positive-fixnum > to>> first 1 max dup most-positive-fixnum >
[ drop full-interval interval-log2 ] [ drop full-interval interval-log2 ]
[ 1+ >integer log2 0 swap [a,b] ] [ 1 + >integer log2 0 swap [a,b] ]
if if
] ]
} case ; } case ;
@ -407,7 +407,7 @@ SYMBOL: incomparable
: integral-closure ( i1 -- i2 ) : integral-closure ( i1 -- i2 )
dup special-interval? [ dup special-interval? [
[ from>> first2 [ 1+ ] unless ] [ from>> first2 [ 1 + ] unless ]
[ to>> first2 [ 1- ] unless ] [ to>> first2 [ 1 - ] unless ]
bi [a,b] bi [a,b]
] unless ; ] unless ;

View File

@ -1,4 +1,4 @@
USING: math.miller-rabin tools.test ; USING: math.miller-rabin tools.test kernel sequences ;
IN: math.miller-rabin.tests IN: math.miller-rabin.tests
[ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
@ -8,4 +8,12 @@ IN: math.miller-rabin.tests
[ t ] [ 37 miller-rabin ] unit-test [ t ] [ 37 miller-rabin ] unit-test
[ 101 ] [ 100 next-prime ] unit-test [ 101 ] [ 100 next-prime ] unit-test
[ t ] [ 2135623355842621559 miller-rabin ] unit-test [ t ] [ 2135623355842621559 miller-rabin ] unit-test
[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test [ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
[ 863 ] [ 862 next-safe-prime ] unit-test
[ f ] [ 862 safe-prime? ] unit-test
[ t ] [ 7 safe-prime? ] unit-test
[ f ] [ 31 safe-prime? ] unit-test
[ t ] [ 863 safe-prime? ] unit-test
[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test

View File

@ -1,36 +1,34 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel locals math math.functions math.ranges USING: combinators kernel locals math math.functions math.ranges
random sequences sets ; random sequences sets combinators.short-circuit math.bitwise ;
IN: math.miller-rabin IN: math.miller-rabin
<PRIVATE <PRIVATE
: >odd ( n -- int ) dup even? [ 1+ ] when ; foldable : >odd ( n -- int ) dup even? [ 1 + ] when ; foldable
TUPLE: positive-even-expected n ; TUPLE: positive-even-expected n ;
:: (miller-rabin) ( n trials -- ? ) :: (miller-rabin) ( n trials -- ? )
[let | r [ n 1- factor-2s drop ] n 1 - :> n-1
s [ n 1- factor-2s nip ] n-1 factor-2s :> s :> r
prime?! [ t ] 0 :> a!
a! [ 0 ] trials [
count! [ 0 ] | drop
trials [ n 1 - [1,b] random a!
n 1- [1,b] random a! a s n ^mod 1 = [
a s n ^mod 1 = [ f
0 count! ] [
r [ r iota [
2^ s * a swap n ^mod n - -1 = 2^ s * a swap n ^mod n - -1 =
[ count 1+ count! r + ] when ] any? not
] each ] if
count zero? [ f prime?! trials + ] when ] any? not ;
] unless drop
] each prime? ] ;
PRIVATE> PRIVATE>
: next-odd ( m -- n ) dup even? [ 1+ ] [ 2 + ] if ; : next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ;
: miller-rabin* ( n numtrials -- ? ) : miller-rabin* ( n numtrials -- ? )
over { over {
@ -74,3 +72,38 @@ ERROR: too-few-primes ;
dup 5 < [ too-few-primes ] when dup 5 < [ too-few-primes ] when
2dup [ random-prime ] curry replicate 2dup [ random-prime ] curry replicate
dup all-unique? [ 2nip ] [ drop unique-primes ] if ; dup all-unique? [ 2nip ] [ drop unique-primes ] if ;
! Safe primes are of the form p = 2q + 1, p,q are prime
! See http://en.wikipedia.org/wiki/Safe_prime
<PRIVATE
: >safe-prime-form ( q -- p ) 2 * 1 + ;
: safe-prime-candidate? ( n -- ? )
>safe-prime-form
1 + 6 divisor? ;
: next-safe-prime-candidate ( n -- candidate )
next-prime dup safe-prime-candidate?
[ next-safe-prime-candidate ] unless ;
PRIVATE>
: safe-prime? ( q -- ? )
{
[ 1 - 2 / dup integer? [ miller-rabin ] [ drop f ] if ]
[ miller-rabin ]
} 1&& ;
: next-safe-prime ( n -- q )
next-safe-prime-candidate
dup >safe-prime-form
dup miller-rabin
[ nip ] [ drop next-safe-prime ] if ;
: random-bits* ( numbits -- n )
[ random-bits ] keep set-bit ;
: random-safe-prime ( numbits -- p )
1- random-bits* next-safe-prime ;

View File

@ -29,7 +29,7 @@ PRIVATE>
: n*p ( n p -- n*p ) n*v ; : n*p ( n p -- n*p ) n*v ;
: pextend-conv ( p q -- p q ) : pextend-conv ( p q -- p q )
2dup [ length ] bi@ + 1- 2pad-tail [ >vector ] bi@ ; 2dup [ length ] bi@ + 1 - 2pad-tail [ >vector ] bi@ ;
: p* ( p q -- r ) : p* ( p q -- r )
2unempty pextend-conv <reversed> dup length 2unempty pextend-conv <reversed> dup length
@ -44,7 +44,7 @@ PRIVATE>
2ptrim 2ptrim
2dup [ length ] bi@ - 2dup [ length ] bi@ -
dup 1 < [ drop 1 ] when dup 1 < [ drop 1 ] when
[ over length + 0 pad-head pextend ] keep 1+ ; [ over length + 0 pad-head pextend ] keep 1 + ;
: /-last ( seq seq -- a ) : /-last ( seq seq -- a )
#! divide the last two numbers in the sequences #! divide the last two numbers in the sequences

View File

@ -10,7 +10,7 @@ TUPLE: range
{ step read-only } ; { step read-only } ;
: <range> ( a b step -- range ) : <range> ( a b step -- range )
[ over - ] dip [ /i 1+ 0 max ] keep range boa ; inline [ over - ] dip [ /i 1 + 0 max ] keep range boa ; inline
M: range length ( seq -- n ) M: range length ( seq -- n )
length>> ; length>> ;

View File

@ -15,7 +15,7 @@ IN: math.statistics
: median ( seq -- n ) : median ( seq -- n )
natural-sort dup length even? [ natural-sort dup length even? [
[ midpoint@ dup 1- 2array ] keep nths mean [ midpoint@ dup 1 - 2array ] keep nths mean
] [ ] [
[ midpoint@ ] keep nth [ midpoint@ ] keep nth
] if ; ] if ;
@ -33,7 +33,7 @@ IN: math.statistics
drop 0 drop 0
] [ ] [
[ [ mean ] keep [ - sq ] with sigma ] keep [ [ mean ] keep [ - sq ] with sigma ] keep
length 1- / length 1 - /
] if ; ] if ;
: std ( seq -- x ) : std ( seq -- x )
@ -47,7 +47,7 @@ IN: math.statistics
0 [ [ [ pick ] dip swap - ] bi@ * + ] 2reduce 2nip ; 0 [ [ [ pick ] dip swap - ] bi@ * + ] 2reduce 2nip ;
: (r) ( mean(x) mean(y) {x} {y} sx sy -- r ) : (r) ( mean(x) mean(y) {x} {y} sx sy -- r )
* recip [ [ ((r)) ] keep length 1- / ] dip * ; * recip [ [ ((r)) ] keep length 1 - / ] dip * ;
: [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy ) : [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy )
first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ; first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ;

View File

@ -2,7 +2,7 @@ IN: specialized-arrays.tests
USING: tools.test specialized-arrays sequences USING: tools.test specialized-arrays sequences
specialized-arrays.int specialized-arrays.bool specialized-arrays.int specialized-arrays.bool
specialized-arrays.ushort alien.c-types accessors kernel specialized-arrays.ushort alien.c-types accessors kernel
specialized-arrays.direct.int arrays ; specialized-arrays.direct.int specialized-arrays.char arrays ;
[ t ] [ { 1 2 3 } >int-array int-array? ] unit-test [ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
@ -10,7 +10,7 @@ specialized-arrays.direct.int arrays ;
[ 2 ] [ int-array{ 1 2 3 } second ] unit-test [ 2 ] [ int-array{ 1 2 3 } second ] unit-test
[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >int-array underlying>> = ] unit-test [ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >char-array underlying>> = ] unit-test
[ ushort-array{ 1234 } ] [ [ ushort-array{ 1234 } ] [
little-endian? B{ 210 4 } B{ 4 210 } ? byte-array>ushort-array little-endian? B{ 210 4 } B{ 4 210 } ? byte-array>ushort-array

View File

@ -84,6 +84,9 @@ void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value)
case RC_ABSOLUTE_PPC_2_2: case RC_ABSOLUTE_PPC_2_2:
store_address_2_2((cell *)offset,absolute_value); store_address_2_2((cell *)offset,absolute_value);
break; break;
case RC_ABSOLUTE_PPC_2:
store_address_masked((cell *)offset,absolute_value,REL_ABSOLUTE_PPC_2_MASK,0);
break;
case RC_RELATIVE_PPC_2: case RC_RELATIVE_PPC_2:
store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_2_MASK,0); store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_2_MASK,0);
break; break;

View File

@ -31,8 +31,10 @@ enum relocation_class {
RC_ABSOLUTE, RC_ABSOLUTE,
/* relative address in a 32-bit location */ /* relative address in a 32-bit location */
RC_RELATIVE, RC_RELATIVE,
/* relative address in a PowerPC LIS/ORI sequence */ /* absolute address in a PowerPC LIS/ORI sequence */
RC_ABSOLUTE_PPC_2_2, RC_ABSOLUTE_PPC_2_2,
/* absolute address in a PowerPC LWZ instruction */
RC_ABSOLUTE_PPC_2,
/* relative address in a PowerPC LWZ/STW/BC instruction */ /* relative address in a PowerPC LWZ/STW/BC instruction */
RC_RELATIVE_PPC_2, RC_RELATIVE_PPC_2,
/* relative address in a PowerPC B/BL instruction */ /* relative address in a PowerPC B/BL instruction */
@ -45,6 +47,7 @@ enum relocation_class {
RC_INDIRECT_ARM_PC RC_INDIRECT_ARM_PC
}; };
#define REL_ABSOLUTE_PPC_2_MASK 0xffff
#define REL_RELATIVE_PPC_2_MASK 0xfffc #define REL_RELATIVE_PPC_2_MASK 0xfffc
#define REL_RELATIVE_PPC_3_MASK 0x3fffffc #define REL_RELATIVE_PPC_3_MASK 0x3fffffc
#define REL_INDIRECT_ARM_MASK 0xfff #define REL_INDIRECT_ARM_MASK 0xfff