Updating ARM optimizing compiler backend
U-SLAVA-FB3999113\Slava
parent
87944928aa
commit
b4b4c599c6
2
core/cpu/arm5/intrinsics/intrinsics.factor → core/cpu/arm/4/4.factor
Normal file → Executable file
2
core/cpu/arm5/intrinsics/intrinsics.factor → core/cpu/arm/4/4.factor
Normal file → Executable 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,0 +1 @@
|
|||
Additional compiler intrinsics for ARM4
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
USING: cpu.arm.assembler cpu.arm4 namespaces ;
|
||||
|
||||
t have-BLX? set-global
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 - ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,4 +0,0 @@
|
|||
USING: cpu.arm.assembler cpu.arm5.assembler cpu.arm5.intrinsics
|
||||
namespaces ;
|
||||
|
||||
T{ arm5-variant } arm-variant set-global
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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 - ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue