steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

initial AMD64 porting work

cvs
Slava Pestov 2005-12-02 07:25:44 +00:00
parent f751f17259
commit d8384c12c9
23 changed files with 175 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
library/alien/compiler.factor
View File

@ -2,8 +2,8 @@
! See http://factor.sf.net/license.txt for BSD license.
IN: alien
USING: assembler compiler compiler-backend compiler-frontend
errors generic hashtables inference io kernel lists math
namespaces prettyprint sequences strings words parser ;
errors generic hashtables inference io kernel kernel-internals
lists math namespaces prettyprint sequences strings words parser ;
! ! ! WARNING ! ! !
! Reloading this file into a running Factor instance on Win32

25
library/alien/primitive-types.factor
View File

@ -1,4 +1,5 @@
USING: alien compiler-backend kernel math namespaces ;
USING: alien compiler-backend kernel kernel-internals
math namespaces ;
[
[ alien-unsigned-cell <alien> ] "getter" set
@ -29,6 +30,24 @@ USING: alien compiler-backend kernel math namespaces ;
"unbox_unsigned_8" "unboxer" set
] "ulonglong" define-primitive-type
[
[ alien-signed-cell ] "getter" set
[ set-alien-signed-cell ] "setter" set
cell "width" set
cell "align" set
"box_signed_cell" "boxer" set
"unbox_signed_cell" "unboxer" set
] "long" define-primitive-type
[
[ alien-unsigned-cell ] "getter" set
[ set-alien-unsigned-cell ] "setter" set
cell "width" set
cell "align" set
"box_unsigned_cell" "boxer" set
"unbox_unsigned_cell" "unboxer" set
] "ulong" define-primitive-type
[
[ alien-signed-4 ] "getter" set
[ set-alien-signed-4 ] "setter" set
@ -129,7 +148,3 @@ USING: alien compiler-backend kernel math namespaces ;
"unbox_double" "unboxer" set
T{ float-regs f 8 } "reg-class" set
] "double" define-primitive-type
! FIXME for 64-bit platforms
"int" "long" typedef
"uint" "ulong" typedef

4
library/alien/structs.factor
View File

@ -2,8 +2,8 @@
! See http://factor.sf.net/license.txt for BSD license.
IN: alien
USING: assembler compiler compiler-backend errors generic
hashtables kernel lists math namespaces parser sequences strings
words ;
hashtables kernel kernel-internals lists math namespaces parser
sequences strings words ;
! Some code for interfacing with C structures.

14
library/bootstrap/boot-stage2.factor
View File

@ -18,6 +18,10 @@ cpu "ppc" = [
"/library/compiler/ppc/load.factor"
] pull-in
cpu "amd64" = [
"/library/compiler/amd64/load.factor"
] pull-in
"Loading more library code..." print
t [
@ -25,11 +29,11 @@ t [
"/library/alien/malloc.factor"
"/library/io/buffer.factor"
! "/library/sdl/load.factor"
! "/library/opengl/load.factor"
! "/library/freetype/load.factor"
! "/library/ui/load.factor"
! "/library/help/load.factor"
"/library/sdl/load.factor"
"/library/opengl/load.factor"
"/library/freetype/load.factor"
"/library/ui/load.factor"
"/library/help/load.factor"
] pull-in
! Handle -libraries:... overrides

6
library/bootstrap/image.factor
View File

@ -9,10 +9,10 @@
! strings etc to the image file in the CFactor object memory
! format.
IN: image
USING: arrays errors generic hashtables kernel lists
math namespaces parser prettyprint sequences
USING: arrays errors generic hashtables kernel kernel-internals
lists math namespaces parser prettyprint sequences
sequences-internals io strings vectors words ;
IN: image
! The image being constructed; a vector of word-size integers
SYMBOL: image

1
library/collections/cons.factor
View File

@ -30,7 +30,6 @@ PREDICATE: general-list list ( list -- ? )
: swons ( cdr car -- [[ car cdr ]] ) swap cons ; inline
: unit ( a -- [ a ] ) f cons ; inline
: 2list ( a b -- [ a b ] ) unit cons ; inline
: 2car ( cons cons -- car car ) [ car ] 2apply ; inline
: 2cdr ( cons cons -- car car ) [ cdr ] 2apply ; inline

8
library/compiler/amd64/load.factor Normal file
View File

@ -0,0 +1,8 @@
USING: io kernel parser sequences ;
[
"/library/compiler/x86/assembler.factor"
"/library/compiler/amd64/architecture.factor"
] [
dup print run-resource
] each

3
library/compiler/architecture.factor
View File

@ -2,9 +2,6 @@ IN: compiler-backend
! A few things the front-end needs to know about the back-end.
DEFER: cell ( -- n )
#! Word size
DEFER: fixnum-imm? ( -- ? )
#! Can fixnum operations take immediate operands?

4
library/compiler/assembler.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: assembler
USING: alien compiler-backend generic hashtables kernel lists
USING: alien generic hashtables kernel kernel-internals lists
math memory namespaces ;
: compiled-header HEX: 01c3babe ; inline
@ -16,7 +16,7 @@ math memory namespaces ;
f swap set-alien-signed-cell ; inline
: compile-aligned ( n -- )
compiled-offset cell 2 * align set-compiled-offset ; inline
compiled-offset 8 align set-compiled-offset ; inline
: add-literal ( obj -- lit# )
address

5
library/compiler/generator.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler-backend
USING: assembler compiler errors inference kernel lists math
memory namespaces sequences strings vectors words ;
USING: assembler compiler errors inference kernel
kernel-internals lists math memory namespaces sequences strings
vectors words ;
! Compile a VOP.
GENERIC: generate-node ( vop -- )

4
library/compiler/ppc/architecture.factor
View File

@ -6,10 +6,6 @@ USING: assembler compiler-backend kernel math ;
! r14 data stack
! r15 call stack
: cell
#! Word size.
4 ; inline
: fixnum-imm? ( -- ? )
#! Can fixnum operations take immediate operands?
f ; inline

4
library/compiler/relocate.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler
USING: assembler compiler-backend kernel lists math namespaces
sequences words ;
USING: assembler compiler-backend kernel kernel-internals lists
math namespaces sequences words ;
! To support saving compiled code to disk, generator words
! append relocation instructions to this vector.

2
library/compiler/x86/alien.factor
View File

@ -20,7 +20,7 @@ M: int-regs push-reg drop EAX PUSH ;
M: float-regs reg-size float-regs-size ;
M: float-regs push-reg
ESP swap reg-size [ SUB [ ESP ] ] keep
ESP swap reg-size [ SUB { ESP } ] keep
4 = [ FSTPS ] [ FSTPL ] if ;
M: %unbox generate-node

4
library/compiler/x86/architecture.factor
View File

@ -6,10 +6,6 @@ USING: assembler compiler-backend kernel sequences ;
! ESI datastack
! EBX callstack
: cell
#! Word size.
4 ; inline
: fixnum-imm? ( -- ? )
#! Can fixnum operations take immediate operands?
t ; inline

159
library/compiler/x86/assembler.factor
View File

@ -1,51 +1,10 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: assembler
USING: compiler errors generic kernel lists math parser
sequences words ;
USING: arrays compiler errors generic kernel kernel-internals
lists math parser sequences words ;
! A postfix assembler.
!
! x86 is a convoluted mess, so this code will be hard to
! understand unless you already know the instruction set.
!
! Syntax is: destination source opcode. For example, to add
! 3 to EAX:
!
! EAX 3 ADD
!
! The general format of an x86 instruction is:
!
! - 1-4 bytes: prefix. not supported.
! - 1-2 bytes: opcode. if the first byte is 0x0f, then opcode is
! 2 bytes.
! - 1 byte (optional): mod-r/m byte, specifying operands
! - 1/4 bytes (optional): displacement
! - 1 byte (optional): scale/index/displacement byte. not
! supported.
! - 1/4 bytes (optional): immediate operand
!
! mod-r/m has three bit fields:
! - 0-2: r/m
! - 3-5: reg
! - 6-7: mod
!
! If the direction bit (bin mask 10) in the opcode is set, then
! the source is reg, the destination is r/m. Otherwise, it is
! the opposite. x86 does this because reg can only encode a
! direct register operand, while r/m can encode other addressing
! modes in conjunction with the mod field.
!
! The mod field has this encoding:
! - BIN: 00 indirect
! - BIN: 01 1-byte displacement is present after mod-r/m field
! - BIN: 10 4-byte displacement is present after mod-r/m field
! - BIN: 11 direct register operand
!
! To encode displacement only (eg, [ 1234 ] EAX MOV), the
! r/m field stores the code for the EBP register, mod is 00, and
! a 4-byte displacement field is given. Usually if mod is 00, no
! displacement field is present.
! A postfix assembler for x86 and AMD64.
: byte? -128 127 between? ;
@ -54,59 +13,106 @@ GENERIC: register ( op -- reg )
GENERIC: displacement ( op -- )
GENERIC: canonicalize ( op -- op )
#! Extended AMD64 registers return true.
GENERIC: extended? ( op -- ? )
#! 64-bit registers return true.
GENERIC: operand-64? ( op -- ? )
M: object canonicalize ;
M: object extended? drop f ;
M: object operand-64? drop cell 8 = ;
( Register operands -- eg, ECX )
: REGISTER:
CREATE dup define-symbol
scan-word "register" set-word-prop ; parsing
dup scan-word "register" set-word-prop
scan-word "register-size" set-word-prop ; parsing
REGISTER: EAX 0
REGISTER: ECX 1
REGISTER: EDX 2
REGISTER: EBX 3
REGISTER: ESP 4
REGISTER: EBP 5
REGISTER: ESI 6
REGISTER: EDI 7
! x86 registers
REGISTER: AX 0 16
REGISTER: CX 1 16
REGISTER: DX 2 16
REGISTER: BX 3 16
REGISTER: SP 4 16
REGISTER: BP 5 16
REGISTER: SI 6 16
REGISTER: DI 7 16
REGISTER: EAX 0 32
REGISTER: ECX 1 32
REGISTER: EDX 2 32
REGISTER: EBX 3 32
REGISTER: ESP 4 32
REGISTER: EBP 5 32
REGISTER: ESI 6 32
REGISTER: EDI 7 32
! AMD64 registers
REGISTER: RAX 0 64
REGISTER: RCX 1 64
REGISTER: RDX 2 64
REGISTER: RBX 3 64
REGISTER: RSP 4 64
REGISTER: RBP 5 64
REGISTER: RSI 6 64
REGISTER: RDI 7 64
REGISTER: R8 8 64
REGISTER: R9 9 64
REGISTER: R10 10 64
REGISTER: R11 11 64
REGISTER: R12 12 64
REGISTER: R13 13 64
REGISTER: R14 14 64
REGISTER: R15 15 64
PREDICATE: word register "register" word-prop ;
M: register modifier drop BIN: 11 ;
M: register register "register" word-prop ;
M: register displacement drop ;
PREDICATE: register register-32 "register-size" word-prop 32 = ;
PREDICATE: register register-64 "register-size" word-prop 64 = ;
( Indirect register operands -- eg, [ ECX ] )
PREDICATE: cons indirect
dup cdr [ drop f ] [ car register? ] if ;
M: register modifier drop BIN: 11 ;
M: register register "register" word-prop 7 bitand ;
M: register displacement drop ;
M: register extended? "register" word-prop 7 > ;
M: register operand-64? register-64? ;
( Indirect register operands -- eg, { ECX } )
PREDICATE: array indirect
dup length 1 = [ first register? ] [ drop f ] if ;
M: indirect modifier drop BIN: 00 ;
M: indirect register car register ;
M: indirect register first register ;
M: indirect displacement drop ;
M: indirect canonicalize dup car EBP = [ drop [ EBP 0 ] ] when ;
M: indirect canonicalize dup first EBP = [ drop { EBP 0 } ] when ;
M: indirect extended? register extended? ;
M: indirect operand-64? register register-64? ;
( Displaced indirect register operands -- eg, [ EAX 4 ] )
PREDICATE: cons displaced
( Displaced indirect register operands -- eg, { EAX 4 } )
PREDICATE: array displaced
dup length 2 =
[ first2 integer? swap register? and ] [ drop f ] if ;
M: displaced modifier second byte? BIN: 01 BIN: 10 ? ;
M: displaced register car register ;
M: displaced register first register ;
M: displaced displacement
second dup byte? [ compile-byte ] [ compile-cell ] if ;
M: displaced canonicalize
dup first EBP = not over second 0 = and [ first unit ] when ;
dup first EBP = not over second 0 = and
[ first 1array ] when ;
M: displaced extended? register extended? ;
M: displaced operand-64? register register-64? ;
( Displacement-only operands -- eg, [ 1234 ] )
PREDICATE: cons disp-only
dup length 1 = [ car integer? ] [ drop f ] if ;
( Displacement-only operands -- eg, { 1234 } )
PREDICATE: array disp-only
dup length 1 = [ first integer? ] [ drop f ] if ;
M: disp-only modifier drop BIN: 00 ;
M: disp-only register
#! x86 encodes displacement-only as [ EBP ].
#! x86 encodes displacement-only as { EBP }.
drop BIN: 101 ;
M: disp-only displacement
car compile-cell ;
first compile-cell ;
( Utilities )
UNION: operand register indirect displaced disp-only ;
@ -138,9 +144,22 @@ UNION: operand register indirect displaced disp-only ;
#! 'reg' field of the mod-r/m byte.
>r compile-byte swap r> 1-operand compile-byte ;
: rex-prefix ( dst src -- )
#! Compute a prefix for two 64-bit register operands.
over register-64? over register-64? and [
BIN: 01001000
swap extended? [ BIN: 00000100 bitor ] when
swap extended? [ BIN: 00000001 bitor ] when
compile-byte
] [
2drop
] if ;
: 2-operand ( dst src op -- )
#! Sets the opcode's direction bit. It is set if the
#! destination is a direct register operand.
>r 2dup rex-prefix r>
pick register? [ BIN: 10 bitor swapd ] when
compile-byte register 1-operand ;

4
library/compiler/x86/generator.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler-backend
USING: alien assembler compiler inference kernel
USING: alien arrays assembler compiler inference kernel
kernel-internals lists math memory namespaces sequences words ;
! Not used on x86
@ -72,7 +72,7 @@ M: %type generate-node ( vop -- )
ECX object-tag CMP
"f" get JE
! The pointer is not equal to 3. Load the object header.
dup ECX object-tag neg 2list MOV
dup ECX object-tag neg 2array MOV
! Mask off header tag, making a fixnum.
dup object-tag XOR
"end" get JMP

8
library/compiler/x86/slots.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler-backend
USING: alien assembler compiler inference kernel
USING: alien arrays assembler compiler inference kernel
kernel-internals lists math memory namespaces sequences words ;
M: %slot generate-node ( vop -- )
@ -14,7 +14,7 @@ M: %slot generate-node ( vop -- )
dup unit MOV ;
M: %fast-slot generate-node ( vop -- )
dup 0 vop-in swap 0 vop-out v>operand tuck >r 2list r>
dup 0 vop-in swap 0 vop-out v>operand tuck >r 2array r>
swap MOV ;
: card-offset 1 getenv ;
@ -23,7 +23,7 @@ M: %write-barrier generate-node ( vop -- )
#! Mark the card pointed to by vreg.
0 vop-in v>operand
dup card-bits SHR
card-offset 2list card-mark OR
card-offset 2array card-mark OR
0 rel-cards ;
M: %set-slot generate-node ( vop -- )
@ -37,7 +37,7 @@ M: %set-slot generate-node ( vop -- )
M: %fast-set-slot generate-node ( vop -- )
dup 2 vop-in over 1 vop-in v>operand
swap 2list swap 0 vop-in v>operand MOV ;
swap 2array swap 0 vop-in v>operand MOV ;
: userenv@ ( n -- addr )
cell * "userenv" f dlsym + ;

6
library/compiler/x86/stack.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler-backend
USING: alien assembler compiler inference kernel lists math
memory sequences words ;
USING: alien arrays assembler compiler inference kernel lists
math memory sequences words ;
: reg-stack ( n reg -- op ) swap cell * neg 2list ;
: reg-stack ( n reg -- op ) swap cell * neg 2array ;
GENERIC: loc>operand

27
library/kernel.factor
View File

@ -44,18 +44,6 @@ M: object clone ;
os "linux" = or
os "macosx" = or ;
: tag-mask BIN: 111 ; inline
: num-tags 8 ; inline
: tag-bits 3 ; inline
: fixnum-tag BIN: 000 ; inline
: bignum-tag BIN: 001 ; inline
: cons-tag BIN: 010 ; inline
: object-tag BIN: 011 ; inline
: ratio-tag BIN: 100 ; inline
: float-tag BIN: 101 ; inline
: complex-tag BIN: 110 ; inline
: slip ( quot x -- x | quot: -- )
>r call r> ; inline
@ -137,3 +125,18 @@ IN: kernel-internals
#! specifying an incorrect size. Note that this word is also
#! handled specially by the compiler's type inferencer.
<tuple> [ 2 set-slot ] keep ; flushable
! Some runtime implementation details
: tag-mask BIN: 111 ; inline
: num-tags 8 ; inline
: tag-bits 3 ; inline
: fixnum-tag BIN: 000 ; inline
: bignum-tag BIN: 001 ; inline
: cons-tag BIN: 010 ; inline
: object-tag BIN: 011 ; inline
: ratio-tag BIN: 100 ; inline
: float-tag BIN: 101 ; inline
: complex-tag BIN: 110 ; inline
: cell 17 getenv ; inline

12
library/test/compiler/assembler-x86.factor
View File

@ -1,9 +1,9 @@
IN: temporary
USING: assembler kernel test ;
[ t ] [ [ EBP ] indirect? >boolean ] unit-test
[ [ EBP 0 ] ] [ [ EBP ] canonicalize ] unit-test
[ t ] [ [ EAX 3 ] displaced? >boolean ] unit-test
[ [ EAX ] ] [ [ EAX 0 ] canonicalize ] unit-test
[ [ EAX ] ] [ [ EAX ] canonicalize ] unit-test
[ [ EAX 3 ] ] [ [ EAX 3 ] canonicalize ] unit-test
[ t ] [ { EBP } indirect? >boolean ] unit-test
[ { EBP 0 } ] [ { EBP } canonicalize ] unit-test
[ t ] [ { EAX 3 } displaced? >boolean ] unit-test
[ { EAX } ] [ { EAX 0 } canonicalize ] unit-test
[ { EAX } ] [ { EAX } canonicalize ] unit-test
[ { EAX 3 } ] [ { EAX 3 } canonicalize ] unit-test

2
native/factor.c
View File

@ -22,8 +22,6 @@ void init_factor(char* image, CELL ds_size, CELL cs_size,
userenv[CARD_OFF_ENV] = tag_cell(cards_offset);
userenv[IMAGE_ENV] = tag_object(from_c_string(image));
userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL));
userenv[INT_SIZE_ENV] = tag_fixnum(sizeof(int));
userenv[LONG_SIZE_ENV] = tag_fixnum(sizeof(long));
}
INLINE bool factor_arg(const char* str, const char* arg, CELL* value)

4
native/factor.h
View File

@ -38,6 +38,8 @@ CELL ds_bot;
register CELL ds asm("esi");
#elif defined(FACTOR_PPC)
register CELL ds asm("r14");
#elif defined(FACTOR_AMD64)
register CELL ds asm("r12");
#else
CELL ds;
#endif
@ -50,6 +52,8 @@ CELL cs_bot;
register CELL cs asm("ebx");
#elif defined(FACTOR_PPC)
register CELL cs asm("r15");
#elif defined(FACTOR_AMD64)
register CELL cs asm("r13");
#else
CELL cs;
#endif

2
native/run.h
View File

@ -17,8 +17,6 @@
#define GEN_ENV 15 /* set to gen_count */
#define IMAGE_ENV 16 /* image name */
#define CELL_SIZE_ENV 17 /* sizeof(CELL) */
#define INT_SIZE_ENV 18 /* sizeof(int) */
#define LONG_SIZE_ENV 19 /* sizeof(long) */
/* TAGGED user environment data; see getenv/setenv prims */
DLLEXPORT CELL userenv[USER_ENV];