Further progress on the ARM backend
U-SLAVA-FB3999113\Slava
parent
bf82687051
commit
b841dcc159
|
|
@ -22,7 +22,7 @@ IN: cpu.arm.allot
|
|||
;
|
||||
|
||||
: %store-tagged ( reg tag -- )
|
||||
>r dup fresh-object v>operand R11 r> tag-number ORI ;
|
||||
>r dup fresh-object v>operand R11 r> tag-number ORR ;
|
||||
|
||||
: %allot-bignum ( #digits -- )
|
||||
#! 1 cell header, 1 cell length, 1 cell sign, + digits
|
||||
|
|
@ -32,10 +32,10 @@ IN: cpu.arm.allot
|
|||
R12 R11 cell <+> STR ! store the length
|
||||
;
|
||||
|
||||
: %allot-bignum-signed-1 ( reg -- )
|
||||
: %allot-bignum-signed-1 ( dst src -- )
|
||||
#! on entry, reg is a 30-bit quantity sign-extended to
|
||||
#! 32-bits.
|
||||
#! exits with tagged ptr to bignum in allot-tmp.
|
||||
#! exits with tagged ptr to bignum in reg.
|
||||
[
|
||||
"end" define-label
|
||||
! is it zero?
|
||||
|
|
@ -55,9 +55,9 @@ IN: cpu.arm.allot
|
|||
! store sign
|
||||
R12 R11 2 cells <+> STR
|
||||
! store the number
|
||||
dup v>operand R11 3 cells <+> STR
|
||||
v>operand R11 3 cells <+> STR
|
||||
! tag the bignum, store it in reg
|
||||
bignum %tag-allot
|
||||
bignum %store-tagged
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
|
|
|
|||
|
|
@ -52,19 +52,19 @@ M: immediate load-literal
|
|||
M: arm-backend stack-frame ( n -- i )
|
||||
factor-area-size + 8 align ;
|
||||
|
||||
M: ppc-backend %save-xt ( -- )
|
||||
M: arm-backend %save-xt ( -- )
|
||||
R12 PC 8 SUB ;
|
||||
|
||||
M: arm-backend %prologue ( n -- )
|
||||
SP SP pick SUB
|
||||
R11 over LI
|
||||
R11 over MOV
|
||||
R11 SP pick next-save <+> STR
|
||||
R12 SP rot xt-save <+> STR
|
||||
LR SP pick lr-save <+> STR ;
|
||||
R12 SP pick xt-save <+> STR
|
||||
LR SP rot lr-save <+> STR ;
|
||||
|
||||
M: arm-backend %epilogue ( n -- )
|
||||
LR SP lr-save <+> LDR
|
||||
SP SP rot stack-frame ADD ;
|
||||
LR SP pick lr-save <+> LDR
|
||||
SP SP rot ADD ;
|
||||
|
||||
: compile-dlsym ( symbol dll reg -- )
|
||||
[
|
||||
|
|
@ -99,9 +99,6 @@ M: arm-backend %call-label ( label -- ) BL ;
|
|||
|
||||
M: arm-backend %jump-label ( label -- ) B ;
|
||||
|
||||
: %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
|
||||
|
|
@ -145,11 +142,9 @@ M: arm-backend %return ( -- ) %epilogue-later PC LR MOV ;
|
|||
|
||||
M: arm-backend %unwind drop %return ;
|
||||
|
||||
: (%peek/replace)
|
||||
>r drop >r v>operand r> loc>operand r> execute ;
|
||||
M: arm-backend %peek >r v>operand r> loc>operand LDR ;
|
||||
|
||||
M: int-regs (%peek) \ LDR (%peek/replace) ;
|
||||
M: int-regs (%replace) \ STR (%peek/replace) ;
|
||||
M: arm-backend %replace >r v>operand r> loc>operand STR ;
|
||||
|
||||
: (%inc) ( n reg -- )
|
||||
dup rot cells dup 0 < [ neg SUB ] [ ADD ] if ;
|
||||
|
|
@ -255,14 +250,14 @@ 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
|
||||
M: arm-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 ;
|
||||
ds-reg R12 8 <+> STR
|
||||
rs-reg R12 12 <+> STR ;
|
||||
|
||||
M: arm-backend %alien-invoke ( symbol dll -- )
|
||||
! Load target address
|
||||
|
|
@ -314,37 +309,50 @@ M: long-long-type c-type-stack-align? drop wince? not ;
|
|||
M: arm-backend fp-shadows-int? ( -- ? ) f ;
|
||||
|
||||
! Alien intrinsics
|
||||
: add-alien-offset "offset" operand tag-bits get <ASR> ADD ;
|
||||
M: arm-backend %unbox-byte-array ( dst src -- )
|
||||
[ v>operand ] 2apply byte-array-offset ADD ;
|
||||
|
||||
: (%unbox-alien) <+> roll call ; inline
|
||||
M: arm-backend %unbox-alien ( dst src -- )
|
||||
[ v>operand ] 2apply alien-offset <+> LDR ;
|
||||
|
||||
M: arm-backend %unbox-byte-array ( quot src -- )
|
||||
"address" operand "alien" operand add-alien-offset
|
||||
"address" operand alien-offset (%unbox-alien) ;
|
||||
M: arm-backend %unbox-f ( dst src -- )
|
||||
drop v>operand 0 MOV ;
|
||||
|
||||
M: arm-backend %unbox-alien ( quot src -- )
|
||||
"address" operand "alien" operand alien-offset <+> LDR
|
||||
"address" operand dup add-alien-offset
|
||||
"address" operand 0 (%unbox-alien) ;
|
||||
|
||||
M: arm-backend %unbox-f ( quot src -- )
|
||||
"offset" operand dup %untag-fixnum
|
||||
"offset" operand 0 (%unbox-alien) ;
|
||||
|
||||
M: arm-backend %complex-alien-accessor ( quot src -- )
|
||||
"is-f" define-label
|
||||
"is-alien" define-label
|
||||
M: arm-backend %unbox-any-c-ptr ( dst src -- )
|
||||
#! We need three registers here. R11 and R12 are reserved
|
||||
#! temporary registers. The third one is R14, which we have
|
||||
#! to save/restore.
|
||||
"end" define-label
|
||||
"alien" operand f v>operand CMP
|
||||
"is-f" get EQ B
|
||||
"address" operand "alien" operand header-offset neg <-> LDR
|
||||
"address" operand alien type-number tag-header CMP
|
||||
"is-alien" get EQ B
|
||||
[ %unbox-byte-array ] 2keep
|
||||
"end" get B
|
||||
"is-alien" resolve-label
|
||||
[ %unbox-alien ] 2keep
|
||||
"end" get B
|
||||
"is-f" resolve-label
|
||||
%unbox-f
|
||||
"end" resolve-label ;
|
||||
"start" define-label
|
||||
! Save R14.
|
||||
R14 SP 4 <-> STR
|
||||
! Address is computed in RR11
|
||||
R11 0 MOV
|
||||
! Load object into R12
|
||||
R12 swap v>operand MOV
|
||||
! We come back here with displaced aliens
|
||||
"start" resolve-label
|
||||
! Is the object f?
|
||||
R12 f v>operand CMP
|
||||
! If so, done
|
||||
"end" get EQ B
|
||||
! Is the object an alien?
|
||||
R14 R12 header-offset <+> LDR
|
||||
R14 alien type-number tag-header CMP
|
||||
! Add byte array address to address being computed
|
||||
R11 R11 R12 NE ADD
|
||||
! Add an offset to start of byte array's data area
|
||||
R11 R11 byte-array-offset NE ADD
|
||||
"end" get NE B
|
||||
! If alien, load the offset
|
||||
R14 R12 alien-offset LDR
|
||||
! Add it to address being computed
|
||||
R11 R11 R14 ADD
|
||||
! Now recurse on the underlying alien
|
||||
R12 R12 underlying-alien-offset LDR
|
||||
"start" get B
|
||||
"end" resolve-label
|
||||
! Done, store address in destination register
|
||||
v>operand R11 MOV
|
||||
! Restore R14.
|
||||
R14 SP 4 <-> LDR ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,9 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types kernel math namespaces
|
||||
cpu.architecture cpu.arm.architecture cpu.arm.intrinsics
|
||||
generator generator.registers continuations compiler io
|
||||
vocabs.loader ;
|
||||
cpu.architecture cpu.arm.architecture cpu.arm.assembler
|
||||
cpu.arm.intrinsics generator generator.registers continuations
|
||||
compiler io vocabs.loader sequences ;
|
||||
|
||||
! EABI passes floats in integer registers.
|
||||
[ alien-float ]
|
||||
|
|
@ -34,9 +36,9 @@ T{ arm-backend } compiler-backend set-global
|
|||
"==========" print
|
||||
"You should specify the -arm-variant=<variant> switch." print
|
||||
"<variant> can be one of arm3, arm4, arm4t, or arm5." print
|
||||
"Assuming arm4t." print
|
||||
"Assuming arm3." print
|
||||
"==========" print
|
||||
"arm4t" "arm-variant" set
|
||||
"arm3" "arm-variant" set-global
|
||||
] if
|
||||
|
||||
"arm-variant" get { "arm4" "arm4t" "arm5" } member? [
|
||||
|
|
|
|||
|
|
@ -276,7 +276,7 @@ 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 ;
|
||||
: BLX have-BLX? get [ 1 (BX) ] [ LR PC MOV BX ] if ;
|
||||
|
||||
! More load and store instructions
|
||||
GENERIC: addressing-mode-3 ( addressing-mode -- n )
|
||||
|
|
|
|||
|
|
@ -1,10 +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 cpu.arm5.assembler math layouts words vocabs ;
|
||||
cpu.arm.assembler math layouts words vocabs ;
|
||||
IN: bootstrap.arm
|
||||
|
||||
T{ arm5-variant } arm-variant set-global
|
||||
! We generate ARM3 code
|
||||
f have-BX? set
|
||||
|
||||
4 \ cell set
|
||||
big-endian off
|
||||
|
|
@ -66,12 +67,12 @@ big-endian off
|
|||
: jit-call
|
||||
scan-reg SP scan-save <+> STR ! save scan pointer
|
||||
LR PC MOV ! save return address
|
||||
PC xt-reg MOV ! call
|
||||
xt-reg BX ! call
|
||||
scan-reg SP scan-save <+> LDR ! restore scan pointer
|
||||
;
|
||||
|
||||
: jit-jump
|
||||
PC xt-reg MOV ;
|
||||
xt-reg BX ;
|
||||
|
||||
[ load-word-xt jit-call ] { } make jit-word-call set
|
||||
|
||||
|
|
@ -113,6 +114,6 @@ big-endian off
|
|||
LR SP 4 <-> LDR ! load return address
|
||||
] { } make jit-epilog set
|
||||
|
||||
[ PC LR MOV ] { } make jit-return set
|
||||
[ LR BX ] { } make jit-return set
|
||||
|
||||
"bootstrap.arm" forget-vocab
|
||||
|
|
|
|||
|
|
@ -16,11 +16,11 @@ IN: cpu.arm.intrinsics
|
|||
"obj" get operand-tag - <+/-> ;
|
||||
|
||||
: %slot-literal-any-tag
|
||||
"obj" operand "scratch" operand %untag
|
||||
"scratch" operand "obj" operand %untag
|
||||
"val" operand "scratch" operand "n" get cells <+> ;
|
||||
|
||||
: %slot-any
|
||||
"obj" operand "scratch" operand %untag
|
||||
"scratch" operand "obj" operand %untag
|
||||
"n" operand dup 1 <LSR> MOV
|
||||
"scratch" operand "val" operand "n" operand <+> ;
|
||||
|
||||
|
|
@ -52,8 +52,8 @@ IN: cpu.arm.intrinsics
|
|||
}
|
||||
} define-intrinsics
|
||||
|
||||
: generate-write-barrier ( -- )
|
||||
"val" operand-immediate? "obj" get fresh-object? or [
|
||||
: %write-barrier ( -- )
|
||||
"val" get operand-immediate? "obj" get fresh-object? or [
|
||||
"cards_offset" f R12 %alien-global
|
||||
"scratch" operand R12 "scratch" operand card-bits <LSR> ADD
|
||||
"val" operand "scratch" operand 0 LDRB
|
||||
|
|
@ -156,7 +156,7 @@ IN: cpu.arm.intrinsics
|
|||
"end" get VC B
|
||||
{ "x" "y" } %untag-fixnums
|
||||
"x" operand "x" operand "y" operand roll execute
|
||||
"x" get %allot-bignum-signed-1
|
||||
"out" get "x" get %allot-bignum-signed-1
|
||||
"end" resolve-label
|
||||
] with-scope ; inline
|
||||
|
||||
|
|
@ -173,7 +173,7 @@ IN: cpu.arm.intrinsics
|
|||
|
||||
\ fixnum>bignum [
|
||||
"x" operand dup %untag-fixnum
|
||||
"x" get %allot-bignum-signed-1
|
||||
"out" get "x" get %allot-bignum-signed-1
|
||||
] H{
|
||||
{ +input+ { { f "x" } } }
|
||||
{ +scratch+ { { f "out" } } }
|
||||
|
|
|
|||
Loading…
Reference in New Issue