diff --git a/core/cpu/arm5/intrinsics/intrinsics.factor b/core/cpu/arm/4/4.factor old mode 100644 new mode 100755 similarity index 98% rename from core/cpu/arm5/intrinsics/intrinsics.factor rename to core/cpu/arm/4/4.factor index d6f651b0e2..0d317fd553 --- a/core/cpu/arm5/intrinsics/intrinsics.factor +++ b/core/cpu/arm/4/4.factor @@ -6,7 +6,7 @@ math math.private namespaces sequences words quotations byte-arrays hashtables.private hashtables generator generator.registers generator.fixup sequences.private strings.private ; -IN: cpu.arm5.intrinsics +IN: cpu.arm4 : (%char-slot) "out" operand string-offset MOV diff --git a/core/cpu/arm5/authors.txt b/core/cpu/arm/4/authors.txt similarity index 100% rename from core/cpu/arm5/authors.txt rename to core/cpu/arm/4/authors.txt diff --git a/core/cpu/arm/4/summary.txt b/core/cpu/arm/4/summary.txt new file mode 100644 index 0000000000..7be5231690 --- /dev/null +++ b/core/cpu/arm/4/summary.txt @@ -0,0 +1 @@ +Additional compiler intrinsics for ARM4 diff --git a/core/cpu/arm/5/5.factor b/core/cpu/arm/5/5.factor new file mode 100755 index 0000000000..ae07345cd1 --- /dev/null +++ b/core/cpu/arm/5/5.factor @@ -0,0 +1,3 @@ +USING: cpu.arm.assembler cpu.arm4 namespaces ; + +t have-BLX? set-global diff --git a/core/cpu/arm/5/authors.txt b/core/cpu/arm/5/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/core/cpu/arm/5/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/core/cpu/arm5/summary.txt b/core/cpu/arm/5/summary.txt similarity index 100% rename from core/cpu/arm5/summary.txt rename to core/cpu/arm/5/summary.txt diff --git a/core/cpu/arm/allot/allot.factor b/core/cpu/arm/allot/allot.factor index 2081a07f35..c70c1090c2 100755 --- a/core/cpu/arm/allot/allot.factor +++ b/core/cpu/arm/allot/allot.factor @@ -8,31 +8,28 @@ IN: cpu.arm.allot : load-zone-ptr ( reg -- ) "nursery" f rot %alien-global ; -: object@ "allot-tmp" operand swap cells <+> ; - : %allot ( header size -- ) #! Store a pointer to 'size' bytes allocated from the - #! nursery in allot-tmp. + #! nursery in R11 8 align ! align the size R12 load-zone-ptr ! nusery -> r12 - "allot-tmp" operand R12 cell <+> LDR ! nursery.here -> allot-tmp - "allot-tmp" operand dup pick ADD ! increment allot-tmp - "allot-tmp" operand R12 cell <+> STR ! allot-tmp -> nursery.here - "allot-tmp" operand dup rot SUB ! old value + 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-header MOV ! compute header - R12 0 object@ STR ! store header + R12 R11 0 <+> STR ! store header ; -: %tag-allot ( tag -- ) - "allot-tmp" operand dup rot tag-number ORR - "allot-tmp" get fresh-object ; +: %store-tagged ( reg tag -- ) + >r dup fresh-object v>operand R11 r> tag-number ORI ; : %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 1 object@ STR ! store the length + R12 R11 cell <+> STR ! store the length ; : %allot-bignum-signed-1 ( reg -- ) @@ -43,7 +40,7 @@ IN: cpu.arm.allot "end" define-label ! is it zero? dup v>operand 0 CMP - 0 >bignum "allot-tmp" operand EQ load-indirect + 0 >bignum over EQ load-literal "end" get EQ B ! ! it is non-zero 1 %allot-bignum @@ -56,29 +53,27 @@ IN: cpu.arm.allot ! positive sign R12 0 GE MOV ! store sign - R12 2 object@ STR + R12 R11 2 cells <+> STR ! store the number - v>operand 3 object@ STR + dup v>operand R11 3 cells <+> STR ! tag the bignum, store it in reg bignum %tag-allot "end" resolve-label ] with-scope ; -: %allot-alien ( ptr -- ) - #! Tagged pointer to alien is in allot-tmp on exit. - [ - "temp" set - "end" define-label - "temp" operand 0 CMP - "allot-tmp" operand f v>operand EQ MOV - "end" get EQ B - alien 4 cells %allot - "temp" operand 2 object@ STR - "temp" operand f v>operand MOV - "temp" operand 1 object@ STR - "temp" operand 0 MOV - "temp" operand 3 object@ STR - ! Store tagged ptr in reg - object %tag-allot - "end" resolve-label - ] with-scope ; +M: arm-backend %box-alien ( dst src -- ) + "end" define-label + dup v>operand 0 CMP + over 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 R12 + ! 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 ; diff --git a/core/cpu/arm/architecture/architecture.factor b/core/cpu/arm/architecture/architecture.factor index 527daed7c4..7e077b4a22 100755 --- a/core/cpu/arm/architecture/architecture.factor +++ b/core/cpu/arm/architecture/architecture.factor @@ -9,8 +9,8 @@ IN: cpu.arm.architecture TUPLE: arm-backend ; ! ARM register assignments: -! R0, R1, R2, R3 integer vregs -! R12 temporary +! R0-R4, R7-R10 integer vregs +! R11, R12 temporary ! R5 data stack ! R6 retain stack ! R7 primitives @@ -22,7 +22,7 @@ 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 R11 } ; +M: int-regs vregs drop { R0 R1 R2 R3 R4 R7 R8 R9 R10 } ; ! No FPU support yet M: float-regs param-regs drop { } ; @@ -44,15 +44,27 @@ M: immediate load-literal v>operand load-indirect ] if ; -M: arm-backend stack-frame ( n -- i ) 4 + 8 align ; +: 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: ppc-backend %save-xt ( -- ) + R12 PC 8 SUB ; M: arm-backend %prologue ( n -- ) - LR SP 4 <-> STR - SP SP rot stack-frame SUB ; + SP SP pick SUB + R11 over LI + R11 SP pick next-save <+> STR + R12 SP rot xt-save <+> STR + LR SP pick lr-save <+> STR ; M: arm-backend %epilogue ( n -- ) - SP SP rot stack-frame ADD - LR SP 4 <-> LDR ; + LR SP lr-save <+> LDR + SP SP rot stack-frame ADD ; : compile-dlsym ( symbol dll reg -- ) [ @@ -83,26 +95,32 @@ M: arm-backend %profiler-prologue ( word -- ) R0 R12 profile-count-offset <+> STR "end" resolve-label ; -: primitive-addr ( word dst -- ) - #! Load a word address into dst. - R7 rot word-primitive cells <+> LDR ; +M: arm-backend %call-label ( label -- ) BL ; -M: arm-backend %call ( label -- ) - #! Far C call for primitives, near C call for compiled defs. - dup primitive? [ R0 primitive-addr R0 BLX ] [ BL ] if ; +M: arm-backend %jump-label ( label -- ) B ; -M: arm-backend %jump-label ( label -- ) - #! For tail calls. IP not saved on C stack. - #! WARNING: don't clobber LR here! - dup primitive? [ PC primitive-addr ] [ B ] if ; +: %load-xt ( word -- ) + 0 swap LOAD32 rc-absolute-ppc-2/2 rel-word ; + +: %prepare-primitive ( word -- ) + #! Save stack pointer to stack_chain->callstack_top, load XT + R1 SP MOV + T{ temp-reg } load-literal + R12 R12 word-xt-offset <+> LDR ; + +M: arm-backend %call-primitive ( word -- ) + %prepare-primitive R12 BLX ; + +M: arm-backend %jump-primitive ( word -- ) + %prepare-primitive R12 BX ; M: arm-backend %jump-t ( label -- ) - "flag" operand object tag-number CMP NE B ; + "flag" operand f v>operand CMP NE B ; : (%dispatch) ( word-table# reg -- ) #! Load jump table target address into reg. - "n" operand PC "n" operand 1 ADD - "n" operand 0 <+> LDR + "scratch" operand PC "n" operand 1 ADD + "scratch" operand 0 <+> LDR rc-indirect-arm rel-dispatch ; M: arm-backend %call-dispatch ( word-table# -- ) @@ -112,7 +130,6 @@ M: arm-backend %call-dispatch ( word-table# -- ) ] H{ { +input+ { { f "n" } } } { +scratch+ { { f "scratch" } } } - { +clobber+ { "n" } } } with-template ; M: arm-backend %jump-dispatch ( word-table# -- ) @@ -121,7 +138,7 @@ M: arm-backend %jump-dispatch ( word-table# -- ) PC (%dispatch) ] H{ { +input+ { { f "n" } } } - { +clobber+ { "n" } } + { +scratch+ { { f "scratch" } } } } with-template ; M: arm-backend %return ( -- ) %epilogue-later PC LR MOV ; @@ -134,9 +151,6 @@ M: arm-backend %unwind drop %return ; M: int-regs (%peek) \ LDR (%peek/replace) ; M: int-regs (%replace) \ STR (%peek/replace) ; -M: arm-backend %move-int>int ( dst src -- ) - [ v>operand ] 2apply MOV ; - : (%inc) ( n reg -- ) dup rot cells dup 0 < [ neg SUB ] [ ADD ] if ; @@ -215,11 +229,13 @@ M: arm-backend %box-small-struct ( size -- ) 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* swap - cell - + stack-frame* factor-area-size - swap - ] ?if ; M: arm-backend %prepare-box-struct ( size -- ) @@ -239,6 +255,15 @@ M: arm-backend %box-large-struct ( n size -- ) M: arm-backend struct-small-enough? ( size -- ? ) wince? [ drop f ] [ 4 <= ] if ; +M: ppc-backend %prepare-alien-invoke + #! Save Factor stack pointers in case the C code calls a + #! callback which does a GC, which must reliably trace + #! all roots. + "stack_chain" f R12 %alien-global + SP R12 0 <+> STR + ds-reg 11 8 <+> STR + rs-reg 11 12 <+> STR ; + M: arm-backend %alien-invoke ( symbol dll -- ) ! Load target address R12 PC 4 <+> LDR @@ -249,15 +274,13 @@ M: arm-backend %alien-invoke ( symbol dll -- ) ! The target address 0 , rc-absolute rel-dlsym ; -: temp@ SP stack-frame* 2 cells - <+> ; - M: arm-backend %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke - R0 temp@ STR ; + R0 SP cell temp@ <+> STR ; M: arm-backend %alien-indirect ( -- ) - IP temp@ LDR - IP BLX ; + R12 SP cell temp@ <+> LDR + R12 BLX ; M: arm-backend %alien-callback ( quot -- ) R0 load-indirect @@ -266,11 +289,11 @@ M: arm-backend %alien-callback ( quot -- ) M: arm-backend %callback-value ( ctype -- ) ! Save top of data stack %prepare-unbox - R0 temp@ STR + R0 SP cell temp@ <+> STR ! Restore data/call/retain stacks "unnest_stacks" f %alien-invoke ! Place former top of data stack in R0 - R0 temp@ LDR + R0 SP cell temp@ <+> LDR ! Unbox R0 unbox-return ; diff --git a/core/cpu/arm/arm.factor b/core/cpu/arm/arm.factor old mode 100644 new mode 100755 index 111044a552..afe6411d97 --- a/core/cpu/arm/arm.factor +++ b/core/cpu/arm/arm.factor @@ -24,27 +24,29 @@ vocabs.loader ; T{ arm-backend } compiler-backend set-global -: (detect-arm5) ; - -\ (detect-arm5) [ - ! The LDRH word is defined in the module we conditionally - ! load below... - ! R0 PC 0 <+> LDRH - HEX: e1df00b0 , -] H{ - { +scratch+ { { 0 "scratch" } } } -} define-intrinsic - -: detect-arm5 (detect-arm5) ; - -: arm5? ( -- ? ) [ detect-arm5 ] catch not ; +! 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 [ - \ detect-arm5 compile - "Detecting ARM architecture variant..." print - arm5? "arm5" "arm3" ? "arm-variant" set -] unless + "ARM variant: " write "arm-variant" get print +] [ + "==========" print + "You should specify the -arm-variant= switch." print + " can be one of arm3, arm4, arm4t, or arm5." print + "Assuming arm4t." print + "==========" print + "arm4t" "arm-variant" set +] if -"ARM architecture variant: " write "arm-variant" get print +"arm-variant" get { "arm4" "arm4t" "arm5" } member? [ + "cpu.arm.4" require +] when -"arm-variant" "arm5" = [ "cpu.arm5" require ] when +"arm-variant" get { "arm4t" "arm5" } member? [ + t have-BX? set-global +] when + +"arm-variant" get "arm5" = [ + t have-BLX? set-global +] when diff --git a/core/cpu/arm/assembler/assembler.factor b/core/cpu/arm/assembler/assembler.factor old mode 100644 new mode 100755 index 0152380547..e61e02ae8d --- a/core/cpu/arm/assembler/assembler.factor +++ b/core/cpu/arm/assembler/assembler.factor @@ -4,8 +4,6 @@ USING: arrays generator generator.fixup kernel sequences words namespaces math math.bitfields ; IN: cpu.arm.assembler -SYMBOL: arm-variant - : define-registers ( seq -- ) dup length [ "register" set-word-prop ] 2each ; @@ -253,15 +251,77 @@ M: object addressing-mode-2 shifter-op { { 1 25 } 0 } bitfield ; : STR 0 0 addr2 ; : STRB 1 0 addr2 ; -HOOK: BX arm-variant ( operand -- ) - -HOOK: BLX arm-variant ( operand -- ) - ! We might have to simulate these instructions since older ARM ! chips don't have them. -M: f BX PC swap MOV ; +SYMBOL: have-BX? +SYMBOL: have-BLX? -M: f BLX LR PC MOV BX ; +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 (BLX) ] [ 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 diff --git a/core/cpu/arm/bootstrap.factor b/core/cpu/arm/bootstrap.factor index 3054a0bb85..4f67255305 100755 --- a/core/cpu/arm/bootstrap.factor +++ b/core/cpu/arm/bootstrap.factor @@ -1,9 +1,11 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system -cpu.arm.assembler math layouts words vocabs ; +cpu.arm.assembler cpu.arm5.assembler math layouts words vocabs ; IN: bootstrap.arm +T{ arm5-variant } arm-variant set-global + 4 \ cell set big-endian off @@ -17,7 +19,7 @@ big-endian off : temp-reg R3 ; : xt-reg R12 ; -: stack-frame 8 bootstrap-cells ; +: stack-frame 16 bootstrap-cells ; : next-save stack-frame 2 bootstrap-cells - ; : xt-save stack-frame 3 bootstrap-cells - ; diff --git a/core/cpu/arm/intrinsics/intrinsics.factor b/core/cpu/arm/intrinsics/intrinsics.factor index 218cdc9fb9..18cfb7d3de 100755 --- a/core/cpu/arm/intrinsics/intrinsics.factor +++ b/core/cpu/arm/intrinsics/intrinsics.factor @@ -9,27 +9,45 @@ sbufs.private vectors vectors.private system tuples.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 + "obj" operand "scratch" operand %untag + "val" operand "scratch" operand "n" get cells <+> ; + +: %slot-any + "obj" operand "scratch" operand %untag + "n" operand dup 1 MOV + "scratch" operand "val" 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 { - [ - "out" operand "obj" operand %untag - "out" operand dup "n" get cells <+> LDR - ] H{ + [ %slot-literal-any-tag LDR ] H{ { +input+ { { f "obj" } { [ small-slot? ] "n" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } + { +scratch+ { { f "scratch" } { f "val" } } } + { +output+ { "val" } } } } ! Slot number in a register { - [ - "out" operand "obj" operand %untag - "out" operand dup "n" operand 1 <+> LDR - ] H{ + [ %slot-any LDR ] H{ { +input+ { { f "obj" } { f "n" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } + { +scratch+ { { f "val" } { f "scratch" } } } + { +output+ { "val" } } + { +clobber+ { "n" } } } } } define-intrinsics @@ -44,13 +62,17 @@ IN: cpu.arm.intrinsics ] 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 { - [ - "scratch" operand "obj" operand %untag - "val" operand "scratch" operand "n" get cells <+> STR - generate-write-barrier - ] H{ + [ %slot-literal-any-tag STR %write-barrier ] H{ { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } } { +scratch+ { { f "scratch" } } } { +clobber+ { "val" } } @@ -58,12 +80,7 @@ IN: cpu.arm.intrinsics } ! Slot number is in a register { - [ - "scratch" operand "obj" operand %untag - "n" operand "scratch" operand "n" operand 1 ADD - "val" operand "n" operand 0 STR - generate-write-barrier - ] H{ + [ %slot-any STR %write-barrier ] H{ { +input+ { { f "val" } { f "obj" } { f "n" } } } { +scratch+ { { f "scratch" } } } { +clobber+ { "val" "n" } } @@ -135,7 +152,7 @@ IN: cpu.arm.intrinsics : overflow-check ( insn -- ) [ "end" define-label - [ "allot-tmp" operand "x" operand "y" operand roll S execute ] keep + [ "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 @@ -146,8 +163,8 @@ IN: cpu.arm.intrinsics : overflow-template ( word insn -- ) [ overflow-check ] curry H{ { +input+ { { f "x" } { f "y" } } } - { +scratch+ { { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } { +clobber+ { "x" "y" } } } define-intrinsic ; @@ -159,9 +176,9 @@ IN: cpu.arm.intrinsics "x" get %allot-bignum-signed-1 ] H{ { +input+ { { f "x" } } } - { +scratch+ { { f "allot-tmp" } } } + { +scratch+ { { f "out" } } } { +clobber+ { "x" } } - { +output+ { "allot-tmp" } } + { +output+ { "out" } } } define-intrinsic \ bignum>fixnum [ @@ -224,28 +241,39 @@ IN: cpu.arm.intrinsics } 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 - "y" operand "obj" operand tag-mask get AND + "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). - "y" operand object tag-number CMP - ! Tag the tag if it is not equal to 3 - "x" operand "y" operand NE %tag-fixnum - ! Jump to end if it is not equal to 3 - "end" get NE B - ! Is the pointer itself equal to 3? Then its F_TYPE (9). - "obj" operand object tag-number CMP - ! Load F_TYPE (9) if it is equal - "x" operand f type v>operand EQ MOV - ! Load the object header if it is not equal - "x" operand "obj" operand object tag-number <-> NE LDR - ! Turn the header into a fixnum - "x" operand dup NE %untag + "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 "x" } { f "y" } } } - { +output+ { "x" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } } define-intrinsic : userenv ( reg -- ) @@ -273,7 +301,7 @@ IN: cpu.arm.intrinsics { +clobber+ { "n" } } } define-intrinsic -: %set-slot "allot-tmp" operand swap cells <+> STR ; +: %set-slot R11 swap cells <+> STR ; : %store-length R12 "n" operand MOV @@ -289,11 +317,11 @@ IN: cpu.arm.intrinsics ! Zero out the rest of the tuple R12 f v>operand MOV "n" get 1- [ 1+ R12 %fill-array ] each - object %tag-allot + "out" get object %store-tagged ] H{ { +input+ { { f "class" } { [ inline-array? ] "n" } } } - { +scratch+ { { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } } define-intrinsic \ [ @@ -301,11 +329,11 @@ IN: cpu.arm.intrinsics %store-length ! Store initial element "n" get [ "initial" operand %fill-array ] each - object %tag-allot + "out" get object %store-tagged ] H{ { +input+ { { [ inline-array? ] "n" } { f "initial" } } } - { +scratch+ { { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } } define-intrinsic \ [ @@ -314,22 +342,22 @@ IN: cpu.arm.intrinsics ! Store initial element R12 0 MOV "n" get cell align cell /i [ R12 %fill-array ] each - object %tag-allot + "out" get object %store-tagged ] H{ { +input+ { { [ inline-array? ] "n" } } } - { +scratch+ { { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } } define-intrinsic \ [ ratio 3 cells %allot "numerator" operand 1 %set-slot "denominator" operand 2 %set-slot - ratio %tag-allot + "out" get ratio %store-tagged ] H{ { +input+ { { f "numerator" } { f "denominator" } } } - { +scratch+ { { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } } define-intrinsic \ [ @@ -337,22 +365,22 @@ IN: cpu.arm.intrinsics "real" operand 1 %set-slot "imaginary" operand 2 %set-slot ! Store tagged ptr in reg - complex %tag-allot + "out" get complex %store-tagged ] H{ { +input+ { { f "real" } { f "imaginary" } } } - { +scratch+ { { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } } define-intrinsic \ [ wrapper 2 cells %allot "obj" operand 1 %set-slot ! Store tagged ptr in reg - wrapper %tag-allot + "out" get object %store-tagged ] H{ { +input+ { { f "obj" } } } - { +scratch+ { { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } } define-intrinsic \ (hashtable) [ @@ -362,80 +390,82 @@ IN: cpu.arm.intrinsics R12 2 %set-slot R12 3 %set-slot ! Store tagged ptr in reg - object %tag-allot + "out" get object %store-tagged ] H{ - { +scratch+ { { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } } define-intrinsic \ string>sbuf [ sbuf 3 cells %allot "length" operand 1 %set-slot "string" operand 2 %set-slot - object %tag-allot + "out" get object %store-tagged ] H{ { +input+ { { f "string" } { f "length" } } } - { +scratch+ { { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } } define-intrinsic \ array>vector [ vector 3 cells %allot "length" operand 1 %set-slot "array" operand 2 %set-slot - object %tag-allot + "out" get object %store-tagged ] H{ { +input+ { { f "array" } { f "length" } } } - { +scratch+ { { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } + { +scratch+ { { f "out" } } } + { +output+ { "out" } } } define-intrinsic \ curry [ \ curry 3 cells %allot "obj" operand 1 %set-slot "quot" operand 2 %set-slot - object %tag-allot + "out" get object %store-tagged ] H{ { +input+ { { f "obj" } { f "quot" } } } - { +scratch+ { { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } + { +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+ { - { f "alien" simple-c-ptr } + { unboxed-c-ptr "alien" c-ptr } { f "offset" fixnum } } } - { +scratch+ { { f "output" } } } - { +output+ { "output" } } + { +scratch+ { { f "value" } } } + { +output+ { "value" } } { +clobber+ { "offset" } } } ; -: %alien-get ( quot -- ) - "output" get "address" set - "output" operand "alien" operand-class %alien-accessor ; - : %alien-integer-get ( quot -- ) - %alien-get - "output" operand dup %tag-fixnum ; inline - -: %alien-integer-set ( quot -- ) - "value" operand dup %untag-fixnum - "value" operand "alien" operand-class %alien-accessor ; inline + %alien-accessor + "value" operand dup %tag-fixnum ; inline : alien-integer-set-template H{ { +input+ { { f "value" fixnum } - { f "alien" simple-c-ptr } + { unboxed-c-ptr "alien" c-ptr } { f "offset" fixnum } } } - { +scratch+ { { f "address" } } } { +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 @@ -448,15 +478,31 @@ IN: cpu.arm.intrinsics \ set-alien-unsigned-1 [ STRB ] define-alien-integer-intrinsics -\ alien-cell [ - [ LDR ] %alien-get - "output" get %allot-alien -] H{ - { +input+ { - { f "alien" simple-c-ptr } - { f "offset" fixnum } - } } - { +scratch+ { { f "output" } { f "allot-tmp" } } } - { +output+ { "allot-tmp" } } - { +clobber+ { "offset" } } -} define-intrinsic +: 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 diff --git a/core/cpu/arm5/arm5.factor b/core/cpu/arm5/arm5.factor deleted file mode 100644 index 11675f106a..0000000000 --- a/core/cpu/arm5/arm5.factor +++ /dev/null @@ -1,4 +0,0 @@ -USING: cpu.arm.assembler cpu.arm5.assembler cpu.arm5.intrinsics -namespaces ; - -T{ arm5-variant } arm-variant set-global diff --git a/core/cpu/arm5/assembler/assembler.factor b/core/cpu/arm5/assembler/assembler.factor deleted file mode 100644 index 237394af11..0000000000 --- a/core/cpu/arm5/assembler/assembler.factor +++ /dev/null @@ -1,74 +0,0 @@ -! 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 cpu.arm.assembler ; -IN: cpu.arm5.assembler - -TUPLE: arm5-variant ; - -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 ; - -M: arm5-variant BX 0 (BX) ; - -M: arm5-variant BLX 1 (BX) ; - -! 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 ; diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index 508a46b4a7..ba2f90c7ed 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -15,10 +15,8 @@ TUPLE: ppc-backend ; ! r14: data stack ! r15: retain stack -! For stack frame layout, see vm/cpu-ppc.h. - -: ds-reg 14 ; -: rs-reg 15 ; +: ds-reg 14 ; inline +: rs-reg 15 ; inline : reserved-area-size os { @@ -59,13 +57,11 @@ M: int-regs vregs } ; M: float-regs return-reg drop 1 ; - M: float-regs param-regs drop os H{ { "macosx" { 1 2 3 4 5 6 7 8 9 10 11 12 13 } } { "linux" { 1 2 3 4 5 6 7 8 } } } at ; - M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ; GENERIC: loc>operand ( loc -- reg n ) @@ -123,7 +119,7 @@ M: ppc-backend %call-label ( label -- ) BL ; M: ppc-backend %jump-label ( label -- ) B ; : %prepare-primitive ( word -- ) - ! Save stack pointer to stack_chain->callstack_top, load XT + #! Save stack pointer to stack_chain->callstack_top, load XT 4 1 MR 11 %load-xt ; : (%call) 11 MTLR BLRL ; @@ -137,7 +133,7 @@ M: ppc-backend %jump-primitive ( word -- ) %prepare-primitive (%jump) ; M: ppc-backend %jump-t ( label -- ) - 0 "flag" operand \ f tag-number CMPI BNE ; + 0 "flag" operand f v>operand CMPI BNE ; : dispatch-template ( word-table# quot -- ) [ diff --git a/core/generator/generator.factor b/core/generator/generator.factor old mode 100644 new mode 100755 index 30295b722e..380d6fd4a4 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -312,3 +312,4 @@ M: #return generate-node drop end-basic-block %return f ; : underlying-alien-offset cell object tag-number - ; : tuple-class-offset 2 cells tuple tag-number - ; : class-hash-offset cell object tag-number - ; +: word-xt-offset 8 cells object tag-number - ;