--- /dev/null
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types arrays cpu.arm.assembler compiler
+kernel kernel.private math namespaces words words.private
+generator.registers generator.fixup generator cpu.architecture
+system layouts ;
+IN: cpu.arm.architecture
+
+TUPLE: arm-backend ;
+
+! ARM register assignments:
+! R0-R4, R7-R10 integer vregs
+! R11, R12 temporary
+! R5 data stack
+! R6 retain stack
+! R7 primitives
+
+: ds-reg R5 ; inline
+: rs-reg R6 ; inline
+
+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 } ;
+
+! No FPU support yet
+M: float-regs param-regs drop { } ;
+M: float-regs vregs drop { } ;
+
+: <+/-> dup 0 < [ neg <-> ] [ <+> ] if ;
+
+GENERIC: loc>operand ( loc -- reg addressing )
+M: ds-loc loc>operand ds-loc-n cells neg ds-reg swap <+/-> ;
+M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap <+/-> ;
+
+: load-cell ( reg -- )
+ [
+ "end" define-label
+ ! Load target address
+ PC 0 <+> LDR
+ ! Skip an instruction
+ "end" get B
+ ! The target address
+ 0 ,
+ ! Continue here
+ "end" resolve-label
+ ] with-scope ;
+
+: call-cell ( -- )
+ ! Compute return address; we skip 3 instructions
+ LR PC 8 ADD
+ ! Load target address
+ R12 PC 0 <+> LDR
+ ! Jump to target address
+ R12 BX
+ ! The target address
+ 0 , ;
+
+M: arm-backend load-indirect ( obj reg -- )
+ tuck load-cell rc-absolute-cell rel-literal
+ dup 0 <+> LDR ;
+
+M: immediate load-literal
+ over v>operand small-enough? [
+ [ v>operand ] bi@ swap MOV
+ ] [
+ v>operand load-indirect
+ ] if ;
+
+: 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: arm-backend %save-word-xt ( -- )
+ R12 PC 9 cells SUB ;
+
+M: arm-backend %save-dispatch-xt ( -- )
+ R12 PC 2 cells SUB ;
+
+M: arm-backend %prologue ( n -- )
+ SP SP pick SUB
+ R11 over MOV
+ R11 SP pick next-save <+> STR
+ R12 SP pick xt-save <+> STR
+ LR SP rot lr-save <+> STR ;
+
+M: arm-backend %epilogue ( n -- )
+ LR SP pick lr-save <+> LDR
+ SP SP rot ADD ;
+
+: compile-dlsym ( symbol dll reg -- )
+ load-cell rc-absolute rel-dlsym ;
+
+: %alien-global ( symbol dll reg -- )
+ [ compile-dlsym ] keep dup 0 <+> LDR ;
+
+M: arm-backend %profiler-prologue ( -- )
+ ! We can clobber R0 here since it is undefined at the start
+ ! of a word.
+ R12 load-indirect
+ R0 R12 profile-count-offset <+> LDR
+ R0 R0 1 v>operand ADD
+ R0 R12 profile-count-offset <+> STR ;
+
+M: arm-backend %call-label ( label -- ) BL ;
+
+M: arm-backend %jump-label ( label -- ) B ;
+
+: %prepare-primitive ( -- )
+ ! Save stack pointer to stack_chain->callstack_top, load XT
+ R1 SP 4 SUB ;
+
+M: arm-backend %call-primitive ( word -- )
+ %prepare-primitive
+ call-cell rc-absolute-cell rel-word ;
+
+M: arm-backend %jump-primitive ( word -- )
+ %prepare-primitive
+ ! Load target address
+ R12 PC 0 <+> LDR
+ ! Jump to target address
+ R12 BX
+ ! The target address
+ 0 , rc-absolute-cell rel-word ;
+
+M: arm-backend %jump-t ( label -- )
+ "flag" operand f v>operand CMP NE B ;
+
+: (%dispatch) ( word-table# -- )
+ ! Load jump table target address into reg.
+ "scratch" operand PC "n" operand 1 <LSR> ADD
+ "scratch" operand dup 0 <+> LDR
+ rc-indirect-arm rel-dispatch
+ "scratch" operand dup compiled-header-size ADD ;
+
+M: arm-backend %call-dispatch ( word-table# -- )
+ [
+ (%dispatch)
+ "scratch" operand BLX
+ ] H{
+ { +input+ { { f "n" } } }
+ { +scratch+ { { f "scratch" } } }
+ } with-template ;
+
+M: arm-backend %jump-dispatch ( word-table# -- )
+ [
+ %epilogue-later
+ (%dispatch)
+ "scratch" operand BX
+ ] H{
+ { +input+ { { f "n" } } }
+ { +scratch+ { { f "scratch" } } }
+ } with-template ;
+
+M: arm-backend %return ( -- ) %epilogue-later PC LR MOV ;
+
+M: arm-backend %unwind drop %return ;
+
+M: arm-backend %peek >r v>operand r> loc>operand LDR ;
+
+M: arm-backend %replace >r v>operand r> loc>operand STR ;
+
+: (%inc) ( n reg -- )
+ dup rot cells dup 0 < [ neg SUB ] [ ADD ] if ;
+
+M: arm-backend %inc-d ( n -- ) ds-reg (%inc) ;
+
+M: arm-backend %inc-r ( n -- ) rs-reg (%inc) ;
+
+: stack@ SP swap <+> ;
+
+M: int-regs %save-param-reg drop swap stack@ STR ;
+
+M: int-regs %load-param-reg drop swap stack@ LDR ;
+
+M: stack-params %save-param-reg
+ drop
+ R12 swap stack-frame* + stack@ LDR
+ R12 swap stack@ STR ;
+
+M: stack-params %load-param-reg
+ drop
+ R12 rot stack@ LDR
+ R12 swap stack@ STR ;
+
+M: arm-backend %prepare-unbox ( -- )
+ ! First parameter is top of stack
+ R0 R5 4 <-!> LDR ;
+
+M: arm-backend %unbox ( n reg-class func -- )
+ ! Value must be in R0.
+ ! Call the unboxer
+ f %alien-invoke
+ ! Store the return value on the C stack
+ over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
+
+M: arm-backend %unbox-long-long ( n func -- )
+ ! Value must be in R0:R1.
+ ! Call the unboxer
+ f %alien-invoke
+ ! Store the return value on the C stack
+ [
+ R0 over stack@ STR
+ R1 swap cell + stack@ STR
+ ] when* ;
+
+M: arm-backend %unbox-small-struct ( size -- )
+ ! Alien must be in R0.
+ drop
+ "alien_offset" f %alien-invoke
+ ! Load first cell
+ R0 R0 0 <+> LDR ;
+
+M: arm-backend %unbox-large-struct ( n size -- )
+ ! Alien must be in R0.
+ ! Compute destination address
+ R1 SP roll ADD
+ R2 swap MOV
+ ! Copy the struct to the stack
+ "to_value_struct" f %alien-invoke ;
+
+M: arm-backend %box ( n reg-class func -- )
+ ! If the source is a stack location, load it into freg #0.
+ ! If the source is f, then we assume the value is already in
+ ! freg #0.
+ >r
+ over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
+ r> f %alien-invoke ;
+
+M: arm-backend %box-long-long ( n func -- )
+ >r [
+ R0 over stack@ LDR
+ R1 swap cell + stack@ LDR
+ ] when* r> f %alien-invoke ;
+
+M: arm-backend %box-small-struct ( size -- )
+ ! Box a 4-byte struct returned in R0.
+ 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* factor-area-size - swap -
+ ] ?if ;
+
+M: arm-backend %prepare-box-struct ( size -- )
+ ! Compute target address for value struct return
+ R0 SP rot f struct-return@ ADD
+ ! Store it as the first parameter
+ R0 0 stack@ STR ;
+
+M: arm-backend %box-large-struct ( n size -- )
+ ! Compute destination address
+ [ swap struct-return@ ] keep
+ R0 SP roll ADD
+ R1 swap MOV
+ ! Copy the struct from the C stack
+ "box_value_struct" f %alien-invoke ;
+
+M: arm-backend struct-small-enough? ( size -- ? )
+ 4 <= ;
+
+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 R12 8 <+> STR
+ rs-reg R12 12 <+> STR ;
+
+M: arm-backend %alien-invoke ( symbol dll -- )
+ call-cell rc-absolute-cell rel-dlsym ;
+
+M: arm-backend %prepare-alien-indirect ( -- )
+ "unbox_alien" f %alien-invoke
+ R0 SP cell temp@ <+> STR ;
+
+M: arm-backend %alien-indirect ( -- )
+ R12 SP cell temp@ <+> LDR
+ R12 BLX ;
+
+M: arm-backend %alien-callback ( quot -- )
+ R0 load-indirect
+ "c_to_factor" f %alien-invoke ;
+
+M: arm-backend %callback-value ( ctype -- )
+ ! Save top of data stack
+ %prepare-unbox
+ R0 SP cell temp@ <+> STR
+ ! Restore data/call/retain stacks
+ "unnest_stacks" f %alien-invoke
+ ! Place former top of data stack in R0
+ R0 SP cell temp@ <+> LDR
+ ! Unbox R0
+ unbox-return ;
+
+M: arm-backend %cleanup ( alien-node -- ) drop ;
+
+: %untag ( dest src -- ) 0b111 BIC ;
+
+: %untag-fixnum ( dest src -- ) tag-bits get <ASR> MOV ;
+
+: %tag-fixnum ( dest src -- ) tag-bits get <LSL> MOV ;
+
+M: arm-backend value-structs? t ;
+
+M: arm-backend small-enough? ( n -- ? ) 0 255 between? ;
+
+M: long-long-type c-type-stack-align? drop t ;
+
+M: arm-backend fp-shadows-int? ( -- ? ) f ;
+
+! Alien intrinsics
+M: arm-backend %unbox-byte-array ( dst src -- )
+ [ v>operand ] bi@ byte-array-offset ADD ;
+
+M: arm-backend %unbox-alien ( dst src -- )
+ [ v>operand ] bi@ alien-offset <+> LDR ;
+
+M: arm-backend %unbox-f ( dst src -- )
+ drop v>operand 0 MOV ;
+
+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
+ "start" define-label
+ ! Save R14.
+ R14 SP 4 <-> STR
+ ! Address is computed in R11
+ 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-fixnum 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 ;
projects / factor-unmaintained.git / blobdiff