+++ /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 -- ? )
- 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 ;
+++ /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 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
-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
+! 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 -- ? )
+ 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 ;
--- /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 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
+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
projects / factor-unmaintained.git / commitdiff