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

Updating ARM optimizing compiler backend

release
U-SLAVA-FB3999113\Slava 2007-10-15 19:59:03 -04:00
parent 87944928aa
commit b4b4c599c6
16 changed files with 338 additions and 286 deletions

2
core/cpu/arm5/intrinsics/intrinsics.factor → core/cpu/arm/4/4.factor Normal file → Executable file
View File

@ -6,7 +6,7 @@ math math.private namespaces sequences words quotations
byte-arrays hashtables.private hashtables generator
generator.registers generator.fixup sequences.private
strings.private ;
IN: cpu.arm5.intrinsics
IN: cpu.arm4
: (%char-slot)
"out" operand string-offset MOV

0
core/cpu/arm5/authors.txt → core/cpu/arm/4/authors.txt
View File

1
core/cpu/arm/4/summary.txt Normal file
View File

@ -0,0 +1 @@
Additional compiler intrinsics for ARM4

3
core/cpu/arm/5/5.factor Executable file
View File

@ -0,0 +1,3 @@
USING: cpu.arm.assembler cpu.arm4 namespaces ;
t have-BLX? set-global

1
core/cpu/arm/5/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

0
core/cpu/arm5/summary.txt → core/cpu/arm/5/summary.txt
View File

61
core/cpu/arm/allot/allot.factor
View File

@ -8,31 +8,28 @@ IN: cpu.arm.allot
: load-zone-ptr ( reg -- ) "nursery" f rot %alien-global ;
: object@ "allot-tmp" operand swap cells <+> ;
: %allot ( header size -- )
#! Store a pointer to 'size' bytes allocated from the
#! nursery in allot-tmp.
#! nursery in R11
8 align ! align the size
R12 load-zone-ptr ! nusery -> r12
"allot-tmp" operand R12 cell <+> LDR ! nursery.here -> allot-tmp
"allot-tmp" operand dup pick ADD ! increment allot-tmp
"allot-tmp" operand R12 cell <+> STR ! allot-tmp -> nursery.here
"allot-tmp" operand dup rot SUB ! old value
R11 R12 cell <+> LDR ! nursery.here -> r11
R11 R11 pick ADD ! increment r11
R11 R12 cell <+> STR ! r11 -> nursery.here
R11 R11 rot SUB ! old value
R12 swap type-number tag-header MOV ! compute header
R12 0 object@ STR ! store header
R12 R11 0 <+> STR ! store header
;
: %tag-allot ( tag -- )
"allot-tmp" operand dup rot tag-number ORR
"allot-tmp" get fresh-object ;
: %store-tagged ( reg tag -- )
>r dup fresh-object v>operand R11 r> tag-number ORI ;
: %allot-bignum ( #digits -- )
#! 1 cell header, 1 cell length, 1 cell sign, + digits
#! length is the # of digits + sign
bignum over 3 + cells %allot
R12 swap 1+ v>operand MOV ! compute the length
R12 1 object@ STR ! store the length
R12 R11 cell <+> STR ! store the length
;
: %allot-bignum-signed-1 ( reg -- )
@ -43,7 +40,7 @@ IN: cpu.arm.allot
"end" define-label
! is it zero?
dup v>operand 0 CMP
0 >bignum "allot-tmp" operand EQ load-indirect
0 >bignum over EQ load-literal
"end" get EQ B
! ! it is non-zero
1 %allot-bignum
@ -56,29 +53,27 @@ IN: cpu.arm.allot
! positive sign
R12 0 GE MOV
! store sign
R12 2 object@ STR
R12 R11 2 cells <+> STR
! store the number
v>operand 3 object@ STR
dup v>operand R11 3 cells <+> STR
! tag the bignum, store it in reg
bignum %tag-allot
"end" resolve-label
] with-scope ;
: %allot-alien ( ptr -- )
#! Tagged pointer to alien is in allot-tmp on exit.
[
"temp" set
"end" define-label
"temp" operand 0 CMP
"allot-tmp" operand f v>operand EQ MOV
"end" get EQ B
alien 4 cells %allot
"temp" operand 2 object@ STR
"temp" operand f v>operand MOV
"temp" operand 1 object@ STR
"temp" operand 0 MOV
"temp" operand 3 object@ STR
! Store tagged ptr in reg
object %tag-allot
"end" resolve-label
] with-scope ;
M: arm-backend %box-alien ( dst src -- )
"end" define-label
dup v>operand 0 CMP
over f v>operand EQ MOV
"end" get EQ B
alien 4 cells %allot
! Store offset
v>operand R11 3 cells <+> STR
R12 f v>operand R12
! Store expired slot
R12 R11 1 cells <+> STR
! Store underlying-alien slot
R12 R11 2 cells <+> STR
! Store tagged ptr in reg
object %store-tagged
"end" resolve-label ;

91
core/cpu/arm/architecture/architecture.factor
View File

@ -9,8 +9,8 @@ IN: cpu.arm.architecture
TUPLE: arm-backend ;
! ARM register assignments:
! R0, R1, R2, R3 integer vregs
! R12 temporary
! R0-R4, R7-R10 integer vregs
! R11, R12 temporary
! R5 data stack
! R6 retain stack
! R7 primitives
@ -22,7 +22,7 @@ M: temp-reg v>operand drop R12 ;
M: int-regs return-reg drop R0 ;
M: int-regs param-regs drop { R0 R1 R2 R3 } ;
M: int-regs vregs drop { R0 R1 R2 R3 R4 R7 R8 R9 R10 R11 } ;
M: int-regs vregs drop { R0 R1 R2 R3 R4 R7 R8 R9 R10 } ;
! No FPU support yet
M: float-regs param-regs drop { } ;
@ -44,15 +44,27 @@ M: immediate load-literal
v>operand load-indirect
] if ;
M: arm-backend stack-frame ( n -- i ) 4 + 8 align ;
: lr-save ( n -- i ) cell - ;
: next-save ( n -- i ) 2 cells - ;
: xt-save ( n -- i ) 3 cells - ;
: factor-area-size 5 cells ;
M: arm-backend stack-frame ( n -- i )
factor-area-size + 8 align ;
M: ppc-backend %save-xt ( -- )
R12 PC 8 SUB ;
M: arm-backend %prologue ( n -- )
LR SP 4 <-> STR
SP SP rot stack-frame SUB ;
SP SP pick SUB
R11 over LI
R11 SP pick next-save <+> STR
R12 SP rot xt-save <+> STR
LR SP pick lr-save <+> STR ;
M: arm-backend %epilogue ( n -- )
SP SP rot stack-frame ADD
LR SP 4 <-> LDR ;
LR SP lr-save <+> LDR
SP SP rot stack-frame ADD ;
: compile-dlsym ( symbol dll reg -- )
[
@ -83,26 +95,32 @@ M: arm-backend %profiler-prologue ( word -- )
R0 R12 profile-count-offset <+> STR
"end" resolve-label ;
: primitive-addr ( word dst -- )
#! Load a word address into dst.
R7 rot word-primitive cells <+> LDR ;
M: arm-backend %call-label ( label -- ) BL ;
M: arm-backend %call ( label -- )
#! Far C call for primitives, near C call for compiled defs.
dup primitive? [ R0 primitive-addr R0 BLX ] [ BL ] if ;
M: arm-backend %jump-label ( label -- ) B ;
M: arm-backend %jump-label ( label -- )
#! For tail calls. IP not saved on C stack.
#! WARNING: don't clobber LR here!
dup primitive? [ PC primitive-addr ] [ B ] if ;
: %load-xt ( word -- )
0 swap LOAD32 rc-absolute-ppc-2/2 rel-word ;
: %prepare-primitive ( word -- )
#! Save stack pointer to stack_chain->callstack_top, load XT
R1 SP MOV
T{ temp-reg } load-literal
R12 R12 word-xt-offset <+> LDR ;
M: arm-backend %call-primitive ( word -- )
%prepare-primitive R12 BLX ;
M: arm-backend %jump-primitive ( word -- )
%prepare-primitive R12 BX ;
M: arm-backend %jump-t ( label -- )
"flag" operand object tag-number CMP NE B ;
"flag" operand f v>operand CMP NE B ;
: (%dispatch) ( word-table# reg -- )
#! Load jump table target address into reg.
"n" operand PC "n" operand 1 <LSR> ADD
"n" operand 0 <+> LDR
"scratch" operand PC "n" operand 1 <LSR> ADD
"scratch" operand 0 <+> LDR
rc-indirect-arm rel-dispatch ;
M: arm-backend %call-dispatch ( word-table# -- )
@ -112,7 +130,6 @@ M: arm-backend %call-dispatch ( word-table# -- )
] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "scratch" } } }
{ +clobber+ { "n" } }
} with-template ;
M: arm-backend %jump-dispatch ( word-table# -- )
@ -121,7 +138,7 @@ M: arm-backend %jump-dispatch ( word-table# -- )
PC (%dispatch)
] H{
{ +input+ { { f "n" } } }
{ +clobber+ { "n" } }
{ +scratch+ { { f "scratch" } } }
} with-template ;
M: arm-backend %return ( -- ) %epilogue-later PC LR MOV ;
@ -134,9 +151,6 @@ M: arm-backend %unwind drop %return ;
M: int-regs (%peek) \ LDR (%peek/replace) ;
M: int-regs (%replace) \ STR (%peek/replace) ;
M: arm-backend %move-int>int ( dst src -- )
[ v>operand ] 2apply MOV ;
: (%inc) ( n reg -- )
dup rot cells dup 0 < [ neg SUB ] [ ADD ] if ;
@ -215,11 +229,13 @@ M: arm-backend %box-small-struct ( size -- )
R2 swap MOV
"box_small_struct" f %alien-invoke ;
: temp@ stack-frame* factor-area-size - swap - ;
: struct-return@ ( size n -- n )
[
stack-frame* +
] [
stack-frame* swap - cell -
stack-frame* factor-area-size - swap -
] ?if ;
M: arm-backend %prepare-box-struct ( size -- )
@ -239,6 +255,15 @@ M: arm-backend %box-large-struct ( n size -- )
M: arm-backend struct-small-enough? ( size -- ? )
wince? [ drop f ] [ 4 <= ] if ;
M: ppc-backend %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
"stack_chain" f R12 %alien-global
SP R12 0 <+> STR
ds-reg 11 8 <+> STR
rs-reg 11 12 <+> STR ;
M: arm-backend %alien-invoke ( symbol dll -- )
! Load target address
R12 PC 4 <+> LDR
@ -249,15 +274,13 @@ M: arm-backend %alien-invoke ( symbol dll -- )
! The target address
0 , rc-absolute rel-dlsym ;
: temp@ SP stack-frame* 2 cells - <+> ;
M: arm-backend %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
R0 temp@ STR ;
R0 SP cell temp@ <+> STR ;
M: arm-backend %alien-indirect ( -- )
IP temp@ LDR
IP BLX ;
R12 SP cell temp@ <+> LDR
R12 BLX ;
M: arm-backend %alien-callback ( quot -- )
R0 load-indirect
@ -266,11 +289,11 @@ M: arm-backend %alien-callback ( quot -- )
M: arm-backend %callback-value ( ctype -- )
! Save top of data stack
%prepare-unbox
R0 temp@ STR
R0 SP cell temp@ <+> STR
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
! Place former top of data stack in R0
R0 temp@ LDR
R0 SP cell temp@ <+> LDR
! Unbox R0
unbox-return ;

42
core/cpu/arm/arm.factor Normal file → Executable file
View File

@ -24,27 +24,29 @@ vocabs.loader ;
T{ arm-backend } compiler-backend set-global
: (detect-arm5) ;
\ (detect-arm5) [
! The LDRH word is defined in the module we conditionally
! load below...
! R0 PC 0 <+> LDRH
HEX: e1df00b0 ,
] H{
{ +scratch+ { { 0 "scratch" } } }
} define-intrinsic
: detect-arm5 (detect-arm5) ;
: arm5? ( -- ? ) [ detect-arm5 ] catch not ;
! We don't auto-detect since that would require us to support
! illegal instruction traps. This works on Linux but not on
! Windows CE.
"arm-variant" get [
\ detect-arm5 compile
"Detecting ARM architecture variant..." print
arm5? "arm5" "arm3" ? "arm-variant" set
] unless
"ARM variant: " write "arm-variant" get print
] [
"==========" print
"You should specify the -arm-variant=<variant> switch." print
"<variant> can be one of arm3, arm4, arm4t, or arm5." print
"Assuming arm4t." print
"==========" print
"arm4t" "arm-variant" set
] if
"ARM architecture variant: " write "arm-variant" get print
"arm-variant" get { "arm4" "arm4t" "arm5" } member? [
"cpu.arm.4" require
] when
"arm-variant" "arm5" = [ "cpu.arm5" require ] when
"arm-variant" get { "arm4t" "arm5" } member? [
t have-BX? set-global
] when
"arm-variant" get "arm5" = [
t have-BLX? set-global
] when

76
core/cpu/arm/assembler/assembler.factor Normal file → Executable file
View File

@ -4,8 +4,6 @@ USING: arrays generator generator.fixup kernel sequences words
namespaces math math.bitfields ;
IN: cpu.arm.assembler
SYMBOL: arm-variant
: define-registers ( seq -- )
dup length [ "register" set-word-prop ] 2each ;
@ -253,15 +251,77 @@ M: object addressing-mode-2 shifter-op { { 1 25 } 0 } bitfield ;
: STR 0 0 addr2 ;
: STRB 1 0 addr2 ;
HOOK: BX arm-variant ( operand -- )
HOOK: BLX arm-variant ( operand -- )
! We might have to simulate these instructions since older ARM
! chips don't have them.
M: f BX PC swap MOV ;
SYMBOL: have-BX?
SYMBOL: have-BLX?
M: f BLX LR PC MOV BX ;
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 ;
M: word (BX) 0 swap (BX) rc-relative-arm-3 rel-word ;
M: label (BX) 0 swap (BX) rc-relative-arm-3 label-fixup ;
: BX have-BX? get [ 0 (BX) ] [ PC swap MOV ] if ;
: BLX have-BLX? get [ 1 (BLX) ] [ LR PC MOV BX ] if ;
! More load and store instructions
GENERIC: addressing-mode-3 ( addressing-mode -- n )
: b>n/n ( b -- n n ) dup -4 shift swap HEX: f bitand ;
M: addressing addressing-mode-3
[ addressing-p ] keep
[ addressing-u ] keep
[ addressing-w ] keep
delegate addressing-mode-3
{ 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 ;
: LDRH 1 1 0 addr3 ;
: LDRSB 0 1 1 addr3 ;
: LDRSH 1 1 1 addr3 ;
: STRH 1 0 0 addr3 ;
! Load and store multiple instructions

6
core/cpu/arm/bootstrap.factor
View File

@ -1,9 +1,11 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
cpu.arm.assembler math layouts words vocabs ;
cpu.arm.assembler cpu.arm5.assembler math layouts words vocabs ;
IN: bootstrap.arm
T{ arm5-variant } arm-variant set-global
4 \ cell set
big-endian off
@ -17,7 +19,7 @@ big-endian off
: temp-reg R3 ;
: xt-reg R12 ;
: stack-frame 8 bootstrap-cells ;
: stack-frame 16 bootstrap-cells ;
: next-save stack-frame 2 bootstrap-cells - ;
: xt-save stack-frame 3 bootstrap-cells - ;

250
core/cpu/arm/intrinsics/intrinsics.factor
View File

@ -9,27 +9,45 @@ sbufs.private vectors vectors.private system tuples.private
layouts strings.private slots.private ;
IN: cpu.arm.intrinsics
: %slot-literal-known-tag
"val" operand
"obj" operand
"n" get cells
"obj" get operand-tag - <+/-> ;
: %slot-literal-any-tag
"obj" operand "scratch" operand %untag
"val" operand "scratch" operand "n" get cells <+> ;
: %slot-any
"obj" operand "scratch" operand %untag
"n" operand dup 1 <LSR> MOV
"scratch" operand "val" operand "n" operand <+> ;
\ slot {
! Slot number is literal and the tag is known
{
[ %slot-literal-known-tag LDR ] H{
{ +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } }
{ +scratch+ { { f "val" } } }
{ +output+ { "val" } }
}
}
! Slot number is literal
{
[
"out" operand "obj" operand %untag
"out" operand dup "n" get cells <+> LDR
] H{
[ %slot-literal-any-tag LDR ] H{
{ +input+ { { f "obj" } { [ small-slot? ] "n" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
{ +scratch+ { { f "scratch" } { f "val" } } }
{ +output+ { "val" } }
}
}
! Slot number in a register
{
[
"out" operand "obj" operand %untag
"out" operand dup "n" operand 1 <LSR> <+> LDR
] H{
[ %slot-any LDR ] H{
{ +input+ { { f "obj" } { f "n" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
{ +scratch+ { { f "val" } { f "scratch" } } }
{ +output+ { "val" } }
{ +clobber+ { "n" } }
}
}
} define-intrinsics
@ -44,13 +62,17 @@ IN: cpu.arm.intrinsics
] unless ;
\ set-slot {
! Slot number is literal and tag is known
{
[ %slot-literal-known-tag STR %write-barrier ] H{
{ +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
{ +scratch+ { { f "scratch" } } }
{ +clobber+ { "val" } }
}
}
! Slot number is literal
{
[
"scratch" operand "obj" operand %untag
"val" operand "scratch" operand "n" get cells <+> STR
generate-write-barrier
] H{
[ %slot-literal-any-tag STR %write-barrier ] H{
{ +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
{ +scratch+ { { f "scratch" } } }
{ +clobber+ { "val" } }
@ -58,12 +80,7 @@ IN: cpu.arm.intrinsics
}
! Slot number is in a register
{
[
"scratch" operand "obj" operand %untag
"n" operand "scratch" operand "n" operand 1 <LSR> ADD
"val" operand "n" operand 0 STR
generate-write-barrier
] H{
[ %slot-any STR %write-barrier ] H{
{ +input+ { { f "val" } { f "obj" } { f "n" } } }
{ +scratch+ { { f "scratch" } } }
{ +clobber+ { "val" "n" } }
@ -135,7 +152,7 @@ IN: cpu.arm.intrinsics
: overflow-check ( insn -- )
[
"end" define-label
[ "allot-tmp" operand "x" operand "y" operand roll S execute ] keep
[ "out" operand "x" operand "y" operand roll S execute ] keep
"end" get VC B
{ "x" "y" } %untag-fixnums
"x" operand "x" operand "y" operand roll execute
@ -146,8 +163,8 @@ IN: cpu.arm.intrinsics
: overflow-template ( word insn -- )
[ overflow-check ] curry H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
{ +clobber+ { "x" "y" } }
} define-intrinsic ;
@ -159,9 +176,9 @@ IN: cpu.arm.intrinsics
"x" get %allot-bignum-signed-1
] H{
{ +input+ { { f "x" } } }
{ +scratch+ { { f "allot-tmp" } } }
{ +scratch+ { { f "out" } } }
{ +clobber+ { "x" } }
{ +output+ { "allot-tmp" } }
{ +output+ { "out" } }
} define-intrinsic
\ bignum>fixnum [
@ -224,28 +241,39 @@ IN: cpu.arm.intrinsics
} define-intrinsic
\ type [
! Get the tag
"out" operand "obj" operand tag-mask get AND
! Compare with object tag number (3).
"out" operand object tag-number CMP
! Tag the tag if it is not equal to 3
"out" operand dup NE %tag-fixnum
! Load the object header if tag is equal to 3
"out" operand "obj" operand object tag-number <-> EQ LDR
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ class-hash [
"end" define-label
! Get the tag
"y" operand "obj" operand tag-mask get AND
"out" operand "obj" operand tag-mask get AND
! Compare with tuple tag number (2).
"out" operand tuple tag-number CMP
"out" operand "obj" operand tuple-class-offset <+/-> EQ LDR
"out" operand dup class-hash-offset <+/-> EQ LDR
"end" get EQ B
! Compare with object tag number (3).
"y" operand object tag-number CMP
! Tag the tag if it is not equal to 3
"x" operand "y" operand NE %tag-fixnum
! Jump to end if it is not equal to 3
"end" get NE B
! Is the pointer itself equal to 3? Then its F_TYPE (9).
"obj" operand object tag-number CMP
! Load F_TYPE (9) if it is equal
"x" operand f type v>operand EQ MOV
! Load the object header if it is not equal
"x" operand "obj" operand object tag-number <-> NE LDR
! Turn the header into a fixnum
"x" operand dup NE %untag
"out" operand object tag-number CMP
"out" operand "obj" operand object tag-number <-> EQ LDR
! Tag the tag
"out" operand dup NE %tag-fixnum
"end" resolve-label
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "x" } { f "y" } } }
{ +output+ { "x" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
: userenv ( reg -- )
@ -273,7 +301,7 @@ IN: cpu.arm.intrinsics
{ +clobber+ { "n" } }
} define-intrinsic
: %set-slot "allot-tmp" operand swap cells <+> STR ;
: %set-slot R11 swap cells <+> STR ;
: %store-length
R12 "n" operand MOV
@ -289,11 +317,11 @@ IN: cpu.arm.intrinsics
! Zero out the rest of the tuple
R12 f v>operand MOV
"n" get 1- [ 1+ R12 %fill-array ] each
object %tag-allot
"out" get object %store-tagged
] H{
{ +input+ { { f "class" } { [ inline-array? ] "n" } } }
{ +scratch+ { { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ <array> [
@ -301,11 +329,11 @@ IN: cpu.arm.intrinsics
%store-length
! Store initial element
"n" get [ "initial" operand %fill-array ] each
object %tag-allot
"out" get object %store-tagged
] H{
{ +input+ { { [ inline-array? ] "n" } { f "initial" } } }
{ +scratch+ { { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ <byte-array> [
@ -314,22 +342,22 @@ IN: cpu.arm.intrinsics
! Store initial element
R12 0 MOV
"n" get cell align cell /i [ R12 %fill-array ] each
object %tag-allot
"out" get object %store-tagged
] H{
{ +input+ { { [ inline-array? ] "n" } } }
{ +scratch+ { { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ <ratio> [
ratio 3 cells %allot
"numerator" operand 1 %set-slot
"denominator" operand 2 %set-slot
ratio %tag-allot
"out" get ratio %store-tagged
] H{
{ +input+ { { f "numerator" } { f "denominator" } } }
{ +scratch+ { { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ <complex> [
@ -337,22 +365,22 @@ IN: cpu.arm.intrinsics
"real" operand 1 %set-slot
"imaginary" operand 2 %set-slot
! Store tagged ptr in reg
complex %tag-allot
"out" get complex %store-tagged
] H{
{ +input+ { { f "real" } { f "imaginary" } } }
{ +scratch+ { { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ <wrapper> [
wrapper 2 cells %allot
"obj" operand 1 %set-slot
! Store tagged ptr in reg
wrapper %tag-allot
"out" get object %store-tagged
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ (hashtable) [
@ -362,80 +390,82 @@ IN: cpu.arm.intrinsics
R12 2 %set-slot
R12 3 %set-slot
! Store tagged ptr in reg
object %tag-allot
"out" get object %store-tagged
] H{
{ +scratch+ { { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ string>sbuf [
sbuf 3 cells %allot
"length" operand 1 %set-slot
"string" operand 2 %set-slot
object %tag-allot
"out" get object %store-tagged
] H{
{ +input+ { { f "string" } { f "length" } } }
{ +scratch+ { { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ array>vector [
vector 3 cells %allot
"length" operand 1 %set-slot
"array" operand 2 %set-slot
object %tag-allot
"out" get object %store-tagged
] H{
{ +input+ { { f "array" } { f "length" } } }
{ +scratch+ { { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ curry [
\ curry 3 cells %allot
"obj" operand 1 %set-slot
"quot" operand 2 %set-slot
object %tag-allot
"out" get object %store-tagged
] H{
{ +input+ { { f "obj" } { f "quot" } } }
{ +scratch+ { { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
! Alien intrinsics
: %alien-accessor ( quot -- )
"offset" operand dup %untag-fixnum
"offset" operand dup "alien" operand ADD
"value" operand "offset" operand 0 <+> roll call ; inline
: alien-integer-get-template
H{
{ +input+ {
{ f "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "output" } } }
{ +output+ { "output" } }
{ +scratch+ { { f "value" } } }
{ +output+ { "value" } }
{ +clobber+ { "offset" } }
} ;
: %alien-get ( quot -- )
"output" get "address" set
"output" operand "alien" operand-class %alien-accessor ;
: %alien-integer-get ( quot -- )
%alien-get
"output" operand dup %tag-fixnum ; inline
: %alien-integer-set ( quot -- )
"value" operand dup %untag-fixnum
"value" operand "alien" operand-class %alien-accessor ; inline
%alien-accessor
"value" operand dup %tag-fixnum ; inline
: alien-integer-set-template
H{
{ +input+ {
{ f "value" fixnum }
{ f "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "address" } } }
{ +clobber+ { "value" "offset" } }
} ;
: %alien-integer-set ( quot -- )
"offset" get "value" get = [
"value" operand dup %untag-fixnum
] unless
%alien-accessor ; inline
: define-alien-integer-intrinsics ( word get-quot word set-quot -- )
[ %alien-integer-set ] curry
alien-integer-set-template
@ -448,15 +478,31 @@ IN: cpu.arm.intrinsics
\ set-alien-unsigned-1 [ STRB ]
define-alien-integer-intrinsics
\ alien-cell [
[ LDR ] %alien-get
"output" get %allot-alien
] H{
{ +input+ {
{ f "alien" simple-c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "output" } { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +clobber+ { "offset" } }
} define-intrinsic
: alien-cell-template
H{
{ +input+ {
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { unboxed-alien "value" } } }
{ +output+ { "value" } }
{ +clobber+ { "offset" } }
} ;
\ alien-cell
[ [ LDR ] %alien-accessor ]
alien-cell-template define-intrinsic
: set-alien-cell-template
H{
{ +input+ {
{ unboxed-c-ptr "value" pinned-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +clobber+ { "offset" } }
} ;
\ set-alien-cell
[ [ STR ] %alien-accessor ]
set-alien-cell-template define-intrinsic

4
core/cpu/arm5/arm5.factor
View File

@ -1,4 +0,0 @@
USING: cpu.arm.assembler cpu.arm5.assembler cpu.arm5.intrinsics
namespaces ;
T{ arm5-variant } arm-variant set-global

74
core/cpu/arm5/assembler/assembler.factor
View File

@ -1,74 +0,0 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generator generator.fixup kernel sequences words
namespaces math math.bitfields cpu.arm.assembler ;
IN: cpu.arm5.assembler
TUPLE: arm5-variant ;
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 ;
M: word (BX) 0 swap (BX) rc-relative-arm-3 rel-word ;
M: label (BX) 0 swap (BX) rc-relative-arm-3 label-fixup ;
M: arm5-variant BX 0 (BX) ;
M: arm5-variant BLX 1 (BX) ;
! More load and store instructions
GENERIC: addressing-mode-3 ( addressing-mode -- n )
: b>n/n ( b -- n n ) dup -4 shift swap HEX: f bitand ;
M: addressing addressing-mode-3
[ addressing-p ] keep
[ addressing-u ] keep
[ addressing-w ] keep
delegate addressing-mode-3
{ 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 ;
: LDRH 1 1 0 addr3 ;
: LDRSB 0 1 1 addr3 ;
: LDRSH 1 1 1 addr3 ;
: STRH 1 0 0 addr3 ;

12
core/cpu/ppc/architecture/architecture.factor
View File

@ -15,10 +15,8 @@ TUPLE: ppc-backend ;
! r14: data stack
! r15: retain stack
! For stack frame layout, see vm/cpu-ppc.h.
: ds-reg 14 ;
: rs-reg 15 ;
: ds-reg 14 ; inline
: rs-reg 15 ; inline
: reserved-area-size
os {
@ -59,13 +57,11 @@ M: int-regs vregs
} ;
M: float-regs return-reg drop 1 ;
M: float-regs param-regs
drop os H{
{ "macosx" { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
{ "linux" { 1 2 3 4 5 6 7 8 } }
} at ;
M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
GENERIC: loc>operand ( loc -- reg n )
@ -123,7 +119,7 @@ M: ppc-backend %call-label ( label -- ) BL ;
M: ppc-backend %jump-label ( label -- ) B ;
: %prepare-primitive ( word -- )
! Save stack pointer to stack_chain->callstack_top, load XT
#! Save stack pointer to stack_chain->callstack_top, load XT
4 1 MR 11 %load-xt ;
: (%call) 11 MTLR BLRL ;
@ -137,7 +133,7 @@ M: ppc-backend %jump-primitive ( word -- )
%prepare-primitive (%jump) ;
M: ppc-backend %jump-t ( label -- )
0 "flag" operand \ f tag-number CMPI BNE ;
0 "flag" operand f v>operand CMPI BNE ;
: dispatch-template ( word-table# quot -- )
[

1
core/generator/generator.factor Normal file → Executable file
View File

@ -312,3 +312,4 @@ M: #return generate-node drop end-basic-block %return f ;
: underlying-alien-offset cell object tag-number - ;
: tuple-class-offset 2 cells tuple tag-number - ;
: class-hash-offset cell object tag-number - ;
: word-xt-offset 8 cells object tag-number - ;