From d2ec46e38ffc31844b423906be9749146be75615 Mon Sep 17 00:00:00 2001 From: sheeple Date: Thu, 6 Nov 2008 06:27:27 -0600 Subject: [PATCH] PowerPC backend almost functional; some new compiler unit tests added, better compilation of 'f eq?'; f becomes an immediate operand move aux-offset to compiler.constants --- .../cfg/intrinsics/alien/alien.factor | 2 +- .../cfg/intrinsics/fixnum/fixnum.factor | 9 +- .../cfg/intrinsics/slots/slots.factor | 4 +- basis/compiler/cfg/utilities/utilities.factor | 16 +- basis/compiler/constants/constants.factor | 71 +++++---- basis/compiler/tests/intrinsics.factor | 32 +++- basis/cpu/ppc/ppc.factor | 149 +++++++++--------- basis/cpu/x86/x86.factor | 4 +- 8 files changed, 161 insertions(+), 126 deletions(-) diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor index 6b9bc9fcce..42e23c29c9 100644 --- a/basis/compiler/cfg/intrinsics/alien/alien.factor +++ b/basis/compiler/cfg/intrinsics/alien/alien.factor @@ -15,7 +15,7 @@ IN: compiler.cfg.intrinsics.alien : prepare-alien-accessor ( infos -- offset-vreg ) [ second class>> ] [ first ] bi - dup value-info-small-tagged? [ + dup value-info-small-fixnum? [ literal>> (prepare-alien-accessor-imm) ] [ drop (prepare-alien-accessor) ] if ; diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index 12a3ef8597..04c9097725 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -9,7 +9,10 @@ IN: compiler.cfg.intrinsics.fixnum : (emit-fixnum-imm-op) ( infos insn -- dst ) ds-drop - [ ds-pop ] [ second literal>> tag-fixnum ] [ ] tri* + [ ds-pop ] + [ second literal>> [ tag-fixnum ] [ \ f tag-number ] if* ] + [ ] + tri* call ; inline : (emit-fixnum-op) ( insn -- dst ) @@ -25,7 +28,7 @@ IN: compiler.cfg.intrinsics.fixnum ] ; inline : emit-fixnum-shift-fast ( node -- ) - dup node-input-infos dup second value-info-small-tagged? [ + dup node-input-infos dup second value-info-small-fixnum? [ nip [ ds-drop ds-pop ] dip second literal>> dup sgn { @@ -48,7 +51,7 @@ IN: compiler.cfg.intrinsics.fixnum : emit-fixnum*fast ( node -- ) node-input-infos - dup second value-info-small-tagged? + dup second value-info-small-fixnum? [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if ds-push ; diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor index 22fb4e747b..fec234a576 100644 --- a/basis/compiler/cfg/intrinsics/slots/slots.factor +++ b/basis/compiler/cfg/intrinsics/slots/slots.factor @@ -25,7 +25,7 @@ IN: compiler.cfg.intrinsics.slots dup node-input-infos dup first value-tag [ nip - dup second value-info-small-tagged? + dup second value-info-small-fixnum? [ (emit-slot-imm) ] [ (emit-slot) ] if ds-push ] [ drop emit-primitive ] if ; @@ -46,7 +46,7 @@ IN: compiler.cfg.intrinsics.slots dup second value-tag [ nip [ - dup third value-info-small-tagged? + dup third value-info-small-fixnum? [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if ] [ first class>> immediate class<= ] bi [ drop ] [ i i ##write-barrier ] if diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index b00fd0ed3d..cef14d06e4 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -1,12 +1,24 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math layouts make sequences +USING: accessors kernel math layouts make sequences combinators cpu.architecture namespaces compiler.cfg compiler.cfg.instructions ; IN: compiler.cfg.utilities +: value-info-small-fixnum? ( value-info -- ? ) + literal>> { + { [ dup fixnum? ] [ tag-fixnum small-enough? ] } + [ drop f ] + } cond ; + : value-info-small-tagged? ( value-info -- ? ) - literal>> dup fixnum? [ tag-fixnum small-enough? ] [ drop f ] if ; + dup literal?>> [ + literal>> { + { [ dup fixnum? ] [ tag-fixnum small-enough? ] } + { [ dup not ] [ drop t ] } + [ drop f ] + } cond + ] [ drop f ] if ; : set-basic-block ( basic-block -- ) [ basic-block set ] [ instructions>> building set ] bi ; diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index b5b2be5095..cd68602768 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -1,49 +1,50 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math kernel layouts system ; +USING: math kernel layouts system strings ; IN: compiler.constants ! These constants must match vm/memory.h -: card-bits 8 ; -: deck-bits 18 ; -: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ; +: card-bits 8 ; inline +: deck-bits 18 ; inline +: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ; inline ! These constants must match vm/layouts.h -: header-offset ( -- n ) object tag-number neg ; -: float-offset ( -- n ) 8 float tag-number - ; -: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; -: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; -: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; -: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; -: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; -: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; -: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; -: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; -: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ; -: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; -: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; -: compiled-header-size ( -- n ) 4 bootstrap-cells ; +: header-offset ( -- n ) object tag-number neg ; inline +: float-offset ( -- n ) 8 float tag-number - ; inline +: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline +: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline +: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline +: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline +: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline +: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline +: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline +: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline +: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline +: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline +: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline +: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline +: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline ! Relocation classes -: rc-absolute-cell 0 ; -: rc-absolute 1 ; -: rc-relative 2 ; -: rc-absolute-ppc-2/2 3 ; -: rc-relative-ppc-2 4 ; -: rc-relative-ppc-3 5 ; -: rc-relative-arm-3 6 ; -: rc-indirect-arm 7 ; -: rc-indirect-arm-pc 8 ; +: rc-absolute-cell 0 ; inline +: rc-absolute 1 ; inline +: rc-relative 2 ; inline +: rc-absolute-ppc-2/2 3 ; inline +: rc-relative-ppc-2 4 ; inline +: rc-relative-ppc-3 5 ; inline +: rc-relative-arm-3 6 ; inline +: rc-indirect-arm 7 ; inline +: rc-indirect-arm-pc 8 ; inline ! Relocation types -: rt-primitive 0 ; -: rt-dlsym 1 ; -: rt-literal 2 ; -: rt-dispatch 3 ; -: rt-xt 4 ; -: rt-here 5 ; -: rt-label 6 ; -: rt-immediate 7 ; +: rt-primitive 0 ; inline +: rt-dlsym 1 ; inline +: rt-literal 2 ; inline +: rt-dispatch 3 ; inline +: rt-xt 4 ; inline +: rt-here 5 ; inline +: rt-label 6 ; inline +: rt-immediate 7 ; inline : rc-absolute? ( n -- ? ) [ rc-absolute-ppc-2/2 = ] diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index e012a42cc0..c90a31fc61 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -4,7 +4,8 @@ continuations sequences.private hashtables.private byte-arrays strings.private system random layouts vectors sbufs strings.private slots.private alien math.order alien.accessors alien.c-types alien.syntax alien.strings -namespaces libc sequences.private io.encodings.ascii ; +namespaces libc sequences.private io.encodings.ascii +classes ; IN: compiler.tests ! Make sure that intrinsic ops compile to correct code. @@ -27,6 +28,9 @@ IN: compiler.tests [ 1 ] [ { 1 2 } [ 2 slot ] compile-call ] unit-test [ 1 ] [ [ { 1 2 } 2 slot ] compile-call ] unit-test + +[ { f f } ] [ 2 f ] unit-test + [ 3 ] [ 3 1 2 2array [ { array } declare [ 2 set-slot ] keep ] compile-call first ] unit-test [ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-call first ] unit-test [ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-call first ] unit-test @@ -37,13 +41,19 @@ IN: compiler.tests ! Write barrier hits on the wrong value were causing segfaults [ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test -! [ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test -! [ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test -! [ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test -! -! [ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test -! [ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test -! [ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test +[ CHAR: a ] [ 0 "abc" [ string-nth ] compile-call ] unit-test +[ CHAR: a ] [ 0 [ "abc" string-nth ] compile-call ] unit-test +[ CHAR: a ] [ [ 0 "abc" string-nth ] compile-call ] unit-test +[ CHAR: b ] [ 1 "abc" [ string-nth ] compile-call ] unit-test +[ CHAR: b ] [ 1 [ "abc" string-nth ] compile-call ] unit-test +[ CHAR: b ] [ [ 1 "abc" string-nth ] compile-call ] unit-test + +[ HEX: 123456 ] [ 0 "\u123456bc" [ string-nth ] compile-call ] unit-test +[ HEX: 123456 ] [ 0 [ "\u123456bc" string-nth ] compile-call ] unit-test +[ HEX: 123456 ] [ [ 0 "\u123456bc" string-nth ] compile-call ] unit-test +[ HEX: 123456 ] [ 1 "a\u123456c" [ string-nth ] compile-call ] unit-test +[ HEX: 123456 ] [ 1 [ "a\u123456c" string-nth ] compile-call ] unit-test +[ HEX: 123456 ] [ [ 1 "a\u123456c" string-nth ] compile-call ] unit-test [ ] [ [ 0 getenv ] compile-call drop ] unit-test [ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test @@ -158,6 +168,10 @@ IN: compiler.tests [ 4 ] [ 1 [ 3 fixnum+fast ] compile-call ] unit-test [ 4 ] [ [ 1 3 fixnum+fast ] compile-call ] unit-test +[ -2 ] [ 1 3 [ fixnum-fast ] compile-call ] unit-test +[ -2 ] [ 1 [ 3 fixnum-fast ] compile-call ] unit-test +[ -2 ] [ [ 1 3 fixnum-fast ] compile-call ] unit-test + [ 30001 ] [ 1 [ 30000 fixnum+fast ] compile-call ] unit-test [ 6 ] [ 2 3 [ fixnum*fast ] compile-call ] unit-test @@ -263,6 +277,8 @@ cell 8 = [ : compiled-fixnum>bignum fixnum>bignum ; +[ bignum ] [ 0 compiled-fixnum>bignum class ] unit-test + [ ] [ 10000 [ 32 random-bits >fixnum diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 77c4320f0c..ad6c63b8c9 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -1,21 +1,10 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types -accessors -cpu.architecture -compiler.cfg.registers -cpu.ppc.assembler -kernel -locals -layouts -combinators -make -compiler.cfg.instructions -math.order -system -math -compiler.constants -namespaces compiler.codegen.fixup ; +USING: accessors assocs sequences kernel combinators make math +math.order math.ranges system namespaces locals layouts words +alien alien.c-types cpu.architecture cpu.ppc.assembler +compiler.cfg.registers compiler.cfg.instructions +compiler.constants compiler.codegen compiler.codegen.fixup ; IN: cpu.ppc ! PowerPC register assignments: @@ -57,13 +46,13 @@ M:: ppc %load-indirect ( reg obj -- ) obj rc-absolute-ppc-2/2 rel-literal reg reg 0 LWZ ; -: ds-reg 30 ; inline -: rs-reg 31 ; inline +: ds-reg 29 ; inline +: rs-reg 30 ; inline GENERIC: loc-reg ( loc -- reg ) -M: ds-loc log-reg drop ds-reg ; -M: rs-loc log-reg drop rs-reg ; +M: ds-loc loc-reg drop ds-reg ; +M: rs-loc loc-reg drop rs-reg ; : loc>operand ( loc -- reg n ) [ loc-reg ] [ n>> cells neg ] bi ; inline @@ -137,9 +126,25 @@ M: ppc %slot-imm ( dst obj slot tag -- ) (%slot-imm) LWZ ; M: ppc %set-slot ( src obj slot tag temp -- ) (%slot) STW ; M: ppc %set-slot-imm ( src obj slot tag -- ) (%slot-imm) STW ; +M:: ppc %string-nth ( dst src index temp -- ) + [ + "end" define-label + temp src index ADD + dst temp string-offset LBZ + temp src string-aux-offset LWZ + 0 temp \ f tag-number CMPI + "end" get BEQ + temp temp index ADD + temp temp index ADD + temp temp byte-array-offset LHZ + temp temp 8 SLWI + dst dst temp OR + "end" resolve-label + ] with-scope ; + M: ppc %add ADD ; M: ppc %add-imm ADDI ; -M: ppc %sub swapd SUBF ; +M: ppc %sub swap SUBF ; M: ppc %sub-imm SUBI ; M: ppc %mul MULLW ; M: ppc %mul-imm MULLI ; @@ -156,44 +161,42 @@ M: ppc %not NOT ; : bignum@ ( n -- offset ) cells bignum tag-number - ; inline -M: ppc %integer>bignum ( dst src temp -- ) +M:: ppc %integer>bignum ( dst src temp -- ) [ - { "end" "non-zero" "pos" "store" } [ define-label ] each - dst 0 >bignum %load-immediate + "end" define-label + dst 0 >bignum %load-indirect ! Is it zero? Then just go to the end and return this zero 0 src 0 CMPI "end" get BEQ ! Allocate a bignum dst 4 cells bignum temp %allot ! Write length - 2 temp LI - dst 1 bignum@ temp STW - ! Store value - dst 3 bignum@ src STW + 2 tag-fixnum temp LI + temp dst 1 bignum@ STW ! Compute sign temp src MR - temp cell-bits 1- SRAWI + temp temp cell-bits 1- SRAWI temp temp 1 ANDI ! Store sign - dst 2 bignum@ temp STW + temp dst 2 bignum@ STW ! Make negative value positive temp temp temp ADD temp temp NEG temp temp 1 ADDI temp src temp MULLW ! Store the bignum - dst 3 bignum@ temp STW + temp dst 3 bignum@ STW "end" resolve-label ] with-scope ; -M:: %bignum>integer ( dst src temp -- ) +M:: ppc %bignum>integer ( dst src temp -- ) [ "end" define-label temp src 1 bignum@ LWZ ! if the length is 1, its just the sign and nothing else, ! so output 0 0 dst LI - 0 temp 1 v>operand CMPI + 0 temp 1 tag-fixnum CMPI "end" get BEQ ! load the value dst src 3 bignum@ LWZ @@ -203,6 +206,7 @@ M:: %bignum>integer ( dst src temp -- ) ! and 1 into -1 temp temp temp ADD temp temp 1 SUBI + temp temp NEG ! multiply value by sign dst dst temp MULLW "end" resolve-label @@ -213,14 +217,14 @@ M: ppc %sub-float FSUB ; M: ppc %mul-float FMUL ; M: ppc %div-float FDIV ; -M: ppc %integer>float ( dst src -- ) +M:: ppc %integer>float ( dst src -- ) HEX: 4330 scratch-reg LIS scratch-reg 1 0 param@ STW scratch-reg src MR scratch-reg dup HEX: 8000 XORIS scratch-reg 1 cell param@ STW fp-scratch-reg-2 1 0 param@ LFD - 4503601774854144.0 scratch-reg load-indirect + scratch-reg 4503601774854144.0 %load-indirect fp-scratch-reg-2 scratch-reg float-offset LFD fp-scratch-reg-2 fp-scratch-reg-2 fp-scratch-reg-2 FSUB ; @@ -231,7 +235,7 @@ M:: ppc %float>integer ( dst src -- ) M: ppc %copy ( dst src -- ) MR ; -M: ppc %copy-float ( dst src -- ) MFR ; +M: ppc %copy-float ( dst src -- ) FMR ; M: ppc %unbox-float ( dst src -- ) float-offset LFD ; @@ -277,9 +281,9 @@ M:: ppc %box-alien ( dst src temp -- ) "f" get BEQ dst 4 cells alien temp %allot ! Store offset - dst src 3 alien@ STW - temp \ f tag-number %load-immediate + src dst 3 alien@ STW ! Store expired slot + temp \ f tag-number %load-immediate temp dst 1 alien@ STW ! Store underlying-alien slot temp dst 2 alien@ STW @@ -289,7 +293,7 @@ M:: ppc %box-alien ( dst src temp -- ) M: ppc %alien-unsigned-1 0 LBZ ; M: ppc %alien-unsigned-2 0 LHZ ; -M: ppc %alien-signed-1 dupd 0 LBZ EXTSB ; +M: ppc %alien-signed-1 dupd 0 LBZ dup EXTSB ; M: ppc %alien-signed-2 0 LHA ; M: ppc %alien-cell 0 LWZ ; @@ -297,45 +301,47 @@ M: ppc %alien-cell 0 LWZ ; M: ppc %alien-float 0 LFS ; M: ppc %alien-double 0 LFD ; -M: ppc %set-alien-integer-1 0 STB ; -M: ppc %set-alien-integer-2 0 STH ; +M: ppc %set-alien-integer-1 swap 0 STB ; +M: ppc %set-alien-integer-2 swap 0 STH ; -M: ppc %set-alien-cell 0 STW ; +M: ppc %set-alien-cell swap 0 STW ; -M: ppc %set-alien-float 0 STFS ; -M: ppc %set-alien-double 0 STFD ; +M: ppc %set-alien-float swap 0 STFS ; +M: ppc %set-alien-double swap 0 STFD ; + +: %load-dlsym ( symbol dll register -- ) + 0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ; : load-zone-ptr ( reg -- ) [ "nursery" f ] dip %load-dlsym ; : load-allot-ptr ( nursery-ptr allot-ptr -- ) - [ drop load-zone-ptr ] [ swap cell LWZ ] 2bi ; + [ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ; -:: inc-allot-ptr ( nursery-ptr n -- ) - scratch-reg inc-allot-ptr 4 LWZ - scratch-reg scratch-reg n 8 align ADD - scratch-reg inc-allot-ptr 4 STW ; +:: inc-allot-ptr ( nursery-ptr allot-ptr n -- ) + scratch-reg allot-ptr n 8 align ADDI + scratch-reg nursery-ptr 4 STW ; -:: store-header ( temp class -- ) +:: store-header ( dst class -- ) class type-number tag-fixnum scratch-reg LI - temp scratch-reg 0 STW ; + scratch-reg dst 0 STW ; : store-tagged ( dst tag -- ) dupd tag-number ORI ; M:: ppc %allot ( dst size class nursery-ptr -- ) nursery-ptr dst load-allot-ptr + nursery-ptr dst size inc-allot-ptr dst class store-header - dst class store-tagged - nursery-ptr size inc-allot-ptr ; + dst class store-tagged ; -: %alien-global ( dest name -- ) - [ f swap %load-dlsym ] [ drop dup 0 LWZ ] 2bi ; +: %alien-global ( dst name -- ) + [ f rot %load-dlsym ] [ drop dup 0 LWZ ] 2bi ; -: load-cards-offset ( dest -- ) +: load-cards-offset ( dst -- ) "cards_offset" %alien-global ; -: load-decks-offset ( dest -- ) +: load-decks-offset ( dst -- ) "decks_offset" %alien-global ; M:: ppc %write-barrier ( src card# table -- ) @@ -359,18 +365,17 @@ M: ppc %gc 11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here 11 0 12 CMP ! is here >= end? "end" get BLE - 0 frame-required %prepare-alien-invoke "minor_gc" f %alien-invoke "end" resolve-label ; M: ppc %prologue ( n -- ) - 0 scrach-reg LOAD32 rc-absolute-ppc-2/2 rel-this + 0 scratch-reg LOAD32 rc-absolute-ppc-2/2 rel-this 0 MFLR 1 1 pick neg ADDI - scrach-reg 1 pick xt-save STW - dup scrach-reg LI - scrach-reg 1 pick next-save STW + scratch-reg 1 pick xt-save STW + dup scratch-reg LI + scratch-reg 1 pick next-save STW 0 1 rot lr-save + STW ; M: ppc %epilogue ( n -- ) @@ -384,19 +389,19 @@ M: ppc %epilogue ( n -- ) :: (%boolean) ( dst word -- ) "end" define-label - \ f tag-number %load-immediate + dst \ f tag-number %load-immediate "end" get word execute dst \ t %load-indirect "end" get resolve-label ; inline : %boolean ( dst cc -- ) negate-cc { - { cc< [ \ BLT %boolean ] } - { cc<= [ \ BLE %boolean ] } - { cc> [ \ BGT %boolean ] } - { cc>= [ \ BGE %boolean ] } - { cc= [ \ BEQ %boolean ] } - { cc/= [ \ BNE %boolean ] } + { cc< [ \ BLT (%boolean) ] } + { cc<= [ \ BLE (%boolean) ] } + { cc> [ \ BGT (%boolean) ] } + { cc>= [ \ BGE (%boolean) ] } + { cc= [ \ BEQ (%boolean) ] } + { cc/= [ \ BNE (%boolean) ] } } case ; : (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline @@ -426,7 +431,7 @@ M: ppc %compare-float-branch (%compare-float) %branch ; : stack@ 1 swap ; inline -: spill-integer@ ( n -- op ) +: spill-integer@ ( n -- reg offset ) cells stack-frame get spill-integer-base + stack@ ; @@ -437,7 +442,7 @@ M: ppc %compare-float-branch (%compare-float) %branch ; [ return>> ] tri + + ; -: spill-float@ ( n -- op ) +: spill-float@ ( n -- reg offset ) double-float-regs reg-size * stack-frame get spill-float-base + stack@ ; @@ -560,7 +565,7 @@ M: ppc %alien-invoke ( symbol dll -- ) 11 %load-dlsym 11 MTLR BLRL ; M: ppc %alien-callback ( quot -- ) - 3 load-indirect "c_to_factor" f %alien-invoke ; + 3 swap %load-indirect "c_to_factor" f %alien-invoke ; M: ppc %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 0e00ce60ee..8ae3bddfaa 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -293,15 +293,13 @@ M:: x86 %box-alien ( dst src temp -- ) [ quot call ] with-save/restore ] if ; inline -: aux-offset 2 cells string tag-number - ; inline - M:: x86 %string-nth ( dst src index temp -- ) "end" define-label dst { src index temp } [| new-dst | temp src index [+] LEA new-dst 1 small-reg temp string-offset [+] MOV new-dst new-dst 1 small-reg MOVZX - temp src aux-offset [+] MOV + temp src string-aux-offset [+] MOV temp \ f tag-number CMP "end" get JE new-dst temp XCHG