--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
+++ /dev/null
-! Copyright (C) 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays cpu.architecture cpu.arm.assembler
-cpu.arm.architecture cpu.arm5.assembler kernel kernel.private
-math math.private namespaces sequences words quotations
-byte-arrays hashtables.private hashtables generator
-generator.registers generator.fixup sequences.private
-strings.private ;
-IN: cpu.arm4
-
-: (%char-slot)
- "out" operand string-offset MOV
- "out" operand dup "n" operand 2 <LSR> ADD ;
-
-\ char-slot [
- (%char-slot)
- "out" operand "obj" operand "out" operand <+> LDRH
- "out" operand dup %tag-fixnum
-] H{
- { +input+ { { f "n" } { f "obj" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-\ set-char-slot [
- "val" operand dup %untag-fixnum
- (%char-slot)
- "val" operand "obj" operand "out" operand <+> STRH
-] H{
- { +input+ { { f "val" } { f "n" } { f "obj" } } }
- { +scratch+ { { f "out" } } }
- { +clobber+ { "val" } }
-} define-intrinsic
-
-\ alien-signed-1 [ LDRSB ]
-\ set-alien-signed-1 [ STRB ]
-define-alien-integer-intrinsics
-
-\ alien-unsigned-2 [ LDRH ]
-\ set-alien-unsigned-2 [ STRH ]
-define-alien-integer-intrinsics
-
-\ alien-signed-2 [ LDRSH ]
-\ set-alien-signed-2 [ STRH ]
-define-alien-integer-intrinsics
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Additional compiler intrinsics for ARM4
+++ /dev/null
-! Copyright (C) 2006, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel cpu.architecture cpu.arm.assembler
-cpu.arm.architecture namespaces math sequences
-generator generator.registers generator.fixup system layouts
-alien ;
-IN: cpu.arm.allot
-
-: load-zone-ptr ( reg -- ) "nursery" f rot %alien-global ;
-
-: %allot ( header size -- )
- #! Store a pointer to 'size' bytes allocated from the
- #! nursery in R11
- 8 align ! align the size
- R12 load-zone-ptr ! nusery -> r12
- 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-fixnum MOV ! compute header
- R12 R11 0 <+> STR ! store header
- ;
-
-: %store-tagged ( reg tag -- )
- >r dup fresh-object v>operand R11 r> tag-number ORR ;
-
-: %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 R11 cell <+> STR ! store the length
- ;
-
-: %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 reg.
- [
- "end" define-label
- ! is it zero?
- dup v>operand 0 CMP
- 0 >bignum pick EQ load-literal
- "end" get EQ B
- ! ! it is non-zero
- 1 %allot-bignum
- ! is the fixnum negative?
- dup v>operand 0 CMP
- ! negative sign
- R12 1 LT MOV
- ! negate fixnum
- dup v>operand dup 0 LT RSB
- ! positive sign
- R12 0 GE MOV
- ! store sign
- R12 R11 2 cells <+> STR
- ! store the number
- v>operand R11 3 cells <+> STR
- ! tag the bignum, store it in reg
- bignum %store-tagged
- "end" resolve-label
- ] with-scope ;
-
-M: arm-backend %box-alien ( dst src -- )
- "end" define-label
- dup v>operand 0 CMP
- over v>operand 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 MOV
- ! 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 ;
+++ /dev/null
-Slava Pestov
+++ /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 -- ? )
- wince? [ drop f ] [ 4 <= ] if ;
-
-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 -- ) BIN: 111 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 wince? not ;
-
-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 ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! 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.assembler
-cpu.arm.intrinsics generator generator.registers continuations
-compiler io vocabs.loader sequences system ;
-
-! EABI passes floats in integer registers.
-[ alien-float ]
-[ >r >r >float r> r> set-alien-float ]
-4
-"box_float"
-"to_float" <primitive-type>
-"float" define-primitive-type
-
-[ >float ] "float" c-type set-c-type-prep
-
-[ alien-double ]
-[ >r >r >float r> r> set-alien-double ]
-8
-"box_double"
-"to_double" <primitive-type> <long-long-type>
-"double" define-primitive-type
-
-[ >float ] "double" c-type set-c-type-prep
-
-T{ arm-backend } compiler-backend set-global
-
-! 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 [
- "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 arm3." print
- "==========" print
- "arm3" "arm-variant" set-global
-] if
-
-"arm-variant" get { "arm4" "arm4t" "arm5" } member? [
- "cpu.arm.4" require
-] when
-
-"arm-variant" get { "arm4t" "arm5" } member? [
- t have-BX? set-global
-] when
-
-"arm-variant" get "arm5" = [
- t have-BLX? set-global
-] when
-
-7 cells profiler-prologues set-global
+++ /dev/null
-IN: cpu.arm.assembler.tests
-USING: assembler-arm math test namespaces sequences kernel
-quotations ;
-
-: test-opcode [ { } make first ] curry unit-test ;
-
-[ HEX: ea000000 ] [ 0 B ] test-opcode
-[ HEX: eb000000 ] [ 0 BL ] test-opcode
-! [ HEX: e12fff30 ] [ R0 BLX ] test-opcode
-
-[ HEX: e24cc004 ] [ IP IP 4 SUB ] test-opcode
-[ HEX: e24cb004 ] [ FP IP 4 SUB ] test-opcode
-[ HEX: e087e3ac ] [ LR R7 IP 7 <LSR> ADD ] test-opcode
-[ HEX: e08c0109 ] [ R0 IP R9 2 <LSL> ADD ] test-opcode
-[ HEX: 02850004 ] [ R0 R5 4 EQ ADD ] test-opcode
-[ HEX: 00000000 ] [ R0 R0 R0 EQ AND ] test-opcode
-
-[ HEX: e1a0c00c ] [ IP IP MOV ] test-opcode
-[ HEX: e1a0c00d ] [ IP SP MOV ] test-opcode
-[ HEX: e3a03003 ] [ R3 3 MOV ] test-opcode
-[ HEX: e1a00003 ] [ R0 R3 MOV ] test-opcode
-[ HEX: e1e01c80 ] [ R1 R0 25 <LSL> MVN ] test-opcode
-[ HEX: e1e00ca1 ] [ R0 R1 25 <LSR> MVN ] test-opcode
-[ HEX: 11a021ac ] [ R2 IP 3 <LSR> NE MOV ] test-opcode
-
-[ HEX: e3530007 ] [ R3 7 CMP ] test-opcode
-
-[ HEX: e008049a ] [ R8 SL R4 MUL ] test-opcode
-
-[ HEX: e5151004 ] [ R1 R5 4 <-> LDR ] test-opcode
-[ HEX: e41c2004 ] [ R2 IP 4 <-!> LDR ] test-opcode
-[ HEX: e50e2004 ] [ R2 LR 4 <-> STR ] test-opcode
-
-[ HEX: e7910002 ] [ R0 R1 R2 <+> LDR ] test-opcode
-[ HEX: e7910102 ] [ R0 R1 R2 2 <LSL> <+> LDR ] test-opcode
-
-[ HEX: e1d310bc ] [ R1 R3 12 <+> LDRH ] test-opcode
-[ HEX: e1d310fc ] [ R1 R3 12 <+> LDRSH ] test-opcode
-[ HEX: e1d310dc ] [ R1 R3 12 <+> LDRSB ] test-opcode
-[ HEX: e1c310bc ] [ R1 R3 12 <+> STRH ] test-opcode
-[ HEX: e19310b4 ] [ R1 R3 R4 <+> LDRH ] test-opcode
-[ HEX: e1f310fc ] [ R1 R3 12 <!+> LDRSH ] test-opcode
-[ HEX: e1b310d4 ] [ R1 R3 R4 <!+> LDRSB ] test-opcode
-[ HEX: e0c317bb ] [ R1 R3 123 <+!> STRH ] test-opcode
-[ HEX: e08310b4 ] [ R1 R3 R4 <+!> STRH ] test-opcode
+++ /dev/null
-! 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 ;
-IN: cpu.arm.assembler
-
-: define-registers ( seq -- )
- dup length [ "register" set-word-prop ] 2each ;
-
-SYMBOL: R0
-SYMBOL: R1
-SYMBOL: R2
-SYMBOL: R3
-SYMBOL: R4
-SYMBOL: R5
-SYMBOL: R6
-SYMBOL: R7
-SYMBOL: R8
-SYMBOL: R9
-SYMBOL: R10
-SYMBOL: R11
-SYMBOL: R12
-SYMBOL: R13
-SYMBOL: R14
-SYMBOL: R15
-
-{ R0 R1 R2 R3 R4 R5 R6 R7 R8 R9 R10 R11 R12 R13 R14 R15 }
-define-registers
-
-PREDICATE: register < word register >boolean ;
-
-GENERIC: register ( register -- n )
-M: word register "register" word-prop ;
-M: f register drop 0 ;
-
-: SL R10 ; inline : FP R11 ; inline : IP R12 ; inline
-: SP R13 ; inline : LR R14 ; inline : PC R15 ; inline
-
-! Condition codes
-SYMBOL: cond-code
-
-: >CC ( n -- )
- cond-code set ;
-
-: CC> ( -- n )
- #! Default value is BIN: 1110 AL (= always)
- cond-code [ f ] change BIN: 1110 or ;
-
-: EQ BIN: 0000 >CC ;
-: NE BIN: 0001 >CC ;
-: CS BIN: 0010 >CC ;
-: CC BIN: 0011 >CC ;
-: LO BIN: 0100 >CC ;
-: PL BIN: 0101 >CC ;
-: VS BIN: 0110 >CC ;
-: VC BIN: 0111 >CC ;
-: HI BIN: 1000 >CC ;
-: LS BIN: 1001 >CC ;
-: GE BIN: 1010 >CC ;
-: LT BIN: 1011 >CC ;
-: GT BIN: 1100 >CC ;
-: LE BIN: 1101 >CC ;
-: AL BIN: 1110 >CC ;
-: NV BIN: 1111 >CC ;
-
-: (insn) ( n -- ) CC> 28 shift bitor , ;
-
-: insn ( bitspec -- ) bitfield (insn) ; inline
-
-! Branching instructions
-GENERIC# (B) 1 ( signed-imm-24 l -- )
-
-M: integer (B) { 24 { 1 25 } { 0 26 } { 1 27 } 0 } insn ;
-M: word (B) 0 swap (B) rc-relative-arm-3 rel-word ;
-M: label (B) 0 swap (B) rc-relative-arm-3 label-fixup ;
-
-: B 0 (B) ; : BL 1 (B) ;
-
-! Data processing instructions
-SYMBOL: updates-cond-code
-
-: S ( -- ) updates-cond-code on ;
-
-: S> ( -- ? ) updates-cond-code [ f ] change ;
-
-: sinsn ( bitspec -- )
- bitfield S> [ 20 2^ bitor ] when (insn) ; inline
-
-GENERIC# shift-imm/reg 2 ( shift-imm/Rs Rm shift -- n )
-
-M: integer shift-imm/reg ( shift-imm Rm shift -- n )
- { { 0 4 } 5 { register 0 } 7 } bitfield ;
-
-M: register shift-imm/reg ( Rs Rm shift -- n )
- {
- { 1 4 }
- { 0 7 }
- 5
- { register 8 }
- { register 0 }
- } bitfield ;
-
-GENERIC: shifter-op ( shifter-op -- n )
-
-TUPLE: IMM immed rotate ;
-C: <IMM> IMM
-
-M: IMM shifter-op
- dup IMM-immed swap IMM-rotate
- { { 1 25 } 8 0 } bitfield ;
-
-TUPLE: shifter Rm by shift ;
-C: <shifter> shifter
-
-M: shifter shifter-op
- dup shifter-by over shifter-Rm rot shifter-shift
- shift-imm/reg ;
-
-: <LSL> ( Rm shift-imm/Rs -- shifter-op ) BIN: 00 <shifter> ;
-: <LSR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 01 <shifter> ;
-: <ASR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 10 <shifter> ;
-: <ROR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 11 <shifter> ;
-: <RRX> ( Rm -- shifter-op ) 0 <ROR> ;
-
-M: register shifter-op 0 <LSL> shifter-op ;
-
-M: integer shifter-op 0 <IMM> shifter-op ;
-
-: addr1 ( Rd Rn shifter-op opcode -- )
- {
- 21 ! opcode
- { shifter-op 0 }
- { register 16 } ! Rn
- { register 12 } ! Rd
- } sinsn ;
-
-: AND BIN: 0000 addr1 ;
-: EOR BIN: 0001 addr1 ;
-: SUB BIN: 0010 addr1 ;
-: RSB BIN: 0011 addr1 ;
-: ADD BIN: 0100 addr1 ;
-: ADC BIN: 0101 addr1 ;
-: SBC BIN: 0110 addr1 ;
-: RSC BIN: 0111 addr1 ;
-: ORR BIN: 1100 addr1 ;
-: BIC BIN: 1110 addr1 ;
-
-: MOV f swap BIN: 1101 addr1 ;
-: MVN f swap BIN: 1111 addr1 ;
-
-! These always update the condition code flags
-: (CMP) >r f -rot r> S addr1 ;
-
-: TST BIN: 1000 (CMP) ;
-: TEQ BIN: 1001 (CMP) ;
-: CMP BIN: 1010 (CMP) ;
-: CMN BIN: 1011 (CMP) ;
-
-! Multiply instructions
-: (MLA) ( Rd Rm Rs Rn a -- )
- {
- 21
- { register 12 }
- { register 8 }
- { register 0 }
- { register 16 }
- { 1 7 }
- { 1 4 }
- } sinsn ;
-
-: MUL ( Rd Rm Rs -- ) f 0 (MLA) ;
-: MLA ( Rd Rm Rs Rn -- ) 1 (MLA) ;
-
-: (S/UMLAL) ( RdLo RdHi Rm Rs s a -- )
- {
- { 1 23 }
- 22
- 21
- { register 8 }
- { register 0 }
- { register 16 }
- { register 12 }
- { 1 7 }
- { 1 4 }
- } sinsn ;
-
-: SMLAL 1 1 (S/UMLAL) ; : SMULL 1 0 (S/UMLAL) ;
-: UMLAL 0 1 (S/UMLAL) ; : UMULL 0 0 (S/UMLAL) ;
-
-! Miscellaneous arithmetic instructions
-: CLZ ( Rd Rm -- )
- {
- { 1 24 }
- { 1 22 }
- { 1 21 }
- { BIN: 111 16 }
- { BIN: 1111 8 }
- { 1 4 }
- { register 0 }
- { register 12 }
- } sinsn ;
-
-! Status register acess instructions
-
-! Load and store instructions
-GENERIC: addressing-mode-2 ( addressing-mode -- n )
-
-TUPLE: addressing p u w ;
-: <addressing> ( delegate p u w -- addressing )
- {
- set-delegate
- set-addressing-p
- set-addressing-u
- set-addressing-w
- } addressing construct ;
-
-M: addressing addressing-mode-2
- {
- addressing-p addressing-u addressing-w delegate
- } get-slots addressing-mode-2
- { 0 21 23 24 } bitfield ;
-
-M: integer addressing-mode-2 ;
-
-M: object addressing-mode-2 shifter-op { { 1 25 } 0 } bitfield ;
-
-! Offset
-: <+> 1 1 0 <addressing> ;
-: <-> 1 0 0 <addressing> ;
-
-! Pre-indexed
-: <!+> 1 1 1 <addressing> ;
-: <!-> 1 0 1 <addressing> ;
-
-! Post-indexed
-: <+!> 0 1 0 <addressing> ;
-: <-!> 0 0 0 <addressing> ;
-
-: addr2 ( Rd Rn addressing-mode b l -- )
- {
- { 1 26 }
- 20
- 22
- { addressing-mode-2 0 }
- { register 16 }
- { register 12 }
- } insn ;
-
-: LDR 0 1 addr2 ;
-: LDRB 1 1 addr2 ;
-: STR 0 0 addr2 ;
-: STRB 1 0 addr2 ;
-
-! We might have to simulate these instructions since older ARM
-! chips don't have them.
-SYMBOL: have-BX?
-SYMBOL: have-BLX?
-
-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 (BX) ] [ 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
-
-! Semaphore instructions
-
-! Exception-generating instructions
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! 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 compiler.units ;
-IN: bootstrap.arm
-
-! We generate ARM3 code
-f have-BX? set
-
-4 \ cell set
-big-endian off
-
-4 jit-code-format set
-
-: ds-reg R5 ;
-
-: word-reg R0 ;
-: quot-reg R0 ;
-: scan-reg R2 ;
-: temp-reg R3 ;
-: xt-reg R12 ;
-
-: stack-frame 16 bootstrap-cells ;
-
-: next-save stack-frame 2 bootstrap-cells - ;
-: xt-save stack-frame 3 bootstrap-cells - ;
-: array-save stack-frame 4 bootstrap-cells - ;
-: scan-save stack-frame 5 bootstrap-cells - ;
-
-[
- temp-reg quot-reg quot-array@ <+> LDR ! load array
- scan-reg temp-reg scan@ ADD ! initialize scan pointer
-] { } make jit-setup set
-
-[
- LR SP 4 <-> STR ! save return address
- SP SP stack-frame SUB
- xt-reg SP xt-save <+> STR ! save XT
- xt-reg stack-frame MOV
- xt-reg SP next-save <+> STR ! save frame size
- temp-reg SP array-save <+> STR ! save array
-] { } make jit-prolog set
-
-[
- temp-reg scan-reg 4 <!+> LDR ! load literal and advance
- temp-reg ds-reg 4 <!+> STR ! push literal
-] { } make jit-push-literal set
-
-[
- temp-reg scan-reg 4 <!+> LDR ! load wrapper and advance
- temp-reg dup wrapper@ <+> LDR ! load wrapped object
- temp-reg ds-reg 4 <!+> STR ! push wrapped object
-] { } make jit-push-wrapper set
-
-[
- R1 SP 4 SUB ! pass stack pointer to primitive
-] { } make jit-word-primitive-jump set
-
-[
- R1 SP 4 SUB ! pass stack pointer to primitive
-] { } make jit-word-primitive-call set
-
-: load-word-xt ( -- )
- word-reg scan-reg 4 <!+> LDR ! load word and advance
- xt-reg word-reg word-xt@ <+> LDR ;
-
-: jit-call
- scan-reg SP scan-save <+> STR ! save scan pointer
- LR PC MOV ! save return address
- xt-reg BX ! call
- scan-reg SP scan-save <+> LDR ! restore scan pointer
- ;
-
-: jit-jump
- xt-reg BX ;
-
-[ load-word-xt jit-call ] { } make jit-word-call set
-
-[ load-word-xt jit-jump ] { } make jit-word-jump set
-
-: load-quot-xt
- xt-reg quot-reg quot-xt@ <+> LDR ;
-
-: load-branch
- temp-reg ds-reg 4 <-!> LDR ! pop boolean
- temp-reg \ f tag-number CMP ! compare it with f
- quot-reg scan-reg MOV ! point quot-reg at false branch
- quot-reg dup 4 EQ ADD ! point quot-reg at true branch
- quot-reg dup 4 <+> LDR ! load the branch
- scan-reg dup 12 ADD ! advance scan pointer
- load-quot-xt
- ;
-
-[
- load-branch jit-jump
-] { } make jit-if-jump set
-
-[
- load-branch jit-call
-] { } make jit-if-call set
-
-[
- temp-reg ds-reg 4 <-!> LDR ! pop index
- temp-reg dup 1 <LSR> MOV ! turn it into an array offset
- scan-reg dup 4 <+> LDR ! load array
- temp-reg dup scan-reg ADD ! compute quotation location
- quot-reg temp-reg array-start <+> LDR ! load quotation
- load-quot-xt
- jit-jump
-] { } make jit-dispatch set
-
-[
- SP SP stack-frame ADD ! pop stack frame
- LR SP 4 <-> LDR ! load return address
-] { } make jit-epilog set
-
-[ LR BX ] { } make jit-return set
-
-[ "bootstrap.arm" forget-vocab ] with-compilation-unit
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays cpu.architecture cpu.arm.assembler
-cpu.arm.architecture cpu.arm.allot kernel kernel.private math
-math.private namespaces sequences words
-quotations byte-arrays hashtables.private hashtables generator
-generator.registers generator.fixup sequences.private sbufs
-sbufs.private vectors vectors.private system
-classes.tuple.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
- "scratch" operand "obj" operand %untag
- "val" operand "scratch" operand "n" get cells <+> ;
-
-: %slot-any
- "scratch" operand "obj" operand %untag
- "n" operand dup 1 <LSR> MOV
- "val" operand "scratch" 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
- {
- [ %slot-literal-any-tag LDR ] H{
- { +input+ { { f "obj" } { [ small-slot? ] "n" } } }
- { +scratch+ { { f "scratch" } { f "val" } } }
- { +output+ { "val" } }
- }
- }
- ! Slot number in a register
- {
- [ %slot-any LDR ] H{
- { +input+ { { f "obj" } { f "n" } } }
- { +scratch+ { { f "val" } { f "scratch" } } }
- { +output+ { "val" } }
- { +clobber+ { "n" } }
- }
- }
-} define-intrinsics
-
-: %write-barrier ( -- )
- "val" get operand-immediate? "obj" get fresh-object? or [
- "cards_offset" f R12 %alien-global
- "scratch" operand R12 "obj" operand card-bits <LSR> ADD
- "val" operand "scratch" operand 0 <+> LDRB
- "val" operand dup card-mark ORR
- "val" operand "scratch" operand 0 <+> STRB
- ] 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
- {
- [ %slot-literal-any-tag STR %write-barrier ] H{
- { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
- { +scratch+ { { f "scratch" } } }
- { +clobber+ { "val" } }
- }
- }
- ! Slot number is in a register
- {
- [ %slot-any STR %write-barrier ] H{
- { +input+ { { f "val" } { f "obj" } { f "n" } } }
- { +scratch+ { { f "scratch" } } }
- { +clobber+ { "val" "n" } }
- }
- }
-} define-intrinsics
-
-: fixnum-op ( op -- quot )
- [ "out" operand "x" operand "y" operand ] swap add ;
-
-: fixnum-register-op ( op -- pair )
- fixnum-op H{
- { +input+ { { f "x" } { f "y" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
- } 2array ;
-
-: fixnum-value-op ( op -- pair )
- fixnum-op H{
- { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
- } 2array ;
-
-: define-fixnum-op ( word op -- )
- [ fixnum-value-op ] keep fixnum-register-op 2array
- define-intrinsics ;
-
-{
- { fixnum+fast ADD }
- { fixnum-fast SUB }
- { fixnum-bitand AND }
- { fixnum-bitor ORR }
- { fixnum-bitxor EOR }
-} [
- first2 define-fixnum-op
-] each
-
-\ fixnum-bitnot [
- "x" operand dup MVN
- "x" operand dup %untag
-] H{
- { +input+ { { f "x" } } }
- { +output+ { "x" } }
-} define-intrinsic
-
-\ fixnum*fast [
- "out" operand "y" operand %untag-fixnum
- "out" operand "x" operand "out" operand MUL
-] H{
- { +input+ { { f "x" } { f "y" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-\ fixnum-shift [
- "out" operand "x" operand "y" get neg <ASR> MOV
- ! Mask off low bits
- "out" operand dup %untag
-] H{
- { +input+ { { f "x" } { [ -31 0 between? ] "y" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-: %untag-fixnums ( seq -- )
- [ dup %untag-fixnum ] unique-operands ;
-
-: overflow-check ( insn -- )
- [
- "end" define-label
- [ "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
- "out" get "x" get %allot-bignum-signed-1
- "end" resolve-label
- ] with-scope ; inline
-
-: overflow-template ( word insn -- )
- [ overflow-check ] curry H{
- { +input+ { { f "x" } { f "y" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
- { +clobber+ { "x" "y" } }
- } define-intrinsic ;
-
-\ fixnum+ \ ADD overflow-template
-\ fixnum- \ SUB overflow-template
-
-\ fixnum>bignum [
- "x" operand dup %untag-fixnum
- "out" get "x" get %allot-bignum-signed-1
-] H{
- { +input+ { { f "x" } } }
- { +scratch+ { { f "out" } } }
- { +clobber+ { "x" } }
- { +output+ { "out" } }
-} define-intrinsic
-
-\ bignum>fixnum [
- "end" define-label
- "x" operand dup %untag
- "y" operand "x" operand cell <+> LDR
- ! if the length is 1, its just the sign and nothing else,
- ! so output 0
- "y" operand 1 v>operand CMP
- "y" operand 0 EQ MOV
- "end" get EQ B
- ! load the value
- "y" operand "x" operand 3 cells <+> LDR
- ! load the sign
- "x" operand "x" operand 2 cells <+> LDR
- ! is the sign negative?
- "x" operand 0 CMP
- ! Negate the value
- "y" operand "y" operand 0 NE RSB
- "y" operand dup %tag-fixnum
- "end" resolve-label
-] H{
- { +input+ { { f "x" } } }
- { +scratch+ { { f "y" } } }
- { +clobber+ { "x" } }
- { +output+ { "y" } }
-} define-intrinsic
-
-: fixnum-jump ( op -- quo )
- [ "x" operand "y" operand CMP ] swap
- 1quotation [ B ] 3append ;
-
-: fixnum-register-jump ( op -- pair )
- fixnum-jump { { f "x" } { f "y" } } 2array ;
-
-: fixnum-value-jump ( op -- pair )
- fixnum-jump { { f "x" } { [ small-tagged? ] "y" } } 2array ;
-
-: define-fixnum-jump ( word op -- )
- [ fixnum-value-jump ] keep fixnum-register-jump
- 2array define-if-intrinsics ;
-
-{
- { fixnum< LT }
- { fixnum<= LE }
- { fixnum> GT }
- { fixnum>= GE }
- { eq? EQ }
-} [
- first2 define-fixnum-jump
-] each
-
-\ tag [
- "out" operand "in" operand tag-mask get AND
- "out" operand dup %tag-fixnum
-] H{
- { +input+ { { f "in" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
-} 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
- "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).
- "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 "out" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-: userenv ( reg -- )
- #! Load the userenv pointer in a register.
- "userenv" f rot compile-dlsym ;
-
-\ getenv [
- "n" operand dup 1 <ASR> MOV
- "x" operand userenv
- "x" operand "x" operand "n" operand <+> LDR
-] H{
- { +input+ { { f "n" } } }
- { +scratch+ { { f "x" } } }
- { +output+ { "x" } }
- { +clobber+ { "n" } }
-} define-intrinsic
-
-\ setenv [
- "n" operand dup 1 <ASR> MOV
- "x" operand userenv
- "val" operand "x" operand "n" operand <+> STR
-] H{
- { +input+ { { f "val" } { f "n" } } }
- { +scratch+ { { f "x" } } }
- { +clobber+ { "n" } }
-} define-intrinsic
-
-: %set-slot R11 swap cells <+> STR ;
-
-: %store-length
- R12 "n" operand MOV
- R12 1 %set-slot ;
-
-: %fill-array swap 2 + %set-slot ;
-
-\ <tuple> [
- tuple "n" get 2 + cells %allot
- %store-length
- ! Store class
- "class" operand 2 %set-slot
- ! Zero out the rest of the tuple
- "initial" operand f v>operand MOV
- "n" get 1- [ 1+ "initial" operand %fill-array ] each
- "out" get tuple %store-tagged
-] H{
- { +input+ { { f "class" } { [ inline-array? ] "n" } } }
- { +scratch+ { { f "out" } { f "initial" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-\ <array> [
- array "n" get 2 + cells %allot
- %store-length
- ! Store initial element
- "n" get [ "initial" operand %fill-array ] each
- "out" get object %store-tagged
-] H{
- { +input+ { { [ inline-array? ] "n" } { f "initial" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-\ <byte-array> [
- byte-array "n" get 2 cells + %allot
- %store-length
- ! Store initial element
- R12 0 MOV
- "n" get cell align cell /i [ R12 %fill-array ] each
- "out" get object %store-tagged
-] H{
- { +input+ { { [ inline-array? ] "n" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-\ <ratio> [
- ratio 3 cells %allot
- "numerator" operand 1 %set-slot
- "denominator" operand 2 %set-slot
- "out" get ratio %store-tagged
-] H{
- { +input+ { { f "numerator" } { f "denominator" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-\ <complex> [
- complex 3 cells %allot
- "real" operand 1 %set-slot
- "imaginary" operand 2 %set-slot
- ! Store tagged ptr in reg
- "out" get complex %store-tagged
-] H{
- { +input+ { { f "real" } { f "imaginary" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-\ <wrapper> [
- wrapper 2 cells %allot
- "obj" operand 1 %set-slot
- ! Store tagged ptr in reg
- "out" get object %store-tagged
-] H{
- { +input+ { { f "obj" } } }
- { +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+ {
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { +scratch+ { { f "value" } } }
- { +output+ { "value" } }
- { +clobber+ { "offset" } }
- } ;
-
-: %alien-integer-get ( quot -- )
- %alien-accessor
- "value" operand dup %tag-fixnum ; inline
-
-: alien-integer-set-template
- H{
- { +input+ {
- { f "value" fixnum }
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { +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
- define-intrinsic
- [ %alien-integer-get ] curry
- alien-integer-get-template
- define-intrinsic ;
-
-\ alien-unsigned-1 [ LDRB ]
-\ set-alien-unsigned-1 [ STRB ]
-define-alien-integer-intrinsics
-
-: 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
+++ /dev/null
-ARM3 compiler backend
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
[ swap ] [ over disjoint-set inc-rank ] [ ] branch
disjoint-set link-sets
] if ;
+
+M: disjoint-set clone
+ [ parents>> ] [ ranks>> ] [ counts>> ] tri [ clone ] tri@
+ disjoint-set boa ;
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
+unportable
windows
tools
MEMO: all-vocabs-seq ( -- seq )\r
all-vocabs values concat ;\r
\r
-: dangerous? ( name -- ? )\r
- #! Hack\r
- {\r
- { [ "cpu." ?head ] [ t ] }\r
- { [ "io.unix" ?head ] [ t ] }\r
- { [ "io.windows" ?head ] [ t ] }\r
- { [ "ui.x11" ?head ] [ t ] }\r
- { [ "ui.windows" ?head ] [ t ] }\r
- { [ "ui.cocoa" ?head ] [ t ] }\r
- { [ "cocoa" ?head ] [ t ] }\r
- { [ "core-foundation" ?head ] [ t ] }\r
- { [ "vocabs.loader.test" ?head ] [ t ] }\r
- { [ "editors." ?head ] [ t ] }\r
- { [ ".windows" ?tail ] [ t ] }\r
- { [ ".unix" ?tail ] [ t ] }\r
- { [ "unix" ?head ] [ t ] }\r
- { [ ".linux" ?tail ] [ t ] }\r
- { [ ".bsd" ?tail ] [ t ] }\r
- { [ ".macosx" ?tail ] [ t ] }\r
- { [ "windows." ?head ] [ t ] }\r
- { [ "cocoa" ?head ] [ t ] }\r
- { [ ".test" ?tail ] [ t ] }\r
- { [ "raptor" ?head ] [ t ] }\r
- { [ dup "tools.deploy.app" = ] [ t ] }\r
- [ f ]\r
- } cond nip ;\r
-\r
-: filter-dangerous ( seq -- seq' )\r
- [ vocab-name dangerous? not ] filter ;\r
+: unportable? ( name -- ? )\r
+ vocab-tags "unportable" swap member? ;\r
+\r
+: filter-unportable ( seq -- seq' )\r
+ [ vocab-name unportable? not ] filter ;\r
\r
: try-everything ( -- failures )\r
all-vocabs-seq\r
- filter-dangerous\r
+ filter-unportable\r
require-all ;\r
\r
: load-everything ( -- )\r
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
-windows\r
-com\r
-bindings\r
+unportable
+windows
+com
+bindings
-windows\r
-com\r
-bindings\r
+unportable
+windows
+com
+bindings
+unportable
windows
com
bindings
--- /dev/null
+unportable
+unportable
windows
bindings
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
+unportable
windows
bindings
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
+unportable
input
gamepads
joysticks
+unportable
gamepads
joysticks
mac
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien arrays cpu.architecture cpu.arm.assembler
+cpu.arm.architecture cpu.arm5.assembler kernel kernel.private
+math math.private namespaces sequences words quotations
+byte-arrays hashtables.private hashtables generator
+generator.registers generator.fixup sequences.private
+strings.private ;
+IN: cpu.arm4
+
+: (%char-slot)
+ "out" operand string-offset MOV
+ "out" operand dup "n" operand 2 <LSR> ADD ;
+
+\ char-slot [
+ (%char-slot)
+ "out" operand "obj" operand "out" operand <+> LDRH
+ "out" operand dup %tag-fixnum
+] H{
+ { +input+ { { f "n" } { f "obj" } } }
+ { +scratch+ { { f "out" } } }
+ { +output+ { "out" } }
+} define-intrinsic
+
+\ set-char-slot [
+ "val" operand dup %untag-fixnum
+ (%char-slot)
+ "val" operand "obj" operand "out" operand <+> STRH
+] H{
+ { +input+ { { f "val" } { f "n" } { f "obj" } } }
+ { +scratch+ { { f "out" } } }
+ { +clobber+ { "val" } }
+} define-intrinsic
+
+\ alien-signed-1 [ LDRSB ]
+\ set-alien-signed-1 [ STRB ]
+define-alien-integer-intrinsics
+
+\ alien-unsigned-2 [ LDRH ]
+\ set-alien-unsigned-2 [ STRH ]
+define-alien-integer-intrinsics
+
+\ alien-signed-2 [ LDRSH ]
+\ set-alien-signed-2 [ STRH ]
+define-alien-integer-intrinsics
--- /dev/null
+Slava Pestov
--- /dev/null
+Additional compiler intrinsics for ARM4
--- /dev/null
+! Copyright (C) 2006, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel cpu.architecture cpu.arm.assembler
+cpu.arm.architecture namespaces math sequences
+generator generator.registers generator.fixup system layouts
+alien ;
+IN: cpu.arm.allot
+
+: load-zone-ptr ( reg -- ) "nursery" f rot %alien-global ;
+
+: %allot ( header size -- )
+ #! Store a pointer to 'size' bytes allocated from the
+ #! nursery in R11
+ 8 align ! align the size
+ R12 load-zone-ptr ! nusery -> r12
+ 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-fixnum MOV ! compute header
+ R12 R11 0 <+> STR ! store header
+ ;
+
+: %store-tagged ( reg tag -- )
+ >r dup fresh-object v>operand R11 r> tag-number ORR ;
+
+: %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 R11 cell <+> STR ! store the length
+ ;
+
+: %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 reg.
+ [
+ "end" define-label
+ ! is it zero?
+ dup v>operand 0 CMP
+ 0 >bignum pick EQ load-literal
+ "end" get EQ B
+ ! ! it is non-zero
+ 1 %allot-bignum
+ ! is the fixnum negative?
+ dup v>operand 0 CMP
+ ! negative sign
+ R12 1 LT MOV
+ ! negate fixnum
+ dup v>operand dup 0 LT RSB
+ ! positive sign
+ R12 0 GE MOV
+ ! store sign
+ R12 R11 2 cells <+> STR
+ ! store the number
+ v>operand R11 3 cells <+> STR
+ ! tag the bignum, store it in reg
+ bignum %store-tagged
+ "end" resolve-label
+ ] with-scope ;
+
+M: arm-backend %box-alien ( dst src -- )
+ "end" define-label
+ dup v>operand 0 CMP
+ over v>operand 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 MOV
+ ! 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 ;
--- /dev/null
+Slava Pestov
--- /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 -- ? )
+ wince? [ drop f ] [ 4 <= ] if ;
+
+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 -- ) BIN: 111 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 wince? not ;
+
+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 ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! 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.assembler
+cpu.arm.intrinsics generator generator.registers continuations
+compiler io vocabs.loader sequences system ;
+
+! EABI passes floats in integer registers.
+[ alien-float ]
+[ >r >r >float r> r> set-alien-float ]
+4
+"box_float"
+"to_float" <primitive-type>
+"float" define-primitive-type
+
+[ >float ] "float" c-type set-c-type-prep
+
+[ alien-double ]
+[ >r >r >float r> r> set-alien-double ]
+8
+"box_double"
+"to_double" <primitive-type> <long-long-type>
+"double" define-primitive-type
+
+[ >float ] "double" c-type set-c-type-prep
+
+T{ arm-backend } compiler-backend set-global
+
+! 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 [
+ "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 arm3." print
+ "==========" print
+ "arm3" "arm-variant" set-global
+] if
+
+"arm-variant" get { "arm4" "arm4t" "arm5" } member? [
+ "cpu.arm.4" require
+] when
+
+"arm-variant" get { "arm4t" "arm5" } member? [
+ t have-BX? set-global
+] when
+
+"arm-variant" get "arm5" = [
+ t have-BLX? set-global
+] when
+
+7 cells profiler-prologues set-global
--- /dev/null
+IN: cpu.arm.assembler.tests
+USING: assembler-arm math test namespaces sequences kernel
+quotations ;
+
+: test-opcode [ { } make first ] curry unit-test ;
+
+[ HEX: ea000000 ] [ 0 B ] test-opcode
+[ HEX: eb000000 ] [ 0 BL ] test-opcode
+! [ HEX: e12fff30 ] [ R0 BLX ] test-opcode
+
+[ HEX: e24cc004 ] [ IP IP 4 SUB ] test-opcode
+[ HEX: e24cb004 ] [ FP IP 4 SUB ] test-opcode
+[ HEX: e087e3ac ] [ LR R7 IP 7 <LSR> ADD ] test-opcode
+[ HEX: e08c0109 ] [ R0 IP R9 2 <LSL> ADD ] test-opcode
+[ HEX: 02850004 ] [ R0 R5 4 EQ ADD ] test-opcode
+[ HEX: 00000000 ] [ R0 R0 R0 EQ AND ] test-opcode
+
+[ HEX: e1a0c00c ] [ IP IP MOV ] test-opcode
+[ HEX: e1a0c00d ] [ IP SP MOV ] test-opcode
+[ HEX: e3a03003 ] [ R3 3 MOV ] test-opcode
+[ HEX: e1a00003 ] [ R0 R3 MOV ] test-opcode
+[ HEX: e1e01c80 ] [ R1 R0 25 <LSL> MVN ] test-opcode
+[ HEX: e1e00ca1 ] [ R0 R1 25 <LSR> MVN ] test-opcode
+[ HEX: 11a021ac ] [ R2 IP 3 <LSR> NE MOV ] test-opcode
+
+[ HEX: e3530007 ] [ R3 7 CMP ] test-opcode
+
+[ HEX: e008049a ] [ R8 SL R4 MUL ] test-opcode
+
+[ HEX: e5151004 ] [ R1 R5 4 <-> LDR ] test-opcode
+[ HEX: e41c2004 ] [ R2 IP 4 <-!> LDR ] test-opcode
+[ HEX: e50e2004 ] [ R2 LR 4 <-> STR ] test-opcode
+
+[ HEX: e7910002 ] [ R0 R1 R2 <+> LDR ] test-opcode
+[ HEX: e7910102 ] [ R0 R1 R2 2 <LSL> <+> LDR ] test-opcode
+
+[ HEX: e1d310bc ] [ R1 R3 12 <+> LDRH ] test-opcode
+[ HEX: e1d310fc ] [ R1 R3 12 <+> LDRSH ] test-opcode
+[ HEX: e1d310dc ] [ R1 R3 12 <+> LDRSB ] test-opcode
+[ HEX: e1c310bc ] [ R1 R3 12 <+> STRH ] test-opcode
+[ HEX: e19310b4 ] [ R1 R3 R4 <+> LDRH ] test-opcode
+[ HEX: e1f310fc ] [ R1 R3 12 <!+> LDRSH ] test-opcode
+[ HEX: e1b310d4 ] [ R1 R3 R4 <!+> LDRSB ] test-opcode
+[ HEX: e0c317bb ] [ R1 R3 123 <+!> STRH ] test-opcode
+[ HEX: e08310b4 ] [ R1 R3 R4 <+!> STRH ] test-opcode
--- /dev/null
+! 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 ;
+IN: cpu.arm.assembler
+
+: define-registers ( seq -- )
+ dup length [ "register" set-word-prop ] 2each ;
+
+SYMBOL: R0
+SYMBOL: R1
+SYMBOL: R2
+SYMBOL: R3
+SYMBOL: R4
+SYMBOL: R5
+SYMBOL: R6
+SYMBOL: R7
+SYMBOL: R8
+SYMBOL: R9
+SYMBOL: R10
+SYMBOL: R11
+SYMBOL: R12
+SYMBOL: R13
+SYMBOL: R14
+SYMBOL: R15
+
+{ R0 R1 R2 R3 R4 R5 R6 R7 R8 R9 R10 R11 R12 R13 R14 R15 }
+define-registers
+
+PREDICATE: register < word register >boolean ;
+
+GENERIC: register ( register -- n )
+M: word register "register" word-prop ;
+M: f register drop 0 ;
+
+: SL R10 ; inline : FP R11 ; inline : IP R12 ; inline
+: SP R13 ; inline : LR R14 ; inline : PC R15 ; inline
+
+! Condition codes
+SYMBOL: cond-code
+
+: >CC ( n -- )
+ cond-code set ;
+
+: CC> ( -- n )
+ #! Default value is BIN: 1110 AL (= always)
+ cond-code [ f ] change BIN: 1110 or ;
+
+: EQ BIN: 0000 >CC ;
+: NE BIN: 0001 >CC ;
+: CS BIN: 0010 >CC ;
+: CC BIN: 0011 >CC ;
+: LO BIN: 0100 >CC ;
+: PL BIN: 0101 >CC ;
+: VS BIN: 0110 >CC ;
+: VC BIN: 0111 >CC ;
+: HI BIN: 1000 >CC ;
+: LS BIN: 1001 >CC ;
+: GE BIN: 1010 >CC ;
+: LT BIN: 1011 >CC ;
+: GT BIN: 1100 >CC ;
+: LE BIN: 1101 >CC ;
+: AL BIN: 1110 >CC ;
+: NV BIN: 1111 >CC ;
+
+: (insn) ( n -- ) CC> 28 shift bitor , ;
+
+: insn ( bitspec -- ) bitfield (insn) ; inline
+
+! Branching instructions
+GENERIC# (B) 1 ( signed-imm-24 l -- )
+
+M: integer (B) { 24 { 1 25 } { 0 26 } { 1 27 } 0 } insn ;
+M: word (B) 0 swap (B) rc-relative-arm-3 rel-word ;
+M: label (B) 0 swap (B) rc-relative-arm-3 label-fixup ;
+
+: B 0 (B) ; : BL 1 (B) ;
+
+! Data processing instructions
+SYMBOL: updates-cond-code
+
+: S ( -- ) updates-cond-code on ;
+
+: S> ( -- ? ) updates-cond-code [ f ] change ;
+
+: sinsn ( bitspec -- )
+ bitfield S> [ 20 2^ bitor ] when (insn) ; inline
+
+GENERIC# shift-imm/reg 2 ( shift-imm/Rs Rm shift -- n )
+
+M: integer shift-imm/reg ( shift-imm Rm shift -- n )
+ { { 0 4 } 5 { register 0 } 7 } bitfield ;
+
+M: register shift-imm/reg ( Rs Rm shift -- n )
+ {
+ { 1 4 }
+ { 0 7 }
+ 5
+ { register 8 }
+ { register 0 }
+ } bitfield ;
+
+GENERIC: shifter-op ( shifter-op -- n )
+
+TUPLE: IMM immed rotate ;
+C: <IMM> IMM
+
+M: IMM shifter-op
+ dup IMM-immed swap IMM-rotate
+ { { 1 25 } 8 0 } bitfield ;
+
+TUPLE: shifter Rm by shift ;
+C: <shifter> shifter
+
+M: shifter shifter-op
+ dup shifter-by over shifter-Rm rot shifter-shift
+ shift-imm/reg ;
+
+: <LSL> ( Rm shift-imm/Rs -- shifter-op ) BIN: 00 <shifter> ;
+: <LSR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 01 <shifter> ;
+: <ASR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 10 <shifter> ;
+: <ROR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 11 <shifter> ;
+: <RRX> ( Rm -- shifter-op ) 0 <ROR> ;
+
+M: register shifter-op 0 <LSL> shifter-op ;
+
+M: integer shifter-op 0 <IMM> shifter-op ;
+
+: addr1 ( Rd Rn shifter-op opcode -- )
+ {
+ 21 ! opcode
+ { shifter-op 0 }
+ { register 16 } ! Rn
+ { register 12 } ! Rd
+ } sinsn ;
+
+: AND BIN: 0000 addr1 ;
+: EOR BIN: 0001 addr1 ;
+: SUB BIN: 0010 addr1 ;
+: RSB BIN: 0011 addr1 ;
+: ADD BIN: 0100 addr1 ;
+: ADC BIN: 0101 addr1 ;
+: SBC BIN: 0110 addr1 ;
+: RSC BIN: 0111 addr1 ;
+: ORR BIN: 1100 addr1 ;
+: BIC BIN: 1110 addr1 ;
+
+: MOV f swap BIN: 1101 addr1 ;
+: MVN f swap BIN: 1111 addr1 ;
+
+! These always update the condition code flags
+: (CMP) >r f -rot r> S addr1 ;
+
+: TST BIN: 1000 (CMP) ;
+: TEQ BIN: 1001 (CMP) ;
+: CMP BIN: 1010 (CMP) ;
+: CMN BIN: 1011 (CMP) ;
+
+! Multiply instructions
+: (MLA) ( Rd Rm Rs Rn a -- )
+ {
+ 21
+ { register 12 }
+ { register 8 }
+ { register 0 }
+ { register 16 }
+ { 1 7 }
+ { 1 4 }
+ } sinsn ;
+
+: MUL ( Rd Rm Rs -- ) f 0 (MLA) ;
+: MLA ( Rd Rm Rs Rn -- ) 1 (MLA) ;
+
+: (S/UMLAL) ( RdLo RdHi Rm Rs s a -- )
+ {
+ { 1 23 }
+ 22
+ 21
+ { register 8 }
+ { register 0 }
+ { register 16 }
+ { register 12 }
+ { 1 7 }
+ { 1 4 }
+ } sinsn ;
+
+: SMLAL 1 1 (S/UMLAL) ; : SMULL 1 0 (S/UMLAL) ;
+: UMLAL 0 1 (S/UMLAL) ; : UMULL 0 0 (S/UMLAL) ;
+
+! Miscellaneous arithmetic instructions
+: CLZ ( Rd Rm -- )
+ {
+ { 1 24 }
+ { 1 22 }
+ { 1 21 }
+ { BIN: 111 16 }
+ { BIN: 1111 8 }
+ { 1 4 }
+ { register 0 }
+ { register 12 }
+ } sinsn ;
+
+! Status register acess instructions
+
+! Load and store instructions
+GENERIC: addressing-mode-2 ( addressing-mode -- n )
+
+TUPLE: addressing p u w ;
+: <addressing> ( delegate p u w -- addressing )
+ {
+ set-delegate
+ set-addressing-p
+ set-addressing-u
+ set-addressing-w
+ } addressing construct ;
+
+M: addressing addressing-mode-2
+ {
+ addressing-p addressing-u addressing-w delegate
+ } get-slots addressing-mode-2
+ { 0 21 23 24 } bitfield ;
+
+M: integer addressing-mode-2 ;
+
+M: object addressing-mode-2 shifter-op { { 1 25 } 0 } bitfield ;
+
+! Offset
+: <+> 1 1 0 <addressing> ;
+: <-> 1 0 0 <addressing> ;
+
+! Pre-indexed
+: <!+> 1 1 1 <addressing> ;
+: <!-> 1 0 1 <addressing> ;
+
+! Post-indexed
+: <+!> 0 1 0 <addressing> ;
+: <-!> 0 0 0 <addressing> ;
+
+: addr2 ( Rd Rn addressing-mode b l -- )
+ {
+ { 1 26 }
+ 20
+ 22
+ { addressing-mode-2 0 }
+ { register 16 }
+ { register 12 }
+ } insn ;
+
+: LDR 0 1 addr2 ;
+: LDRB 1 1 addr2 ;
+: STR 0 0 addr2 ;
+: STRB 1 0 addr2 ;
+
+! We might have to simulate these instructions since older ARM
+! chips don't have them.
+SYMBOL: have-BX?
+SYMBOL: have-BLX?
+
+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 (BX) ] [ 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
+
+! Semaphore instructions
+
+! Exception-generating instructions
--- /dev/null
+Slava Pestov
--- /dev/null
+Slava Pestov
--- /dev/null
+! 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 compiler.units ;
+IN: bootstrap.arm
+
+! We generate ARM3 code
+f have-BX? set
+
+4 \ cell set
+big-endian off
+
+4 jit-code-format set
+
+: ds-reg R5 ;
+
+: word-reg R0 ;
+: quot-reg R0 ;
+: scan-reg R2 ;
+: temp-reg R3 ;
+: xt-reg R12 ;
+
+: stack-frame 16 bootstrap-cells ;
+
+: next-save stack-frame 2 bootstrap-cells - ;
+: xt-save stack-frame 3 bootstrap-cells - ;
+: array-save stack-frame 4 bootstrap-cells - ;
+: scan-save stack-frame 5 bootstrap-cells - ;
+
+[
+ temp-reg quot-reg quot-array@ <+> LDR ! load array
+ scan-reg temp-reg scan@ ADD ! initialize scan pointer
+] { } make jit-setup set
+
+[
+ LR SP 4 <-> STR ! save return address
+ SP SP stack-frame SUB
+ xt-reg SP xt-save <+> STR ! save XT
+ xt-reg stack-frame MOV
+ xt-reg SP next-save <+> STR ! save frame size
+ temp-reg SP array-save <+> STR ! save array
+] { } make jit-prolog set
+
+[
+ temp-reg scan-reg 4 <!+> LDR ! load literal and advance
+ temp-reg ds-reg 4 <!+> STR ! push literal
+] { } make jit-push-literal set
+
+[
+ temp-reg scan-reg 4 <!+> LDR ! load wrapper and advance
+ temp-reg dup wrapper@ <+> LDR ! load wrapped object
+ temp-reg ds-reg 4 <!+> STR ! push wrapped object
+] { } make jit-push-wrapper set
+
+[
+ R1 SP 4 SUB ! pass stack pointer to primitive
+] { } make jit-word-primitive-jump set
+
+[
+ R1 SP 4 SUB ! pass stack pointer to primitive
+] { } make jit-word-primitive-call set
+
+: load-word-xt ( -- )
+ word-reg scan-reg 4 <!+> LDR ! load word and advance
+ xt-reg word-reg word-xt@ <+> LDR ;
+
+: jit-call
+ scan-reg SP scan-save <+> STR ! save scan pointer
+ LR PC MOV ! save return address
+ xt-reg BX ! call
+ scan-reg SP scan-save <+> LDR ! restore scan pointer
+ ;
+
+: jit-jump
+ xt-reg BX ;
+
+[ load-word-xt jit-call ] { } make jit-word-call set
+
+[ load-word-xt jit-jump ] { } make jit-word-jump set
+
+: load-quot-xt
+ xt-reg quot-reg quot-xt@ <+> LDR ;
+
+: load-branch
+ temp-reg ds-reg 4 <-!> LDR ! pop boolean
+ temp-reg \ f tag-number CMP ! compare it with f
+ quot-reg scan-reg MOV ! point quot-reg at false branch
+ quot-reg dup 4 EQ ADD ! point quot-reg at true branch
+ quot-reg dup 4 <+> LDR ! load the branch
+ scan-reg dup 12 ADD ! advance scan pointer
+ load-quot-xt
+ ;
+
+[
+ load-branch jit-jump
+] { } make jit-if-jump set
+
+[
+ load-branch jit-call
+] { } make jit-if-call set
+
+[
+ temp-reg ds-reg 4 <-!> LDR ! pop index
+ temp-reg dup 1 <LSR> MOV ! turn it into an array offset
+ scan-reg dup 4 <+> LDR ! load array
+ temp-reg dup scan-reg ADD ! compute quotation location
+ quot-reg temp-reg array-start <+> LDR ! load quotation
+ load-quot-xt
+ jit-jump
+] { } make jit-dispatch set
+
+[
+ SP SP stack-frame ADD ! pop stack frame
+ LR SP 4 <-> LDR ! load return address
+] { } make jit-epilog set
+
+[ LR BX ] { } make jit-return set
+
+[ "bootstrap.arm" forget-vocab ] with-compilation-unit
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien arrays cpu.architecture cpu.arm.assembler
+cpu.arm.architecture cpu.arm.allot kernel kernel.private math
+math.private namespaces sequences words
+quotations byte-arrays hashtables.private hashtables generator
+generator.registers generator.fixup sequences.private sbufs
+sbufs.private vectors vectors.private system
+classes.tuple.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
+ "scratch" operand "obj" operand %untag
+ "val" operand "scratch" operand "n" get cells <+> ;
+
+: %slot-any
+ "scratch" operand "obj" operand %untag
+ "n" operand dup 1 <LSR> MOV
+ "val" operand "scratch" 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
+ {
+ [ %slot-literal-any-tag LDR ] H{
+ { +input+ { { f "obj" } { [ small-slot? ] "n" } } }
+ { +scratch+ { { f "scratch" } { f "val" } } }
+ { +output+ { "val" } }
+ }
+ }
+ ! Slot number in a register
+ {
+ [ %slot-any LDR ] H{
+ { +input+ { { f "obj" } { f "n" } } }
+ { +scratch+ { { f "val" } { f "scratch" } } }
+ { +output+ { "val" } }
+ { +clobber+ { "n" } }
+ }
+ }
+} define-intrinsics
+
+: %write-barrier ( -- )
+ "val" get operand-immediate? "obj" get fresh-object? or [
+ "cards_offset" f R12 %alien-global
+ "scratch" operand R12 "obj" operand card-bits <LSR> ADD
+ "val" operand "scratch" operand 0 <+> LDRB
+ "val" operand dup card-mark ORR
+ "val" operand "scratch" operand 0 <+> STRB
+ ] 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
+ {
+ [ %slot-literal-any-tag STR %write-barrier ] H{
+ { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
+ { +scratch+ { { f "scratch" } } }
+ { +clobber+ { "val" } }
+ }
+ }
+ ! Slot number is in a register
+ {
+ [ %slot-any STR %write-barrier ] H{
+ { +input+ { { f "val" } { f "obj" } { f "n" } } }
+ { +scratch+ { { f "scratch" } } }
+ { +clobber+ { "val" "n" } }
+ }
+ }
+} define-intrinsics
+
+: fixnum-op ( op -- quot )
+ [ "out" operand "x" operand "y" operand ] swap add ;
+
+: fixnum-register-op ( op -- pair )
+ fixnum-op H{
+ { +input+ { { f "x" } { f "y" } } }
+ { +scratch+ { { f "out" } } }
+ { +output+ { "out" } }
+ } 2array ;
+
+: fixnum-value-op ( op -- pair )
+ fixnum-op H{
+ { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
+ { +scratch+ { { f "out" } } }
+ { +output+ { "out" } }
+ } 2array ;
+
+: define-fixnum-op ( word op -- )
+ [ fixnum-value-op ] keep fixnum-register-op 2array
+ define-intrinsics ;
+
+{
+ { fixnum+fast ADD }
+ { fixnum-fast SUB }
+ { fixnum-bitand AND }
+ { fixnum-bitor ORR }
+ { fixnum-bitxor EOR }
+} [
+ first2 define-fixnum-op
+] each
+
+\ fixnum-bitnot [
+ "x" operand dup MVN
+ "x" operand dup %untag
+] H{
+ { +input+ { { f "x" } } }
+ { +output+ { "x" } }
+} define-intrinsic
+
+\ fixnum*fast [
+ "out" operand "y" operand %untag-fixnum
+ "out" operand "x" operand "out" operand MUL
+] H{
+ { +input+ { { f "x" } { f "y" } } }
+ { +scratch+ { { f "out" } } }
+ { +output+ { "out" } }
+} define-intrinsic
+
+\ fixnum-shift [
+ "out" operand "x" operand "y" get neg <ASR> MOV
+ ! Mask off low bits
+ "out" operand dup %untag
+] H{
+ { +input+ { { f "x" } { [ -31 0 between? ] "y" } } }
+ { +scratch+ { { f "out" } } }
+ { +output+ { "out" } }
+} define-intrinsic
+
+: %untag-fixnums ( seq -- )
+ [ dup %untag-fixnum ] unique-operands ;
+
+: overflow-check ( insn -- )
+ [
+ "end" define-label
+ [ "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
+ "out" get "x" get %allot-bignum-signed-1
+ "end" resolve-label
+ ] with-scope ; inline
+
+: overflow-template ( word insn -- )
+ [ overflow-check ] curry H{
+ { +input+ { { f "x" } { f "y" } } }
+ { +scratch+ { { f "out" } } }
+ { +output+ { "out" } }
+ { +clobber+ { "x" "y" } }
+ } define-intrinsic ;
+
+\ fixnum+ \ ADD overflow-template
+\ fixnum- \ SUB overflow-template
+
+\ fixnum>bignum [
+ "x" operand dup %untag-fixnum
+ "out" get "x" get %allot-bignum-signed-1
+] H{
+ { +input+ { { f "x" } } }
+ { +scratch+ { { f "out" } } }
+ { +clobber+ { "x" } }
+ { +output+ { "out" } }
+} define-intrinsic
+
+\ bignum>fixnum [
+ "end" define-label
+ "x" operand dup %untag
+ "y" operand "x" operand cell <+> LDR
+ ! if the length is 1, its just the sign and nothing else,
+ ! so output 0
+ "y" operand 1 v>operand CMP
+ "y" operand 0 EQ MOV
+ "end" get EQ B
+ ! load the value
+ "y" operand "x" operand 3 cells <+> LDR
+ ! load the sign
+ "x" operand "x" operand 2 cells <+> LDR
+ ! is the sign negative?
+ "x" operand 0 CMP
+ ! Negate the value
+ "y" operand "y" operand 0 NE RSB
+ "y" operand dup %tag-fixnum
+ "end" resolve-label
+] H{
+ { +input+ { { f "x" } } }
+ { +scratch+ { { f "y" } } }
+ { +clobber+ { "x" } }
+ { +output+ { "y" } }
+} define-intrinsic
+
+: fixnum-jump ( op -- quo )
+ [ "x" operand "y" operand CMP ] swap
+ 1quotation [ B ] 3append ;
+
+: fixnum-register-jump ( op -- pair )
+ fixnum-jump { { f "x" } { f "y" } } 2array ;
+
+: fixnum-value-jump ( op -- pair )
+ fixnum-jump { { f "x" } { [ small-tagged? ] "y" } } 2array ;
+
+: define-fixnum-jump ( word op -- )
+ [ fixnum-value-jump ] keep fixnum-register-jump
+ 2array define-if-intrinsics ;
+
+{
+ { fixnum< LT }
+ { fixnum<= LE }
+ { fixnum> GT }
+ { fixnum>= GE }
+ { eq? EQ }
+} [
+ first2 define-fixnum-jump
+] each
+
+\ tag [
+ "out" operand "in" operand tag-mask get AND
+ "out" operand dup %tag-fixnum
+] H{
+ { +input+ { { f "in" } } }
+ { +scratch+ { { f "out" } } }
+ { +output+ { "out" } }
+} 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
+ "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).
+ "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 "out" } } }
+ { +output+ { "out" } }
+} define-intrinsic
+
+: userenv ( reg -- )
+ #! Load the userenv pointer in a register.
+ "userenv" f rot compile-dlsym ;
+
+\ getenv [
+ "n" operand dup 1 <ASR> MOV
+ "x" operand userenv
+ "x" operand "x" operand "n" operand <+> LDR
+] H{
+ { +input+ { { f "n" } } }
+ { +scratch+ { { f "x" } } }
+ { +output+ { "x" } }
+ { +clobber+ { "n" } }
+} define-intrinsic
+
+\ setenv [
+ "n" operand dup 1 <ASR> MOV
+ "x" operand userenv
+ "val" operand "x" operand "n" operand <+> STR
+] H{
+ { +input+ { { f "val" } { f "n" } } }
+ { +scratch+ { { f "x" } } }
+ { +clobber+ { "n" } }
+} define-intrinsic
+
+: %set-slot R11 swap cells <+> STR ;
+
+: %store-length
+ R12 "n" operand MOV
+ R12 1 %set-slot ;
+
+: %fill-array swap 2 + %set-slot ;
+
+\ <tuple> [
+ tuple "n" get 2 + cells %allot
+ %store-length
+ ! Store class
+ "class" operand 2 %set-slot
+ ! Zero out the rest of the tuple
+ "initial" operand f v>operand MOV
+ "n" get 1- [ 1+ "initial" operand %fill-array ] each
+ "out" get tuple %store-tagged
+] H{
+ { +input+ { { f "class" } { [ inline-array? ] "n" } } }
+ { +scratch+ { { f "out" } { f "initial" } } }
+ { +output+ { "out" } }
+} define-intrinsic
+
+\ <array> [
+ array "n" get 2 + cells %allot
+ %store-length
+ ! Store initial element
+ "n" get [ "initial" operand %fill-array ] each
+ "out" get object %store-tagged
+] H{
+ { +input+ { { [ inline-array? ] "n" } { f "initial" } } }
+ { +scratch+ { { f "out" } } }
+ { +output+ { "out" } }
+} define-intrinsic
+
+\ <byte-array> [
+ byte-array "n" get 2 cells + %allot
+ %store-length
+ ! Store initial element
+ R12 0 MOV
+ "n" get cell align cell /i [ R12 %fill-array ] each
+ "out" get object %store-tagged
+] H{
+ { +input+ { { [ inline-array? ] "n" } } }
+ { +scratch+ { { f "out" } } }
+ { +output+ { "out" } }
+} define-intrinsic
+
+\ <ratio> [
+ ratio 3 cells %allot
+ "numerator" operand 1 %set-slot
+ "denominator" operand 2 %set-slot
+ "out" get ratio %store-tagged
+] H{
+ { +input+ { { f "numerator" } { f "denominator" } } }
+ { +scratch+ { { f "out" } } }
+ { +output+ { "out" } }
+} define-intrinsic
+
+\ <complex> [
+ complex 3 cells %allot
+ "real" operand 1 %set-slot
+ "imaginary" operand 2 %set-slot
+ ! Store tagged ptr in reg
+ "out" get complex %store-tagged
+] H{
+ { +input+ { { f "real" } { f "imaginary" } } }
+ { +scratch+ { { f "out" } } }
+ { +output+ { "out" } }
+} define-intrinsic
+
+\ <wrapper> [
+ wrapper 2 cells %allot
+ "obj" operand 1 %set-slot
+ ! Store tagged ptr in reg
+ "out" get object %store-tagged
+] H{
+ { +input+ { { f "obj" } } }
+ { +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+ {
+ { unboxed-c-ptr "alien" c-ptr }
+ { f "offset" fixnum }
+ } }
+ { +scratch+ { { f "value" } } }
+ { +output+ { "value" } }
+ { +clobber+ { "offset" } }
+ } ;
+
+: %alien-integer-get ( quot -- )
+ %alien-accessor
+ "value" operand dup %tag-fixnum ; inline
+
+: alien-integer-set-template
+ H{
+ { +input+ {
+ { f "value" fixnum }
+ { unboxed-c-ptr "alien" c-ptr }
+ { f "offset" fixnum }
+ } }
+ { +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
+ define-intrinsic
+ [ %alien-integer-get ] curry
+ alien-integer-get-template
+ define-intrinsic ;
+
+\ alien-unsigned-1 [ LDRB ]
+\ set-alien-unsigned-1 [ STRB ]
+define-alien-integer-intrinsics
+
+: 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
--- /dev/null
+ARM3 compiler backend