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..8b0051148f 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" [ "-ppc" append ] } + { "x86.64" [ "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 ; @@ -25,7 +31,7 @@ IN: bootstrap.image : images ( -- seq ) { "x86.32" - "x86.64" + "winnt-x86.64" "unix-x86.64" "linux-ppc" "macosx-ppc" } ; 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/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 ad6c63b8c9..d2d1e26396 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -15,18 +15,6 @@ 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 >> - M: ppc machine-registers { { int-regs T{ range f 2 26 1 } } @@ -65,17 +53,8 @@ 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 - -: lr-save ( -- n ) - os { - { linux [ 1 ] } - { macosx [ 2 ] } - } case cells ; foldable +HOOK: reserved-area-size os ( -- n ) +HOOK: lr-save os ( -- n ) : param@ ( n -- x ) reserved-area-size + ; inline @@ -458,11 +437,6 @@ 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 ; @@ -585,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 ; @@ -601,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 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..29d48bd794 --- /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" parse-file parsed >> +call diff --git a/basis/cpu/x86/64/unix/tags.txt b/basis/cpu/x86/64/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cpu/x86/64/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor new file mode 100644 index 0000000000..abbd0cf21b --- /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 cpu.x86 ; +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/tags.txt b/basis/cpu/x86/64/winnt/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cpu/x86/64/winnt/tags.txt @@ -0,0 +1 @@ +unportable 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/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/build-support/factor.sh b/build-support/factor.sh index 5cbc1e96e3..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." } @@ -271,18 +272,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=boot.$MAKE_IMAGE_TARGET.image } parse_build_info() { @@ -335,7 +336,7 @@ cd_factor() { } invoke_make() { - $MAKE $* + $MAKE $MAKE_OPTS $* check_ret $MAKE } 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" } 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 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 ; diff --git a/extra/mason/release/branch/branch-tests.factor b/extra/mason/release/branch/branch-tests.factor index 68046f79cf..ae3ddb61fc 100644 --- a/extra/mason/release/branch/branch-tests.factor +++ b/extra/mason/release/branch/branch-tests.factor @@ -12,7 +12,7 @@ USING: mason.release.branch mason.config tools.test namespaces ; ] with-scope ] unit-test -[ { "scp" "boot.x86.64.image" "joe@blah.com:/stuff/clean/netbsd-x86-64" } ] [ +[ { "scp" "boot.unix-x86.64.image" "joe@blah.com:/stuff/clean/netbsd-x86-64" } ] [ [ "joe" image-username set "blah.com" image-host set 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/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); 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; }