From 765d36d08236f3205d2c50170617619a69b5f0ae Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Nov 2008 06:12:39 -0600 Subject: [PATCH 01/26] Fix markup problem detected by help-lint --- extra/advice/advice-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/advice/advice-docs.factor b/extra/advice/advice-docs.factor index 2b33378b99..7b523e9a8c 100644 --- a/extra/advice/advice-docs.factor +++ b/extra/advice/advice-docs.factor @@ -13,7 +13,7 @@ HELP: make-advised { $see-also advised? annotate } ; HELP: advised? -{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet word } " is advised" } } +{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet "word" } " is advised" } } { $description "Determines whether or not the given word has any advice on it." } ; ARTICLE: "advice" "Advice" From d2ec46e38ffc31844b423906be9749146be75615 Mon Sep 17 00:00:00 2001 From: sheeple Date: Thu, 6 Nov 2008 06:27:27 -0600 Subject: [PATCH 02/26] 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 From a95bb533b5d40e65a91b1ffe30182edbf752b308 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Nov 2008 09:08:17 -0600 Subject: [PATCH 03/26] Remove more redundant branches from tuple type predicates and generic words with methods on tuple classes --- core/classes/tuple/tuple.factor | 21 ++++++++++---- .../standard/engines/tuple/tuple.factor | 29 ++++++++++++++----- 2 files changed, 37 insertions(+), 13 deletions(-) diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index c2f93ead3e..a56a4df029 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -90,20 +90,29 @@ ERROR: bad-superclass class ; 2drop f ] if ; inline +: tuple-instance-1? ( object class -- ? ) + swap dup tuple? [ + layout-of 7 slot eq? + ] [ 2drop f ] if ; inline + : tuple-instance? ( object class offset -- ? ) - #! 4 slot == superclasses>> rot dup tuple? [ layout-of 2dup 1 slot fixnum<= [ swap slot eq? ] [ 3drop f ] if ] [ 3drop f ] if ; inline -: layout-class-offset ( class -- n ) - tuple-layout third 2 * 5 + ; +: layout-class-offset ( echelon -- n ) + 2 * 5 + ; + +: echelon-of ( class -- n ) + tuple-layout third ; : define-tuple-predicate ( class -- ) - dup dup layout-class-offset - [ tuple-instance? ] 2curry define-predicate ; + dup dup echelon-of { + { 1 [ [ tuple-instance-1? ] curry ] } + [ layout-class-offset [ tuple-instance? ] 2curry ] + } case define-predicate ; : class-size ( class -- n ) superclasses [ "slots" word-prop length ] sigma ; @@ -292,7 +301,7 @@ M: tuple-class reset-class M: tuple-class rank-class drop 0 ; M: tuple-class instance? - dup layout-class-offset tuple-instance? ; + dup echelon-of layout-class-offset tuple-instance? ; M: tuple-class (flatten-class) dup set ; diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index 34447fb92d..04368099fb 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -48,10 +48,14 @@ TUPLE: tuple-dispatch-engine echelons ; \ convert-methods ; M: trivial-tuple-dispatch-engine engine>quot - [ - [ n>> nth-superclass% ] - [ methods>> engines>quots* linear-dispatch-quot % ] bi - ] [ ] make ; + [ n>> ] [ methods>> ] bi dup assoc-empty? [ + 2drop default get [ drop ] prepend + ] [ + [ + [ nth-superclass% ] + [ engines>quots* linear-dispatch-quot % ] bi* + ] [ ] make + ] if ; : hash-methods ( n methods -- buckets ) >alist V{ } clone [ hashcode 1array ] distribute-buckets @@ -119,11 +123,19 @@ M: echelon-dispatch-engine engine>quot ] assoc-map alist>quot ; +: simplify-echelon-alist ( default alist -- default' alist' ) + dup empty? [ + dup first first 1 <= [ + nip unclip second swap + simplify-echelon-alist + ] when + ] unless ; + : echelon-case-quot ( alist -- quot ) #! We don't have to test for echelon 1 since all tuple #! classes are at least at depth 1 in the inheritance #! hierarchy. - dup first first 1 = [ unclip second ] [ default get ] if swap + default get swap simplify-echelon-alist [ [ picker % @@ -140,8 +152,11 @@ M: tuple-dispatch-engine engine>quot echelons>> unclip-last [ [ - engine>quot define-engine-word - [ remember-engine ] [ 1quotation ] bi + engine>quot + over 0 = [ + define-engine-word + [ remember-engine ] [ 1quotation ] bi + ] unless dup default set ] assoc-map ] From 1c1333fbe99441834639e6275c8da678f0df6bf0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Nov 2008 09:09:21 -0600 Subject: [PATCH 04/26] Compile not and >boolean as branchless intrinsics by having the CFG builder detect certain code patterns --- basis/compiler/cfg/builder/builder.factor | 29 ++++++++++++++++++++++- core/kernel/kernel.factor | 4 ++-- 2 files changed, 30 insertions(+), 3 deletions(-) diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index a59ceff5b9..5b9f2e068b 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -125,8 +125,35 @@ M: #recursive emit-node : ##branch-t ( vreg -- ) \ f tag-number cc/= ##compare-imm-branch ; +: trivial-branch? ( nodes -- value ? ) + dup length 1 = [ + first dup #push? [ literal>> t ] [ drop f f ] if + ] [ drop f f ] if ; + +: trivial-if? ( #if -- ? ) + children>> first2 + [ trivial-branch? [ t eq? ] when ] + [ trivial-branch? [ f eq? ] when ] bi* + and ; + +: emit-trivial-if ( -- ) + ds-pop \ f tag-number cc/= ^^compare-imm ds-push ; + +: trivial-not-if? ( #if -- ? ) + children>> first2 + [ trivial-branch? [ f eq? ] when ] + [ trivial-branch? [ t eq? ] when ] bi* + and ; + +: emit-trivial-not-if ( -- ) + ds-pop \ f tag-number cc= ^^compare-imm ds-push ; + M: #if emit-node - ds-pop ##branch-t emit-if iterate-next ; + { + { [ dup trivial-if? ] [ drop emit-trivial-if ] } + { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] } + [ ds-pop ##branch-t emit-if ] + } cond iterate-next ; ! #dispatch : dispatch-branch ( nodes word -- label ) diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index fae1922d29..62e37ef301 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -167,11 +167,11 @@ GENERIC: boa ( ... class -- tuple ) compose compose ; inline ! Booleans -: not ( obj -- ? ) f t ? ; inline +: not ( obj -- ? ) [ f ] [ t ] if ; inline : and ( obj1 obj2 -- ? ) over ? ; inline -: >boolean ( obj -- ? ) t f ? ; inline +: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline : or ( obj1 obj2 -- ? ) dupd ? ; inline From 64cbf619a9a2c3cee098d51eec3accb66a5211a1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Nov 2008 09:27:52 -0600 Subject: [PATCH 05/26] Add more algebraic simplifications: comparison of a comparison, comparison where first is immediate --- .../value-numbering/rewrite/rewrite.factor | 70 ++++++++++++++--- .../value-numbering-tests.factor | 76 ++++++++++++++++++- 2 files changed, 135 insertions(+), 11 deletions(-) diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor index 16a3b57829..94c3f0d6f9 100644 --- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor +++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor @@ -42,25 +42,75 @@ M: ##mul-imm rewrite : tag-fixnum-expr? ( expr -- ? ) dup op>> \ ##shl-imm eq? - [ in2>> vn>expr value>> tag-bits get = ] [ drop f ] if ; + [ in2>> vn>constant tag-bits get = ] [ drop f ] if ; : rewrite-tagged-comparison? ( insn -- ? ) #! Are we comparing two tagged fixnums? Then untag them. - dup ##compare-imm-branch? [ - [ src1>> vreg>expr tag-fixnum-expr? ] - [ src2>> tag-mask get bitand 0 = ] - bi and - ] [ drop f ] if ; inline + [ src1>> vreg>expr tag-fixnum-expr? ] + [ src2>> tag-mask get bitand 0 = ] + bi and ; inline -: rewrite-tagged-comparison ( insn -- insn' ) +: (rewrite-tagged-comparison) ( insn -- src1 src2 cc ) [ src1>> vreg>expr in1>> vn>vreg ] [ src2>> tag-bits get neg shift ] [ cc>> ] - tri - f \ ##compare-imm-branch boa ; + tri ; inline + +GENERIC: rewrite-tagged-comparison ( insn -- insn' ) + +M: ##compare-imm-branch rewrite-tagged-comparison + (rewrite-tagged-comparison) f \ ##compare-imm-branch boa ; + +M: ##compare-imm rewrite-tagged-comparison + [ dst>> ] [ (rewrite-tagged-comparison) ] bi + f \ ##compare-imm boa ; M: ##compare-imm-branch rewrite dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when - dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when ; + dup ##compare-imm-branch? [ + dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when + ] when ; + +: flip-comparison? ( insn -- ? ) + dup cc>> cc= eq? [ src1>> vreg>expr constant-expr? ] [ drop f ] if ; + +: flip-comparison ( insn -- insn' ) + [ dst>> ] + [ src2>> ] + [ src1>> vreg>vn vn>constant ] tri + cc= f \ ##compare-imm boa ; + +M: ##compare rewrite + dup flip-comparison? [ + flip-comparison + dup number-values + rewrite + ] when ; + +: rewrite-redundant-comparison? ( insn -- ? ) + [ src1>> vreg>expr compare-expr? ] + [ src2>> \ f tag-number = ] + [ cc>> { cc= cc/= } memq? ] + tri and and ; inline + +: rewrite-redundant-comparison ( insn -- insn' ) + [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri { + { \ ##compare [ >compare-expr< f \ ##compare boa ] } + { \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm boa ] } + { \ ##compare-float [ >compare-expr< f \ ##compare-float boa ] } + } case + swap cc= eq? [ [ negate-cc ] change-cc ] when ; + +M: ##compare-imm rewrite + dup rewrite-redundant-comparison? [ + rewrite-redundant-comparison + dup number-values rewrite + ] when + dup ##compare-imm? [ + dup rewrite-tagged-comparison? [ + rewrite-tagged-comparison + dup number-values rewrite + ] when + ] when ; M: insn rewrite ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index a33c2f28c4..d3be68c3c9 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -1,6 +1,6 @@ IN: compiler.cfg.value-numbering.tests USING: compiler.cfg.value-numbering compiler.cfg.instructions -compiler.cfg.registers cpu.architecture tools.test kernel ; +compiler.cfg.registers cpu.architecture tools.test kernel math ; [ { T{ ##peek f V int-regs 45 D 1 } @@ -66,3 +66,77 @@ compiler.cfg.registers cpu.architecture tools.test kernel ; T{ ##replace f V int-regs 3 D 0 } } value-numbering ] unit-test + +[ + { + T{ ##load-indirect f V int-regs 1 + } + T{ ##peek f V int-regs 2 D 0 } + T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> } + T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> } + T{ ##replace f V int-regs 4 D 0 } + } +] [ + { + T{ ##load-indirect f V int-regs 1 + } + T{ ##peek f V int-regs 2 D 0 } + T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> } + T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= } + T{ ##replace f V int-regs 6 D 0 } + } value-numbering +] unit-test + +[ + { + T{ ##load-indirect f V int-regs 1 + } + T{ ##peek f V int-regs 2 D 0 } + T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= } + T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> } + T{ ##replace f V int-regs 6 D 0 } + } +] [ + { + T{ ##load-indirect f V int-regs 1 + } + T{ ##peek f V int-regs 2 D 0 } + T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= } + T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= } + T{ ##replace f V int-regs 6 D 0 } + } value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 8 D 0 } + T{ ##peek f V int-regs 9 D -1 } + T{ ##unbox-float f V double-float-regs 10 V int-regs 8 } + T{ ##unbox-float f V double-float-regs 11 V int-regs 9 } + T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< } + T{ ##compare-float f V int-regs 14 V double-float-regs 10 V double-float-regs 11 cc>= } + T{ ##replace f V int-regs 14 D 0 } + } +] [ + { + T{ ##peek f V int-regs 8 D 0 } + T{ ##peek f V int-regs 9 D -1 } + T{ ##unbox-float f V double-float-regs 10 V int-regs 8 } + T{ ##unbox-float f V double-float-regs 11 V int-regs 9 } + T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< } + T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= } + T{ ##replace f V int-regs 14 D 0 } + } value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 29 D -1 } + T{ ##peek f V int-regs 30 D -2 } + T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= } + T{ ##compare-branch f V int-regs 29 V int-regs 30 cc<= } + } +] [ + { + T{ ##peek f V int-regs 29 D -1 } + T{ ##peek f V int-regs 30 D -2 } + T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= } + T{ ##compare-imm-branch f V int-regs 33 7 cc/= } + } value-numbering +] unit-test From 9366ad650d736c51f2aaa1ebbcb3e1e3527950b3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Nov 2008 09:29:21 -0600 Subject: [PATCH 06/26] Add unportable tag --- basis/cpu/x86/tags.txt | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 basis/cpu/x86/tags.txt diff --git a/basis/cpu/x86/tags.txt b/basis/cpu/x86/tags.txt new file mode 100644 index 0000000000..8e66660f70 --- /dev/null +++ b/basis/cpu/x86/tags.txt @@ -0,0 +1,2 @@ +unportable +compiler From d2b2cda596e542c6c23cde8557a4c982005ef29e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Nov 2008 10:44:06 -0600 Subject: [PATCH 07/26] Sort methods by tag, this speeds up >fixnum in the common case where the input is a fixnum --- core/generic/standard/engines/tag/tag.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor index c65726260c..87e2f1c9b1 100644 --- a/core/generic/standard/engines/tag/tag.factor +++ b/core/generic/standard/engines/tag/tag.factor @@ -27,7 +27,7 @@ M: lo-tag-dispatch-engine engine>quot [ >r lo-tag-number r> ] assoc-map [ picker % [ tag ] % [ - ! >alist sort-keys reverse + >alist sort-keys reverse linear-dispatch-quot ] [ num-tags get direct-dispatch-quot From 666100a07bc47a9542f45e179eacb8f731cec898 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Nov 2008 11:07:19 -0600 Subject: [PATCH 08/26] Tweak euler043 to run in constant space, add new each-permutation and reduce-permutations combinators to math.combinatorics --- extra/math/combinatorics/combinatorics.factor | 7 +++++++ extra/project-euler/043/043.factor | 7 +++++-- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/extra/math/combinatorics/combinatorics.factor b/extra/math/combinatorics/combinatorics.factor index b1c49b8ab5..00a104b381 100644 --- a/extra/math/combinatorics/combinatorics.factor +++ b/extra/math/combinatorics/combinatorics.factor @@ -44,5 +44,12 @@ PRIVATE> : all-permutations ( seq -- seq ) [ length factorial ] keep '[ _ permutation ] map ; +: each-permutation ( seq quot -- ) + [ [ length factorial ] keep ] dip + '[ _ permutation @ ] each ; inline + +: reduce-permutations ( seq initial quot -- result ) + swapd each-permutation ; inline + : inverse-permutation ( seq -- permutation ) >alist sort-values keys ; diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor index 268a6becfb..37118b88a3 100644 --- a/extra/project-euler/043/043.factor +++ b/extra/project-euler/043/043.factor @@ -52,8 +52,11 @@ IN: project-euler.043 PRIVATE> : euler043 ( -- answer ) - 1234567890 number>digits all-permutations - [ interesting? ] filter [ 10 digits>integer ] map sum ; + 1234567890 number>digits 0 [ + dup interesting? [ + 10 digits>integer + + ] [ drop ] if + ] reduce-permutations ; ! [ euler043 ] time ! 104526 ms run / 42735 ms GC time From 4e55cd973bbcc08154c6e6d6ccd2ae2d4d4199ff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Nov 2008 11:48:55 -0600 Subject: [PATCH 09/26] If a #dispatch branch is a call to another word which is not an intrinsic, we avoid generating the dispatch branch and just jump to the word directly --- basis/compiler/cfg/builder/builder.factor | 35 +++++++++++++++-------- 1 file changed, 23 insertions(+), 12 deletions(-) diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 5b9f2e068b..93daa601fe 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -156,19 +156,30 @@ M: #if emit-node } cond iterate-next ; ! #dispatch +: trivial-dispatch-branch? ( nodes -- ? ) + dup length 1 = [ + first dup #call? [ + word>> "intrinsic" word-prop not + ] [ drop f ] if + ] [ drop f ] if ; + : dispatch-branch ( nodes word -- label ) - gensym [ - [ - V{ } clone node-stack set - ##prologue - emit-nodes - basic-block get [ - ##epilogue - ##return - end-basic-block - ] when - ] with-cfg-builder - ] keep ; + over trivial-dispatch-branch? [ + drop first word>> + ] [ + gensym [ + [ + V{ } clone node-stack set + ##prologue + emit-nodes + basic-block get [ + ##epilogue + ##return + end-basic-block + ] when + ] with-cfg-builder + ] keep + ] if ; : dispatch-branches ( node -- ) children>> [ From 751426f28358252e537691a7893b0d9debb3cf0f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Nov 2008 11:57:31 -0600 Subject: [PATCH 10/26] Remove dead code from math.intervals; we no longer need the operations to support f anymore --- basis/math/intervals/intervals-tests.factor | 2 -- basis/math/intervals/intervals.factor | 21 +++++---------------- 2 files changed, 5 insertions(+), 18 deletions(-) diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index ad2fb53dc4..0fdcb51291 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -83,8 +83,6 @@ IN: math.intervals.tests 0 1 (a,b) 1 2 [a,b] interval-union 0 2 (a,b] = ] unit-test -[ f ] [ 0 1 (a,b) f interval-union ] unit-test - [ t ] [ 0 1 (a,b) 0 1 [a,b] interval-intersect 0 1 (a,b) = ] unit-test diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 213bfce354..33430e83c3 100644 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -115,14 +115,10 @@ TUPLE: interval { from read-only } { to read-only } ; { [ dup empty-interval eq? ] [ nip ] } { [ over empty-interval eq? ] [ drop ] } [ - 2dup and [ - [ interval>points ] bi@ swapd - [ [ swap endpoint< ] most ] - [ [ swap endpoint> ] most ] 2bi* - - ] [ - or - ] if + [ interval>points ] bi@ swapd + [ [ swap endpoint< ] most ] + [ [ swap endpoint> ] most ] 2bi* + ] } cond ; @@ -133,13 +129,7 @@ TUPLE: interval { from read-only } { to read-only } ; { { [ dup empty-interval eq? ] [ drop ] } { [ over empty-interval eq? ] [ nip ] } - [ - 2dup and [ - [ interval>points 2array ] bi@ append points>interval - ] [ - 2drop f - ] if - ] + [ [ interval>points 2array ] bi@ append points>interval ] } cond ; : interval-subset? ( i1 i2 -- ? ) @@ -183,7 +173,6 @@ TUPLE: interval { from read-only } { to read-only } ; : interval-length ( int -- n ) { { [ dup empty-interval eq? ] [ drop 0 ] } - { [ dup not ] [ drop 0 ] } [ interval>points [ first ] bi@ swap - ] } cond ; From 63a9975a0eb3064177de6b1496be36e32cadc329 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Nov 2008 13:13:37 -0600 Subject: [PATCH 11/26] Support inline, foldable, flushable on methods; add declarations in a couple of places for ricing purposes --- basis/io/ports/ports.factor | 4 ++-- core/generic/parser/parser.factor | 12 ++++++------ core/words/words.factor | 2 +- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 6ee982fcda..9fb9755d4b 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -39,7 +39,7 @@ HOOK: (wait-to-read) io-backend ( port -- ) M: input-port stream-read1 dup check-disposed - dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ; + dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ; inline : read-step ( count port -- byte-array/f ) dup wait-to-read [ 2drop f ] [ buffer>> buffer-read ] if ; @@ -105,7 +105,7 @@ TUPLE: output-port < buffered-port ; M: output-port stream-write1 dup check-disposed 1 over wait-to-write - buffer>> byte>buffer ; + buffer>> byte>buffer ; inline M: output-port stream-write dup check-disposed diff --git a/core/generic/parser/parser.factor b/core/generic/parser/parser.factor index 70f57f85e3..7380399b5c 100644 --- a/core/generic/parser/parser.factor +++ b/core/generic/parser/parser.factor @@ -8,7 +8,7 @@ ERROR: not-in-a-method-error ; : CREATE-GENERIC ( -- word ) CREATE dup reset-word ; : create-method-in ( class generic -- method ) - create-method f set-word dup save-location ; + create-method dup set-word dup save-location ; : CREATE-METHOD ( -- method ) scan-word bootstrap-word scan-word create-method-in ; @@ -18,11 +18,11 @@ SYMBOL: current-generic : with-method-definition ( quot -- parsed ) [ - >r - [ "method-class" word-prop current-class set ] - [ "method-generic" word-prop current-generic set ] - [ ] tri - r> call + [ + [ "method-class" word-prop current-class set ] + [ "method-generic" word-prop current-generic set ] + [ ] tri + ] dip call ] with-scope ; inline : (M:) ( method def -- ) diff --git a/core/words/words.factor b/core/words/words.factor index ce1fdf194b..8a4f7e7bd2 100644 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -262,7 +262,7 @@ M: word forget* ] if ; M: word hashcode* - nip 1 slot { fixnum } declare ; + nip 1 slot { fixnum } declare ; foldable M: word literalize ; From 55902df52916ae14a6b84b543d9727b8ff900289 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Nov 2008 13:13:47 -0600 Subject: [PATCH 12/26] Fix indentation --- extra/benchmark/benchmark.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index c00087fc9f..5a8e7595b5 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -6,12 +6,12 @@ continuations debugger ; IN: benchmark : run-benchmark ( vocab -- result ) - [ [ require ] [ [ run ] benchmark ] bi ] curry - [ error. f ] recover ; + [ [ require ] [ [ run ] benchmark ] bi ] curry + [ error. f ] recover ; : run-benchmarks ( -- assoc ) - "benchmark" all-child-vocabs-seq - [ dup run-benchmark ] { } map>assoc ; + "benchmark" all-child-vocabs-seq + [ dup run-benchmark ] { } map>assoc ; : benchmarks. ( assoc -- ) standard-table-style [ From 811026ce4d7b61863e51144b284ec99e59c5e6cd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 6 Nov 2008 13:16:33 -0600 Subject: [PATCH 13/26] removing some uses of at* in favor of at, simplifying code --- basis/regexp/regexp-tests.factor | 1 - basis/regexp/regexp.factor | 2 -- basis/regexp/traversal/traversal.factor | 11 +++++------ 3 files changed, 5 insertions(+), 9 deletions(-) diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index 46696c8c0f..2339628801 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -331,4 +331,3 @@ IN: regexp-tests [ { 0 3 } ] [ "abc" "(ab|a)(bc)?" first-match ] unit-test [ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" first-match ] unit-test - diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index 73555fe953..083a48a470 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -92,7 +92,6 @@ IN: regexp reversed-regexp initial-option construct-regexp ; - : parsing-regexp ( accum end -- accum ) lexer get dup skip-blank [ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column @@ -112,7 +111,6 @@ IN: regexp : R{ CHAR: } parsing-regexp ; parsing : R| CHAR: | parsing-regexp ; parsing - : find-regexp-syntax ( string -- prefix suffix ) { { "R/ " "/" } diff --git a/basis/regexp/traversal/traversal.factor b/basis/regexp/traversal/traversal.factor index 346d77e918..91c7ce16dc 100644 --- a/basis/regexp/traversal/traversal.factor +++ b/basis/regexp/traversal/traversal.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators kernel math math.ranges quotations sequences regexp.parser regexp.classes fry arrays -combinators.short-circuit regexp.utils prettyprint regexp.nfa ; +combinators.short-circuit regexp.utils prettyprint regexp.nfa +shuffle ; IN: regexp.traversal TUPLE: dfa-traverser @@ -23,8 +24,7 @@ TUPLE: dfa-traverser [ dfa-table>> ] [ dfa-traversal-flags>> ] bi dfa-traverser new swap >>traversal-flags - swap [ start-state>> >>current-state ] keep - >>dfa-table + swap [ start-state>> >>current-state ] [ >>dfa-table ] bi swap >>text t >>traverse-forward 0 >>start-index @@ -116,7 +116,7 @@ M: capture-group-off flag-action ( dfa-traverser flag -- ) V{ } clone >>matches ; : match-literal ( transition from-state table -- to-state/f ) - transitions>> at* [ at ] [ 2drop f ] if ; + transitions>> at at ; : match-class ( transition from-state table -- to-state/f ) transitions>> at* [ @@ -124,8 +124,7 @@ M: capture-group-off flag-action ( dfa-traverser flag -- ) ] [ drop ] if ; : match-default ( transition from-state table -- to-state/f ) - [ nip ] dip transitions>> at* - [ t swap at* [ ] [ drop f ] if ] [ drop f ] if ; + nipd transitions>> at t swap at ; : match-transition ( obj from-state dfa -- to-state/f ) { [ match-literal ] [ match-class ] [ match-default ] } 3|| ; From 5a50046791aa36a76a3a835d26e17d6e55eb76b2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Nov 2008 13:20:27 -0600 Subject: [PATCH 14/26] Change to definition of >boolean broke unit test, so define an inverse for >boolean and not explicitly --- extra/inverse/inverse.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 7f55b609e3..dfef23b56a 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -131,6 +131,9 @@ MACRO: undo ( quot -- ) [undo] ; \ pick [ >r pick r> =/fail ] define-inverse \ tuck [ swapd [ =/fail ] keep ] define-inverse +\ not [ not ] define-inverse +\ >boolean [ { t f } memq? assure ] define-inverse + \ >r [ r> ] define-inverse \ r> [ >r ] define-inverse From b7dc7296dbe591acf682609d3ab797b68e261c9b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Nov 2008 13:42:53 -0600 Subject: [PATCH 15/26] Implement stream-read on memory-streams. This allows alien>string to work with utf16 encoding --- basis/alien/strings/strings-tests.factor | 6 +++++- basis/io/streams/memory/memory.factor | 8 +++++++- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/basis/alien/strings/strings-tests.factor b/basis/alien/strings/strings-tests.factor index 484809469f..c1a509041e 100644 --- a/basis/alien/strings/strings-tests.factor +++ b/basis/alien/strings/strings-tests.factor @@ -1,6 +1,6 @@ USING: alien.strings tools.test kernel libc io.encodings.8-bit io.encodings.utf8 io.encodings.utf16 -io.encodings.ascii alien ; +io.encodings.ascii alien io.encodings.string ; IN: alien.strings.tests [ "\u0000ff" ] @@ -28,3 +28,7 @@ unit-test ] unit-test [ f ] [ f utf8 alien>string ] unit-test + +[ "hello" ] [ "hello" utf16 encode utf16 decode ] unit-test + +[ "hello" ] [ "hello" utf16 string>alien utf16 alien>string ] unit-test diff --git a/basis/io/streams/memory/memory.factor b/basis/io/streams/memory/memory.factor index daadbb0e81..20d9f4eb0c 100644 --- a/basis/io/streams/memory/memory.factor +++ b/basis/io/streams/memory/memory.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors alien.accessors math io ; +USING: kernel accessors alien alien.c-types alien.accessors math io ; IN: io.streams.memory TUPLE: memory-stream alien index ; @@ -11,3 +11,9 @@ TUPLE: memory-stream alien index ; M: memory-stream stream-read1 [ [ alien>> ] [ index>> ] bi alien-unsigned-1 ] [ [ 1+ ] change-index drop ] bi ; + +M: memory-stream stream-read + [ + [ index>> ] [ alien>> ] bi + swap memory>byte-array + ] [ [ + ] change-index drop ] 2bi ; From 73f6691f759357a63171fcd40584bcdd350027a4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 6 Nov 2008 15:48:08 -0600 Subject: [PATCH 16/26] print out clickable pathnames in project euler --- extra/project-euler/project-euler.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 5192e23a27..d85e7e206d 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. USING: definitions io io.files kernel math math.parser project-euler.ave-time - sequences vocabs vocabs.loader + sequences vocabs vocabs.loader prettyprint project-euler.001 project-euler.002 project-euler.003 project-euler.004 project-euler.005 project-euler.006 project-euler.007 project-euler.008 project-euler.009 project-euler.010 project-euler.011 project-euler.012 @@ -33,7 +33,7 @@ IN: project-euler : solution-path ( n -- str/f ) number>euler "project-euler." prepend - vocab where dup [ first ] when ; + vocab where dup [ first ] when ; PRIVATE> @@ -43,8 +43,8 @@ PRIVATE> : run-project-euler ( -- ) problem-prompt dup problem-solved? [ dup number>euler "project-euler." prepend run - "Answer: " swap dup number? [ number>string ] when append print - "Source: " swap solution-path append print + "Answer: " write dup number? [ number>string ] when print + "Source: " write solution-path . ] [ drop "That problem has not been solved yet..." print ] if ; From 46aa56730b4a5c79cc326813026862b5a6e69649 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 6 Nov 2008 16:53:00 -0600 Subject: [PATCH 17/26] better parsing for anchors --- basis/regexp/parser/parser.factor | 44 ++++++++++++++++++++----------- 1 file changed, 29 insertions(+), 15 deletions(-) diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor index d2ed346bf2..d04016b93a 100644 --- a/basis/regexp/parser/parser.factor +++ b/basis/regexp/parser/parser.factor @@ -233,15 +233,22 @@ ERROR: invalid-range a b ; SINGLETON: beginning-of-input SINGLETON: end-of-input -! : beginning-of-input ( -- obj ) -: handle-front-anchor ( -- ) front-anchor push-stack ; -: end-of-line ( -- obj ) - end-of-input +: newlines ( -- obj1 obj2 obj3 ) CHAR: \r CHAR: \n - 2dup 2array 4array lookahead boa ; + 2dup 2array ; -: handle-back-anchor ( -- ) end-of-line push-stack ; +: beginning-of-line ( -- obj ) + beginning-of-input newlines 4array lookbehind boa ; + +: end-of-line ( -- obj ) + end-of-input newlines 4array lookahead boa ; + +: handle-front-anchor ( -- ) + get-multiline beginning-of-line beginning-of-input ? push-stack ; + +: handle-back-anchor ( -- ) + get-multiline end-of-line end-of-input ? push-stack ; ERROR: bad-character-class obj ; ERROR: expected-posix-class ; @@ -412,16 +419,11 @@ DEFER: handle-left-bracket [ [ push ] keep current-regexp get (>>stack) ] [ finish-regexp-parse push-stack ] bi* ; - : parse-regexp-token ( token -- ? ) { -! todo: only match these at beginning/end of regexp - { CHAR: ^ [ handle-front-anchor t ] } - { CHAR: $ [ handle-back-anchor t ] } - - { CHAR: . [ handle-dot t ] } - { CHAR: ( [ handle-left-parenthesis t ] } + { CHAR: ( [ handle-left-parenthesis t ] } ! handle (?..) at beginning? { CHAR: ) [ handle-right-parenthesis f ] } + { CHAR: . [ handle-dot t ] } { CHAR: | [ handle-pipe t ] } { CHAR: ? [ handle-question t ] } { CHAR: * [ handle-star t ] } @@ -429,16 +431,28 @@ DEFER: handle-left-bracket { CHAR: { [ handle-left-brace t ] } { CHAR: [ [ handle-left-bracket t ] } { CHAR: \ [ handle-escape t ] } - [ push-stack t ] + [ + dup CHAR: $ = peek1 f = and [ + drop + handle-back-anchor f + ] [ + push-stack t + ] if + ] } case ; : (parse-regexp) ( -- ) read1 [ parse-regexp-token [ (parse-regexp) ] when ] when* ; +: parse-regexp-beginning ( -- ) + peek1 CHAR: ^ = [ drop1 handle-front-anchor ] when ; + : parse-regexp ( regexp -- ) dup current-regexp [ raw>> [ - [ (parse-regexp) ] with-input-stream + [ + parse-regexp-beginning (parse-regexp) + ] with-input-stream ] unless-empty current-regexp get stack finish-regexp-parse From d1f248dac67db2e6a6a68aa08301f1d384f039db Mon Sep 17 00:00:00 2001 From: sheeple Date: Thu, 6 Nov 2008 19:00:56 -0600 Subject: [PATCH 18/26] Fixing PowerPC backend: prolog register clobberage, spilling, and general stack frame usage. Add some lame tests for spilling --- .../cfg/stack-frame/stack-frame.factor | 18 +- basis/compiler/tests/spilling.factor | 343 ++++++++++++++++++ basis/compiler/tests/templates.factor | 163 +-------- basis/cpu/ppc/ppc.factor | 112 +++--- 4 files changed, 414 insertions(+), 222 deletions(-) create mode 100644 basis/compiler/tests/spilling.factor diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor index 8d79a85b8f..ec9ffaba49 100644 --- a/basis/compiler/cfg/stack-frame/stack-frame.factor +++ b/basis/compiler/cfg/stack-frame/stack-frame.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces accessors math.order assocs kernel sequences -combinators make cpu.architecture compiler.cfg.instructions -compiler.cfg.registers ; +combinators make classes words cpu.architecture +compiler.cfg.instructions compiler.cfg.registers ; IN: compiler.cfg.stack-frame SYMBOL: frame-required? @@ -24,16 +24,16 @@ M: ##stack-frame compute-stack-frame* M: ##call compute-stack-frame* word>> sub-primitive>> [ frame-required? on ] unless ; -M: _gc compute-stack-frame* - drop frame-required? on ; - -M: _spill compute-stack-frame* - drop frame-required? on ; - M: _spill-counts compute-stack-frame* counts>> stack-frame get (>>spill-counts) ; -M: insn compute-stack-frame* drop ; +M: insn compute-stack-frame* + class frame-required? word-prop [ + frame-required? on + ] when ; + +\ _gc t frame-required? set-word-prop +\ _spill t frame-required? set-word-prop : compute-stack-frame ( insns -- ) frame-required? off diff --git a/basis/compiler/tests/spilling.factor b/basis/compiler/tests/spilling.factor new file mode 100644 index 0000000000..156fdfff02 --- /dev/null +++ b/basis/compiler/tests/spilling.factor @@ -0,0 +1,343 @@ +USING: math.private kernel combinators accessors arrays +generalizations float-arrays tools.test ; +IN: compiler.tests + +: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b ) + { + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + } cleave ; + +[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ] +[ 1.0 float-spill-bug ] unit-test + +[ t ] [ \ float-spill-bug compiled>> ] unit-test + +: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object ) + { + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + [ dup float+ ] + [ float>fixnum dup fixnum+fast ] + } cleave ; + +[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ] +[ 1.0 float-fixnum-spill-bug ] unit-test + +[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test + +: resolve-spill-bug ( a b -- c ) + [ 1 fixnum+fast ] bi@ dup 10 fixnum< [ + nip 2 fixnum+fast + ] [ + drop { + [ dup fixnum+fast ] + [ dup fixnum+fast ] + [ dup fixnum+fast ] + [ dup fixnum+fast ] + [ dup fixnum+fast ] + [ dup fixnum+fast ] + [ dup fixnum+fast ] + [ dup fixnum+fast ] + [ dup fixnum+fast ] + [ dup fixnum+fast ] + [ dup fixnum+fast ] + [ dup fixnum+fast ] + [ dup fixnum+fast ] + [ dup fixnum+fast ] + [ dup fixnum+fast ] + [ dup fixnum+fast ] + } cleave + 16 narray + ] if ; + +[ t ] [ \ resolve-spill-bug compiled>> ] unit-test + +[ 4 ] [ 1 1 resolve-spill-bug ] unit-test + +! The above don't really test spilling... +: spill-test-1 ( a -- b ) + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast + dup 1 fixnum+fast fixnum>float + 3array + 3array [ 8 narray ] dip 2array + [ 8 narray [ 8 narray ] dip 2array ] dip 2array + 2array ; + +[ + { + 1 + { + { { 2 3 4 5 6 7 8 9 } { 10 11 12 13 14 15 16 17 } } + { + { 18 19 20 21 22 23 24 25 } + { 26 27 { 28 29 30.0 } } + } + } + } +] [ 1 spill-test-1 ] unit-test + +: spill-test-2 ( a -- b ) + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + dup 1.0 float+ + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* + float* ; + +[ t ] [ 1.0 spill-test-2 1.0 \ spill-test-2 def>> call = ] unit-test diff --git a/basis/compiler/tests/templates.factor b/basis/compiler/tests/templates.factor index 675e0cbc0f..de87ad8c00 100644 --- a/basis/compiler/tests/templates.factor +++ b/basis/compiler/tests/templates.factor @@ -3,7 +3,7 @@ kernel.private math hashtables.private math.private namespaces sequences sequences.private tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts words definitions compiler.units io -combinators vectors ; +combinators vectors float-arrays ; IN: compiler.tests ! Originally, this file did black box testing of templating @@ -206,167 +206,6 @@ TUPLE: my-tuple ; ] compile-call ] unit-test -: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b ) - { - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - [ dup float+ ] - } cleave ; - -[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ] -[ 1.0 float-spill-bug ] unit-test - -[ t ] [ \ float-spill-bug compiled>> ] unit-test - -: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object ) - { - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - [ dup float+ ] - [ float>fixnum dup fixnum+fast ] - } cleave ; - -[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ] -[ 1.0 float-fixnum-spill-bug ] unit-test - -[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test - -: resolve-spill-bug ( a b -- c ) - [ 1 fixnum+fast ] bi@ dup 10 fixnum< [ - nip 2 fixnum+fast - ] [ - drop { - [ dup fixnum+fast ] - [ dup fixnum+fast ] - [ dup fixnum+fast ] - [ dup fixnum+fast ] - [ dup fixnum+fast ] - [ dup fixnum+fast ] - [ dup fixnum+fast ] - [ dup fixnum+fast ] - [ dup fixnum+fast ] - [ dup fixnum+fast ] - [ dup fixnum+fast ] - [ dup fixnum+fast ] - [ dup fixnum+fast ] - [ dup fixnum+fast ] - [ dup fixnum+fast ] - [ dup fixnum+fast ] - } cleave - 16 narray - ] if ; - -[ t ] [ \ resolve-spill-bug compiled>> ] unit-test - -[ 4 ] [ 1 1 resolve-spill-bug ] unit-test - ! Regression : dispatch-alignment-regression ( -- c ) { tuple vector } 3 slot { word } declare diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index ad6c63b8c9..b60fd47b89 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -4,7 +4,8 @@ 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 ; +compiler.constants compiler.codegen compiler.codegen.fixup +compiler.cfg.intrinsics compiler.cfg.stack-frame ; IN: cpu.ppc ! PowerPC register assignments: @@ -25,17 +26,21 @@ IN: cpu.ppc t "longlong" c-type (>>stack-align?) t "ulonglong" c-type (>>stack-align?) ] } -} cond >> +} cond + +enable-float-intrinsics + +\ ##integer>float t frame-required? set-word-prop +\ ##float>integer t frame-required? set-word-prop >> M: ppc machine-registers { { int-regs T{ range f 2 26 1 } } - { double-float-regs T{ range f 0 28 1 } } + { double-float-regs T{ range f 0 29 1 } } } ; : scratch-reg 28 ; inline -: fp-scratch-reg-1 29 ; inline -: fp-scratch-reg-2 30 ; inline +: fp-scratch-reg 30 ; inline M: ppc two-operand? f ; @@ -71,12 +76,15 @@ M: ppc %inc-r ( n -- ) rs-reg (%inc) ; { macosx [ 6 ] } } case cells ; foldable -: lr-save ( -- n ) - os { - { linux [ 1 ] } - { macosx [ 2 ] } - } case cells ; foldable +! The start of the stack frame contains the size of this frame +! as well as the currently executing XT +: factor-area-size ( -- n ) 2 cells ; foldable +: next-save ( n -- i ) cell - ; +: xt-save ( n -- i ) 2 cells - ; +! Next, we have the spill area as well as the FFI parameter area. +! They overlap, since basic blocks with FFI calls will never +! spill. : param@ ( n -- x ) reserved-area-size + ; inline : param-save-size ( -- n ) 8 cells ; foldable @@ -84,19 +92,38 @@ M: ppc %inc-r ( n -- ) rs-reg (%inc) ; : local@ ( n -- x ) reserved-area-size param-save-size + + ; inline -: factor-area-size ( -- n ) 2 cells ; foldable +: spill-integer-base ( -- n ) + stack-frame get spill-counts>> double-float-regs swap at + double-float-regs reg-size * ; -: next-save ( n -- i ) cell - ; +: spill-integer@ ( n -- offset ) + cells spill-integer-base + param@ ; -: xt-save ( n -- i ) 2 cells - ; +: spill-float@ ( n -- offset ) + double-float-regs reg-size * param@ ; + +! Some FP intrinsics need a temporary scratch area in the stack +! frame, 8 bytes in size +: scratch@ ( n -- offset ) + stack-frame get total-size>> + factor-area-size - + param-save-size - + + ; + +! Finally we have the linkage area +: lr-save ( -- n ) + os { + { linux [ 1 ] } + { macosx [ 2 ] } + } case cells ; foldable M: ppc stack-frame-size ( stack-frame -- i ) [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ] [ params>> ] [ return>> ] tri + + - reserved-area-size + param-save-size + + reserved-area-size + factor-area-size + 4 cells align ; @@ -219,19 +246,19 @@ M: ppc %div-float FDIV ; M:: ppc %integer>float ( dst src -- ) HEX: 4330 scratch-reg LIS - scratch-reg 1 0 param@ STW + scratch-reg 1 0 scratch@ 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 + scratch-reg 1 4 scratch@ STW + dst 1 0 scratch@ LFD 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 ; + fp-scratch-reg scratch-reg float-offset LFD + dst dst fp-scratch-reg FSUB ; M:: ppc %float>integer ( dst src -- ) - fp-scratch-reg-1 src FCTIWZ - fp-scratch-reg-2 1 0 param@ STFD - dst 1 4 param@ LWZ ; + fp-scratch-reg src FCTIWZ + fp-scratch-reg 1 0 scratch@ STFD + dst 1 4 scratch@ LWZ ; M: ppc %copy ( dst src -- ) MR ; @@ -239,6 +266,10 @@ M: ppc %copy-float ( dst src -- ) FMR ; M: ppc %unbox-float ( dst src -- ) float-offset LFD ; +M:: ppc %box-float ( dst src temp -- ) + dst 16 float temp %allot + src dst float-offset STFD ; + M:: ppc %unbox-any-c-ptr ( dst src temp -- ) [ { "is-byte-array" "end" "start" } [ define-label ] each @@ -370,12 +401,12 @@ M: ppc %gc "end" resolve-label ; M: ppc %prologue ( n -- ) - 0 scratch-reg LOAD32 rc-absolute-ppc-2/2 rel-this + 0 11 LOAD32 rc-absolute-ppc-2/2 rel-this 0 MFLR 1 1 pick neg ADDI - scratch-reg 1 pick xt-save STW - dup scratch-reg LI - scratch-reg 1 pick next-save STW + 11 1 pick xt-save STW + dup 11 LI + 11 1 pick next-save STW 0 1 rot lr-save + STW ; M: ppc %epilogue ( n -- ) @@ -426,32 +457,11 @@ M: ppc %compare-branch (%compare) %branch ; M: ppc %compare-imm-branch (%compare-imm) %branch ; M: ppc %compare-float-branch (%compare-float) %branch ; -: spill-integer-base ( stack-frame -- n ) - [ params>> ] [ return>> ] bi + ; +M: ppc %spill-integer ( src n -- ) spill-integer@ 1 swap STW ; +M: ppc %reload-integer ( dst n -- ) spill-integer@ 1 swap LWZ ; -: stack@ 1 swap ; inline - -: spill-integer@ ( n -- reg offset ) - cells - stack-frame get spill-integer-base - + stack@ ; - -: spill-float-base ( stack-frame -- n ) - [ spill-counts>> int-regs swap at int-regs reg-size * ] - [ params>> ] - [ return>> ] - tri + + ; - -: spill-float@ ( n -- reg offset ) - double-float-regs reg-size * - stack-frame get spill-float-base - + stack@ ; - -M: ppc %spill-integer ( src n -- ) spill-integer@ STW ; -M: ppc %reload-integer ( dst n -- ) spill-integer@ LWZ ; - -M: ppc %spill-float ( src n -- ) spill-float@ STFD ; -M: ppc %reload-float ( dst n -- ) spill-float@ LFD ; +M: ppc %spill-float ( src n -- ) spill-float@ 1 swap STFD ; +M: ppc %reload-float ( dst n -- ) spill-float@ 1 swap LFD ; M: ppc %loop-entry ; From e45df2e89c006669e59bb7362c46556b46b2a5a0 Mon Sep 17 00:00:00 2001 From: unknown Date: Fri, 7 Nov 2008 20:25:31 -0600 Subject: [PATCH 19/26] Fix bignums for Win64 --- vm/bignum.c | 27 ++++++++++----------------- vm/bignum.h | 8 ++------ 2 files changed, 12 insertions(+), 23 deletions(-) diff --git a/vm/bignum.c b/vm/bignum.c index d92f665354..72616afbc5 100644 --- a/vm/bignum.c +++ b/vm/bignum.c @@ -1,7 +1,7 @@ /* :tabSize=2:indentSize=2:noTabs=true: Copyright (C) 1989-94 Massachusetts Institute of Technology -Portions copyright (C) 2004-2007 Slava Pestov +Portions copyright (C) 2004-2008 Slava Pestov This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -45,6 +45,7 @@ MIT in each case. */ * - Remove unused functions * - Add local variable GC root recording * - Remove s48 prefix from function names + * - Various fixes for Win64 */ #include "master.h" @@ -366,8 +367,6 @@ bignum_remainder(bignum_type numerator, bignum_type denominator) /* all below allocate memory */ FOO_TO_BIGNUM(cell,CELL,CELL) FOO_TO_BIGNUM(fixnum,F_FIXNUM,CELL) -FOO_TO_BIGNUM(long,long,unsigned long) -FOO_TO_BIGNUM(ulong,unsigned long,unsigned long) FOO_TO_BIGNUM(long_long,s64,u64) FOO_TO_BIGNUM(ulong_long,u64,u64) @@ -389,8 +388,6 @@ FOO_TO_BIGNUM(ulong_long,u64,u64) /* all of the below allocate memory */ BIGNUM_TO_FOO(cell,CELL,CELL); BIGNUM_TO_FOO(fixnum,F_FIXNUM,CELL); -BIGNUM_TO_FOO(long,long,unsigned long) -BIGNUM_TO_FOO(ulong,unsigned long,unsigned long) BIGNUM_TO_FOO(long_long,s64,u64) BIGNUM_TO_FOO(ulong_long,u64,u64) @@ -435,7 +432,7 @@ double_to_bignum(double x) bignum_digit_type digit; int odd_bits = (exponent % BIGNUM_DIGIT_LENGTH); if (odd_bits > 0) - DTB_WRITE_DIGIT (1L << odd_bits); + DTB_WRITE_DIGIT ((F_FIXNUM)1 << odd_bits); while (start < scan) { if (significand == 0) @@ -1117,7 +1114,7 @@ bignum_destructive_normalization(bignum_type source, bignum_type target, bignum_digit_type * end_source = (scan_source + (BIGNUM_LENGTH (source))); bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target))); int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left); - bignum_digit_type mask = ((1L << shift_right) - 1); + bignum_digit_type mask = (((CELL)1 << shift_right) - 1); while (scan_source < end_source) { digit = (*scan_source++); @@ -1139,7 +1136,7 @@ bignum_destructive_unnormalization(bignum_type bignum, int shift_right) bignum_digit_type digit; bignum_digit_type carry = 0; int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right); - bignum_digit_type mask = ((1L << shift_right) - 1); + bignum_digit_type mask = (((F_FIXNUM)1 << shift_right) - 1); while (start < scan) { digit = (*--scan); @@ -1489,7 +1486,7 @@ bignum_bitwise_not(bignum_type x) /* allocates memory */ bignum_type -bignum_arithmetic_shift(bignum_type arg1, long n) +bignum_arithmetic_shift(bignum_type arg1, F_FIXNUM n) { if (BIGNUM_NEGATIVE_P(arg1) && n < 0) return bignum_bitwise_not(bignum_magnitude_ash(bignum_bitwise_not(arg1), n)); @@ -1550,14 +1547,14 @@ bignum_bitwise_xor(bignum_type arg1, bignum_type arg2) /* ash for the magnitude */ /* assume arg1 is a big number, n is a long */ bignum_type -bignum_magnitude_ash(bignum_type arg1, long n) +bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n) { bignum_type result = NULL; bignum_digit_type *scan1; bignum_digit_type *scanr; bignum_digit_type *end; - long digit_offset,bit_offset; + F_FIXNUM digit_offset,bit_offset; if (BIGNUM_ZERO_P (arg1)) return (arg1); @@ -1642,10 +1639,6 @@ bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2) while (scanr < endr) { digit1 = (scan1 < end1) ? *scan1++ : 0; digit2 = (scan2 < end2) ? *scan2++ : 0; - /* - fprintf(stderr, "[pospos op = %d, i = %ld, d1 = %lx, d2 = %lx]\n", - op, endr - scanr, digit1, digit2); - */ *scanr++ = (op == AND_OP) ? digit1 & digit2 : (op == IOR_OP) ? digit1 | digit2 : digit1 ^ digit2; @@ -1856,8 +1849,8 @@ digit_stream_to_bignum(unsigned int n_digits, return (BIGNUM_ZERO ()); if (n_digits == 1) { - long digit = ((long) ((*producer) (0))); - return (long_to_bignum (negative_p ? (- digit) : digit)); + F_FIXNUM digit = ((F_FIXNUM) ((*producer) (0))); + return (fixnum_to_bignum (negative_p ? (- digit) : digit)); } { bignum_length_type length; diff --git a/vm/bignum.h b/vm/bignum.h index 3e6fd9f3ec..02309cad34 100644 --- a/vm/bignum.h +++ b/vm/bignum.h @@ -55,14 +55,10 @@ bignum_type bignum_quotient(bignum_type, bignum_type); bignum_type bignum_remainder(bignum_type, bignum_type); DLLEXPORT bignum_type fixnum_to_bignum(F_FIXNUM); DLLEXPORT bignum_type cell_to_bignum(CELL); -DLLEXPORT bignum_type long_to_bignum(long); DLLEXPORT bignum_type long_long_to_bignum(s64 n); DLLEXPORT bignum_type ulong_long_to_bignum(u64 n); -DLLEXPORT bignum_type ulong_to_bignum(unsigned long); F_FIXNUM bignum_to_fixnum(bignum_type); CELL bignum_to_cell(bignum_type); -long bignum_to_long(bignum_type); -unsigned long bignum_to_ulong(bignum_type); s64 bignum_to_long_long(bignum_type); u64 bignum_to_ulong_long(bignum_type); bignum_type double_to_bignum(double); @@ -71,7 +67,7 @@ double bignum_to_double(bignum_type); /* Added bitwise operators. */ DLLEXPORT bignum_type bignum_bitwise_not(bignum_type), - bignum_arithmetic_shift(bignum_type, long), + bignum_arithmetic_shift(bignum_type, F_FIXNUM), bignum_bitwise_and(bignum_type, bignum_type), bignum_bitwise_ior(bignum_type, bignum_type), bignum_bitwise_xor(bignum_type, bignum_type); @@ -116,7 +112,7 @@ bignum_type bignum_maybe_new_sign(bignum_type, int); void bignum_destructive_copy(bignum_type, bignum_type); /* Added for bitwise operations. */ -bignum_type bignum_magnitude_ash(bignum_type arg1, long n); +bignum_type bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n); bignum_type bignum_pospos_bitwise_op(int op, bignum_type, bignum_type); bignum_type bignum_posneg_bitwise_op(int op, bignum_type, bignum_type); bignum_type bignum_negneg_bitwise_op(int op, bignum_type, bignum_type); From 7365959f013ee1d9757e114283943732f6ceb5df Mon Sep 17 00:00:00 2001 From: unknown Date: Fri, 7 Nov 2008 20:33:32 -0600 Subject: [PATCH 20/26] Starting work on Win64 port --- Makefile | 2 +- basis/alien/c-types/c-types.factor | 2 +- basis/bootstrap/image/image.factor | 2 +- basis/cpu/x86/32/32.factor | 2 + basis/cpu/x86/32/bootstrap.factor | 1 + basis/cpu/x86/64/64.factor | 47 ++++++++++--------- basis/cpu/x86/64/bootstrap.factor | 2 - basis/cpu/x86/64/unix/bootstrap.factor | 12 +++++ basis/cpu/x86/64/unix/unix.factor | 12 +++++ basis/cpu/x86/64/winnt/bootstrap.factor | 12 +++++ basis/cpu/x86/64/winnt/winnt.factor | 17 +++++++ basis/cpu/x86/bootstrap.factor | 14 +++--- basis/cpu/x86/x86.factor | 10 ++-- vm/Config.windows.nt.x86.64 | 2 +- vm/callstack.c | 2 + vm/cpu-x86.32.S | 1 + vm/cpu-x86.64.S | 61 +++++++++++++++++++------ vm/cpu-x86.S | 27 ++++++----- vm/data_gc.c | 6 +++ vm/errors.c | 6 +-- vm/factor.c | 1 - vm/factor.rs | 4 +- vm/math.c | 4 +- 23 files changed, 175 insertions(+), 74 deletions(-) create mode 100644 basis/cpu/x86/64/unix/bootstrap.factor create mode 100644 basis/cpu/x86/64/unix/unix.factor create mode 100644 basis/cpu/x86/64/winnt/bootstrap.factor create mode 100644 basis/cpu/x86/64/winnt/winnt.factor diff --git a/Makefile b/Makefile index aa520063e3..973ba1f3d4 100644 --- a/Makefile +++ b/Makefile @@ -170,7 +170,7 @@ vm/resources.o: $(CC) -c $(CFLAGS) -o $@ $< .S.o: - $(CC) -c $(CFLAGS) -o $@ $< + $(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $< .m.o: $(CC) -c $(CFLAGS) -o $@ $< diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 6a88441be9..a93c87611d 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -435,7 +435,7 @@ M: long-long-type box-return ( type -- ) [ >float ] >>unboxer-quot "double" define-primitive-type - os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef + "long" "ptrdiff_t" typedef "ulong" "size_t" typedef ] with-compilation-unit diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 3816b930e0..ed12054bed 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -25,7 +25,7 @@ IN: bootstrap.image : images ( -- seq ) { "x86.32" - "x86.64" + "winnt-x86.64" "unix-x86.64" "linux-ppc" "macosx-ppc" } ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 890938c6b3..82fa7a012e 100644 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -26,6 +26,8 @@ M: x86.32 stack-reg ESP ; M: x86.32 temp-reg-1 EAX ; M: x86.32 temp-reg-2 ECX ; +M: x86.32 reserved-area-size 0 ; + M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ; M: x86.32 %alien-invoke (CALL) rel-dlsym ; diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 37f9b3ada0..44f840e66a 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -6,6 +6,7 @@ IN: bootstrap.x86 4 \ cell set +: stack-frame-size ( -- n ) 4 bootstrap-cells ; : shift-arg ( -- reg ) ECX ; : div-arg ( -- reg ) EAX ; : mod-arg ( -- reg ) EDX ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 16e7319c03..d45dd098b8 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -24,14 +24,12 @@ M: x86.64 stack-reg RSP ; M: x86.64 temp-reg-1 RAX ; M: x86.64 temp-reg-2 RCX ; +: param-reg-1 int-regs param-regs first ; inline +: param-reg-2 int-regs param-regs second ; inline + M: int-regs return-reg drop RAX ; -M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ; - M: float-regs return-reg drop XMM0 ; -M: float-regs param-regs - drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ; - M: x86.64 rel-literal-x86 rc-relative rel-literal ; M: x86.64 %prologue ( n -- ) @@ -90,7 +88,7 @@ M: struct-type flatten-value-type ( type -- seq ) M: x86.64 %prepare-unbox ( -- ) ! First parameter is top of stack - RDI R14 [] MOV + param-reg-1 R14 [] MOV R14 cell SUB ; M: x86.64 %unbox ( n reg-class func -- ) @@ -103,27 +101,27 @@ M: x86.64 %unbox-long-long ( n func -- ) int-regs swap %unbox ; : %unbox-struct-field ( c-type i -- ) - ! Alien must be in RDI. - RDI swap cells [+] swap reg-class>> { + ! Alien must be in param-reg-1. + param-reg-1 swap cells [+] swap reg-class>> { { int-regs [ int-regs get pop swap MOV ] } { double-float-regs [ float-regs get pop swap MOVSD ] } } case ; M: x86.64 %unbox-small-struct ( c-type -- ) - ! Alien must be in RDI. + ! Alien must be in param-reg-1. "alien_offset" f %alien-invoke - ! Move alien_offset() return value to RDI so that we don't + ! Move alien_offset() return value to param-reg-1 so that we don't ! clobber it. - RDI RAX MOV + param-reg-1 RAX MOV [ flatten-small-struct [ %unbox-struct-field ] each-index ] with-return-regs ; M: x86.64 %unbox-large-struct ( n c-type -- ) - ! Source is in RDI + ! Source is in param-reg-1 heap-size ! Load destination address - RSI rot stack@ LEA + param-reg-2 rot stack@ LEA ! Load structure size RDX swap MOV ! Copy the struct to the C stack @@ -160,8 +158,8 @@ M: x86.64 %box-small-struct ( c-type -- ) [ [ flatten-small-struct [ %box-struct-field ] each-index ] [ RDX swap heap-size MOV ] bi - RDI 0 box-struct-field@ MOV - RSI 1 box-struct-field@ MOV + param-reg-1 0 box-struct-field@ MOV + param-reg-2 1 box-struct-field@ MOV "box_small_struct" f %alien-invoke ] with-return-regs ; @@ -170,9 +168,9 @@ M: x86.64 %box-small-struct ( c-type -- ) M: x86.64 %box-large-struct ( n c-type -- ) ! Struct size is parameter 2 - RSI swap heap-size MOV + param-reg-2 swap heap-size MOV ! Compute destination address - RDI swap struct-return@ LEA + param-reg-1 swap struct-return@ LEA ! Copy the struct from the C stack "box_value_struct" f %alien-invoke ; @@ -200,7 +198,7 @@ M: x86.64 %alien-indirect ( -- ) RBP CALL ; M: x86.64 %alien-callback ( quot -- ) - RDI swap %load-indirect + param-reg-1 swap %load-indirect "c_to_factor" f %alien-invoke ; M: x86.64 %callback-value ( ctype -- ) @@ -208,11 +206,11 @@ M: x86.64 %callback-value ( ctype -- ) %prepare-unbox ! Save top of data stack RSP 8 SUB - RDI PUSH + param-reg-1 PUSH ! Restore data/call/retain stacks "unnest_stacks" f %alien-invoke - ! Put former top of data stack in RDI - RDI POP + ! Put former top of data stack in param-reg-1 + param-reg-1 POP RSP 8 ADD ! Unbox former top of data stack to return registers unbox-return ; @@ -223,3 +221,10 @@ enable-alien-4-intrinsics ! SSE2 is always available on x86-64. enable-float-intrinsics + +USE: vocabs.loader + +{ + { [ os unix? ] [ "cpu.x86.64.unix" require ] } + { [ os winnt? ] [ "cpu.x86.64.winnt" require ] } +} cond diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index c1f5156178..acac8b55bc 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -9,8 +9,6 @@ IN: bootstrap.x86 : shift-arg ( -- reg ) RCX ; : div-arg ( -- reg ) RAX ; : mod-arg ( -- reg ) RDX ; -: arg0 ( -- reg ) RDI ; -: arg1 ( -- reg ) RSI ; : temp-reg ( -- reg ) RBX ; : stack-reg ( -- reg ) RSP ; : ds-reg ( -- reg ) R14 ; diff --git a/basis/cpu/x86/64/unix/bootstrap.factor b/basis/cpu/x86/64/unix/bootstrap.factor new file mode 100644 index 0000000000..a42353fabd --- /dev/null +++ b/basis/cpu/x86/64/unix/bootstrap.factor @@ -0,0 +1,12 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: bootstrap.image.private kernel namespaces system +cpu.x86.assembler layouts vocabs parser ; +IN: bootstrap.x86 + +: stack-frame-size ( -- n ) 4 bootstrap-cells ; +: arg0 ( -- reg ) RDI ; +: arg1 ( -- reg ) RSI ; + +<< "resource:basis/cpu/x86/64/bootstrap.factor" parsed-file parsed >> +call diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor new file mode 100644 index 0000000000..9e70ada5d0 --- /dev/null +++ b/basis/cpu/x86/64/unix/unix.factor @@ -0,0 +1,12 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel layouts system compiler.cfg.registers +cpu.architecture cpu.x86.assembler ; +IN: cpu.x86.64.unix + +M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ; + +M: float-regs param-regs + drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ; + +M: x86.64 reserved-area-size 0 ; diff --git a/basis/cpu/x86/64/winnt/bootstrap.factor b/basis/cpu/x86/64/winnt/bootstrap.factor new file mode 100644 index 0000000000..a62b946e83 --- /dev/null +++ b/basis/cpu/x86/64/winnt/bootstrap.factor @@ -0,0 +1,12 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: bootstrap.image.private kernel namespaces system +cpu.x86.assembler layouts vocabs parser ; +IN: bootstrap.x86 + +: stack-frame-size ( -- n ) 8 bootstrap-cells ; +: arg0 ( -- reg ) RCX ; +: arg1 ( -- reg ) RDX ; + +<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >> +call diff --git a/basis/cpu/x86/64/winnt/winnt.factor b/basis/cpu/x86/64/winnt/winnt.factor new file mode 100644 index 0000000000..d4c092f63d --- /dev/null +++ b/basis/cpu/x86/64/winnt/winnt.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel layouts system alien.c-types compiler.cfg.registers +cpu.architecture cpu.x86.assembler cpu.x86 ; +IN: cpu.x86.64.winnt + +M: int-regs param-regs drop { RCX RDX R8 R9 } ; + +M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ; + +M: x86.64 reserved-area-size 4 cells ; + +<< +"longlong" "ptrdiff_t" typedef +"int" "long" typedef +"uint" "ulong" typedef +>> diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index d2ff9a5928..6dadbc096c 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -10,8 +10,6 @@ big-endian off 1 jit-code-format set -: stack-frame-size ( -- n ) 4 bootstrap-cells ; - [ ! Load word temp-reg 0 MOV @@ -30,7 +28,7 @@ big-endian off temp-reg 0 MOV ! load XT stack-frame-size PUSH ! save stack frame size temp-reg PUSH ! push XT - arg1 PUSH ! alignment + stack-reg stack-frame-size 3 bootstrap-cells - SUB ! alignment ] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define [ @@ -302,14 +300,14 @@ big-endian off shift-arg ds-reg [] MOV ! load shift count shift-arg tag-bits get SAR ! untag shift count ds-reg bootstrap-cell SUB ! adjust stack pointer - arg0 ds-reg [] MOV ! load value - arg1 arg0 MOV ! make a copy + temp-reg ds-reg [] MOV ! load value + arg1 temp-reg MOV ! make a copy arg1 CL SHL ! compute positive shift value in arg1 shift-arg NEG ! compute negative shift value in arg0 - arg0 CL SAR - arg0 tag-mask get bitnot AND + temp-reg CL SAR + temp-reg tag-mask get bitnot AND shift-arg 0 CMP ! if shift count was negative, move arg0 to arg1 - arg1 arg0 CMOVGE + arg1 temp-reg CMOVGE ds-reg [] arg1 MOV ! push to stack ] f f f \ fixnum-shift-fast define-sub-primitive diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 8ae3bddfaa..55675a5e42 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -39,12 +39,15 @@ M: x86 %inc-r ( n -- ) rs-reg (%inc) ; : align-stack ( n -- n' ) os macosx? cpu x86.64? or [ 16 align ] when ; +HOOK: reserved-area-size cpu ( -- n ) + M: x86 stack-frame-size ( stack-frame -- i ) [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ] [ params>> ] [ return>> ] tri + + 3 cells + + reserved-area-size + align-stack ; M: x86 %call ( label -- ) CALL ; @@ -465,7 +468,7 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- ) : stack@ ( n -- op ) stack-reg swap [+] ; : spill-integer-base ( stack-frame -- n ) - [ params>> ] [ return>> ] bi + ; + [ params>> ] [ return>> ] bi + reserved-area-size + ; : spill-integer@ ( n -- op ) cells @@ -473,10 +476,9 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- ) + stack@ ; : spill-float-base ( stack-frame -- n ) + [ spill-integer-base ] [ spill-counts>> int-regs swap at int-regs reg-size * ] - [ params>> ] - [ return>> ] - tri + + ; + bi + ; : spill-float@ ( n -- op ) double-float-regs reg-size * diff --git a/vm/Config.windows.nt.x86.64 b/vm/Config.windows.nt.x86.64 index 6d3865c2f4..3ede556171 100644 --- a/vm/Config.windows.nt.x86.64 +++ b/vm/Config.windows.nt.x86.64 @@ -1,5 +1,5 @@ #WIN64_PATH=/k/MinGW/win64/bin -WIN64_PATH=/cygdrive/k/MinGW/win64/bin/x86_64-pc-mingw32 +#WIN64_PATH=/cygdrive/k/MinGW/win64/bin/x86_64-pc-mingw32 CC=$(WIN64_PATH)-gcc.exe WINDRES=$(WIN64_PATH)-windres.exe include vm/Config.windows.nt diff --git a/vm/callstack.c b/vm/callstack.c index df4063d149..c9466bbbb2 100755 --- a/vm/callstack.c +++ b/vm/callstack.c @@ -116,6 +116,8 @@ CELL frame_executing(F_STACK_FRAME *frame) F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame) { + if(frame->size == 0) + critical_error("Stack frame has zero size",frame); return (F_STACK_FRAME *)((CELL)frame - frame->size); } diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index d903f8013d..e0e674a7e2 100755 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -11,6 +11,7 @@ and the callstack top is passed in EDX */ #define RETURN_REG %eax #define CELL_SIZE 4 +#define STACK_PADDING 12 #define PUSH_NONVOLATILE \ push %ebx ; \ diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index 57bfcee87b..15a4eb8da3 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -1,24 +1,55 @@ #include "asm.h" -#define ARG0 %rdi -#define ARG1 %rsi #define STACK_REG %rsp #define DS_REG %r14 #define RETURN_REG %rax #define CELL_SIZE 8 +#define STACK_PADDING 56 -#define PUSH_NONVOLATILE \ - push %rbx ; \ - push %rbp ; \ - push %r12 ; \ - push %r13 ; +#ifdef WINDOWS -#define POP_NONVOLATILE \ - pop %r13 ; \ - pop %r12 ; \ - pop %rbp ; \ - pop %rbx + #define ARG0 %rcx + #define ARG1 %rdx + #define ARG2 %r8 + #define ARG3 %r9 + + #define PUSH_NONVOLATILE \ + push %r12 ; \ + push %r13 ; \ + push %rdi ; \ + push %rsi ; \ + push %rbx ; \ + push %rbp + + #define POP_NONVOLATILE \ + pop %rbp ; \ + pop %rbx ; \ + pop %rsi ; \ + pop %rdi ; \ + pop %r13 ; \ + pop %r12 + +#else + + #define ARG0 %rdi + #define ARG1 %rsi + #define ARG2 %rdx + #define ARG3 %rcx + + #define PUSH_NONVOLATILE \ + push %rbx ; \ + push %rbp ; \ + push %r12 ; \ + push %r13 + + #define POP_NONVOLATILE \ + pop %r13 ; \ + pop %r12 ; \ + pop %rbp ; \ + pop %rbx + +#endif #define QUOT_XT_OFFSET 21 @@ -26,9 +57,9 @@ ABI limitation which would otherwise require us to do a bizzaro PC-relative trampoline to retrieve the function address */ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)): - sub %rdx,%rdi /* compute new stack pointer */ - mov %rdi,%rsp - call *%rcx /* call memcpy */ + sub ARG2,ARG0 /* compute new stack pointer */ + mov ARG0,%rsp + call *ARG3 /* call memcpy */ ret /* return _with new stack_ */ #include "cpu-x86.S" diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S index e8e2af7b25..3d6cacdebd 100755 --- a/vm/cpu-x86.S +++ b/vm/cpu-x86.S @@ -1,31 +1,34 @@ DEF(F_FASTCALL void,c_to_factor,(CELL quot)): PUSH_NONVOLATILE - push ARG0 /* Save quot */ + push ARG0 - lea -CELL_SIZE(STACK_REG),ARG0 /* Save stack pointer */ + /* Save stack pointer */ + lea -CELL_SIZE(STACK_REG),ARG0 + + /* Create register shadow area for Win64 */ + sub $32,STACK_REG call MANGLE(save_callstack_bottom) + add $32,STACK_REG - mov (STACK_REG),ARG0 /* Pass quot as arg 1 */ - call *QUOT_XT_OFFSET(ARG0) /* Call quot-xt */ + /* Call quot-xt */ + mov (STACK_REG),ARG0 + call *QUOT_XT_OFFSET(ARG0) - POP ARG0 + pop ARG0 POP_NONVOLATILE ret DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): - mov ARG1,STACK_REG /* rewind_to */ + /* rewind_to */ + mov ARG1,STACK_REG jmp *QUOT_XT_OFFSET(ARG0) DEF(FASTCALL void,lazy_jit_compile,(CELL quot)): mov STACK_REG,ARG1 /* Save stack pointer */ - push ARG1 /* Alignment */ - push ARG1 - push ARG1 + sub $STACK_PADDING,STACK_REG call MANGLE(primitive_jit_compile) mov RETURN_REG,ARG0 /* No-op on 32-bit */ - pop ARG1 /* OK to clobber ARG1 here */ - pop ARG1 - pop ARG1 + add $STACK_PADDING,STACK_REG jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */ #ifdef WINDOWS diff --git a/vm/data_gc.c b/vm/data_gc.c index 9aa4f88de6..5342ff04d9 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -438,6 +438,8 @@ void collect_gen_cards(CELL gen) old->new references */ void collect_cards(void) { + GC_PRINT("Collect cards\n"); + int i; for(i = collecting_gen + 1; i < data_heap->gen_count; i++) collect_gen_cards(i); @@ -465,7 +467,10 @@ void collect_callstack(F_CONTEXT *stacks) { CELL top = (CELL)stacks->callstack_top; CELL bottom = (CELL)stacks->callstack_bottom; + + GC_PRINT("Collect callstack %ld %ld\n",top,bottom); iterate_callstack(top,bottom,collect_stack_frame); + GC_PRINT("Done\n"); } } @@ -481,6 +486,7 @@ void collect_gc_locals(void) the user environment and extra roots registered with REGISTER_ROOT */ void collect_roots(void) { + GC_PRINT("Collect roots\n"); copy_handle(&T); copy_handle(&bignum_zero); copy_handle(&bignum_pos_one); diff --git a/vm/errors.c b/vm/errors.c index 7a23e3e53f..36072920fe 100755 --- a/vm/errors.c +++ b/vm/errors.c @@ -129,17 +129,17 @@ void divide_by_zero_error(F_STACK_FRAME *native_stack) void memory_signal_handler_impl(void) { - memory_protection_error(signal_fault_addr,signal_callstack_top); + memory_protection_error(signal_fault_addr,signal_callstack_top); } void divide_by_zero_signal_handler_impl(void) { - divide_by_zero_error(signal_callstack_top); + divide_by_zero_error(signal_callstack_top); } void misc_signal_handler_impl(void) { - signal_error(signal_number,signal_callstack_top); + signal_error(signal_number,signal_callstack_top); } DEFINE_PRIMITIVE(throw) diff --git a/vm/factor.c b/vm/factor.c index e81152bd99..c8b07cba64 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -167,7 +167,6 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded } init_factor(&p); - nest_stacks(); F_ARRAY *args = allot_array(ARRAY_TYPE,argc,F); diff --git a/vm/factor.rs b/vm/factor.rs index 5b983cacba..47f899fef6 100644 --- a/vm/factor.rs +++ b/vm/factor.rs @@ -1,2 +1,2 @@ -fraptor ICON "misc/icons/Factor.ico" - +fraptor ICON "misc/icons/Factor.ico" + diff --git a/vm/math.c b/vm/math.c index c7c5dba5a4..7d3b64ed39 100644 --- a/vm/math.c +++ b/vm/math.c @@ -363,13 +363,13 @@ CELL unbox_array_size(void) case BIGNUM_TYPE: { bignum_type zero = untag_object(bignum_zero); - bignum_type max = ulong_to_bignum(ARRAY_SIZE_MAX); + bignum_type max = cell_to_bignum(ARRAY_SIZE_MAX); bignum_type n = untag_object(dpeek()); if(bignum_compare(n,zero) != bignum_comparison_less && bignum_compare(n,max) == bignum_comparison_less) { dpop(); - return bignum_to_ulong(n); + return bignum_to_cell(n); } break; } From cc7ab1188104e36f48d0119df249f0b91fa5dac6 Mon Sep 17 00:00:00 2001 From: unknown Date: Fri, 7 Nov 2008 20:34:04 -0600 Subject: [PATCH 21/26] Add more unit tests --- basis/math/functions/functions-tests.factor | 19 +++++++++++++++++++ core/math/integers/integers-tests.factor | 5 +++++ 2 files changed, 24 insertions(+) diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index d5bdac761f..cbaf37daf8 100644 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -76,6 +76,25 @@ IN: math.functions.tests gcd nip ] unit-test +[ 11 ] [ + 13262642990609552931815424 + 159151715887314635181785 + gcd nip +] unit-test + +[ 3 ] [ + 13262642990609552931 + 1591517158873146351 + gcd nip +] unit-test + +[ 26525285981219 ] [ + 132626429906095 + 159151715887314 + gcd nip +] unit-test + + : verify-gcd ( a b -- ? ) 2dup gcd >r rot * swap rem r> = ; diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index f428df33ae..5a649120a0 100644 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -101,8 +101,13 @@ unit-test [ 268435456 ] [ -268435456 >fixnum -1 /i ] unit-test [ 268435456 0 ] [ -268435456 >fixnum -1 /mod ] unit-test [ 0 ] [ -1 -268435456 >fixnum /i ] unit-test +[ 4420880996869850977 ] [ 13262642990609552931 3 /i ] unit-test [ 0 -1 ] [ -1 -268435456 >fixnum /mod ] unit-test +[ 0 -1 ] [ -1 -268435456 >bignum /mod ] unit-test [ 14355 ] [ 1591517158873146351817850880000000 32769 mod ] unit-test +[ 8 530505719624382123 ] [ 13262642990609552931 1591517158873146351 /mod ] unit-test +[ 8 ] [ 13262642990609552931 1591517158873146351 /i ] unit-test +[ 530505719624382123 ] [ 13262642990609552931 1591517158873146351 mod ] unit-test [ -351382792 ] [ -43922849 3 shift ] unit-test From 78eeaddcf2e6071e439833f25552a20ec47f2a3d Mon Sep 17 00:00:00 2001 From: unknown Date: Fri, 7 Nov 2008 20:34:26 -0600 Subject: [PATCH 22/26] Add winnt-x86.64 boot image name --- core/bootstrap/primitives.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 3accb8a9b8..24faf81662 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -20,7 +20,8 @@ H{ } clone sub-primitives set "resource:basis/cpu/" architecture get { { "x86.32" "x86/32" } - { "x86.64" "x86/64" } + { "winnt-x86.64" "x86/64/winnt" } + { "unix-x86.64" "x86/64/unix" } { "linux-ppc" "ppc/linux" } { "macosx-ppc" "ppc/macosx" } { "arm" "arm" } From 639da2d33541ae7b7ac0b49e5205d61e440e00be Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Nov 2008 20:45:25 -0600 Subject: [PATCH 23/26] Refactor OS-specific parts of PowerPC backend --- basis/cpu/ppc/linux/linux.factor | 19 ++++ basis/cpu/ppc/linux/tags.txt | 1 + basis/cpu/ppc/macosx/macosx.factor | 20 ++++ basis/cpu/ppc/macosx/tags.txt | 1 + basis/cpu/ppc/ppc.factor | 144 +++++++++++------------------ 5 files changed, 95 insertions(+), 90 deletions(-) create mode 100644 basis/cpu/ppc/linux/linux.factor create mode 100644 basis/cpu/ppc/linux/tags.txt create mode 100644 basis/cpu/ppc/macosx/macosx.factor create mode 100644 basis/cpu/ppc/macosx/tags.txt diff --git a/basis/cpu/ppc/linux/linux.factor b/basis/cpu/ppc/linux/linux.factor new file mode 100644 index 0000000000..d92709a399 --- /dev/null +++ b/basis/cpu/ppc/linux/linux.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors system kernel alien.c-types cpu.architecture cpu.ppc ; +IN: cpu.ppc.linux + +<< +t "longlong" c-type (>>stack-align?) +t "ulonglong" c-type (>>stack-align?) +>> + +M: linux reserved-area-size 2 ; + +M: linux lr-save 1 ; + +M: float-regs param-regs { 1 2 3 4 5 6 7 8 } ; + +M: ppc value-structs? drop f ; + +M: ppc fp-shadows-int? drop f ; diff --git a/basis/cpu/ppc/linux/tags.txt b/basis/cpu/ppc/linux/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cpu/ppc/linux/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cpu/ppc/macosx/macosx.factor b/basis/cpu/ppc/macosx/macosx.factor new file mode 100644 index 0000000000..1e0a6caca0 --- /dev/null +++ b/basis/cpu/ppc/macosx/macosx.factor @@ -0,0 +1,20 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors system kernel alien.c-types cpu.architecture cpu.ppc ; +IN: cpu.ppc.macosx + +<< +4 "longlong" c-type (>>align) +4 "ulonglong" c-type (>>align) +4 "double" c-type (>>align) +>> + +M: macosx reserved-area-size 6 ; + +M: macosx lr-save 2 ; + +M: float-regs param-regs { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ; + +M: ppc value-structs? drop t ; + +M: ppc fp-shadows-int? drop t ; diff --git a/basis/cpu/ppc/macosx/tags.txt b/basis/cpu/ppc/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cpu/ppc/macosx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index b60fd47b89..d2d1e26396 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -4,8 +4,7 @@ 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 -compiler.cfg.intrinsics compiler.cfg.stack-frame ; +compiler.constants compiler.codegen compiler.codegen.fixup ; IN: cpu.ppc ! PowerPC register assignments: @@ -16,31 +15,15 @@ IN: cpu.ppc ! f0-f29: float vregs ! f30, f31: float scratch -<< { - { [ os macosx? ] [ - 4 "longlong" c-type (>>align) - 4 "ulonglong" c-type (>>align) - 4 "double" c-type (>>align) - ] } - { [ os linux? ] [ - t "longlong" c-type (>>stack-align?) - t "ulonglong" c-type (>>stack-align?) - ] } -} cond - -enable-float-intrinsics - -\ ##integer>float t frame-required? set-word-prop -\ ##float>integer t frame-required? set-word-prop >> - M: ppc machine-registers { { int-regs T{ range f 2 26 1 } } - { double-float-regs T{ range f 0 29 1 } } + { double-float-regs T{ range f 0 28 1 } } } ; : scratch-reg 28 ; inline -: fp-scratch-reg 30 ; inline +: fp-scratch-reg-1 29 ; inline +: fp-scratch-reg-2 30 ; inline M: ppc two-operand? f ; @@ -70,21 +53,9 @@ M: ppc %replace loc>operand STW ; M: ppc %inc-d ( n -- ) ds-reg (%inc) ; M: ppc %inc-r ( n -- ) rs-reg (%inc) ; -: reserved-area-size ( -- n ) - os { - { linux [ 2 ] } - { macosx [ 6 ] } - } case cells ; foldable +HOOK: reserved-area-size os ( -- n ) +HOOK: lr-save os ( -- n ) -! The start of the stack frame contains the size of this frame -! as well as the currently executing XT -: factor-area-size ( -- n ) 2 cells ; foldable -: next-save ( n -- i ) cell - ; -: xt-save ( n -- i ) 2 cells - ; - -! Next, we have the spill area as well as the FFI parameter area. -! They overlap, since basic blocks with FFI calls will never -! spill. : param@ ( n -- x ) reserved-area-size + ; inline : param-save-size ( -- n ) 8 cells ; foldable @@ -92,38 +63,19 @@ M: ppc %inc-r ( n -- ) rs-reg (%inc) ; : local@ ( n -- x ) reserved-area-size param-save-size + + ; inline -: spill-integer-base ( -- n ) - stack-frame get spill-counts>> double-float-regs swap at - double-float-regs reg-size * ; +: factor-area-size ( -- n ) 2 cells ; foldable -: spill-integer@ ( n -- offset ) - cells spill-integer-base + param@ ; +: next-save ( n -- i ) cell - ; -: spill-float@ ( n -- offset ) - double-float-regs reg-size * param@ ; - -! Some FP intrinsics need a temporary scratch area in the stack -! frame, 8 bytes in size -: scratch@ ( n -- offset ) - stack-frame get total-size>> - factor-area-size - - param-save-size - - + ; - -! Finally we have the linkage area -: lr-save ( -- n ) - os { - { linux [ 1 ] } - { macosx [ 2 ] } - } case cells ; foldable +: xt-save ( n -- i ) 2 cells - ; M: ppc stack-frame-size ( stack-frame -- i ) [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ] [ params>> ] [ return>> ] tri + + - param-save-size + reserved-area-size + + param-save-size + factor-area-size + 4 cells align ; @@ -246,19 +198,19 @@ M: ppc %div-float FDIV ; M:: ppc %integer>float ( dst src -- ) HEX: 4330 scratch-reg LIS - scratch-reg 1 0 scratch@ STW + scratch-reg 1 0 param@ STW scratch-reg src MR scratch-reg dup HEX: 8000 XORIS - scratch-reg 1 4 scratch@ STW - dst 1 0 scratch@ LFD + scratch-reg 1 cell param@ STW + fp-scratch-reg-2 1 0 param@ LFD scratch-reg 4503601774854144.0 %load-indirect - fp-scratch-reg scratch-reg float-offset LFD - dst dst fp-scratch-reg FSUB ; + fp-scratch-reg-2 scratch-reg float-offset LFD + fp-scratch-reg-2 fp-scratch-reg-2 fp-scratch-reg-2 FSUB ; M:: ppc %float>integer ( dst src -- ) - fp-scratch-reg src FCTIWZ - fp-scratch-reg 1 0 scratch@ STFD - dst 1 4 scratch@ LWZ ; + fp-scratch-reg-1 src FCTIWZ + fp-scratch-reg-2 1 0 param@ STFD + dst 1 4 param@ LWZ ; M: ppc %copy ( dst src -- ) MR ; @@ -266,10 +218,6 @@ M: ppc %copy-float ( dst src -- ) FMR ; M: ppc %unbox-float ( dst src -- ) float-offset LFD ; -M:: ppc %box-float ( dst src temp -- ) - dst 16 float temp %allot - src dst float-offset STFD ; - M:: ppc %unbox-any-c-ptr ( dst src temp -- ) [ { "is-byte-array" "end" "start" } [ define-label ] each @@ -401,12 +349,12 @@ M: ppc %gc "end" resolve-label ; M: ppc %prologue ( n -- ) - 0 11 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 - 11 1 pick xt-save STW - dup 11 LI - 11 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 -- ) @@ -457,22 +405,38 @@ M: ppc %compare-branch (%compare) %branch ; M: ppc %compare-imm-branch (%compare-imm) %branch ; M: ppc %compare-float-branch (%compare-float) %branch ; -M: ppc %spill-integer ( src n -- ) spill-integer@ 1 swap STW ; -M: ppc %reload-integer ( dst n -- ) spill-integer@ 1 swap LWZ ; +: spill-integer-base ( stack-frame -- n ) + [ params>> ] [ return>> ] bi + ; -M: ppc %spill-float ( src n -- ) spill-float@ 1 swap STFD ; -M: ppc %reload-float ( dst n -- ) spill-float@ 1 swap LFD ; +: stack@ 1 swap ; inline + +: spill-integer@ ( n -- reg offset ) + cells + stack-frame get spill-integer-base + + stack@ ; + +: spill-float-base ( stack-frame -- n ) + [ spill-counts>> int-regs swap at int-regs reg-size * ] + [ params>> ] + [ return>> ] + tri + + ; + +: spill-float@ ( n -- reg offset ) + double-float-regs reg-size * + stack-frame get spill-float-base + + stack@ ; + +M: ppc %spill-integer ( src n -- ) spill-integer@ STW ; +M: ppc %reload-integer ( dst n -- ) spill-integer@ LWZ ; + +M: ppc %spill-float ( src n -- ) spill-float@ STFD ; +M: ppc %reload-float ( dst n -- ) spill-float@ LFD ; M: ppc %loop-entry ; M: int-regs return-reg drop 3 ; M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ; 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: int-regs %save-param-reg drop 1 rot local@ STW ; M: int-regs %load-param-reg drop 1 rot local@ LWZ ; @@ -595,13 +559,6 @@ M: ppc %callback-value ( ctype -- ) ! Unbox former top of data stack to return registers unbox-return ; -M: ppc value-structs? - #! On Linux/PPC, value structs are passed in the same way - #! as reference structs, we just have to make a copy first. - os linux? not ; - -M: ppc fp-shadows-int? ( -- ? ) os macosx? ; - M: ppc small-enough? ( n -- ? ) -32768 32767 between? ; M: ppc struct-small-enough? ( size -- ? ) drop f ; @@ -611,3 +568,10 @@ M: ppc %box-small-struct M: ppc %unbox-small-struct drop "No small structs" throw ; + +USE: vocabs.loader + +{ + { [ os macosx? ] [ "cpu.ppc.macosx" require ] } + { [ os linux? ] [ "cpu.ppc.linux" require ] } +} cond From 1b744ab14b54f7be631e11b1daff300bb103d589 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Nov 2008 21:09:42 -0600 Subject: [PATCH 24/26] Updating code for boot image renaming --- basis/bootstrap/image/image.factor | 10 ++++++++-- build-support/factor.sh | 20 ++++++++++---------- extra/mason/platform/platform.factor | 4 ++-- 3 files changed, 20 insertions(+), 14 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 3816b930e0..c556ee660f 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -12,9 +12,15 @@ io.encodings.binary math.order math.private accessors slots.private compiler.units ; IN: bootstrap.image +: arch ( os cpu -- arch ) + { + { "ppc" [ name>> "-ppc" append ] } + { "x86.64" [ name>> "winnt" = "winnt" "unix" ? "-x86.64" append ] } + [ nip ] + } case ; + : my-arch ( -- arch ) - cpu name>> - dup "ppc" = [ >r os name>> "-" r> 3append ] when ; + os name>> cpu name>> arch ; : boot-image-name ( arch -- string ) "boot." swap ".image" 3append ; diff --git a/build-support/factor.sh b/build-support/factor.sh index 5cbc1e96e3..07d05e29b5 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -271,18 +271,18 @@ check_os_arch_word() { set_build_info() { check_os_arch_word MAKE_TARGET=$OS-$ARCH-$WORD - MAKE_IMAGE_TARGET=$ARCH.$WORD - BOOT_IMAGE=boot.$ARCH.$WORD.image if [[ $OS == macosx && $ARCH == ppc ]] ; then - MAKE_IMAGE_TARGET=$OS-$ARCH - MAKE_TARGET=$OS-$ARCH - BOOT_IMAGE=boot.macosx-ppc.image - fi - if [[ $OS == linux && $ARCH == ppc ]] ; then - MAKE_IMAGE_TARGET=$OS-$ARCH - MAKE_TARGET=$OS-$ARCH - BOOT_IMAGE=boot.linux-ppc.image + MAKE_IMAGE_TARGET=macosx-ppc + elif [[ $OS == linux && $ARCH == ppc ]] ; then + MAKE_IMAGE_TARGET=linux-ppc + elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then + MAKE_IMAGE_TARGET=winnt-x86.64 + elif [[ $ARCH == x86 && $WORD == 64 ]] ; then + MAKE_IMAGE_TARGET=unix-x86.64 + else + MAKE_IMAGE_TARGET=$ARCH.$WORD fi + BOOT_IMAGE_NAME=boot.$MAKE_IMAGE_TARGET.image } parse_build_info() { diff --git a/extra/mason/platform/platform.factor b/extra/mason/platform/platform.factor index cd7d3f3836..59c525f5ea 100644 --- a/extra/mason/platform/platform.factor +++ b/extra/mason/platform/platform.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel system accessors namespaces splitting sequences -mason.config ; +mason.config bootstrap.image ; IN: mason.platform : platform ( -- string ) @@ -11,7 +11,7 @@ IN: mason.platform target-os get { "freebsd" "openbsd" "netbsd" } member? "gmake" "make" ? ; : boot-image-arch ( -- string ) - target-cpu get dup "ppc" = [ target-os get "-" append prepend ] when ; + target-os get target-cpu get arch ; : boot-image-name ( -- string ) "boot." boot-image-arch ".image" 3append ; From eb83b542d6247c632807407433f20d2c3eef074e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Nov 2008 21:54:13 -0600 Subject: [PATCH 25/26] Fix unix x86.64 bootstrap --- basis/cpu/x86/64/unix/bootstrap.factor | 2 +- basis/cpu/x86/64/unix/unix.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/cpu/x86/64/unix/bootstrap.factor b/basis/cpu/x86/64/unix/bootstrap.factor index a42353fabd..29d48bd794 100644 --- a/basis/cpu/x86/64/unix/bootstrap.factor +++ b/basis/cpu/x86/64/unix/bootstrap.factor @@ -8,5 +8,5 @@ IN: bootstrap.x86 : arg0 ( -- reg ) RDI ; : arg1 ( -- reg ) RSI ; -<< "resource:basis/cpu/x86/64/bootstrap.factor" parsed-file parsed >> +<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >> call diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor index 9e70ada5d0..abbd0cf21b 100644 --- a/basis/cpu/x86/64/unix/unix.factor +++ b/basis/cpu/x86/64/unix/unix.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel layouts system compiler.cfg.registers -cpu.architecture cpu.x86.assembler ; +cpu.architecture cpu.x86.assembler cpu.x86 ; IN: cpu.x86.64.unix M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ; From c669040754d94077d17f88f38ee33840bca4f1be Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Nov 2008 21:56:57 -0600 Subject: [PATCH 26/26] Pass -fno-forward-propagate on gcc 4.3 --- build-support/factor.sh | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index 07d05e29b5..7fbb54a568 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -60,10 +60,11 @@ check_gcc_version() { GCC_VERSION=`$CC --version` check_ret gcc if [[ $GCC_VERSION == *3.3.* ]] ; then - $ECHO "bad!" $ECHO "You have a known buggy version of gcc (3.3)" $ECHO "Install gcc 3.4 or higher and try again." exit 3 + elif [[ $GCC_VERSION == *4.3.* ]] ; then + MAKE_OPTS="$MAKE_OPTS SITE_CFLAGS=-fno-forward-propagate" fi $ECHO "ok." } @@ -282,7 +283,7 @@ set_build_info() { else MAKE_IMAGE_TARGET=$ARCH.$WORD fi - BOOT_IMAGE_NAME=boot.$MAKE_IMAGE_TARGET.image + BOOT_IMAGE=boot.$MAKE_IMAGE_TARGET.image } parse_build_info() { @@ -335,7 +336,7 @@ cd_factor() { } invoke_make() { - $MAKE $* + $MAKE $MAKE_OPTS $* check_ret $MAKE }