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/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index cab86dcb54..35d4d59253 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces make math math.parser sequences accessors +USING: namespaces make math math.order math.parser sequences accessors kernel kernel.private layouts assocs words summary arrays combinators classes.algebra alien alien.c-types alien.structs alien.strings alien.arrays sets threads libc continuations.private @@ -234,13 +234,26 @@ M: float-regs reg-class-variable drop float-regs ; GENERIC: inc-reg-class ( register-class -- ) -M: reg-class inc-reg-class - dup reg-class-variable inc - fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ; +: ?dummy-stack-params ( reg-class -- ) + dummy-stack-params? [ reg-size stack-params +@ ] [ drop ] if ; + +: ?dummy-int-params ( reg-class -- ) + dummy-int-params? [ reg-size cell /i 1 max int-regs +@ ] [ drop ] if ; + +: ?dummy-fp-params ( reg-class -- ) + drop dummy-fp-params? [ float-regs inc ] when ; + +M: int-regs inc-reg-class + [ reg-class-variable inc ] + [ ?dummy-stack-params ] + [ ?dummy-fp-params ] + tri ; M: float-regs inc-reg-class - dup call-next-method - fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ; + [ reg-class-variable inc ] + [ ?dummy-stack-params ] + [ ?dummy-int-params ] + tri ; GENERIC: reg-class-full? ( class -- ? ) 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/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index e4fa9419f0..b0b5b048d9 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -146,8 +146,14 @@ HOOK: struct-small-enough? cpu ( heap-size -- ? ) ! Do we pass value structs by value or hidden reference? HOOK: value-structs? cpu ( -- ? ) -! If t, fp parameters are shadowed by dummy int parameters -HOOK: fp-shadows-int? cpu ( -- ? ) +! If t, all parameters are shadowed by dummy stack parameters +HOOK: dummy-stack-params? cpu ( -- ? ) + +! If t, all FP parameters are shadowed by dummy int parameters +HOOK: dummy-int-params? cpu ( -- ? ) + +! If t, all int parameters are shadowed by dummy FP parameters +HOOK: dummy-fp-params? cpu ( -- ? ) HOOK: %prepare-unbox cpu ( -- ) diff --git a/basis/cpu/ppc/linux/linux.factor b/basis/cpu/ppc/linux/linux.factor new file mode 100644 index 0000000000..090495aa11 --- /dev/null +++ b/basis/cpu/ppc/linux/linux.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors system kernel layouts +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 cells ; + +M: linux lr-save 1 cells ; + +M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 } ; + +M: ppc value-structs? f ; + +M: ppc dummy-stack-params? f ; + +M: ppc dummy-int-params? f ; + +M: ppc dummy-fp-params? 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..877fb37d31 --- /dev/null +++ b/basis/cpu/ppc/macosx/macosx.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors system kernel layouts +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 cells ; + +M: macosx lr-save 2 cells ; + +M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ; + +M: ppc value-structs? t ; + +M: ppc dummy-stack-params? t ; + +M: ppc dummy-int-params? t ; + +M: ppc dummy-fp-params? f ; 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..2be46d15ee 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 @@ -370,12 +349,17 @@ M: ppc %gc "end" resolve-label ; M: ppc %prologue ( n -- ) - 0 scratch-reg LOAD32 rc-absolute-ppc-2/2 rel-this + #! We use a volatile register (r11) here for scratch. Because + #! callback bodies have a prologue too, we cannot assume + #! that c_to_factor saved all non-volatile registers, so + #! we have to respect the C calling convention. Also, we + #! cannot touch any param-regs either. + 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 -- ) @@ -458,11 +442,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 +564,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 +573,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..f26d76551a 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 ; @@ -272,6 +274,12 @@ M: x86.32 %callback-return ( n -- ) [ drop 0 ] } cond RET ; +M: x86.32 dummy-stack-params? f ; + +M: x86.32 dummy-int-params? f ; + +M: x86.32 dummy-fp-params? f ; + os windows? [ cell "longlong" c-type (>>align) cell "ulonglong" c-type (>>align) 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..0d20660021 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -24,14 +24,13 @@ 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 +: param-reg-3 int-regs param-regs third ; 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 -- ) @@ -42,13 +41,13 @@ M: x86.64 %prologue ( n -- ) M: stack-params %load-param-reg drop - >r R11 swap stack@ MOV - r> stack@ R11 MOV ; + >r R11 swap param@ MOV + r> param@ R11 MOV ; M: stack-params %save-param-reg drop R11 swap next-stack@ MOV - stack@ R11 MOV ; + param@ R11 MOV ; : with-return-regs ( quot -- ) [ @@ -57,40 +56,9 @@ M: stack-params %save-param-reg call ] with-scope ; inline -! The ABI for passing structs by value is pretty messed up -<< "void*" c-type clone "__stack_value" define-primitive-type -stack-params "__stack_value" c-type (>>reg-class) >> - -: struct-types&offset ( struct-type -- pairs ) - fields>> [ - [ type>> ] [ offset>> ] bi 2array - ] map ; - -: split-struct ( pairs -- seq ) - [ - [ 8 mod zero? [ t , ] when , ] assoc-each - ] { } make { t } split harvest ; - -: flatten-small-struct ( c-type -- seq ) - struct-types&offset split-struct [ - [ c-type c-type-reg-class ] map - int-regs swap member? "void*" "double" ? c-type - ] map ; - -: flatten-large-struct ( c-type -- seq ) - heap-size cell align - cell /i "__stack_value" c-type ; - -M: struct-type flatten-value-type ( type -- seq ) - dup heap-size 16 > [ - flatten-large-struct - ] [ - flatten-small-struct - ] if ; - 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,29 +71,29 @@ 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. + R11 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 R11 so that we don't ! clobber it. - RDI RAX MOV + R11 RAX MOV [ - flatten-small-struct [ %unbox-struct-field ] each-index + flatten-value-type [ %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 param@ LEA ! Load structure size - RDX swap MOV + param-reg-3 swap MOV ! Copy the struct to the C stack "to_value_struct" f %alien-invoke ; @@ -144,10 +112,7 @@ M: x86.64 %box ( n reg-class func -- ) M: x86.64 %box-long-long ( n func -- ) int-regs swap %box ; -M: x86.64 struct-small-enough? ( size -- ? ) - heap-size 2 cells <= ; - -: box-struct-field@ ( i -- operand ) 1+ cells stack@ ; +: box-struct-field@ ( i -- operand ) 1+ cells param@ ; : %box-struct-field ( c-type i -- ) box-struct-field@ swap reg-class>> { @@ -158,21 +123,21 @@ M: x86.64 struct-small-enough? ( size -- ? ) M: x86.64 %box-small-struct ( c-type -- ) #! Box a <= 16-byte struct. [ - [ 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 + [ flatten-value-type [ %box-struct-field ] each-index ] + [ param-reg-3 swap heap-size MOV ] bi + 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 ; : struct-return@ ( n -- operand ) - [ stack-frame get params>> ] unless* stack@ ; + [ stack-frame get params>> ] unless* param@ ; 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 ; @@ -180,7 +145,7 @@ M: x86.64 %prepare-box-struct ( -- ) ! Compute target address for value struct return RAX f struct-return@ LEA ! Store it as the first parameter - 0 stack@ RAX MOV ; + 0 param@ RAX MOV ; M: x86.64 %prepare-var-args RAX RAX XOR ; @@ -200,7 +165,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 +173,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 +188,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..ddb412873a --- /dev/null +++ b/basis/cpu/x86/64/unix/unix.factor @@ -0,0 +1,54 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays sequences math splitting make assocs +kernel layouts system alien.c-types alien.structs +cpu.architecture cpu.x86.assembler cpu.x86 +compiler.codegen compiler.cfg.registers ; +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 ; + +! The ABI for passing structs by value is pretty messed up +<< "void*" c-type clone "__stack_value" define-primitive-type +stack-params "__stack_value" c-type (>>reg-class) >> + +: struct-types&offset ( struct-type -- pairs ) + fields>> [ + [ type>> ] [ offset>> ] bi 2array + ] map ; + +: split-struct ( pairs -- seq ) + [ + [ 8 mod zero? [ t , ] when , ] assoc-each + ] { } make { t } split harvest ; + +: flatten-small-struct ( c-type -- seq ) + struct-types&offset split-struct [ + [ c-type c-type-reg-class ] map + int-regs swap member? "void*" "double" ? c-type + ] map ; + +: flatten-large-struct ( c-type -- seq ) + heap-size cell align + cell /i "__stack_value" c-type ; + +M: struct-type flatten-value-type ( type -- seq ) + dup heap-size 16 > [ + flatten-large-struct + ] [ + flatten-small-struct + ] if ; + +M: x86.64 struct-small-enough? ( size -- ? ) + heap-size 2 cells <= ; + +M: x86.64 dummy-stack-params? f ; + +M: x86.64 dummy-int-params? f ; + +M: x86.64 dummy-fp-params? f ; 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..0124c40877 --- /dev/null +++ b/basis/cpu/x86/64/winnt/winnt.factor @@ -0,0 +1,26 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel layouts system math 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 ; + +M: x86.64 struct-small-enough? ( size -- ? ) + heap-size cell <= ; + +M: x86.64 dummy-stack-params? f ; + +M: x86.64 dummy-int-params? t ; + +M: x86.64 dummy-fp-params? t ; + +<< +"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..4f72fe45e1 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 ; @@ -464,8 +467,10 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- ) : stack@ ( n -- op ) stack-reg swap [+] ; +: param@ ( n -- op ) reserved-area-size + stack@ ; + : spill-integer-base ( stack-frame -- n ) - [ params>> ] [ return>> ] bi + ; + [ params>> ] [ return>> ] bi + reserved-area-size + ; : spill-integer@ ( n -- op ) cells @@ -473,10 +478,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 * @@ -491,16 +495,16 @@ M: x86 %reload-float ( dst n -- ) spill-float@ MOVSD ; M: x86 %loop-entry 16 code-alignment [ NOP ] times ; -M: int-regs %save-param-reg drop >r stack@ r> MOV ; -M: int-regs %load-param-reg drop swap stack@ MOV ; +M: int-regs %save-param-reg drop >r param@ r> MOV ; +M: int-regs %load-param-reg drop swap param@ MOV ; GENERIC: MOVSS/D ( dst src reg-class -- ) M: single-float-regs MOVSS/D drop MOVSS ; M: double-float-regs MOVSS/D drop MOVSD ; -M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ; -M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ; +M: float-regs %save-param-reg >r >r param@ r> r> MOVSS/D ; +M: float-regs %load-param-reg >r swap param@ r> MOVSS/D ; GENERIC: push-return-reg ( reg-class -- ) GENERIC: load-return-reg ( n reg-class -- ) @@ -516,8 +520,6 @@ M: x86 %prepare-alien-invoke temp-reg-1 2 cells [+] ds-reg MOV temp-reg-1 3 cells [+] rs-reg MOV ; -M: x86 fp-shadows-int? ( -- ? ) f ; - M: x86 value-structs? t ; M: x86 small-enough? ( n -- ? ) diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor index 395d5c3caf..87c59e18a0 100644 --- a/basis/fry/fry.factor +++ b/basis/fry/fry.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences combinators parser splitting math -quotations arrays make qualified words ; +quotations arrays make words ; IN: fry : _ ( -- * ) "Only valid inside a fry" throw ; 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/basis/qualified/qualified-docs.factor b/basis/qualified/qualified-docs.factor index d62f696a74..067d221d2f 100644 --- a/basis/qualified/qualified-docs.factor +++ b/basis/qualified/qualified-docs.factor @@ -32,3 +32,14 @@ HELP: RENAME: "RENAME: + math => -" "2 3 - ! => 5" } } ; +ARTICLE: "qualified" "Qualified word lookup" +"The " { $vocab-link "qualified" } " vocabulary provides a handful of parsing words which give more control over word lookup than is offered by " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } "." +$nl +"These words are useful when there is no way to avoid using two vocabularies with identical word names in the same source file." +{ $subsection POSTPONE: QUALIFIED: } +{ $subsection POSTPONE: QUALIFIED-WITH: } +{ $subsection POSTPONE: FROM: } +{ $subsection POSTPONE: EXCLUDE: } +{ $subsection POSTPONE: RENAME: } ; + +ABOUT: "qualified" diff --git a/basis/qualified/qualified-tests.factor b/basis/qualified/qualified-tests.factor index 8f67ddf730..78efec4861 100644 --- a/basis/qualified/qualified-tests.factor +++ b/basis/qualified/qualified-tests.factor @@ -1,24 +1,33 @@ -USING: tools.test qualified ; -IN: foo +USING: tools.test qualified eval accessors parser ; +IN: qualified.tests.foo : x 1 ; -IN: bar +: y 5 ; +IN: qualified.tests.bar : x 2 ; -IN: baz +: y 4 ; +IN: qualified.tests.baz : x 3 ; -QUALIFIED: foo -QUALIFIED: bar -[ 1 2 3 ] [ foo:x bar:x x ] unit-test +QUALIFIED: qualified.tests.foo +QUALIFIED: qualified.tests.bar +[ 1 2 3 ] [ qualified.tests.foo:x qualified.tests.bar:x x ] unit-test -QUALIFIED-WITH: bar p +QUALIFIED-WITH: qualified.tests.bar p [ 2 ] [ p:x ] unit-test -RENAME: x baz => y +RENAME: x qualified.tests.baz => y [ 3 ] [ y ] unit-test -FROM: baz => x ; +FROM: qualified.tests.baz => x ; [ 3 ] [ x ] unit-test +[ 3 ] [ y ] unit-test -EXCLUDE: bar => x ; +EXCLUDE: qualified.tests.bar => x ; [ 3 ] [ x ] unit-test +[ 4 ] [ y ] unit-test +[ "USE: qualified IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval ] +[ error>> no-word-error? ] must-fail-with + +[ "USE: qualified IN: qualified.tests RENAME: doesnotexist qualified.tests => blah" eval ] +[ error>> no-word-error? ] must-fail-with diff --git a/basis/qualified/qualified.factor b/basis/qualified/qualified.factor index d636cc0152..d387ef4b0e 100644 --- a/basis/qualified/qualified.factor +++ b/basis/qualified/qualified.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2007, 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences assocs hashtables parser lexer -vocabs words namespaces vocabs.loader debugger sets ; +vocabs words namespaces vocabs.loader debugger sets fry ; IN: qualified : define-qualified ( vocab-name prefix-name -- ) [ load-vocab vocab-words ] [ CHAR: : suffix ] bi* - [ -rot >r append r> ] curry assoc-map + '[ [ [ _ ] dip append ] dip ] assoc-map use get push ; : QUALIFIED: @@ -19,27 +19,27 @@ IN: qualified : expect=> ( -- ) scan "=>" assert= ; -: partial-vocab ( words name -- assoc ) - dupd [ - lookup [ "No such word: " swap append throw ] unless* - ] curry map zip ; - -: partial-vocab-ignoring ( words name -- assoc ) - [ load-vocab vocab-words keys swap diff ] keep partial-vocab ; - -: EXCLUDE: - #! Syntax: EXCLUDE: vocab => words ... ; - scan expect=> - ";" parse-tokens swap partial-vocab-ignoring use get push ; parsing +: partial-vocab ( words vocab -- assoc ) + '[ dup _ lookup [ no-word-error ] unless* ] + { } map>assoc ; : FROM: #! Syntax: FROM: vocab => words... ; scan dup load-vocab drop expect=> ";" parse-tokens swap partial-vocab use get push ; parsing +: partial-vocab-excluding ( words vocab -- assoc ) + [ load-vocab vocab-words keys swap diff ] keep partial-vocab ; + +: EXCLUDE: + #! Syntax: EXCLUDE: vocab => words ... ; + scan expect=> + ";" parse-tokens swap partial-vocab-excluding use get push ; parsing + : RENAME: #! Syntax: RENAME: word vocab => newname - scan scan dup load-vocab drop lookup [ "No such word" throw ] unless* + scan scan dup load-vocab drop + dupd lookup [ ] [ no-word-error ] ?if expect=> scan associate use get push ; parsing 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 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|| ; diff --git a/basis/ui/gadgets/lists/lists.factor b/basis/ui/gadgets/lists/lists.factor index 62e5b7d780..17fe68721d 100644 --- a/basis/ui/gadgets/lists/lists.factor +++ b/basis/ui/gadgets/lists/lists.factor @@ -97,7 +97,7 @@ M: list focusable-child* drop t ; ] if ; : select-gadget ( gadget list -- ) - swap over children>> index + tuck children>> index [ swap select-index ] [ drop ] if* ; : clamp-loc ( point max -- point ) diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor index fefce8a040..633e3ad4a8 100644 --- a/basis/ui/gadgets/scrollers/scrollers.factor +++ b/basis/ui/gadgets/scrollers/scrollers.factor @@ -41,7 +41,7 @@ scroller H{ dup model>> dependencies>> first >>x dup x>> @bottom grid-add dup model>> dependencies>> second >>y dup y>> @right grid-add - swap over model>> >>viewport + tuck model>> >>viewport dup viewport>> @center grid-add ; : ( gadget -- scroller ) scroller new-scroller ; diff --git a/build-support/factor.sh b/build-support/factor.sh index 5cbc1e96e3..bd234afb5f 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." } @@ -270,19 +271,23 @@ 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 + MAKE_TARGET=macosx-ppc + elif [[ $OS == linux && $ARCH == ppc ]] ; then + MAKE_IMAGE_TARGET=linux-ppc + MAKE_TARGET=linux-ppc + elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then + MAKE_IMAGE_TARGET=winnt-x86.64 + MAKE_TARGET=winnt-x86-64 + elif [[ $ARCH == x86 && $WORD == 64 ]] ; then + MAKE_IMAGE_TARGET=unix-x86.64 + MAKE_TARGET=$OS-x86-64 + else + MAKE_IMAGE_TARGET=$ARCH.$WORD + MAKE_TARGET=$OS-$ARCH-$WORD fi + BOOT_IMAGE=boot.$MAKE_IMAGE_TARGET.image } parse_build_info() { @@ -335,7 +340,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/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 1d8d1f0714..d33f5cd6d9 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -69,7 +69,7 @@ $nl { $subsection POSTPONE: PRIVATE> } { $subsection "vocabulary-search-errors" } { $subsection "vocabulary-search-shadow" } -{ $see-also "words" } ; +{ $see-also "words" "qualified" } ; ARTICLE: "reading-ahead" "Reading ahead" "Parsing words can consume input:" diff --git a/core/parser/parser.factor b/core/parser/parser.factor index a86715b073..ed8fc4510b 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -71,10 +71,10 @@ ERROR: no-current-vocab ; ] keep ] { } map>assoc ; -TUPLE: no-word-error name ; +ERROR: no-word-error name ; : no-word ( name -- newword ) - dup no-word-error boa + dup \ no-word-error boa swap words-named [ forward-reference? not ] filter word-restarts throw-restarts dup vocabulary>> (use+) ; diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor index 651c5f7ca1..4d83300934 100755 --- a/extra/graphics/bitmap/bitmap.factor +++ b/extra/graphics/bitmap/bitmap.factor @@ -5,7 +5,7 @@ USING: alien arrays byte-arrays combinators summary io.backend graphics.viewer io io.binary io.files kernel libc math math.functions namespaces opengl opengl.gl prettyprint sequences strings ui ui.gadgets.panes io.encodings.binary -accessors ; +accessors grouping ; IN: graphics.bitmap ! Currently can only handle 24bit bitmaps. @@ -23,16 +23,25 @@ TUPLE: bitmap magic size reserved offset header-length width swap [ >>array ] [ >>color-index ] bi 24 >>bit-count ; -: raw-bitmap>string ( str n -- str ) +: 8bit>array ( bitmap -- array ) + [ rgb-quads>> 4 [ 3 head-slice ] map ] + [ color-index>> >array ] bi [ swap nth ] with map concat ; + +: 4bit>array ( bitmap -- array ) + [ rgb-quads>> 4 [ 3 head-slice ] map ] + [ color-index>> >array ] bi [ swap nth ] with map concat ; + +: raw-bitmap>array ( bitmap -- array ) + dup bit-count>> { { 32 [ "32bit" throw ] } - { 24 [ ] } + { 24 [ color-index>> ] } { 16 [ "16bit" throw ] } - { 8 [ "8bit" throw ] } - { 4 [ "4bit" throw ] } + { 8 [ 8bit>array ] } + { 4 [ 4bit>array ] } { 2 [ "2bit" throw ] } { 1 [ "1bit" throw ] } - } case ; + } case >byte-array ; ERROR: bitmap-magic ; @@ -72,13 +81,12 @@ M: bitmap-magic summary : load-bitmap ( path -- bitmap ) normalize-path binary [ - T{ bitmap } clone - dup parse-file-header - dup parse-bitmap-header - dup parse-bitmap + bitmap new + dup parse-file-header + dup parse-bitmap-header + dup parse-bitmap ] with-file-reader - dup color-index>> over bit-count>> - raw-bitmap>string >byte-array >>array ; + dup raw-bitmap>array >>array ; : save-bitmap ( bitmap path -- ) binary [ @@ -118,6 +126,8 @@ M: bitmap draw-image ( bitmap -- ) bit-count>> { ! { 32 [ GL_BGRA GL_UNSIGNED_INT_8_8_8_8 ] } ! broken { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } } case ] keep array>> glDrawPixels ; diff --git a/extra/hexdump/hexdump-tests.factor b/extra/hexdump/hexdump-tests.factor index 7fb26e10c5..b3c03196f5 100644 --- a/extra/hexdump/hexdump-tests.factor +++ b/extra/hexdump/hexdump-tests.factor @@ -6,3 +6,6 @@ USING: hexdump kernel sequences tools.test ; [ t ] [ 256 [ ] map hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test + +[ + "Length: 3, 3h\n00000000h: 01 02 03 ...\n" ] [ B{ 1 2 3 } hexdump ] unit-test diff --git a/extra/hexdump/hexdump.factor b/extra/hexdump/hexdump.factor index b965fb41bb..ecbc2d6169 100644 --- a/extra/hexdump/hexdump.factor +++ b/extra/hexdump/hexdump.factor @@ -21,9 +21,9 @@ IN: hexdump [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-right ; : >ascii ( bytes -- str ) - [ [ printable? ] keep CHAR: . ? ] map ; + [ [ printable? ] keep CHAR: . ? ] "" map-as ; -: write-hex-line ( str lineno -- ) +: write-hex-line ( bytes lineno -- ) write-offset [ >hex-digits write ] [ >ascii write ] bi nl ; PRIVATE> 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/extra/mason/release/tidy/tidy.factor b/extra/mason/release/tidy/tidy.factor index a456e6ff23..fb931650d4 100644 --- a/extra/mason/release/tidy/tidy.factor +++ b/extra/mason/release/tidy/tidy.factor @@ -1,16 +1,14 @@ ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces continuations debugger sequences fry -io.files io.launcher mason.common mason.platform +io.files io.launcher bootstrap.image qualified mason.common mason.config ; +FROM: mason.config => target-os ; IN: mason.release.tidy : common-files ( -- seq ) + images [ boot-image-name ] map { - "boot.x86.32.image" - "boot.x86.64.image" - "boot.macosx-ppc.image" - "boot.linux-ppc.image" "vm" "temp" "logs" @@ -20,7 +18,8 @@ IN: mason.release.tidy "unmaintained" "unfinished" "build-support" - } ; + } + append ; : remove-common-files ( -- ) common-files [ delete-tree ] each ; 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 ; 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..b7e99b418c 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",(CELL)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..6ddbd52da2 100755 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -10,13 +10,18 @@ and the callstack top is passed in EDX */ #define DS_REG %esi #define RETURN_REG %eax +#define NV_TEMP_REG %ebx + #define CELL_SIZE 4 +#define STACK_PADDING 12 #define PUSH_NONVOLATILE \ push %ebx ; \ + push %ebp ; \ push %ebp #define POP_NONVOLATILE \ + pop %ebp ; \ pop %ebp ; \ pop %ebx diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index 57bfcee87b..c981095d62 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -1,24 +1,61 @@ #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 ; +#define NV_TEMP_REG %rbp -#define POP_NONVOLATILE \ - pop %r13 ; \ - pop %r12 ; \ - pop %rbp ; \ - pop %rbx +#ifdef WINDOWS + + #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 ; \ + push %rbp + + #define POP_NONVOLATILE \ + pop %rbp ; \ + 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 ; \ + push %r13 + + #define POP_NONVOLATILE \ + pop %r13 ; \ + pop %r13 ; \ + pop %r12 ; \ + pop %rbp ; \ + pop %rbx + +#endif #define QUOT_XT_OFFSET 21 @@ -26,9 +63,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..1857fb0ed8 100755 --- a/vm/cpu-x86.S +++ b/vm/cpu-x86.S @@ -1,31 +1,35 @@ DEF(F_FASTCALL void,c_to_factor,(CELL quot)): PUSH_NONVOLATILE - push ARG0 /* Save quot */ + mov ARG0,NV_TEMP_REG - lea -CELL_SIZE(STACK_REG),ARG0 /* Save stack pointer */ + /* Create register shadow area for Win64 */ + sub $32,STACK_REG + + /* Save stack pointer */ + lea -CELL_SIZE(STACK_REG),ARG0 call MANGLE(save_callstack_bottom) - mov (STACK_REG),ARG0 /* Pass quot as arg 1 */ - call *QUOT_XT_OFFSET(ARG0) /* Call quot-xt */ + /* Call quot-xt */ + mov NV_TEMP_REG,ARG0 + call *QUOT_XT_OFFSET(ARG0) + + /* Tear down register shadow area */ + add $32,STACK_REG - 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; }