+++ /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