diff --git a/README.txt b/README.txt index addbe38f0d..a33a85b218 100755 --- a/README.txt +++ b/README.txt @@ -20,25 +20,18 @@ implementation. It is not an introduction to the language itself. * Compiling the Factor VM -The Factor runtime is written in GNU C++, and is built with GNU make and -gcc. - Factor supports various platforms. For an up-to-date list, see . -Factor requires gcc 3.4 or later. - -On x86, Factor /will not/ build using gcc 3.3 or earlier. - -If you are using gcc 4.3, you might get an unusable Factor binary unless -you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line -arguments for make. +The Factor VM is written in C++ and uses GNU extensions. When compiling +with GCC 3.x, boost::unordered_map must be installed. On GCC 4.x, Factor +uses std::tr1::unordered_map which is shipped as part of GCC. Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM. * Bootstrapping the Factor image -Once you have compiled the Factor runtime, you must bootstrap the Factor +Once you have compiled the Factor VM, you must bootstrap the Factor system using the image that corresponds to your CPU architecture. Boot images can be obtained from . @@ -97,7 +90,7 @@ When compiling Factor, pass the X11=1 parameter: Then bootstrap with the following switches: - ./factor -i=boot..image -ui-backend=x11 -ui-text-backend=pango + ./factor -i=boot..image -ui-backend=x11 Now if $DISPLAY is set, running ./factor will start the UI. @@ -138,7 +131,7 @@ usage documentation, enter the following in the UI listener: The Factor source tree is organized as follows: build-support/ - scripts used for compiling Factor - vm/ - sources for the Factor VM, written in C++ + vm/ - Factor VM core/ - Factor core library basis/ - Factor basis library, compiler, tools extra/ - more libraries and applications diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 9cd57f61ab..6067c90f2d 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -409,10 +409,10 @@ CONSTANT: primitive-types "uchar" define-primitive-type - [ alien-unsigned-4 zero? not ] >>getter - [ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter - 4 >>size - 4 >>align + [ alien-unsigned-1 zero? not ] >>getter + [ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter + 1 >>size + 1 >>align "box_boolean" >>boxer "to_boolean" >>unboxer "bool" define-primitive-type diff --git a/basis/alien/libraries/libraries.factor b/basis/alien/libraries/libraries.factor old mode 100644 new mode 100755 index 6c18065ab6..0b39bedadd --- a/basis/alien/libraries/libraries.factor +++ b/basis/alien/libraries/libraries.factor @@ -5,7 +5,7 @@ IN: alien.libraries : dlopen ( path -- dll ) native-string>alien (dlopen) ; -: dlsym ( name dll -- alien ) [ native-string>alien ] dip (dlsym) ; +: dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ; SYMBOL: libraries diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor old mode 100644 new mode 100755 index 7940703140..3aefdec29f --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -41,7 +41,7 @@ nl ! which are also quick to compile are replaced by ! compiled definitions as soon as possible. { - roll -roll declare not + not array? hashtable? vector? tuple? sbuf? tombstone? diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index cad40b6384..55e6a31491 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -9,7 +9,7 @@ classes.builtin classes.tuple classes.tuple.private vocabs vocabs.loader source-files definitions debugger quotations.private sequences.private combinators math.order math.private accessors slots.private generic.single.private compiler.units compiler.constants -fry ; +fry bootstrap.image.syntax ; IN: bootstrap.image : arch ( os cpu -- arch ) @@ -93,24 +93,19 @@ CONSTANT: -1-offset 9 SYMBOL: sub-primitives -SYMBOL: jit-define-rc -SYMBOL: jit-define-rt -SYMBOL: jit-define-offset +SYMBOL: jit-relocations -: compute-offset ( -- offset ) - building get length jit-define-rc get rc-absolute-cell = bootstrap-cell 4 ? - ; +: compute-offset ( rc -- offset ) + [ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ; : jit-rel ( rc rt -- ) - jit-define-rt set - jit-define-rc set - compute-offset jit-define-offset set ; + over compute-offset 3array jit-relocations get push-all ; -: make-jit ( quot -- quad ) +: make-jit ( quot -- jit-data ) [ + V{ } clone jit-relocations set call( -- ) - jit-define-rc get - jit-define-rt get - jit-define-offset get 3array + jit-relocations get >array ] B{ } make prefix ; : jit-define ( quot name -- ) @@ -128,98 +123,59 @@ SYMBOL: big-endian ! Bootstrap architecture name SYMBOL: architecture -! Bootstrap global namesapce -SYMBOL: bootstrap-global +RESET ! Boot quotation, set in stage1.factor -SYMBOL: bootstrap-boot-quot +USERENV: bootstrap-boot-quot 20 + +! Bootstrap global namesapce +USERENV: bootstrap-global 21 ! JIT parameters -SYMBOL: jit-prolog -SYMBOL: jit-primitive-word -SYMBOL: jit-primitive -SYMBOL: jit-word-jump -SYMBOL: jit-word-call -SYMBOL: jit-push-immediate -SYMBOL: jit-if-word -SYMBOL: jit-if-1 -SYMBOL: jit-if-2 -SYMBOL: jit-dip-word -SYMBOL: jit-dip -SYMBOL: jit-2dip-word -SYMBOL: jit-2dip -SYMBOL: jit-3dip-word -SYMBOL: jit-3dip -SYMBOL: jit-execute-word -SYMBOL: jit-execute-jump -SYMBOL: jit-execute-call -SYMBOL: jit-epilog -SYMBOL: jit-return -SYMBOL: jit-profiling -SYMBOL: jit-save-stack +USERENV: jit-prolog 23 +USERENV: jit-primitive-word 24 +USERENV: jit-primitive 25 +USERENV: jit-word-jump 26 +USERENV: jit-word-call 27 +USERENV: jit-word-special 28 +USERENV: jit-if-word 29 +USERENV: jit-if 30 +USERENV: jit-epilog 31 +USERENV: jit-return 32 +USERENV: jit-profiling 33 +USERENV: jit-push-immediate 34 +USERENV: jit-dip-word 35 +USERENV: jit-dip 36 +USERENV: jit-2dip-word 37 +USERENV: jit-2dip 38 +USERENV: jit-3dip-word 39 +USERENV: jit-3dip 40 +USERENV: jit-execute-word 41 +USERENV: jit-execute-jump 42 +USERENV: jit-execute-call 43 ! PIC stubs -SYMBOL: pic-load -SYMBOL: pic-tag -SYMBOL: pic-hi-tag -SYMBOL: pic-tuple -SYMBOL: pic-hi-tag-tuple -SYMBOL: pic-check-tag -SYMBOL: pic-check -SYMBOL: pic-hit -SYMBOL: pic-miss-word +USERENV: pic-load 47 +USERENV: pic-tag 48 +USERENV: pic-hi-tag 49 +USERENV: pic-tuple 50 +USERENV: pic-hi-tag-tuple 51 +USERENV: pic-check-tag 52 +USERENV: pic-check 53 +USERENV: pic-hit 54 +USERENV: pic-miss-word 55 +USERENV: pic-miss-tail-word 56 ! Megamorphic dispatch -SYMBOL: mega-lookup -SYMBOL: mega-lookup-word -SYMBOL: mega-miss-word +USERENV: mega-lookup 57 +USERENV: mega-lookup-word 58 +USERENV: mega-miss-word 59 ! Default definition for undefined words -SYMBOL: undefined-quot - -: userenvs ( -- assoc ) - H{ - { bootstrap-boot-quot 20 } - { bootstrap-global 21 } - { jit-prolog 23 } - { jit-primitive-word 24 } - { jit-primitive 25 } - { jit-word-jump 26 } - { jit-word-call 27 } - { jit-if-word 28 } - { jit-if-1 29 } - { jit-if-2 30 } - { jit-epilog 33 } - { jit-return 34 } - { jit-profiling 35 } - { jit-push-immediate 36 } - { jit-save-stack 38 } - { jit-dip-word 39 } - { jit-dip 40 } - { jit-2dip-word 41 } - { jit-2dip 42 } - { jit-3dip-word 43 } - { jit-3dip 44 } - { jit-execute-word 45 } - { jit-execute-jump 46 } - { jit-execute-call 47 } - { pic-load 48 } - { pic-tag 49 } - { pic-hi-tag 50 } - { pic-tuple 51 } - { pic-hi-tag-tuple 52 } - { pic-check-tag 53 } - { pic-check 54 } - { pic-hit 55 } - { pic-miss-word 56 } - { mega-lookup 57 } - { mega-lookup-word 58 } - { mega-miss-word 59 } - { undefined-quot 60 } - } ; inline +USERENV: undefined-quot 60 : userenv-offset ( symbol -- n ) - userenvs at header-size + ; + userenvs get at header-size + ; : emit ( cell -- ) image get push ; @@ -351,7 +307,8 @@ M: f ' [ vocabulary>> , ] [ def>> , ] [ props>> , ] - [ direct-entry-def>> , ] ! direct-entry-def + [ pic-def>> , ] + [ pic-tail-def>> , ] [ drop 0 , ] ! count [ word-sub-primitive , ] [ drop 0 , ] ! xt @@ -510,11 +467,7 @@ M: quotation ' class<=-cache class-not-cache classes-intersect-cache class-and-cache class-or-cache next-method-quot-cache } [ H{ } clone ] H{ } map>assoc assoc-union - bootstrap-global set - bootstrap-global emit-userenv ; - -: emit-boot-quot ( -- ) - bootstrap-boot-quot emit-userenv ; + bootstrap-global set ; : emit-jit-data ( -- ) \ if jit-if-word set @@ -524,46 +477,13 @@ M: quotation ' \ 3dip jit-3dip-word set \ (execute) jit-execute-word set \ inline-cache-miss \ pic-miss-word set + \ inline-cache-miss-tail \ pic-miss-tail-word set \ mega-cache-lookup \ mega-lookup-word set \ mega-cache-miss \ mega-miss-word set - [ undefined ] undefined-quot set - { - jit-prolog - jit-primitive-word - jit-primitive - jit-word-jump - jit-word-call - jit-push-immediate - jit-if-word - jit-if-1 - jit-if-2 - jit-dip-word - jit-dip - jit-2dip-word - jit-2dip - jit-3dip-word - jit-3dip - jit-execute-word - jit-execute-jump - jit-execute-call - jit-epilog - jit-return - jit-profiling - jit-save-stack - pic-load - pic-tag - pic-hi-tag - pic-tuple - pic-hi-tag-tuple - pic-check-tag - pic-check - pic-hit - pic-miss-word - mega-lookup - mega-lookup-word - mega-miss-word - undefined-quot - } [ emit-userenv ] each ; + [ undefined ] undefined-quot set ; + +: emit-userenvs ( -- ) + userenvs get keys [ emit-userenv ] each ; : fixup-header ( -- ) heap-size data-heap-size-offset fixup ; @@ -580,8 +500,8 @@ M: quotation ' emit-jit-data "Serializing global namespace..." print flush emit-global - "Serializing boot quotation..." print flush - emit-boot-quot + "Serializing user environment..." print flush + emit-userenvs "Performing word fixups..." print flush fixup-words "Performing header fixups..." print flush diff --git a/basis/bootstrap/image/syntax/authors.txt b/basis/bootstrap/image/syntax/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/bootstrap/image/syntax/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/bootstrap/image/syntax/syntax.factor b/basis/bootstrap/image/syntax/syntax.factor new file mode 100644 index 0000000000..29dc09717a --- /dev/null +++ b/basis/bootstrap/image/syntax/syntax.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: parser kernel namespaces assocs words.symbol ; +IN: bootstrap.image.syntax + +SYMBOL: userenvs + +SYNTAX: RESET H{ } clone userenvs set-global ; + +SYNTAX: USERENV: + CREATE-WORD scan-word + [ swap userenvs get set-at ] + [ drop define-symbol ] + 2bi ; \ No newline at end of file diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 826fa87b73..47593878fa 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -88,7 +88,7 @@ M: ##call generate-insn word>> dup sub-primitive>> [ first % ] [ [ add-call ] [ %call ] bi ] ?if ; -M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ; +M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ; M: ##return generate-insn drop %return ; diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index 99f258d93c..d0c874feb0 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -56,8 +56,11 @@ SYMBOL: literal-table : rel-word ( word class -- ) [ add-literal ] dip rt-xt rel-fixup ; -: rel-word-direct ( word class -- ) - [ add-literal ] dip rt-xt-direct rel-fixup ; +: rel-word-pic ( word class -- ) + [ add-literal ] dip rt-xt-pic rel-fixup ; + +: rel-word-pic-tail ( word class -- ) + [ add-literal ] dip rt-xt-pic-tail rel-fixup ; : rel-primitive ( word class -- ) [ def>> first add-literal ] dip rt-primitive rel-fixup ; diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index 2f0494b58a..6b383388ef 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel layouts system strings words quotations byte-arrays -alien arrays ; +alien arrays literals sequences ; IN: compiler.constants ! These constants must match vm/memory.h @@ -14,42 +14,42 @@ CONSTANT: deck-bits 18 : float-offset ( -- n ) 8 float tag-number - ; inline : string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline : string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline -: profile-count-offset ( -- n ) 7 bootstrap-cells \ word tag-number - ; inline +: profile-count-offset ( -- n ) 8 bootstrap-cells \ word tag-number - ; inline : byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline : alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline : underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline : tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline -: word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; inline +: word-xt-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline : quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline -: word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline +: word-code-offset ( -- n ) 11 bootstrap-cells \ word tag-number - ; inline : array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline -: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline +: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline ! Relocation classes -CONSTANT: rc-absolute-cell 0 -CONSTANT: rc-absolute 1 -CONSTANT: rc-relative 2 +CONSTANT: rc-absolute-cell 0 +CONSTANT: rc-absolute 1 +CONSTANT: rc-relative 2 CONSTANT: rc-absolute-ppc-2/2 3 -CONSTANT: rc-relative-ppc-2 4 -CONSTANT: rc-relative-ppc-3 5 -CONSTANT: rc-relative-arm-3 6 -CONSTANT: rc-indirect-arm 7 -CONSTANT: rc-indirect-arm-pc 8 +CONSTANT: rc-absolute-ppc-2 4 +CONSTANT: rc-relative-ppc-2 5 +CONSTANT: rc-relative-ppc-3 6 +CONSTANT: rc-relative-arm-3 7 +CONSTANT: rc-indirect-arm 8 +CONSTANT: rc-indirect-arm-pc 9 ! Relocation types -CONSTANT: rt-primitive 0 -CONSTANT: rt-dlsym 1 -CONSTANT: rt-dispatch 2 -CONSTANT: rt-xt 3 -CONSTANT: rt-xt-direct 4 -CONSTANT: rt-here 5 -CONSTANT: rt-this 6 -CONSTANT: rt-immediate 7 -CONSTANT: rt-stack-chain 8 -CONSTANT: rt-untagged 9 +CONSTANT: rt-primitive 0 +CONSTANT: rt-dlsym 1 +CONSTANT: rt-dispatch 2 +CONSTANT: rt-xt 3 +CONSTANT: rt-xt-pic 4 +CONSTANT: rt-xt-pic-tail 5 +CONSTANT: rt-here 6 +CONSTANT: rt-this 7 +CONSTANT: rt-immediate 8 +CONSTANT: rt-stack-chain 9 +CONSTANT: rt-untagged 10 +CONSTANT: rt-megamorphic-cache-hits 11 : rc-absolute? ( n -- ? ) - [ rc-absolute-ppc-2/2 = ] - [ rc-absolute-cell = ] - [ rc-absolute = ] - tri or or ; + ${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 42ed90d64a..f7f24433d7 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -588,3 +588,16 @@ FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ; C{ 1.0 2.0 } C{ 1.5 1.0 } ffi_test_47 ] unit-test + +! Reported by jedahu +C-STRUCT: bool-field-test + { "char*" "name" } + { "bool" "on" } + { "short" "parents" } ; + +FUNCTION: short ffi_test_48 ( bool-field-test x ) ; + +[ 123 ] [ + "bool-field-test" 123 over set-bool-field-test-parents + ffi_test_48 +] unit-test \ No newline at end of file diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index f19a950711..fa1248435b 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -389,4 +389,10 @@ DEFER: loop-bbb [ f ] [ \ broken-declaration optimized? ] unit-test -[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test \ No newline at end of file +[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test + +! Modular arithmetic bug +: modular-arithmetic-bug ( a -- b ) >integer 256 mod ; + +[ 1 ] [ 257 modular-arithmetic-bug ] unit-test +[ -10 ] [ -10 modular-arithmetic-bug ] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor index 5d6a9cdea1..6e1c32d89d 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor @@ -98,13 +98,18 @@ TUPLE: declared-fixnum { x fixnum } ; ] { mod fixnum-mod } inlined? ] unit-test - [ f ] [ [ 256 mod ] { mod fixnum-mod } inlined? ] unit-test +[ f ] [ + [ + >fixnum 256 mod + ] { mod fixnum-mod } inlined? +] unit-test + [ f ] [ [ dup 0 >= [ 256 mod ] when @@ -128,3 +133,6 @@ TUPLE: declared-fixnum { x fixnum } ; { integer } declare [ 256 rem ] map ] { mod fixnum-mod rem } inlined? ] unit-test + +[ [ >fixnum 255 fixnum-bitand ] ] +[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor index de2600f691..31939a0d22 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: math math.partial-dispatch namespaces sequences sets accessors assocs words kernel memoize fry combinators +combinators.short-circuit compiler.tree compiler.tree.combinators compiler.tree.def-use @@ -69,6 +70,12 @@ GENERIC: optimize-modular-arithmetic* ( node -- nodes ) : optimize->fixnum ( #call -- nodes ) dup redundant->fixnum? [ drop f ] when ; +: optimize->integer ( #call -- nodes ) + dup out-d>> first actually-used-by dup length 1 = [ + first node>> { [ #call? ] [ word>> \ >fixnum eq? ] } 1&& + [ drop { } ] when + ] [ drop ] if ; + MEMO: fixnum-coercion ( flags -- nodes ) [ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ; @@ -87,6 +94,7 @@ MEMO: fixnum-coercion ( flags -- nodes ) M: #call optimize-modular-arithmetic* dup word>> { { [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] } + { [ dup \ >integer eq? ] [ drop optimize->integer ] } { [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] } [ drop ] } cond ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index b91a1157f7..2f5c166ac5 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -148,10 +148,6 @@ most-negative-fixnum most-positive-fixnum [a,b] comparison-ops [ dup '[ _ define-comparison-constraints ] each-derived-op ] each -! generic-comparison-ops [ -! dup specific-comparison define-comparison-constraints -! ] each - ! Remove redundant comparisons : fold-comparison ( info1 info2 word -- info ) [ [ interval>> ] bi@ ] dip interval-comparison { @@ -217,6 +213,8 @@ generic-comparison-ops [ { >float float } { fixnum>float float } { bignum>float float } + + { >integer integer } } [ '[ _ @@ -228,19 +226,26 @@ generic-comparison-ops [ ] "outputs" set-word-prop ] assoc-each +: rem-custom-inlining ( #call -- quot/f ) + second value-info literal>> dup integer? + [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ; + { mod-integer-integer mod-integer-fixnum mod-fixnum-integer fixnum-mod - rem } [ [ - in-d>> second value-info >literal< - [ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when + in-d>> dup first value-info interval>> [0,inf] interval-subset? + [ rem-custom-inlining ] [ drop f ] if ] "custom-inlining" set-word-prop ] each +\ rem [ + in-d>> rem-custom-inlining +] "custom-inlining" set-word-prop + { bitand-integer-integer bitand-integer-fixnum diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index eba41dbfdf..aba8dc9eda 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -690,4 +690,7 @@ TUPLE: littledan-2 { from read-only } { to read-only } ; ! Mutable tuples with circularity should not cause problems TUPLE: circle me ; -[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test \ No newline at end of file +[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test + +! Joe found an oversight +[ V{ integer } ] [ [ >integer ] final-classes ] unit-test \ No newline at end of file diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 2c9675426b..de5d1da4e0 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -47,6 +47,7 @@ HOOK: %inc-r cpu ( n -- ) HOOK: stack-frame-size cpu ( stack-frame -- n ) HOOK: %call cpu ( word -- ) +HOOK: %jump cpu ( word -- ) HOOK: %jump-label cpu ( label -- ) HOOK: %return cpu ( -- ) diff --git a/basis/cpu/ppc/assembler/assembler-tests.factor b/basis/cpu/ppc/assembler/assembler-tests.factor index 09db4cb050..14327d08b8 100644 --- a/basis/cpu/ppc/assembler/assembler-tests.factor +++ b/basis/cpu/ppc/assembler/assembler-tests.factor @@ -3,114 +3,114 @@ USING: cpu.ppc.assembler tools.test arrays kernel namespaces make vocabs sequences ; : test-assembler ( expected quot -- ) - [ 1array ] [ [ { } make ] curry ] bi* unit-test ; + [ 1array ] [ [ B{ } make ] curry ] bi* unit-test ; -{ HEX: 38220003 } [ 1 2 3 ADDI ] test-assembler -{ HEX: 3c220003 } [ 1 2 3 ADDIS ] test-assembler -{ HEX: 30220003 } [ 1 2 3 ADDIC ] test-assembler -{ HEX: 34220003 } [ 1 2 3 ADDIC. ] test-assembler -{ HEX: 38400001 } [ 1 2 LI ] test-assembler -{ HEX: 3c400001 } [ 1 2 LIS ] test-assembler -{ HEX: 3822fffd } [ 1 2 3 SUBI ] test-assembler -{ HEX: 1c220003 } [ 1 2 3 MULI ] test-assembler -{ HEX: 7c221a14 } [ 1 2 3 ADD ] test-assembler -{ HEX: 7c221a15 } [ 1 2 3 ADD. ] test-assembler -{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler -{ HEX: 7c221e15 } [ 1 2 3 ADDO. ] test-assembler -{ HEX: 7c221814 } [ 1 2 3 ADDC ] test-assembler -{ HEX: 7c221815 } [ 1 2 3 ADDC. ] test-assembler -{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler -{ HEX: 7c221c15 } [ 1 2 3 ADDCO. ] test-assembler -{ HEX: 7c221914 } [ 1 2 3 ADDE ] test-assembler -{ HEX: 7c411838 } [ 1 2 3 AND ] test-assembler -{ HEX: 7c411839 } [ 1 2 3 AND. ] test-assembler -{ HEX: 7c221bd6 } [ 1 2 3 DIVW ] test-assembler -{ HEX: 7c221b96 } [ 1 2 3 DIVWU ] test-assembler -{ HEX: 7c411a38 } [ 1 2 3 EQV ] test-assembler -{ HEX: 7c411bb8 } [ 1 2 3 NAND ] test-assembler -{ HEX: 7c4118f8 } [ 1 2 3 NOR ] test-assembler -{ HEX: 7c4110f8 } [ 1 2 NOT ] test-assembler -{ HEX: 60410003 } [ 1 2 3 ORI ] test-assembler -{ HEX: 64410003 } [ 1 2 3 ORIS ] test-assembler -{ HEX: 7c411b78 } [ 1 2 3 OR ] test-assembler -{ HEX: 7c411378 } [ 1 2 MR ] test-assembler -{ HEX: 7c221896 } [ 1 2 3 MULHW ] test-assembler -{ HEX: 1c220003 } [ 1 2 3 MULLI ] test-assembler -{ HEX: 7c221816 } [ 1 2 3 MULHWU ] test-assembler -{ HEX: 7c2219d6 } [ 1 2 3 MULLW ] test-assembler -{ HEX: 7c411830 } [ 1 2 3 SLW ] test-assembler -{ HEX: 7c411e30 } [ 1 2 3 SRAW ] test-assembler -{ HEX: 7c411c30 } [ 1 2 3 SRW ] test-assembler -{ HEX: 7c411e70 } [ 1 2 3 SRAWI ] test-assembler -{ HEX: 7c221850 } [ 1 2 3 SUBF ] test-assembler -{ HEX: 7c221810 } [ 1 2 3 SUBFC ] test-assembler -{ HEX: 7c221910 } [ 1 2 3 SUBFE ] test-assembler -{ HEX: 7c410774 } [ 1 2 EXTSB ] test-assembler -{ HEX: 68410003 } [ 1 2 3 XORI ] test-assembler -{ HEX: 7c411a78 } [ 1 2 3 XOR ] test-assembler -{ HEX: 7c2200d0 } [ 1 2 NEG ] test-assembler -{ HEX: 2c220003 } [ 1 2 3 CMPI ] test-assembler -{ HEX: 28220003 } [ 1 2 3 CMPLI ] test-assembler -{ HEX: 7c411800 } [ 1 2 3 CMP ] test-assembler -{ HEX: 5422190a } [ 1 2 3 4 5 RLWINM ] test-assembler -{ HEX: 54221838 } [ 1 2 3 SLWI ] test-assembler -{ HEX: 5422e8fe } [ 1 2 3 SRWI ] test-assembler -{ HEX: 88220003 } [ 1 2 3 LBZ ] test-assembler -{ HEX: 8c220003 } [ 1 2 3 LBZU ] test-assembler -{ HEX: a8220003 } [ 1 2 3 LHA ] test-assembler -{ HEX: ac220003 } [ 1 2 3 LHAU ] test-assembler -{ HEX: a0220003 } [ 1 2 3 LHZ ] test-assembler -{ HEX: a4220003 } [ 1 2 3 LHZU ] test-assembler -{ HEX: 80220003 } [ 1 2 3 LWZ ] test-assembler -{ HEX: 84220003 } [ 1 2 3 LWZU ] test-assembler -{ HEX: 7c4118ae } [ 1 2 3 LBZX ] test-assembler -{ HEX: 7c4118ee } [ 1 2 3 LBZUX ] test-assembler -{ HEX: 7c411aae } [ 1 2 3 LHAX ] test-assembler -{ HEX: 7c411aee } [ 1 2 3 LHAUX ] test-assembler -{ HEX: 7c411a2e } [ 1 2 3 LHZX ] test-assembler -{ HEX: 7c411a6e } [ 1 2 3 LHZUX ] test-assembler -{ HEX: 7c41182e } [ 1 2 3 LWZX ] test-assembler -{ HEX: 7c41186e } [ 1 2 3 LWZUX ] test-assembler -{ HEX: 48000001 } [ 1 B ] test-assembler -{ HEX: 48000001 } [ 1 BL ] test-assembler -{ HEX: 41800004 } [ 1 BLT ] test-assembler -{ HEX: 41810004 } [ 1 BGT ] test-assembler -{ HEX: 40810004 } [ 1 BLE ] test-assembler -{ HEX: 40800004 } [ 1 BGE ] test-assembler -{ HEX: 41800004 } [ 1 BLT ] test-assembler -{ HEX: 40820004 } [ 1 BNE ] test-assembler -{ HEX: 41820004 } [ 1 BEQ ] test-assembler -{ HEX: 41830004 } [ 1 BO ] test-assembler -{ HEX: 40830004 } [ 1 BNO ] test-assembler -{ HEX: 4c200020 } [ 1 BCLR ] test-assembler -{ HEX: 4e800020 } [ BLR ] test-assembler -{ HEX: 4e800021 } [ BLRL ] test-assembler -{ HEX: 4c200420 } [ 1 BCCTR ] test-assembler -{ HEX: 4e800420 } [ BCTR ] test-assembler -{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler -{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler -{ HEX: 7c6902a6 } [ 3 MFCTR ] test-assembler -{ HEX: 7c6103a6 } [ 3 MTXER ] test-assembler -{ HEX: 7c6803a6 } [ 3 MTLR ] test-assembler -{ HEX: 7c6903a6 } [ 3 MTCTR ] test-assembler -{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler -{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler -{ HEX: c0220003 } [ 1 2 3 LFS ] test-assembler -{ HEX: c4220003 } [ 1 2 3 LFSU ] test-assembler -{ HEX: c8220003 } [ 1 2 3 LFD ] test-assembler -{ HEX: cc220003 } [ 1 2 3 LFDU ] test-assembler -{ HEX: d0220003 } [ 1 2 3 STFS ] test-assembler -{ HEX: d4220003 } [ 1 2 3 STFSU ] test-assembler -{ HEX: d8220003 } [ 1 2 3 STFD ] test-assembler -{ HEX: dc220003 } [ 1 2 3 STFDU ] test-assembler -{ HEX: fc201048 } [ 1 2 FMR ] test-assembler -{ HEX: fc20101e } [ 1 2 FCTIWZ ] test-assembler -{ HEX: fc22182a } [ 1 2 3 FADD ] test-assembler -{ HEX: fc22182b } [ 1 2 3 FADD. ] test-assembler -{ HEX: fc221828 } [ 1 2 3 FSUB ] test-assembler -{ HEX: fc2200f2 } [ 1 2 3 FMUL ] test-assembler -{ HEX: fc221824 } [ 1 2 3 FDIV ] test-assembler -{ HEX: fc20102c } [ 1 2 FSQRT ] test-assembler -{ HEX: fc411800 } [ 1 2 3 FCMPU ] test-assembler -{ HEX: fc411840 } [ 1 2 3 FCMPO ] test-assembler -{ HEX: 3c601234 HEX: 60635678 } [ HEX: 12345678 3 LOAD ] test-assembler +B{ HEX: 38 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDI ] test-assembler +B{ HEX: 3c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIS ] test-assembler +B{ HEX: 30 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC ] test-assembler +B{ HEX: 34 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC. ] test-assembler +B{ HEX: 38 HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LI ] test-assembler +B{ HEX: 3c HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LIS ] test-assembler +B{ HEX: 38 HEX: 22 HEX: ff HEX: fd } [ 1 2 3 SUBI ] test-assembler +B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULI ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 1a HEX: 14 } [ 1 2 3 ADD ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 1a HEX: 15 } [ 1 2 3 ADD. ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 1e HEX: 15 } [ 1 2 3 ADDO. ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 18 HEX: 14 } [ 1 2 3 ADDC ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 18 HEX: 15 } [ 1 2 3 ADDC. ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 1c HEX: 15 } [ 1 2 3 ADDCO. ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 19 HEX: 14 } [ 1 2 3 ADDE ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 18 HEX: 38 } [ 1 2 3 AND ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 18 HEX: 39 } [ 1 2 3 AND. ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 1b HEX: d6 } [ 1 2 3 DIVW ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 1b HEX: 96 } [ 1 2 3 DIVWU ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 1a HEX: 38 } [ 1 2 3 EQV ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 1b HEX: b8 } [ 1 2 3 NAND ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 18 HEX: f8 } [ 1 2 3 NOR ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 10 HEX: f8 } [ 1 2 NOT ] test-assembler +B{ HEX: 60 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORI ] test-assembler +B{ HEX: 64 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORIS ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 1b HEX: 78 } [ 1 2 3 OR ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 13 HEX: 78 } [ 1 2 MR ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 18 HEX: 96 } [ 1 2 3 MULHW ] test-assembler +B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULLI ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 18 HEX: 16 } [ 1 2 3 MULHWU ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 19 HEX: d6 } [ 1 2 3 MULLW ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 18 HEX: 30 } [ 1 2 3 SLW ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 1e HEX: 30 } [ 1 2 3 SRAW ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 1c HEX: 30 } [ 1 2 3 SRW ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 1e HEX: 70 } [ 1 2 3 SRAWI ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 18 HEX: 50 } [ 1 2 3 SUBF ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 18 HEX: 10 } [ 1 2 3 SUBFC ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 19 HEX: 10 } [ 1 2 3 SUBFE ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 07 HEX: 74 } [ 1 2 EXTSB ] test-assembler +B{ HEX: 68 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 XORI ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 1a HEX: 78 } [ 1 2 3 XOR ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 00 HEX: d0 } [ 1 2 NEG ] test-assembler +B{ HEX: 2c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPI ] test-assembler +B{ HEX: 28 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPLI ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 CMP ] test-assembler +B{ HEX: 54 HEX: 22 HEX: 19 HEX: 0a } [ 1 2 3 4 5 RLWINM ] test-assembler +B{ HEX: 54 HEX: 22 HEX: 18 HEX: 38 } [ 1 2 3 SLWI ] test-assembler +B{ HEX: 54 HEX: 22 HEX: e8 HEX: fe } [ 1 2 3 SRWI ] test-assembler +B{ HEX: 88 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZ ] test-assembler +B{ HEX: 8c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZU ] test-assembler +B{ HEX: a8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHA ] test-assembler +B{ HEX: ac HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHAU ] test-assembler +B{ HEX: a0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZ ] test-assembler +B{ HEX: a4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZU ] test-assembler +B{ HEX: 80 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZ ] test-assembler +B{ HEX: 84 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZU ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 18 HEX: ae } [ 1 2 3 LBZX ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 18 HEX: ee } [ 1 2 3 LBZUX ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 1a HEX: ae } [ 1 2 3 LHAX ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 1a HEX: ee } [ 1 2 3 LHAUX ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 1a HEX: 2e } [ 1 2 3 LHZX ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 1a HEX: 6e } [ 1 2 3 LHZUX ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 18 HEX: 2e } [ 1 2 3 LWZX ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 18 HEX: 6e } [ 1 2 3 LWZUX ] test-assembler +B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 B ] test-assembler +B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 BL ] test-assembler +B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler +B{ HEX: 41 HEX: 81 HEX: 00 HEX: 04 } [ 1 BGT ] test-assembler +B{ HEX: 40 HEX: 81 HEX: 00 HEX: 04 } [ 1 BLE ] test-assembler +B{ HEX: 40 HEX: 80 HEX: 00 HEX: 04 } [ 1 BGE ] test-assembler +B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler +B{ HEX: 40 HEX: 82 HEX: 00 HEX: 04 } [ 1 BNE ] test-assembler +B{ HEX: 41 HEX: 82 HEX: 00 HEX: 04 } [ 1 BEQ ] test-assembler +B{ HEX: 41 HEX: 83 HEX: 00 HEX: 04 } [ 1 BO ] test-assembler +B{ HEX: 40 HEX: 83 HEX: 00 HEX: 04 } [ 1 BNO ] test-assembler +B{ HEX: 4c HEX: 20 HEX: 00 HEX: 20 } [ 1 BCLR ] test-assembler +B{ HEX: 4e HEX: 80 HEX: 00 HEX: 20 } [ BLR ] test-assembler +B{ HEX: 4e HEX: 80 HEX: 00 HEX: 21 } [ BLRL ] test-assembler +B{ HEX: 4c HEX: 20 HEX: 04 HEX: 20 } [ 1 BCCTR ] test-assembler +B{ HEX: 4e HEX: 80 HEX: 04 HEX: 20 } [ BCTR ] test-assembler +B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler +B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler +B{ HEX: 7c HEX: 69 HEX: 02 HEX: a6 } [ 3 MFCTR ] test-assembler +B{ HEX: 7c HEX: 61 HEX: 03 HEX: a6 } [ 3 MTXER ] test-assembler +B{ HEX: 7c HEX: 68 HEX: 03 HEX: a6 } [ 3 MTLR ] test-assembler +B{ HEX: 7c HEX: 69 HEX: 03 HEX: a6 } [ 3 MTCTR ] test-assembler +B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler +B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler +B{ HEX: c0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFS ] test-assembler +B{ HEX: c4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFSU ] test-assembler +B{ HEX: c8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFD ] test-assembler +B{ HEX: cc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFDU ] test-assembler +B{ HEX: d0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFS ] test-assembler +B{ HEX: d4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFSU ] test-assembler +B{ HEX: d8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFD ] test-assembler +B{ HEX: dc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFDU ] test-assembler +B{ HEX: fc HEX: 20 HEX: 10 HEX: 48 } [ 1 2 FMR ] test-assembler +B{ HEX: fc HEX: 20 HEX: 10 HEX: 1e } [ 1 2 FCTIWZ ] test-assembler +B{ HEX: fc HEX: 22 HEX: 18 HEX: 2a } [ 1 2 3 FADD ] test-assembler +B{ HEX: fc HEX: 22 HEX: 18 HEX: 2b } [ 1 2 3 FADD. ] test-assembler +B{ HEX: fc HEX: 22 HEX: 18 HEX: 28 } [ 1 2 3 FSUB ] test-assembler +B{ HEX: fc HEX: 22 HEX: 00 HEX: f2 } [ 1 2 3 FMUL ] test-assembler +B{ HEX: fc HEX: 22 HEX: 18 HEX: 24 } [ 1 2 3 FDIV ] test-assembler +B{ HEX: fc HEX: 20 HEX: 10 HEX: 2c } [ 1 2 FSQRT ] test-assembler +B{ HEX: fc HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 FCMPU ] test-assembler +B{ HEX: fc HEX: 41 HEX: 18 HEX: 40 } [ 1 2 3 FCMPO ] test-assembler +B{ HEX: 3c HEX: 60 HEX: 12 HEX: 34 HEX: 60 HEX: 63 HEX: 56 HEX: 78 } [ HEX: 12345678 3 LOAD ] test-assembler diff --git a/basis/cpu/ppc/assembler/assembler.factor b/basis/cpu/ppc/assembler/assembler.factor index fbb878a888..2daf3678ce 100644 --- a/basis/cpu/ppc/assembler/assembler.factor +++ b/basis/cpu/ppc/assembler/assembler.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: compiler.codegen.fixup kernel namespaces words -io.binary math math.order cpu.ppc.assembler.backend ; +USING: kernel namespaces words io.binary math math.order +cpu.ppc.assembler.backend ; IN: cpu.ppc.assembler ! See the Motorola or IBM documentation for details. The opcode diff --git a/basis/cpu/ppc/assembler/backend/backend.factor b/basis/cpu/ppc/assembler/backend/backend.factor index befbe112bd..1e6365b1e7 100644 --- a/basis/cpu/ppc/assembler/backend/backend.factor +++ b/basis/cpu/ppc/assembler/backend/backend.factor @@ -1,11 +1,10 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: compiler.codegen.fixup cpu.architecture -compiler.constants kernel namespaces make sequences words math -math.bitwise io.binary parser lexer ; +USING: kernel namespaces make sequences words math +math.bitwise io.binary parser lexer fry ; IN: cpu.ppc.assembler.backend -: insn ( operand opcode -- ) { 26 0 } bitfield , ; +: insn ( operand opcode -- ) { 26 0 } bitfield 4 >be % ; : a-insn ( d a b c xo rc opcode -- ) [ { 0 1 6 11 16 21 } bitfield ] dip insn ; @@ -74,21 +73,16 @@ SYNTAX: XO1: (XO) (1) (( a s -- )) define-declared ; GENERIC# (B) 2 ( dest aa lk -- ) M: integer (B) 18 i-insn ; -M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ; -M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ; GENERIC: BC ( a b c -- ) M: integer BC 0 0 16 b-insn ; -M: word BC [ 0 BC ] dip rc-relative-ppc-2 rel-word ; -M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ; : CREATE-B ( -- word ) scan "B" prepend create-in ; SYNTAX: BC: CREATE-B scan-word scan-word - [ rot BC ] 2curry (( c -- )) define-declared ; + '[ [ _ _ ] dip BC ] (( c -- )) define-declared ; SYNTAX: B: CREATE-B scan-word scan-word scan-word scan-word scan-word - [ b-insn ] curry curry curry curry curry - (( bo -- )) define-declared ; + '[ _ _ _ _ _ b-insn ] (( bo -- )) define-declared ; diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 7278fd2092..6a00dec12f 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -9,8 +9,8 @@ IN: bootstrap.ppc 4 \ cell set big-endian on -CONSTANT: ds-reg 29 -CONSTANT: rs-reg 30 +CONSTANT: ds-reg 13 +CONSTANT: rs-reg 14 : factor-area-size ( -- n ) 4 bootstrap-cells ; @@ -50,15 +50,12 @@ CONSTANT: rs-reg 30 0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel 7 6 0 LWZ 1 7 0 STW -] jit-save-stack jit-define - -[ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel 6 MTCTR BCTR ] jit-primitive jit-define -[ 0 BL rc-relative-ppc-3 rt-xt-direct jit-rel ] jit-word-call jit-define +[ 0 BL rc-relative-ppc-3 rt-xt-pic jit-rel ] jit-word-call jit-define [ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump jit-define @@ -68,11 +65,8 @@ CONSTANT: rs-reg 30 0 3 \ f tag-number CMPI 2 BEQ 0 B rc-relative-ppc-3 rt-xt jit-rel -] jit-if-1 jit-define - -[ 0 B rc-relative-ppc-3 rt-xt jit-rel -] jit-if-2 jit-define +] jit-if jit-define : jit->r ( -- ) 4 ds-reg 0 LWZ @@ -138,6 +132,16 @@ CONSTANT: rs-reg 30 jit-3r> ] jit-3dip jit-define +: prepare-(execute) ( -- operand ) + 3 ds-reg 0 LWZ + ds-reg dup 4 SUBI + 4 3 word-xt-offset LWZ + 4 ; + +[ prepare-(execute) MTCTR BCTR ] jit-execute-jump jit-define + +[ prepare-(execute) MTLR BLRL ] jit-execute-call jit-define + [ 0 1 lr-save stack-frame + LWZ 1 1 stack-frame ADDI @@ -146,7 +150,96 @@ CONSTANT: rs-reg 30 [ BLR ] jit-return jit-define -! Sub-primitives +! ! ! Polymorphic inline caches + +! Load a value from a stack position +[ + 4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel +] pic-load jit-define + +! Tag +: load-tag ( -- ) + 4 4 tag-mask get ANDI + 4 4 tag-bits get SLWI ; + +[ load-tag ] pic-tag jit-define + +! Hi-tag +[ + 3 4 MR + load-tag + 0 4 object tag-number tag-fixnum CMPI + 2 BNE + 4 3 object tag-number neg LWZ +] pic-hi-tag jit-define + +! Tuple +[ + 3 4 MR + load-tag + 0 4 tuple tag-number tag-fixnum CMPI + 2 BNE + 4 3 tuple tag-number neg bootstrap-cell + LWZ +] pic-tuple jit-define + +! Hi-tag and tuple +[ + 3 4 MR + load-tag + ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple) + 0 4 BIN: 110 tag-fixnum CMPI + 5 BLT + ! Untag r3 + 3 3 0 0 31 tag-bits get - RLWINM + ! Set r4 to 0 for objects, and bootstrap-cell for tuples + 4 4 1 tag-fixnum ANDI + 4 4 1 SRAWI + ! Load header cell or tuple layout cell + 4 4 3 LWZX +] pic-hi-tag-tuple jit-define + +[ + 0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel +] pic-check-tag jit-define + +[ + 0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel + 4 0 5 CMP +] pic-check jit-define + +[ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define + +! ! ! Megamorphic caches + +[ + ! cache = ... + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel + ! key = class + 5 4 MR + ! key &= cache.length - 1 + 5 5 mega-cache-size get 1- bootstrap-cell * ANDI + ! cache += array-start-offset + 3 3 array-start-offset ADDI + ! cache += key + 3 3 5 ADD + ! if(get(cache) == class) + 6 3 0 LWZ + 6 0 4 CMP + 5 BNE + ! megamorphic_cache_hits++ + 0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel + 5 4 0 LWZ + 5 5 1 ADDI + 5 4 0 STW + ! ... goto get(cache + bootstrap-cell) + 3 3 4 LWZ + 3 3 word-xt-offset LWZ + 3 MTCTR + BCTR + ! fall-through on miss +] mega-lookup jit-define + +! ! ! Sub-primitives ! Quotations and words [ @@ -157,14 +250,6 @@ CONSTANT: rs-reg 30 BCTR ] \ (call) define-sub-primitive -[ - 3 ds-reg 0 LWZ - ds-reg dup 4 SUBI - 4 3 word-xt-offset LWZ - 4 MTCTR - BCTR -] \ (execute) define-sub-primitive - ! Objects [ 3 ds-reg 0 LWZ diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 85bf188bb8..a11b0daa86 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -1,33 +1,38 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs sequences kernel combinators make math math.order math.ranges system namespaces locals layouts words -alien alien.c-types cpu.architecture cpu.ppc.assembler -compiler.cfg.registers compiler.cfg.instructions +alien alien.c-types literals cpu.architecture cpu.ppc.assembler +literals compiler.cfg.registers compiler.cfg.instructions compiler.constants compiler.codegen compiler.codegen.fixup compiler.cfg.intrinsics compiler.cfg.stack-frame ; IN: cpu.ppc ! PowerPC register assignments: -! r2-r27: integer vregs -! r28: integer scratch -! r29: data stack -! r30: retain stack +! r2-r12: integer vregs +! r15-r29 +! r30: integer scratch ! f0-f29: float vregs -! f30, f31: float scratch +! f30: float scratch + +! Add some methods to the assembler that are useful to us +M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ; +M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ; enable-float-intrinsics -<< \ ##integer>float t frame-required? set-word-prop -\ ##float>integer t frame-required? set-word-prop >> +<< +\ ##integer>float t frame-required? set-word-prop +\ ##float>integer t frame-required? set-word-prop +>> M: ppc machine-registers { - { int-regs T{ range f 2 26 1 } } - { double-float-regs T{ range f 0 29 1 } } + { int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] } + { double-float-regs $[ 0 29 [a,b] ] } } ; -CONSTANT: scratch-reg 28 +CONSTANT: scratch-reg 30 CONSTANT: fp-scratch-reg 30 M: ppc two-operand? f ; @@ -40,8 +45,8 @@ M: ppc %load-reference ( reg obj -- ) M: ppc %alien-global ( register symbol dll -- ) [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ; -CONSTANT: ds-reg 29 -CONSTANT: rs-reg 30 +CONSTANT: ds-reg 13 +CONSTANT: rs-reg 14 GENERIC: loc-reg ( loc -- reg ) @@ -108,7 +113,12 @@ M: ppc stack-frame-size ( stack-frame -- i ) factor-area-size + 4 cells align ; -M: ppc %call ( label -- ) BL ; +M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ; + +M: ppc %jump ( word -- ) + 0 3 LOAD32 rc-absolute-ppc-2/2 rel-here + 0 B rc-relative-ppc-3 rel-word-pic-tail ; + M: ppc %jump-label ( label -- ) B ; M: ppc %return ( -- ) BLR ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 10cd9c8657..0a0ac4a53e 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -42,11 +42,13 @@ M:: x86.32 %dispatch ( src temp offset -- ) M: x86.32 param-reg-1 EAX ; M: x86.32 param-reg-2 EDX ; +M: x86.32 pic-tail-reg EBX ; + M: x86.32 reserved-area-size 0 ; -M: x86.32 %alien-invoke (CALL) rel-dlsym ; +M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ; -M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ; +M: x86.32 %alien-invoke-tail 0 JMP rc-relative rel-dlsym ; M: x86.32 return-struct-in-registers? ( c-type -- ? ) c-type diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index be21344815..490d37ccbc 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system cpu.x86.assembler layouts vocabs parser compiler.constants ; @@ -26,10 +26,8 @@ IN: bootstrap.x86 temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel ! save stack pointer temp0 [] stack-reg MOV -] jit-save-stack jit-define - -[ - (JMP) drop rc-relative rt-primitive jit-rel + ! call the primitive + 0 JMP rc-relative rt-primitive jit-rel ] jit-primitive jit-define << "vocab:cpu/x86/bootstrap.factor" parse-file parsed >> diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 8cc69958a4..ad1b487e44 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -39,6 +39,8 @@ M: x86.64 param-reg-1 int-regs param-regs first ; M: x86.64 param-reg-2 int-regs param-regs second ; : param-reg-3 ( -- reg ) int-regs param-regs third ; inline +M: x86.64 pic-tail-reg RBX ; + M: int-regs return-reg drop RAX ; M: float-regs return-reg drop XMM0 ; diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 8d1ed086e7..c5c7e63dbc 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system cpu.x86.assembler layouts vocabs parser compiler.constants math ; @@ -25,9 +25,6 @@ IN: bootstrap.x86 temp0 temp0 [] MOV ! save stack pointer temp0 [] stack-reg MOV -] jit-save-stack jit-define - -[ ! load XT temp1 0 MOV rc-absolute-cell rt-primitive jit-rel ! go diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 5560d17a1e..2b40aa2053 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -1,12 +1,11 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays cpu.architecture compiler.constants -compiler.codegen.fixup io.binary kernel combinators -kernel.private math namespaces make sequences words system -layouts math.order accessors cpu.x86.assembler.syntax ; +USING: arrays io.binary kernel combinators +kernel.private math namespaces make sequences words system layouts +math.order accessors cpu.x86.assembler.syntax ; IN: cpu.x86.assembler -! A postfix assembler for x86 and AMD64. +! A postfix assembler for x86-32 and x86-64. ! In 32-bit mode, { 1234 } is absolute indirect addressing. ! In 64-bit mode, { 1234 } is RIP-relative. @@ -296,36 +295,23 @@ M: operand (MOV-I) { BIN: 000 t HEX: c6 } pick byte? [ immediate-1 ] [ immediate-4 ] if ; -PREDICATE: callable < word register? not ; - GENERIC: MOV ( dst src -- ) M: immediate MOV swap (MOV-I) ; -M: callable MOV [ 0 ] 2dip (MOV-I) rc-absolute-cell rel-word ; M: operand MOV HEX: 88 2-operand ; : LEA ( dst src -- ) swap HEX: 8d 2-operand ; ! Control flow GENERIC: JMP ( op -- ) -: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ; -M: f JMP (JMP) 2drop ; -M: callable JMP (JMP) rel-word ; -M: label JMP (JMP) label-fixup ; +M: integer JMP HEX: e9 , 4, ; M: operand JMP { BIN: 100 t HEX: ff } 1-operand ; GENERIC: CALL ( op -- ) -: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ; -M: f CALL (CALL) 2drop ; -M: callable CALL (CALL) rel-word-direct ; -M: label CALL (CALL) label-fixup ; +M: integer CALL HEX: e8 , 4, ; M: operand CALL { BIN: 010 t HEX: ff } 1-operand ; GENERIC# JUMPcc 1 ( addr opcode -- ) -: (JUMPcc) ( addr n -- rel-class ) extended-opcode, 4, rc-relative ; -M: f JUMPcc [ 0 ] dip (JUMPcc) 2drop ; -M: integer JUMPcc (JUMPcc) drop ; -M: callable JUMPcc [ 0 ] dip (JUMPcc) rel-word ; -M: label JUMPcc [ 0 ] dip (JUMPcc) label-fixup ; +M: integer JUMPcc extended-opcode, 4, ; : JO ( dst -- ) HEX: 80 JUMPcc ; : JNO ( dst -- ) HEX: 81 JUMPcc ; diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 4fe5e5cd33..994591adcf 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -42,13 +42,18 @@ big-endian off ] jit-push-immediate jit-define [ - f JMP rc-relative rt-xt jit-rel + temp3 0 MOV rc-absolute-cell rt-here jit-rel + 0 JMP rc-relative rt-xt-pic-tail jit-rel ] jit-word-jump jit-define [ - f CALL rc-relative rt-xt-direct jit-rel + 0 CALL rc-relative rt-xt-pic jit-rel ] jit-word-call jit-define +[ + 0 JMP rc-relative rt-xt jit-rel +] jit-word-special jit-define + [ ! load boolean temp0 ds-reg [] MOV @@ -57,13 +62,10 @@ big-endian off ! compare boolean with f temp0 \ f tag-number CMP ! jump to true branch if not equal - f JNE rc-relative rt-xt jit-rel -] jit-if-1 jit-define - -[ + 0 JNE rc-relative rt-xt jit-rel ! jump to false branch if equal - f JMP rc-relative rt-xt jit-rel -] jit-if-2 jit-define + 0 JMP rc-relative rt-xt jit-rel +] jit-if jit-define : jit->r ( -- ) rs-reg bootstrap-cell ADD @@ -115,19 +117,19 @@ big-endian off [ jit->r - f CALL rc-relative rt-xt jit-rel + 0 CALL rc-relative rt-xt jit-rel jit-r> ] jit-dip jit-define [ jit-2>r - f CALL rc-relative rt-xt jit-rel + 0 CALL rc-relative rt-xt jit-rel jit-2r> ] jit-2dip jit-define [ jit-3>r - f CALL rc-relative rt-xt jit-rel + 0 CALL rc-relative rt-xt jit-rel jit-3r> ] jit-3dip jit-define @@ -152,8 +154,7 @@ big-endian off ! ! ! Polymorphic inline caches -! temp0 contains the object being dispatched on -! temp1 contains its class +! The PIC and megamorphic code stubs are not permitted to touch temp3. ! Load a value from a stack position [ @@ -197,7 +198,7 @@ big-endian off [ ! Untag temp0 temp0 tag-mask get bitnot AND - ! Set temp1 to 0 for objects, and 8 for tuples + ! Set temp1 to 0 for objects, and bootstrap-cell for tuples temp1 1 tag-fixnum AND bootstrap-cell 4 = [ temp1 1 SHR ] when ! Load header cell or tuple layout cell @@ -214,7 +215,7 @@ big-endian off temp1 temp2 CMP ] pic-check jit-define -[ f JE rc-relative rt-xt jit-rel ] pic-hit jit-define +[ 0 JE rc-relative rt-xt jit-rel ] pic-hit jit-define ! ! ! Megamorphic caches @@ -232,12 +233,13 @@ big-endian off temp0 temp2 ADD ! if(get(cache) == class) temp0 [] temp1 CMP - ! ... goto get(cache + bootstrap-cell) - [ - temp0 temp0 bootstrap-cell [+] MOV - temp0 word-xt-offset [+] JMP - ] [ ] make - [ length JNE ] [ % ] bi + bootstrap-cell 4 = 14 18 ? JNE ! Yuck! + ! megamorphic_cache_hits++ + temp1 0 MOV rc-absolute-cell rt-megamorphic-cache-hits jit-rel + temp1 [] 1 ADD + ! goto get(cache + bootstrap-cell) + temp0 temp0 bootstrap-cell [+] MOV + temp0 word-xt-offset [+] JMP ! fall-through on miss ] mega-lookup jit-define diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 2859e71be2..e12cec9738 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -11,6 +11,10 @@ IN: cpu.x86 << enable-fixnum-log2 >> +! Add some methods to the assembler to be more useful to the backend +M: label JMP 0 JMP rc-relative label-fixup ; +M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ; + M: x86 two-operand? t ; HOOK: temp-reg-1 cpu ( -- reg ) @@ -19,6 +23,8 @@ HOOK: temp-reg-2 cpu ( -- reg ) HOOK: param-reg-1 cpu ( -- reg ) HOOK: param-reg-2 cpu ( -- reg ) +HOOK: pic-tail-reg cpu ( -- reg ) + M: x86 %load-immediate MOV ; M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ; @@ -53,8 +59,18 @@ M: x86 stack-frame-size ( stack-frame -- i ) reserved-area-size + align-stack ; -M: x86 %call ( label -- ) CALL ; -M: x86 %jump-label ( label -- ) JMP ; +M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ; + +: xt-tail-pic-offset ( -- n ) + #! See the comment in vm/cpu-x86.hpp + cell 4 + 1 + ; inline + +M: x86 %jump ( word -- ) + pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here + 0 JMP rc-relative rel-word-pic-tail ; + +M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ; + M: x86 %return ( -- ) 0 RET ; : code-alignment ( align -- n ) diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 6bf1ea2ff1..27dc25de73 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -5,7 +5,7 @@ compression.lzw constructors endian fry grouping images io io.binary io.encodings.ascii io.encodings.binary io.encodings.string io.encodings.utf8 io.files kernel math math.bitwise math.order math.parser pack prettyprint sequences -strings math.vectors specialized-arrays.float ; +strings math.vectors specialized-arrays.float locals ; IN: images.tiff TUPLE: tiff-image < image ; @@ -184,7 +184,7 @@ samples-per-pixel new-subfile-type subfile-type orientation software date-time photoshop exif-ifd sub-ifd inter-color-profile xmp iptc fill-order document-name page-number page-name x-position y-position host-computer copyright artist -min-sample-value max-sample-value make model cell-width cell-length +min-sample-value max-sample-value tiff-make tiff-model cell-width cell-length gray-response-unit gray-response-curve color-map threshholding image-description free-offsets free-byte-counts tile-width tile-length matteing data-type image-depth tile-depth @@ -243,10 +243,13 @@ ERROR: bad-tiff-magic bytes ; ERROR: no-tag class ; -: find-tag ( idf class -- tag ) - swap processed-tags>> ?at [ no-tag ] unless ; +: find-tag* ( ifd class -- tag/class ? ) + swap processed-tags>> ?at ; -: tag? ( idf class -- tag ) +: find-tag ( ifd class -- tag ) + find-tag* [ no-tag ] unless ; + +: tag? ( ifd class -- tag ) swap processed-tags>> key? ; : read-strips ( ifd -- ifd ) @@ -339,8 +342,8 @@ ERROR: bad-small-ifd-type n ; { 266 [ fill-order ] } { 269 [ ascii decode document-name ] } { 270 [ ascii decode image-description ] } - { 271 [ ascii decode make ] } - { 272 [ ascii decode model ] } + { 271 [ ascii decode tiff-make ] } + { 272 [ ascii decode tiff-model ] } { 273 [ strip-offsets ] } { 274 [ orientation ] } { 277 [ samples-per-pixel ] } @@ -350,7 +353,7 @@ ERROR: bad-small-ifd-type n ; { 281 [ max-sample-value ] } { 282 [ first x-resolution ] } { 283 [ first y-resolution ] } - { 284 [ planar-configuration ] } + { 284 [ lookup-planar-configuration planar-configuration ] } { 285 [ page-name ] } { 286 [ x-position ] } { 287 [ y-position ] } @@ -437,8 +440,8 @@ ERROR: unhandled-compression compression ; [ samples-per-pixel find-tag ] tri [ * ] keep '[ - _ group [ _ group [ rest ] [ first ] bi - [ v+ ] accumulate swap suffix concat ] map + _ group + [ _ group unclip [ v+ ] accumulate swap suffix concat ] map concat >byte-array ] change-bitmap ; @@ -521,23 +524,39 @@ ERROR: unknown-component-order ifd ; ] with-tiff-endianness ] with-file-reader ; -: process-tif-ifds ( parsed-tiff -- parsed-tiff ) - dup ifds>> [ - read-strips - uncompress-strips - strips>bitmap - fix-bitmap-endianness - strips-predictor - dup extra-samples tag? [ handle-alpha-data ] when - drop - ] each ; +: process-chunky-ifd ( ifd -- ) + read-strips + uncompress-strips + strips>bitmap + fix-bitmap-endianness + strips-predictor + dup extra-samples tag? [ handle-alpha-data ] when + drop ; + +: process-planar-ifd ( ifd -- ) + "planar ifd not supported" throw ; + +: dispatch-planar-configuration ( ifd planar-configuration -- ) + { + { planar-configuration-chunky [ process-chunky-ifd ] } + { planar-configuration-planar [ process-planar-ifd ] } + } case ; + +: process-ifd ( ifd -- ) + dup planar-configuration find-tag* [ + dispatch-planar-configuration + ] [ + drop "no planar configuration" throw + ] if ; + +: process-tif-ifds ( parsed-tiff -- ) + ifds>> [ process-ifd ] each ; : load-tiff ( path -- parsed-tiff ) - [ load-tiff-ifds ] [ - binary [ - [ process-tif-ifds ] with-tiff-endianness - ] with-file-reader - ] bi ; + [ load-tiff-ifds dup ] keep + binary [ + [ process-tif-ifds ] with-tiff-endianness + ] with-file-reader ; ! tiff files can store several images -- we just take the first for now M: tiff-image load-image* ( path tiff-image -- image ) diff --git a/basis/literals/literals-docs.factor b/basis/literals/literals-docs.factor index 0d61dcb467..9dd398d962 100644 --- a/basis/literals/literals-docs.factor +++ b/basis/literals/literals-docs.factor @@ -21,7 +21,7 @@ CONSTANT: five 5 USING: kernel literals prettyprint ; IN: scratchpad -<< : seven-eleven ( -- a b ) 7 11 ; >> +: seven-eleven ( -- a b ) 7 11 ; { $ seven-eleven } . "> "{ 7 11 }" } @@ -43,7 +43,24 @@ IN: scratchpad } ; -{ POSTPONE: $ POSTPONE: $[ } related-words +HELP: ${ +{ $syntax "${ code }" } +{ $description "Outputs an array containing the results of executing " { $snippet "code" } " at parse time." } +{ $notes { $snippet "code" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." } +{ $examples + + { $example <" +USING: kernel literals math prettyprint ; +IN: scratchpad + +CONSTANT: five 5 +CONSTANT: six 6 +${ five six 7 } . + "> "{ 5 6 7 }" + } +} ; + +{ POSTPONE: $ POSTPONE: $[ POSTPONE: ${ } related-words ARTICLE: "literals" "Interpolating code results into literal values" "The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values." @@ -51,11 +68,12 @@ ARTICLE: "literals" "Interpolating code results into literal values" USING: kernel literals math prettyprint ; IN: scratchpad -<< CONSTANT: five 5 >> +CONSTANT: five 5 { $ five $[ five dup 1+ dup 2 + ] } . "> "{ 5 5 6 8 }" } { $subsection POSTPONE: $ } { $subsection POSTPONE: $[ } +{ $subsection POSTPONE: ${ } ; ABOUT: "literals" diff --git a/basis/literals/literals-tests.factor b/basis/literals/literals-tests.factor old mode 100644 new mode 100755 index 29072f1299..d7256a64b1 --- a/basis/literals/literals-tests.factor +++ b/basis/literals/literals-tests.factor @@ -20,8 +20,10 @@ IN: literals.tests [ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test -<< CONSTANT: constant-a 3 ->> [ { 3 10 "ftw" } ] [ ${ constant-a 10 "ftw" } ] unit-test + +: sixty-nine ( -- a b ) 6 9 ; + +[ { 6 9 } ] [ ${ sixty-nine } ] unit-test diff --git a/basis/literals/literals.factor b/basis/literals/literals.factor old mode 100644 new mode 100755 index 7c7592dda8..ba1da393b1 --- a/basis/literals/literals.factor +++ b/basis/literals/literals.factor @@ -1,8 +1,21 @@ ! (c) Joe Groff, see license for details USING: accessors continuations kernel parser words quotations -combinators.smart vectors sequences ; +combinators.smart vectors sequences fry ; IN: literals -SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ; +> call so that CONSTANT:s defined in the same file can +! be called + +: expand-literal ( seq obj -- seq' ) + '[ _ dup word? [ def>> call ] when ] with-datastack ; + +: expand-literals ( seq -- seq' ) + [ [ { } ] dip expand-literal ] map concat ; + +PRIVATE> + +SYNTAX: $ scan-word expand-literal >vector ; SYNTAX: $[ parse-quotation with-datastack >vector ; -SYNTAX: ${ \ } [ [ ?execute ] { } map-as ] parse-literal ; +SYNTAX: ${ \ } [ expand-literals ] parse-literal ; diff --git a/basis/math/bits/bits.factor b/basis/math/bits/bits.factor index 8920955df3..72b83a991f 100644 --- a/basis/math/bits/bits.factor +++ b/basis/math/bits/bits.factor @@ -7,7 +7,7 @@ TUPLE: bits { number read-only } { length read-only } ; C: bits : make-bits ( number -- bits ) - dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1+ ] if ; inline + dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1 + ] if ; inline M: bits length length>> ; diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 3148567bc0..73d111f91e 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -13,10 +13,10 @@ IN: math.bitwise : unmask? ( x n -- ? ) unmask 0 > ; inline : mask ( x n -- ? ) bitand ; inline : mask? ( x n -- ? ) mask 0 > ; inline -: wrap ( m n -- m' ) 1- bitand ; inline +: wrap ( m n -- m' ) 1 - bitand ; inline : bits ( m n -- m' ) 2^ wrap ; inline : mask-bit ( m n -- m' ) 2^ mask ; inline -: on-bits ( n -- m ) 2^ 1- ; inline +: on-bits ( n -- m ) 2^ 1 - ; inline : toggle-bit ( m n -- m' ) 2^ bitxor ; inline : shift-mod ( n s w -- n ) @@ -64,8 +64,8 @@ DEFER: byte-bit-count << \ byte-bit-count -256 [ - 8 0 [ [ 1+ ] when ] reduce +256 iota [ + 8 0 [ [ 1 + ] when ] reduce ] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ] (( byte -- table )) define-declared @@ -97,12 +97,12 @@ PRIVATE> ! Signed byte array to integer conversion : signed-le> ( bytes -- x ) - [ le> ] [ length 8 * 1- on-bits ] bi + [ le> ] [ length 8 * 1 - on-bits ] bi 2dup > [ bitnot bitor ] [ drop ] if ; : signed-be> ( bytes -- x ) signed-le> ; : >signed ( x n -- y ) - 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ; + 2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ; diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index d7c6ebc927..3017a12b18 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -164,7 +164,7 @@ M: VECTOR element-type M: VECTOR Vswap (prepare-swap) [ XSWAP ] 2dip ; M: VECTOR Viamax - (prepare-nrm2) IXAMAX 1- ; + (prepare-nrm2) IXAMAX 1 - ; M: VECTOR (blas-vector-like) drop ; diff --git a/basis/math/constants/constants.factor b/basis/math/constants/constants.factor index 118a8e8197..a2d3213e78 100644 --- a/basis/math/constants/constants.factor +++ b/basis/math/constants/constants.factor @@ -7,6 +7,7 @@ IN: math.constants : euler ( -- gamma ) 0.57721566490153286060 ; inline : phi ( -- phi ) 1.61803398874989484820 ; inline : pi ( -- pi ) 3.14159265358979323846 ; inline +: 2pi ( -- pi ) 2 pi * ; inline : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline : smallest-float ( -- x ) HEX: 1 bits>double ; foldable : largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index 397a7cc2f3..66d813bab8 100644 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -157,3 +157,8 @@ IN: math.functions.tests 2135623355842621559 [ >bignum ] tri@ ^mod ] unit-test + +[ 1.0 ] [ 1.0 2.5 0.0 lerp ] unit-test +[ 2.5 ] [ 1.0 2.5 1.0 lerp ] unit-test +[ 1.75 ] [ 1.0 2.5 0.5 lerp ] unit-test + diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index c21053317e..a1bf9480d5 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -18,12 +18,12 @@ M: real sqrt : factor-2s ( n -- r s ) #! factor an integer into 2^r * s dup 0 = [ 1 ] [ - 0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] while + 0 swap [ dup even? ] [ [ 1 + ] [ 2/ ] bi* ] while ] if ; inline interval ] } [ (interval-abs) points>interval ] } cond ; @@ -376,11 +378,11 @@ SYMBOL: incomparable : interval-log2 ( i1 -- i2 ) { { empty-interval [ empty-interval ] } - { full-interval [ 0 [a,inf] ] } + { full-interval [ [0,inf] ] } [ to>> first 1 max dup most-positive-fixnum > [ drop full-interval interval-log2 ] - [ 1+ >integer log2 0 swap [a,b] ] + [ 1 + >integer log2 0 swap [a,b] ] if ] } case ; @@ -407,7 +409,7 @@ SYMBOL: incomparable : integral-closure ( i1 -- i2 ) dup special-interval? [ - [ from>> first2 [ 1+ ] unless ] - [ to>> first2 [ 1- ] unless ] + [ from>> first2 [ 1 + ] unless ] + [ to>> first2 [ 1 - ] unless ] bi [a,b] ] unless ; diff --git a/basis/math/miller-rabin/miller-rabin-docs.factor b/basis/math/miller-rabin/miller-rabin-docs.factor new file mode 100644 index 0000000000..4aa318f674 --- /dev/null +++ b/basis/math/miller-rabin/miller-rabin-docs.factor @@ -0,0 +1,100 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel sequences math ; +IN: math.miller-rabin + +HELP: find-relative-prime +{ $values + { "n" integer } + { "p" integer } +} +{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ; + +HELP: find-relative-prime* +{ $values + { "n" integer } { "guess" integer } + { "p" integer } +} +{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ; + +HELP: miller-rabin +{ $values + { "n" integer } + { "?" "a boolean" } +} +{ $description "Returns true if the number is a prime. Calls " { $link miller-rabin* } " with a default of 10 Miller-Rabin tests." } ; + +{ miller-rabin miller-rabin* } related-words + +HELP: miller-rabin* +{ $values + { "n" integer } { "numtrials" integer } + { "?" "a boolean" } +} +{ $description "Performs " { $snippet "numtrials" } " trials of the Miller-Rabin probabilistic primality test algorithm and returns true if prime." } ; + +HELP: next-prime +{ $values + { "n" integer } + { "p" integer } +} +{ $description "Tests consecutive numbers for primality with " { $link miller-rabin } " and returns the next prime." } ; + +HELP: next-safe-prime +{ $values + { "n" integer } + { "q" integer } +} +{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ; + +HELP: random-bits* +{ $values + { "numbits" integer } + { "n" integer } +} +{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ; + +HELP: random-prime +{ $values + { "numbits" integer } + { "p" integer } +} +{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ; + +HELP: random-safe-prime +{ $values + { "numbits" integer } + { "p" integer } +} +{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ; + +HELP: safe-prime? +{ $values + { "q" integer } + { "?" "a boolean" } +} +{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ; + +HELP: unique-primes +{ $values + { "numbits" integer } { "n" integer } + { "seq" sequence } +} +{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ; + +ARTICLE: "math.miller-rabin" "Miller-Rabin probabilistic primality test" +"The " { $vocab-link "math.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl +"The Miller-Rabin probabilistic primality test:" +{ $subsection miller-rabin } +{ $subsection miller-rabin* } +"Generating relative prime numbers:" +{ $subsection find-relative-prime } +{ $subsection find-relative-prime* } +"Generating prime numbers:" +{ $subsection next-prime } +{ $subsection random-prime } +"Generating safe prime numbers:" +{ $subsection next-safe-prime } +{ $subsection random-safe-prime } ; + +ABOUT: "math.miller-rabin" diff --git a/basis/math/miller-rabin/miller-rabin-tests.factor b/basis/math/miller-rabin/miller-rabin-tests.factor index 5f1b9835e4..9981064ec0 100644 --- a/basis/math/miller-rabin/miller-rabin-tests.factor +++ b/basis/math/miller-rabin/miller-rabin-tests.factor @@ -1,4 +1,5 @@ -USING: math.miller-rabin tools.test ; +USING: math.miller-rabin tools.test kernel sequences +math.miller-rabin.private math ; IN: math.miller-rabin.tests [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test @@ -6,6 +7,23 @@ IN: math.miller-rabin.tests [ t ] [ 3 miller-rabin ] unit-test [ f ] [ 36 miller-rabin ] unit-test [ t ] [ 37 miller-rabin ] unit-test +[ 2 ] [ 1 next-prime ] unit-test +[ 3 ] [ 2 next-prime ] unit-test +[ 5 ] [ 3 next-prime ] unit-test [ 101 ] [ 100 next-prime ] unit-test [ t ] [ 2135623355842621559 miller-rabin ] unit-test -[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test \ No newline at end of file +[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test + +[ 863 ] [ 862 next-safe-prime ] unit-test +[ f ] [ 862 safe-prime? ] unit-test +[ t ] [ 7 safe-prime? ] unit-test +[ f ] [ 31 safe-prime? ] unit-test +[ t ] [ 47 safe-prime-candidate? ] unit-test +[ t ] [ 47 safe-prime? ] unit-test +[ t ] [ 863 safe-prime? ] unit-test + +[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test + +[ 47 ] [ 31 next-safe-prime ] unit-test +[ 49 ] [ 50 random-prime log2 ] unit-test +[ 49 ] [ 50 random-bits* log2 ] unit-test diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/miller-rabin/miller-rabin.factor index 8c237d0dc3..9fd604a003 100755 --- a/basis/math/miller-rabin/miller-rabin.factor +++ b/basis/math/miller-rabin/miller-rabin.factor @@ -1,37 +1,40 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: combinators kernel locals math math.functions math.ranges -random sequences sets ; +random sequences sets combinators.short-circuit math.bitwise +math math.order ; IN: math.miller-rabin odd ( n -- int ) dup even? [ 1+ ] when ; foldable +: >odd ( n -- int ) 0 set-bit ; foldable + +: >even ( n -- int ) 0 clear-bit ; foldable + +: next-even ( m -- n ) >even 2 + ; + +: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; TUPLE: positive-even-expected n ; :: (miller-rabin) ( n trials -- ? ) - [let | r [ n 1- factor-2s drop ] - s [ n 1- factor-2s nip ] - prime?! [ t ] - a! [ 0 ] - count! [ 0 ] | - trials [ - n 1- [1,b] random a! - a s n ^mod 1 = [ - 0 count! - r [ - 2^ s * a swap n ^mod n - -1 = - [ count 1+ count! r + ] when - ] each - count zero? [ f prime?! trials + ] when - ] unless drop - ] each prime? ] ; + n 1 - :> n-1 + n-1 factor-2s :> s :> r + 0 :> a! + trials [ + drop + 2 n 2 - [a,b] random a! + a s n ^mod 1 = [ + f + ] [ + r iota [ + 2^ s * a swap n ^mod n - -1 = + ] any? not + ] if + ] any? not ; PRIVATE> -: next-odd ( m -- n ) dup even? [ 1+ ] [ 2 + ] if ; - : miller-rabin* ( n numtrials -- ? ) over { { [ dup 1 <= ] [ 3drop f ] } @@ -42,11 +45,21 @@ PRIVATE> : miller-rabin ( n -- ? ) 10 miller-rabin* ; +ERROR: prime-range-error n ; + : next-prime ( n -- p ) - next-odd dup miller-rabin [ next-prime ] unless ; + dup 1 < [ prime-range-error ] when + dup 1 = [ + drop 2 + ] [ + next-odd dup miller-rabin [ next-prime ] unless + ] if ; + +: random-bits* ( numbits -- n ) + 1 - [ random-bits ] keep set-bit ; : random-prime ( numbits -- p ) - random-bits next-prime ; + random-bits* next-prime ; ERROR: no-relative-prime n ; @@ -74,3 +87,30 @@ ERROR: too-few-primes ; dup 5 < [ too-few-primes ] when 2dup [ random-prime ] curry replicate dup all-unique? [ 2nip ] [ drop unique-primes ] if ; + +! Safe primes are of the form p = 2q + 1, p,q are prime +! See http://en.wikipedia.org/wiki/Safe_prime + + + +: safe-prime? ( q -- ? ) + { + [ 1 - 2 / dup integer? [ miller-rabin ] [ drop f ] if ] + [ miller-rabin ] + } 1&& ; + +: next-safe-prime ( n -- q ) + next-safe-prime-candidate + dup safe-prime? [ next-safe-prime ] unless ; + +: random-safe-prime ( numbits -- p ) + random-bits* next-safe-prime ; diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index 749bde3a10..f65c4ecaaf 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -16,7 +16,7 @@ IN: math.polynomials PRIVATE> : powers ( n x -- seq ) - 1 [ * ] accumulate nip ; + 1 [ * ] accumulate nip ; : p= ( p q -- ? ) pextend = ; @@ -29,7 +29,7 @@ PRIVATE> : n*p ( n p -- n*p ) n*v ; : pextend-conv ( p q -- p q ) - 2dup [ length ] bi@ + 1- 2pad-tail [ >vector ] bi@ ; + 2dup [ length ] bi@ + 1 - 2pad-tail [ >vector ] bi@ ; : p* ( p q -- r ) 2unempty pextend-conv dup length @@ -44,7 +44,7 @@ PRIVATE> 2ptrim 2dup [ length ] bi@ - dup 1 < [ drop 1 ] when - [ over length + 0 pad-head pextend ] keep 1+ ; + [ over length + 0 pad-head pextend ] keep 1 + ; : /-last ( seq seq -- a ) #! divide the last two numbers in the sequences diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor index 068f599b6f..883be006dc 100644 --- a/basis/math/ranges/ranges.factor +++ b/basis/math/ranges/ranges.factor @@ -10,7 +10,7 @@ TUPLE: range { step read-only } ; : ( a b step -- range ) - [ over - ] dip [ /i 1+ 0 max ] keep range boa ; inline + [ over - ] dip [ /i 1 + 0 max ] keep range boa ; inline M: range length ( seq -- n ) length>> ; diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor index 589876184f..4cd8c5b888 100644 --- a/basis/math/statistics/statistics.factor +++ b/basis/math/statistics/statistics.factor @@ -15,7 +15,7 @@ IN: math.statistics : median ( seq -- n ) natural-sort dup length even? [ - [ midpoint@ dup 1- 2array ] keep nths mean + [ midpoint@ dup 1 - 2array ] keep nths mean ] [ [ midpoint@ ] keep nth ] if ; @@ -33,7 +33,7 @@ IN: math.statistics drop 0 ] [ [ [ mean ] keep [ - sq ] with sigma ] keep - length 1- / + length 1 - / ] if ; : std ( seq -- x ) @@ -47,7 +47,7 @@ IN: math.statistics 0 [ [ [ pick ] dip swap - ] bi@ * + ] 2reduce 2nip ; : (r) ( mean(x) mean(y) {x} {y} sx sy -- r ) - * recip [ [ ((r)) ] keep length 1- / ] dip * ; + * recip [ [ ((r)) ] keep length 1 - / ] dip * ; : [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy ) first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ; diff --git a/basis/math/vectors/vectors-tests.factor b/basis/math/vectors/vectors-tests.factor index aef4ade877..b4b12d619b 100644 --- a/basis/math/vectors/vectors-tests.factor +++ b/basis/math/vectors/vectors-tests.factor @@ -9,3 +9,8 @@ USING: math.vectors tools.test ; [ 5 ] [ { 1 2 } norm-sq ] unit-test [ 13 ] [ { 2 3 } norm-sq ] unit-test +[ { 1.0 2.5 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.0 vnlerp ] unit-test +[ { 2.5 1.0 } ] [ { 1.0 2.5 } { 2.5 1.0 } 1.0 vnlerp ] unit-test +[ { 1.75 1.75 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.5 vnlerp ] unit-test + +[ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index eb5fa7b970..eb203a5f12 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -6,6 +6,11 @@ IN: math.vectors : vneg ( u -- v ) [ neg ] map ; +: v+n ( u n -- v ) [ + ] curry map ; +: n+v ( n u -- v ) [ + ] with map ; +: v-n ( u n -- v ) [ - ] curry map ; +: n-v ( n u -- v ) [ - ] with map ; + : v*n ( u n -- v ) [ * ] curry map ; : n*v ( n u -- v ) [ * ] with map ; : v/n ( u n -- v ) [ / ] curry map ; @@ -19,6 +24,10 @@ IN: math.vectors : vmax ( u v -- w ) [ max ] 2map ; : vmin ( u v -- w ) [ min ] 2map ; +: vfloor ( v -- _v_ ) [ floor ] map ; +: vceiling ( v -- ^v^ ) [ ceiling ] map ; +: vtruncate ( v -- -v- ) [ truncate ] map ; + : vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ; : vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ; @@ -32,6 +41,12 @@ IN: math.vectors : set-axis ( u v axis -- w ) [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ; +: vlerp ( a b t -- a_t ) + [ lerp ] 3map ; + +: vnlerp ( a b t -- a_t ) + [ lerp ] curry 2map ; + HINTS: vneg { array } ; HINTS: norm-sq { array } ; HINTS: norm { array } ; @@ -50,3 +65,6 @@ HINTS: v/ { array array } ; HINTS: vmax { array array } ; HINTS: vmin { array array } ; HINTS: v. { array array } ; + +HINTS: vlerp { array array array } ; +HINTS: vnlerp { array array object } ; diff --git a/basis/random/random.factor b/basis/random/random.factor index d972e1e7ac..6b02c8a3e8 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -3,7 +3,7 @@ USING: alien.c-types kernel math namespaces sequences io.backend io.binary combinators system vocabs.loader summary math.bitwise byte-vectors fry byte-arrays -math.ranges ; +math.ranges math.constants math.functions accessors ; IN: random SYMBOL: system-random-generator @@ -69,6 +69,20 @@ PRIVATE> : with-secure-random ( quot -- ) secure-random-generator get swap with-random ; inline +: uniform-random-float ( min max -- n ) + 4 random-bytes underlying>> *uint >float + 4 random-bytes underlying>> *uint >float + 2.0 32 ^ * + + [ over - 2.0 -64 ^ * ] dip + * + ; inline + +: normal-random-float ( mean sigma -- n ) + 0.0 1.0 uniform-random-float + 0.0 1.0 uniform-random-float + [ 2 pi * * cos ] + [ 1.0 swap - log -2.0 * sqrt ] + bi* * * + ; + USE: vocabs.loader { diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index 73e719b806..f64542fa00 100644 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -2,7 +2,7 @@ IN: specialized-arrays.tests USING: tools.test specialized-arrays sequences specialized-arrays.int specialized-arrays.bool specialized-arrays.ushort alien.c-types accessors kernel -specialized-arrays.direct.int arrays ; +specialized-arrays.direct.int specialized-arrays.char arrays ; [ t ] [ { 1 2 3 } >int-array int-array? ] unit-test @@ -10,7 +10,7 @@ specialized-arrays.direct.int arrays ; [ 2 ] [ int-array{ 1 2 3 } second ] unit-test -[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >int-array underlying>> = ] unit-test +[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >char-array underlying>> = ] unit-test [ ushort-array{ 1234 } ] [ little-endian? B{ 210 4 } B{ 4 210 } ? byte-array>ushort-array diff --git a/basis/tools/disassembler/udis/udis-tests.factor b/basis/tools/disassembler/udis/udis-tests.factor new file mode 100644 index 0000000000..9ad3dbbcc2 --- /dev/null +++ b/basis/tools/disassembler/udis/udis-tests.factor @@ -0,0 +1,9 @@ +IN: tools.disassembler.udis.tests +USING: tools.disassembler.udis tools.test alien.c-types system combinators kernel ; + +{ + { [ os linux? cpu x86.64? and ] [ [ 656 ] [ "ud" heap-size ] unit-test ] } + { [ os macosx? cpu x86.32? and ] [ [ 592 ] [ "ud" heap-size ] unit-test ] } + { [ os macosx? cpu x86.64? and ] [ [ 656 ] [ "ud" heap-size ] unit-test ] } + [ ] +} cond \ No newline at end of file diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor index cd9dd9cf4b..df624cab28 100755 --- a/basis/tools/disassembler/udis/udis.factor +++ b/basis/tools/disassembler/udis/udis.factor @@ -16,7 +16,57 @@ IN: tools.disassembler.udis LIBRARY: libudis86 -TYPEDEF: char[592] ud +C-STRUCT: ud_operand + { "int" "type" } + { "uchar" "size" } + { "ulonglong" "lval" } + { "int" "base" } + { "int" "index" } + { "uchar" "offset" } + { "uchar" "scale" } ; + +C-STRUCT: ud + { "void*" "inp_hook" } + { "uchar" "inp_curr" } + { "uchar" "inp_fill" } + { "FILE*" "inp_file" } + { "uchar" "inp_ctr" } + { "uchar*" "inp_buff" } + { "uchar*" "inp_buff_end" } + { "uchar" "inp_end" } + { "void*" "translator" } + { "ulonglong" "insn_offset" } + { "char[32]" "insn_hexcode" } + { "char[64]" "insn_buffer" } + { "uint" "insn_fill" } + { "uchar" "dis_mode" } + { "ulonglong" "pc" } + { "uchar" "vendor" } + { "struct map_entry*" "mapen" } + { "int" "mnemonic" } + { "ud_operand[3]" "operand" } + { "uchar" "error" } + { "uchar" "pfx_rex" } + { "uchar" "pfx_seg" } + { "uchar" "pfx_opr" } + { "uchar" "pfx_adr" } + { "uchar" "pfx_lock" } + { "uchar" "pfx_rep" } + { "uchar" "pfx_repe" } + { "uchar" "pfx_repne" } + { "uchar" "pfx_insn" } + { "uchar" "default64" } + { "uchar" "opr_mode" } + { "uchar" "adr_mode" } + { "uchar" "br_far" } + { "uchar" "br_near" } + { "uchar" "implicit_addr" } + { "uchar" "c1" } + { "uchar" "c2" } + { "uchar" "c3" } + { "uchar[256]" "inp_cache" } + { "uchar[64]" "inp_sess" } + { "ud_itab_entry*" "itab_entry" } ; FUNCTION: void ud_translate_intel ( ud* u ) ; FUNCTION: void ud_translate_att ( ud* u ) ; diff --git a/basis/tools/time/time.factor b/basis/tools/time/time.factor index 65e87f976f..948c0d482d 100644 --- a/basis/tools/time/time.factor +++ b/basis/tools/time/time.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.vectors memory io io.styles prettyprint +USING: kernel math memory io io.styles prettyprint namespaces system sequences splitting grouping assocs strings generic.single combinators ; IN: tools.time diff --git a/basis/tools/trace/trace-tests.factor b/basis/tools/trace/trace-tests.factor index 74f7c40943..06511c7ada 100644 --- a/basis/tools/trace/trace-tests.factor +++ b/basis/tools/trace/trace-tests.factor @@ -1,4 +1,30 @@ IN: tools.trace.tests -USING: tools.trace tools.test sequences ; +USING: tools.trace tools.test tools.continuations kernel math combinators +sequences ; -[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test \ No newline at end of file +[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test + +GENERIC: method-breakpoint-test ( x -- y ) + +TUPLE: method-breakpoint-tuple ; + +M: method-breakpoint-tuple method-breakpoint-test break drop 1 2 + ; + +\ method-breakpoint-test don't-step-into + +[ 3 ] +[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] trace ] unit-test + +: case-breakpoint-test ( -- x ) + 5 { [ break 1 + ] } case ; + +\ case-breakpoint-test don't-step-into + +[ 6 ] [ [ case-breakpoint-test ] trace ] unit-test + +: call(-breakpoint-test ( -- x ) + [ break 1 ] call( -- x ) 2 + ; + +\ call(-breakpoint-test don't-step-into + +[ 3 ] [ [ call(-breakpoint-test ] trace ] unit-test diff --git a/basis/tools/trace/trace.factor b/basis/tools/trace/trace.factor index e2c6bf864b..f7f0ae4a69 100644 --- a/basis/tools/trace/trace.factor +++ b/basis/tools/trace/trace.factor @@ -4,19 +4,21 @@ USING: concurrency.promises models tools.continuations kernel sequences concurrency.messaging locals continuations threads namespaces namespaces.private make assocs accessors io strings prettyprint math math.parser words effects summary io.styles classes -generic.math combinators.short-circuit ; +generic.math combinators.short-circuit kernel.private quotations ; IN: tools.trace -: callstack-depth ( callstack -- n ) - callstack>array length 2/ ; - -SYMBOL: end - SYMBOL: exclude-vocabs SYMBOL: include-vocabs exclude-vocabs { "math" "accessors" } swap set-global +array length 2/ ; + +SYMBOL: end + : include? ( vocab -- ? ) include-vocabs get dup [ member? ] [ 2drop t ] if ; @@ -65,15 +67,20 @@ M: trace-step summary [ CHAR: \s write ] [ number>string write ": " write ] bi ; +: trace-into? ( continuation -- ? ) + continuation-current into? ; + : trace-step ( continuation -- continuation' ) - dup continuation-current end eq? [ - [ print-depth ] - [ print-step ] - [ - dup continuation-current into? - [ continuation-step-into ] [ continuation-step ] if - ] tri - ] unless ; + dup call>> innermost-frame-executing quotation? [ + dup continuation-current end eq? [ + [ print-depth ] + [ print-step ] + [ dup trace-into? [ continuation-step-into ] [ continuation-step ] if ] + tri + ] unless + ] when ; + +PRIVATE> : trace ( quot -- data ) [ [ trace-step ] break-hook ] dip diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index d07403836a..b73de68e26 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -145,7 +145,9 @@ SYMBOL: ui-thread PRIVATE> : find-window ( quot -- world ) - [ windows get values ] dip '[ gadget-child @ ] find-last nip ; inline + [ windows get values ] dip + '[ dup children>> [ ] [ nip first ] if-empty @ ] + find-last nip ; inline : ui-running? ( -- ? ) \ ui-running get-global ; diff --git a/basis/windows/dinput/dinput.factor b/basis/windows/dinput/dinput.factor index 20a54dff98..e5e32aac0e 100755 --- a/basis/windows/dinput/dinput.factor +++ b/basis/windows/dinput/dinput.factor @@ -444,6 +444,18 @@ CONSTANT: DISCL_FOREGROUND HEX: 00000004 CONSTANT: DISCL_BACKGROUND HEX: 00000008 CONSTANT: DISCL_NOWINKEY HEX: 00000010 +CONSTANT: DIMOFS_X 0 +CONSTANT: DIMOFS_Y 4 +CONSTANT: DIMOFS_Z 8 +CONSTANT: DIMOFS_BUTTON0 12 +CONSTANT: DIMOFS_BUTTON1 13 +CONSTANT: DIMOFS_BUTTON2 14 +CONSTANT: DIMOFS_BUTTON3 15 +CONSTANT: DIMOFS_BUTTON4 16 +CONSTANT: DIMOFS_BUTTON5 17 +CONSTANT: DIMOFS_BUTTON6 18 +CONSTANT: DIMOFS_BUTTON7 19 + CONSTANT: DIK_ESCAPE HEX: 01 CONSTANT: DIK_1 HEX: 02 CONSTANT: DIK_2 HEX: 03 diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor index 896fb7f09f..c74c325726 100644 --- a/core/alien/strings/strings.factor +++ b/core/alien/strings/strings.factor @@ -40,19 +40,26 @@ M: unix alien>native-string utf8 alien>string ; HOOK: native-string>alien os ( string -- alien ) -M: wince native-string>alien utf16n string>alien ; - -M: winnt native-string>alien utf8 string>alien ; +M: windows native-string>alien utf16n string>alien ; M: unix native-string>alien utf8 string>alien ; : dll-path ( dll -- string ) path>> alien>native-string ; -: string>symbol ( str -- alien ) - dup string? - [ native-string>alien ] - [ [ native-string>alien ] map ] if ; +HOOK: string>symbol* os ( str/seq -- alien ) + +M: winnt string>symbol* utf8 string>alien ; + +M: wince string>symbol* utf16n string>alien ; + +M: unix string>symbol* utf8 string>alien ; + +GENERIC: string>symbol ( str -- alien ) + +M: string string>symbol string>symbol* ; + +M: sequence string>symbol [ string>symbol* ] map ; [ 8 getenv utf8 alien>string string>cpu \ cpu set-global diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 83276cd3f2..57bc61a005 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -231,7 +231,8 @@ bi "vocabulary" { "def" { "quotation" "quotations" } initial: [ ] } "props" - { "direct-entry-def" } + "pic-def" + "pic-tail-def" { "counter" { "fixnum" "math" } } { "sub-primitive" read-only } } define-builtin @@ -505,6 +506,7 @@ tuple { "load-locals" "locals.backend" (( ... n -- )) } { "check-datastack" "kernel.private" (( array in# out# -- ? )) } { "inline-cache-miss" "generic.single.private" (( generic methods index cache -- )) } + { "inline-cache-miss-tail" "generic.single.private" (( generic methods index cache -- )) } { "mega-cache-miss" "generic.single.private" (( methods index cache -- method )) } { "lookup-method" "generic.single.private" (( object methods -- method )) } { "reset-dispatch-stats" "generic.single" (( -- )) } diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 6409fc588e..a2617d0ebb 100644 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -64,7 +64,7 @@ IN: continuations.tests [ 1 2 ] [ bar ] unit-test -[ t ] [ \ bar def>> "c" get innermost-frame-quot = ] unit-test +[ t ] [ \ bar def>> "c" get innermost-frame-executing = ] unit-test [ 1 ] [ "c" get innermost-frame-scan ] unit-test diff --git a/core/generic/hook/hook.factor b/core/generic/hook/hook.factor index fe5b62f6c0..5edbc54bd8 100644 --- a/core/generic/hook/hook.factor +++ b/core/generic/hook/hook.factor @@ -17,8 +17,6 @@ M: hook-combination picker M: hook-combination dispatch# drop 0 ; -M: hook-combination inline-cache-quot 2drop f ; - M: hook-combination mega-cache-quot 1quotation picker [ lookup-method (execute) ] surround ; diff --git a/core/generic/single/single-tests.factor b/core/generic/single/single-tests.factor index c8cab970fd..e48d404b92 100644 --- a/core/generic/single/single-tests.factor +++ b/core/generic/single/single-tests.factor @@ -273,5 +273,5 @@ M: growable call-next-hooker call-next-method "growable " prepend ; [ ] [ "IN: generic.single.tests GENERIC: xyz ( a -- b )" eval( -- ) ] unit-test [ ] [ "IN: generic.single.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test -[ f ] [ "xyz" "generic.single.tests" lookup direct-entry-def>> ] unit-test +[ f ] [ "xyz" "generic.single.tests" lookup pic-def>> ] unit-test [ f ] [ "xyz" "generic.single.tests" lookup "decision-tree" word-prop ] unit-test \ No newline at end of file diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index d8fa04edd6..36a76153f9 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -238,10 +238,14 @@ M: f compile-engine ; [ compile-engine ] bi ] tri ; -HOOK: inline-cache-quot combination ( word methods -- quot/f ) +HOOK: inline-cache-quots combination ( word methods -- pic-quot/f pic-tail-quot/f ) + +M: single-combination inline-cache-quots 2drop f f ; : define-inline-cache-quot ( word methods -- ) - [ drop ] [ inline-cache-quot ] 2bi >>direct-entry-def drop ; + [ drop ] [ inline-cache-quots ] 2bi + [ >>pic-def ] [ >>pic-tail-def ] bi* + drop ; HOOK: mega-cache-quot combination ( methods -- quot/f ) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index bf801c4e47..b76bcaa582 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -3,7 +3,7 @@ USING: accessors definitions generic generic.single kernel namespaces words math math.order combinators sequences generic.single.private quotations kernel.private -assocs arrays layouts ; +assocs arrays layouts make ; IN: generic.standard TUPLE: standard-combination < single-combination # ; @@ -38,17 +38,22 @@ M: standard-generic effective-method [ datastack ] dip [ "combination" word-prop #>> swap nth ] keep (effective-method) ; -M: standard-combination inline-cache-quot ( word methods -- ) +: inline-cache-quot ( word methods miss-word -- quot ) + [ [ literalize , ] [ , ] [ combination get #>> , { } , , ] tri* ] [ ] make ; + +M: standard-combination inline-cache-quots #! Direct calls to the generic word (not tail calls or indirect calls) #! will jump to the inline cache entry point instead of the megamorphic #! dispatch entry point. - combination get #>> [ { } inline-cache-miss ] 3curry [ ] like ; + [ \ inline-cache-miss inline-cache-quot ] + [ \ inline-cache-miss-tail inline-cache-quot ] + 2bi ; : make-empty-cache ( -- array ) mega-cache-size get f ; M: standard-combination mega-cache-quot - combination get #>> make-empty-cache [ mega-cache-lookup ] 3curry [ ] like ; + combination get #>> make-empty-cache \ mega-cache-lookup [ ] 4sequence ; M: standard-generic definer drop \ GENERIC# f ; diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 0914134bb6..03bc3e01fd 100644 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -139,14 +139,14 @@ M: hashtable set-at ( value key hash -- ) PRIVATE> M: hashtable >alist - [ array>> [ length 2/ iota ] keep ] [ assoc-size ] bi [ + [ array>> [ length 2/ ] keep ] [ assoc-size ] bi [ [ [ [ 1 fixnum-shift-fast ] dip [ array-nth ] [ [ 1 fixnum+fast ] dip array-nth ] 2bi ] dip pick tombstone? [ 3drop ] [ [ 2array ] dip push-unsafe ] if - ] 2curry each + ] 2curry each-integer ] keep { } like ; M: hashtable clone diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index 3469a81064..97b143e989 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -117,6 +117,7 @@ HELP: seek-relative } { $description "Seeks to an offset from the current position of the stream pointer." } ; +{ seek-absolute seek-relative seek-end } related-words HELP: seek-input { $values @@ -343,6 +344,10 @@ $nl { $subsection bl } "Seeking on the default output stream:" { $subsection seek-output } +"Seeking descriptors:" +{ $subsection seek-absolute } +{ $subsection seek-relative } +{ $subsection seek-end } "A pair of combinators for rebinding the " { $link output-stream } " variable:" { $subsection with-output-stream } { $subsection with-output-stream* } diff --git a/core/words/words.factor b/core/words/words.factor index 1976c1e4cd..c01cf13bcd 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -155,7 +155,8 @@ M: word reset-word [ subwords forget-all ] [ reset-word ] [ - f >>direct-entry-def + f >>pic-def + f >>pic-tail-def { "methods" "combination" diff --git a/extra/game-input/dinput/dinput.factor b/extra/game-input/dinput/dinput.factor index 20815859ab..8540907db9 100755 --- a/extra/game-input/dinput/dinput.factor +++ b/extra/game-input/dinput/dinput.factor @@ -5,16 +5,20 @@ windows.user32 windows.messages sequences combinators locals math.rectangles accessors math alien alien.strings io.encodings.utf16 io.encodings.utf16n continuations byte-arrays game-input.dinput.keys-array game-input -ui.backend.windows windows.errors ; +ui.backend.windows windows.errors struct-arrays +math.bitwise ; IN: game-input.dinput +CONSTANT: MOUSE-BUFFER-SIZE 16 + SINGLETON: dinput-game-input-backend dinput-game-input-backend game-input-backend set-global SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ +controller-devices+ +controller-guids+ - +device-change-window+ +device-change-handle+ ; + +device-change-window+ +device-change-handle+ + +mouse-device+ +mouse-state+ +mouse-buffer+ ; : create-dinput ( -- ) f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid @@ -35,8 +39,24 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ : set-data-format ( device format-symbol -- ) get IDirectInputDevice8W::SetDataFormat ole32-error ; +: ( size -- DIPROPDWORD ) + "DIPROPDWORD" + "DIPROPDWORD" heap-size over set-DIPROPHEADER-dwSize + "DIPROPHEADER" heap-size over set-DIPROPHEADER-dwHeaderSize + 0 over set-DIPROPHEADER-dwObj + DIPH_DEVICE over set-DIPROPHEADER-dwHow + swap over set-DIPROPDWORD-dwData ; + +: set-buffer-size ( device size -- ) + DIPROP_BUFFERSIZE swap + IDirectInputDevice8W::SetProperty ole32-error ; + : configure-keyboard ( keyboard -- ) [ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ; +: configure-mouse ( mouse -- ) + [ c_dfDIMouse2 set-data-format ] + [ MOUSE-BUFFER-SIZE set-buffer-size ] + [ set-coop-level ] tri ; : configure-controller ( controller -- ) [ c_dfDIJoystick2 set-data-format ] [ set-coop-level ] bi ; @@ -47,6 +67,15 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ 256 keyboard-state boa +keyboard-state+ set-global ; +: find-mouse ( -- ) + GUID_SysMouse device-for-guid + [ configure-mouse ] + [ +mouse-device+ set-global ] bi + 0 0 0 0 8 f mouse-state boa + +mouse-state+ set-global + MOUSE-BUFFER-SIZE "DIDEVICEOBJECTDATA" + +mouse-buffer+ set-global ; + : device-info ( device -- DIDEVICEIMAGEINFOW ) "DIDEVICEINSTANCEW" "DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize @@ -190,16 +219,22 @@ TUPLE: window-rect < rect window-loc ; +keyboard-device+ [ com-release f ] change-global f +keyboard-state+ set-global ; +: release-mouse ( -- ) + +mouse-device+ [ com-release f ] change-global + f +mouse-state+ set-global ; + M: dinput-game-input-backend (open-game-input) create-dinput create-device-change-window find-keyboard + find-mouse set-up-controllers add-wm-devicechange ; M: dinput-game-input-backend (close-game-input) remove-wm-devicechange release-controllers + release-mouse release-keyboard close-device-change-window delete-dinput ; @@ -263,6 +298,22 @@ CONSTANT: pov-values [ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ] } 2cleave ; +: read-device-buffer ( device buffer count -- buffer count' ) + [ "DIDEVICEOBJECTDATA" heap-size ] 2dip + [ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ; + +: (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state ) + [ DIDEVICEOBJECTDATA-dwData 32 >signed ] [ DIDEVICEOBJECTDATA-dwOfs ] bi { + { DIMOFS_X [ [ + ] curry change-dx ] } + { DIMOFS_Y [ [ + ] curry change-dy ] } + { DIMOFS_Z [ [ + ] curry change-scroll-dy ] } + [ [ c-bool> ] [ DIMOFS_BUTTON0 - ] bi* rot [ buttons>> set-nth ] keep ] + } case ; + +: fill-mouse-state ( buffer count -- state ) + [ +mouse-state+ get ] 2dip swap + [ "DIDEVICEOBJECTDATA" byte-array>struct-array nth (fill-mouse-state) ] curry each ; + : get-device-state ( device byte-array -- ) [ dup IDirectInputDevice8W::Poll ole32-error ] dip [ length ] keep @@ -283,3 +334,17 @@ M: dinput-game-input-backend read-keyboard +keyboard-device+ get [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ] [ ] [ f ] with-acquisition ; + +M: dinput-game-input-backend read-mouse + +mouse-device+ get [ +mouse-buffer+ get MOUSE-BUFFER-SIZE read-device-buffer ] + [ fill-mouse-state ] [ f ] with-acquisition ; + +M: dinput-game-input-backend reset-mouse + +mouse-device+ get [ f MOUSE-BUFFER-SIZE read-device-buffer ] + [ 2drop ] [ ] with-acquisition + +mouse-state+ get + 0 >>dx + 0 >>dy + 0 >>scroll-dx + 0 >>scroll-dy + drop ; diff --git a/extra/game-input/game-input-docs.factor b/extra/game-input/game-input-docs.factor index 5428ca66d0..b46cf9a295 100755 --- a/extra/game-input/game-input-docs.factor +++ b/extra/game-input/game-input-docs.factor @@ -3,7 +3,7 @@ sequences strings math ; IN: game-input ARTICLE: "game-input" "Game controller input" -"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard input." $nl +"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard and mouse input." $nl "The game input interface must be initialized before being used:" { $subsection open-game-input } { $subsection close-game-input } @@ -18,11 +18,13 @@ ARTICLE: "game-input" "Game controller input" { $subsection instance-id } "A hook is provided for invoking the system calibration tool:" { $subsection calibrate-controller } -"The current state of a controller or the keyboard can be read:" +"The current state of a controller, the keyboard, and the mouse can be read:" { $subsection read-controller } { $subsection read-keyboard } +{ $subsection read-mouse } { $subsection controller-state } -{ $subsection keyboard-state } ; +{ $subsection keyboard-state } +{ $subsection mouse-state } ; HELP: open-game-input { $description "Initializes the game input interface. An exception will be thrown if the initialization fails. If the game input interface is already opened, nothing happens." } ; @@ -86,6 +88,14 @@ HELP: read-keyboard { $warning "For efficiency, the implementation may reuse the returned " { $snippet "keyboard-state" } " object next time " { $snippet "read-keyboard" } " is called. You should " { $link clone } " any values from the returned tuple you need to preserve." $nl "The keyboard state returned by this word is unprocessed by any keymaps, modifier keys, key repeat settings, or other operating environment postprocessing. Because of this, " { $snippet "read-keyboard" } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ; +HELP: read-mouse +{ $values { "mouse-state" mouse-state } } +{ $description "Reads the current mouse state relative to either when the game input interface was opened with " { $link open-game-input } " or when the mouse state was reset with " { $link reset-mouse } "." } +{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "mouse-state" } " object for future " { $snippet "read-mouse" } " or " { $snippet "reset-mouse" } " calls. You should " { $link clone } " the " { $snippet "mouse-state" } " object if you need to preserve it." } ; + +HELP: reset-mouse +{ $description "Resets the mouse state. Future " { $link read-mouse } " values will be relative to the time this word is called." } ; + HELP: controller-state { $class-description "The " { $link read-controller } " word returns objects of this class. " { $snippet "controller-state" } " objects have the following slots:" { $list @@ -121,6 +131,19 @@ HELP: keyboard-state { $class-description "The " { $link read-keyboard } " word returns objects of this class. The " { $snippet "keys" } " slot of a " { $snippet "keyboard-state" } " object contains a " { $link sequence } " of 256 members representing the state of the keys on the keyboard. Each element is a boolean value indicating whether the corresponding key is pressed. The sequence is indexed by scancode as defined under usage page 7 of the USB HID standard. Named scancode constants are provided in the " { $vocab-link "game-input.scancodes" } " vocabulary." } { $warning "The scancodes used to index " { $snippet "keyboard-state" } " objects correspond to physical key positions on the keyboard--they are unaffected by keymaps, modifier keys, or other operating environment postprocessing. The face value of the constants in " { $vocab-link "game-input.scancodes" } " do not necessarily correspond to what the user expects the key to type. Because of this, " { $link read-keyboard } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ; +HELP: mouse-state +{ $class-description "The " { $link read-mouse } " word returns objects of this class. " { $snippet "mouse-state" } " objects have the following slots:" +{ $list + { { $snippet "dx" } " contains the mouse's X axis movement." } + { { $snippet "dy" } " contains the mouse's Y axis movement." } + { { $snippet "scroll-dx" } " contains the scroller's X axis movement." } + { { $snippet "scroll-dy" } " contains the scroller's Y axis movement." } + { { $snippet "buttons" } " contains a sequence of boolean values indicate the state of the mouse's buttons." } +} +"Mouse movement is recorded relative to when the game input interface was opened with " { $link open-game-input } " or the mouse state is reset with " { $link reset-mouse } "." +} ; + + { keyboard-state read-keyboard } related-words ABOUT: "game-input" diff --git a/extra/game-input/game-input.factor b/extra/game-input/game-input.factor index 6efe31861a..8281b7bc4c 100755 --- a/extra/game-input/game-input.factor +++ b/extra/game-input/game-input.factor @@ -73,6 +73,15 @@ M: keyboard-state clone HOOK: read-keyboard game-input-backend ( -- keyboard-state ) +TUPLE: mouse-state dx dy scroll-dx scroll-dy buttons ; + +M: mouse-state clone + call-next-method dup buttons>> clone >>buttons ; + +HOOK: read-mouse game-input-backend ( -- mouse-state ) + +HOOK: reset-mouse game-input-backend ( -- ) + { { [ os windows? ] [ "game-input.dinput" require ] } { [ os macosx? ] [ "game-input.iokit" require ] } diff --git a/extra/game-input/iokit/iokit.factor b/extra/game-input/iokit/iokit.factor index 2ded263899..0cc8b5d51f 100755 --- a/extra/game-input/iokit/iokit.factor +++ b/extra/game-input/iokit/iokit.factor @@ -3,7 +3,7 @@ kernel cocoa.enumeration destructors math.parser cocoa.application sequences locals combinators.short-circuit threads namespaces assocs vectors arrays combinators core-foundation.run-loop accessors sequences.private -alien.c-types math parser game-input ; +alien.c-types math parser game-input vectors ; IN: game-input.iokit SINGLETON: iokit-game-input-backend @@ -23,9 +23,13 @@ iokit-game-input-backend game-input-backend set-global CONSTANT: game-devices-matching-seq { + H{ { "DeviceUsage" 1 } { "DeviceUsagePage" 1 } } ! pointers + H{ { "DeviceUsage" 2 } { "DeviceUsagePage" 1 } } ! mouses H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards + H{ { "DeviceUsage" 7 } { "DeviceUsagePage" 1 } } ! keypads + H{ { "DeviceUsage" 8 } { "DeviceUsagePage" 1 } } ! multiaxis controllers } CONSTANT: buttons-matching-hash @@ -46,6 +50,8 @@ CONSTANT: rz-axis-matching-hash H{ { "UsagePage" 1 } { "Usage" HEX: 35 } { "Type" 1 } } CONSTANT: slider-matching-hash H{ { "UsagePage" 1 } { "Usage" HEX: 36 } { "Type" 1 } } +CONSTANT: wheel-matching-hash + H{ { "UsagePage" 1 } { "Usage" HEX: 38 } { "Type" 1 } } CONSTANT: hat-switch-matching-hash H{ { "UsagePage" 1 } { "Usage" HEX: 39 } { "Type" 1 } } @@ -90,10 +96,17 @@ CONSTANT: hat-switch-matching-hash : transfer-element-property ( element from-key to-key -- ) [ dupd element-property ] dip swap set-element-property ; +: mouse-device? ( device -- ? ) + { + [ 1 1 IOHIDDeviceConformsTo ] + [ 1 2 IOHIDDeviceConformsTo ] + } 1|| ; + : controller-device? ( device -- ? ) { [ 1 4 IOHIDDeviceConformsTo ] [ 1 5 IOHIDDeviceConformsTo ] + [ 1 8 IOHIDDeviceConformsTo ] } 1|| ; : element-usage ( element -- {usage-page,usage} ) @@ -118,6 +131,8 @@ CONSTANT: hat-switch-matching-hash { 1 HEX: 35 } = ; inline : slider? ( {usage-page,usage} -- ? ) { 1 HEX: 36 } = ; inline +: wheel? ( {usage-page,usage} -- ? ) + { 1 HEX: 38 } = ; inline : hat-switch? ( {usage-page,usage} -- ? ) { 1 HEX: 39 } = ; inline @@ -132,12 +147,17 @@ CONSTANT: pov-values IOHIDValueGetIntegerValue dup zero? [ drop f ] when ; : axis-value ( value -- [-1,1] ) kIOHIDValueScaleTypeCalibrated IOHIDValueGetScaledValue ; +: mouse-axis-value ( value -- n ) + IOHIDValueGetIntegerValue ; : pov-value ( value -- pov-direction ) IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ; +: record-button ( hid-value usage state -- ) + [ button-value ] [ second 1- ] [ buttons>> ] tri* set-nth ; + : record-controller ( controller-state value -- ) dup IOHIDValueGetElement element-usage { - { [ dup button? ] [ [ button-value ] [ second 1- ] bi* rot buttons>> set-nth ] } + { [ dup button? ] [ rot record-button ] } { [ dup x-axis? ] [ drop axis-value >>x drop ] } { [ dup y-axis? ] [ drop axis-value >>y drop ] } { [ dup z-axis? ] [ drop axis-value >>z drop ] } @@ -149,7 +169,7 @@ CONSTANT: pov-values [ 3drop ] } cond ; -SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ; +SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ; : ?set-nth ( value nth seq -- ) 2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ; @@ -161,6 +181,27 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ; +keyboard-state+ get ?set-nth ] [ drop ] if ; +: record-mouse ( value -- ) + dup IOHIDValueGetElement element-usage { + { [ dup button? ] [ +mouse-state+ get record-button ] } + { [ dup x-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dx drop ] } + { [ dup y-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dy drop ] } + { [ dup wheel? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dx drop ] } + { [ dup z-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dy drop ] } + [ 2drop ] + } cond ; + +M: iokit-game-input-backend read-mouse + +mouse-state+ get ; + +M: iokit-game-input-backend reset-mouse + +mouse-state+ get + 0 >>dx + 0 >>dy + 0 >>scroll-dx + 0 >>scroll-dy + drop ; + : default-calibrate-saturation ( element -- ) [ kIOHIDElementMinKey kIOHIDElementCalibrationSaturationMinKey transfer-element-property ] [ kIOHIDElementMaxKey kIOHIDElementCalibrationSaturationMaxKey transfer-element-property ] @@ -194,12 +235,21 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ; [ button-count f ] } cleave controller-state boa ; +: ?add-mouse-buttons ( device -- ) + button-count +mouse-state+ get buttons>> + 2dup length > + [ set-length ] [ 2drop ] if ; + : device-matched-callback ( -- alien ) [| context result sender device | - device controller-device? [ - device - device +controller-states+ get set-at - ] when + { + { [ device controller-device? ] [ + device + device +controller-states+ get set-at + ] } + { [ device mouse-device? ] [ device ?add-mouse-buttons ] } + [ ] + } cond ] IOHIDDeviceCallback ; : device-removed-callback ( -- alien ) @@ -209,15 +259,20 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ; : device-input-callback ( -- alien ) [| context result sender value | - sender controller-device? - [ sender +controller-states+ get at value record-controller ] - [ value record-keyboard ] - if + { + { [ sender controller-device? ] [ + sender +controller-states+ get at value record-controller + ] } + { [ sender mouse-device? ] [ value record-mouse ] } + [ value record-keyboard ] + } cond ] IOHIDValueCallback ; : initialize-variables ( manager -- ) +hid-manager+ set-global 4 +controller-states+ set-global + 0 0 0 0 2 mouse-state boa + +mouse-state+ set-global 256 f +keyboard-state+ set-global ; M: iokit-game-input-backend (open-game-input) diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index 2818c16f9f..b891142d5b 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -5,23 +5,28 @@ opengl opengl.gl opengl.textures sequences strings ui ui.gadgets ui.gadgets.panes ui.render ui.images ; IN: images.viewer -TUPLE: image-gadget < gadget image-name ; +TUPLE: image-gadget < gadget image texture ; -M: image-gadget pref-dim* - image-name>> image-dim ; +M: image-gadget pref-dim* image>> dim>> ; + +: image-gadget-texture ( gadget -- texture ) + dup texture>> [ ] [ dup image>> { 0 0 } >>texture texture>> ] ?if ; M: image-gadget draw-gadget* ( gadget -- ) - image-name>> draw-image ; + [ dim>> ] [ image-gadget-texture ] bi draw-scaled-texture ; -: ( image-name -- gadget ) +! Todo: delete texture on ungraft + +GENERIC: ( object -- gadget ) + +M: image \ image-gadget new - swap >>image-name ; + swap >>image ; -: image-window ( path -- gadget ) - [ dup ] [ open-window ] bi ; +M: string load-image ; -GENERIC: image. ( object -- ) +M: pathname load-image ; -M: string image. ( image -- ) gadget. ; +: image-window ( object -- ) "Image" open-window ; -M: pathname image. ( image -- ) gadget. ; +: image. ( object -- ) gadget. ; diff --git a/extra/noise/noise.factor b/extra/noise/noise.factor new file mode 100644 index 0000000000..f2ca8ad59b --- /dev/null +++ b/extra/noise/noise.factor @@ -0,0 +1,121 @@ +USING: byte-arrays combinators fry images kernel locals math +math.affine-transforms math.functions math.order +math.polynomials math.vectors random random.mersenne-twister +sequences sequences.product ; +IN: noise + +: ( -- table ) + 256 iota >byte-array randomize dup append ; + + u + hash 12 bitand zero? + [ gradients second ] + [ hash 13 bitand 12 = [ gradients first ] [ gradients third ] if ] if + :> v + + hash 1 bitand zero? [ u ] [ u neg ] if + hash 2 bitand zero? [ v ] [ v neg ] if + ; + +: unit-cube ( point -- cube ) + [ floor >fixnum 256 mod ] map ; + +:: hashes ( table cube -- aaa baa aba bba aab bab abb bbb ) + cube first :> x + cube second :> y + cube third :> z + x table nth y + :> a + x 1 + table nth y + :> b + + a table nth z + :> aa + b table nth z + :> ba + a 1 + table nth z + :> ab + b 1 + table nth z + :> bb + + aa table nth + ba table nth + ab table nth + bb table nth + aa 1 + table nth + ba 1 + table nth + ab 1 + table nth + bb 1 + table nth ; + +:: 2tetra@ ( p q r s t u v w quot -- ) + p q quot call + r s quot call + t u quot call + v w quot call + ; inline + +: with-seed ( seed quot -- ) + [ ] dip with-random ; inline + +: >byte-map ( floats -- bytes ) + [ 255.0 * >fixnum ] B{ } map-as ; + +: >image ( bytes dim -- image ) + swap [ L f ] dip image boa ; + +PRIVATE> + +:: perlin-noise ( table point -- value ) + point unit-cube :> cube + point dup vfloor v- :> gradients + gradients fade :> faded + + table cube hashes { + [ gradients grad ] + [ gradients { -1.0 0.0 0.0 } v+ grad ] + [ gradients { 0.0 -1.0 0.0 } v+ grad ] + [ gradients { -1.0 -1.0 0.0 } v+ grad ] + [ gradients { 0.0 0.0 -1.0 } v+ grad ] + [ gradients { -1.0 0.0 -1.0 } v+ grad ] + [ gradients { 0.0 -1.0 -1.0 } v+ grad ] + [ gradients { -1.0 -1.0 -1.0 } v+ grad ] + } spread + [ faded first lerp ] 2tetra@ + [ faded second lerp ] 2bi@ + faded third lerp ; + +: normalize-0-1 ( sequence -- sequence' ) + [ supremum ] [ infimum [ - ] keep ] [ ] tri + [ swap - ] with map [ swap / ] with map ; + +: clamp-0-1 ( sequence -- sequence' ) + [ 0.0 max 1.0 min ] map ; + +: perlin-noise-map ( table transform dim -- map ) + [ iota ] map [ a.v 0.0 suffix perlin-noise ] with with product-map ; + +: perlin-noise-byte-map ( table transform dim -- map ) + perlin-noise-map normalize-0-1 >byte-map ; + +: perlin-noise-image ( table transform dim -- image ) + [ perlin-noise-byte-map ] [ >image ] bi ; + +: uniform-noise-map ( seed dim -- map ) + [ product [ 0.0 1.0 uniform-random-float ] replicate ] + curry with-seed ; + +: uniform-noise-byte-map ( seed dim -- map ) + uniform-noise-map >byte-map ; + +: uniform-noise-image ( seed dim -- image ) + [ uniform-noise-byte-map ] [ >image ] bi ; + +: normal-noise-map ( seed sigma dim -- map ) + swap '[ _ product [ 0.5 _ normal-random-float ] replicate ] + with-seed ; + +: normal-noise-byte-map ( seed sigma dim -- map ) + normal-noise-map clamp-0-1 >byte-map ; + +: normal-noise-image ( seed sigma dim -- image ) + [ normal-noise-byte-map ] [ >image ] bi ; diff --git a/extra/modules/remote-loading/authors.txt b/unmaintained/modules/remote-loading/authors.txt similarity index 100% rename from extra/modules/remote-loading/authors.txt rename to unmaintained/modules/remote-loading/authors.txt diff --git a/extra/modules/remote-loading/remote-loading.factor b/unmaintained/modules/remote-loading/remote-loading.factor similarity index 100% rename from extra/modules/remote-loading/remote-loading.factor rename to unmaintained/modules/remote-loading/remote-loading.factor diff --git a/extra/modules/remote-loading/summary.txt b/unmaintained/modules/remote-loading/summary.txt similarity index 100% rename from extra/modules/remote-loading/summary.txt rename to unmaintained/modules/remote-loading/summary.txt diff --git a/extra/modules/rpc-server/authors.txt b/unmaintained/modules/rpc-server/authors.txt similarity index 100% rename from extra/modules/rpc-server/authors.txt rename to unmaintained/modules/rpc-server/authors.txt diff --git a/extra/modules/rpc-server/rpc-server.factor b/unmaintained/modules/rpc-server/rpc-server.factor similarity index 100% rename from extra/modules/rpc-server/rpc-server.factor rename to unmaintained/modules/rpc-server/rpc-server.factor diff --git a/extra/modules/rpc-server/summary.txt b/unmaintained/modules/rpc-server/summary.txt similarity index 100% rename from extra/modules/rpc-server/summary.txt rename to unmaintained/modules/rpc-server/summary.txt diff --git a/extra/modules/rpc/authors.txt b/unmaintained/modules/rpc/authors.txt similarity index 100% rename from extra/modules/rpc/authors.txt rename to unmaintained/modules/rpc/authors.txt diff --git a/extra/modules/rpc/rpc-docs.factor b/unmaintained/modules/rpc/rpc-docs.factor similarity index 100% rename from extra/modules/rpc/rpc-docs.factor rename to unmaintained/modules/rpc/rpc-docs.factor diff --git a/extra/modules/rpc/rpc.factor b/unmaintained/modules/rpc/rpc.factor similarity index 100% rename from extra/modules/rpc/rpc.factor rename to unmaintained/modules/rpc/rpc.factor diff --git a/extra/modules/rpc/summary.txt b/unmaintained/modules/rpc/summary.txt similarity index 100% rename from extra/modules/rpc/summary.txt rename to unmaintained/modules/rpc/summary.txt diff --git a/extra/modules/uploads/authors.txt b/unmaintained/modules/uploads/authors.txt similarity index 100% rename from extra/modules/uploads/authors.txt rename to unmaintained/modules/uploads/authors.txt diff --git a/extra/modules/uploads/summary.txt b/unmaintained/modules/uploads/summary.txt similarity index 100% rename from extra/modules/uploads/summary.txt rename to unmaintained/modules/uploads/summary.txt diff --git a/extra/modules/uploads/uploads.factor b/unmaintained/modules/uploads/uploads.factor similarity index 100% rename from extra/modules/uploads/uploads.factor rename to unmaintained/modules/uploads/uploads.factor diff --git a/extra/modules/using/authors.txt b/unmaintained/modules/using/authors.txt similarity index 100% rename from extra/modules/using/authors.txt rename to unmaintained/modules/using/authors.txt diff --git a/extra/modules/using/summary.txt b/unmaintained/modules/using/summary.txt similarity index 100% rename from extra/modules/using/summary.txt rename to unmaintained/modules/using/summary.txt diff --git a/extra/modules/using/tests/tags.txt b/unmaintained/modules/using/tests/tags.txt similarity index 100% rename from extra/modules/using/tests/tags.txt rename to unmaintained/modules/using/tests/tags.txt diff --git a/extra/modules/using/tests/test-server.factor b/unmaintained/modules/using/tests/test-server.factor similarity index 100% rename from extra/modules/using/tests/test-server.factor rename to unmaintained/modules/using/tests/test-server.factor diff --git a/extra/modules/using/tests/tests.factor b/unmaintained/modules/using/tests/tests.factor similarity index 100% rename from extra/modules/using/tests/tests.factor rename to unmaintained/modules/using/tests/tests.factor diff --git a/extra/modules/using/using-docs.factor b/unmaintained/modules/using/using-docs.factor similarity index 100% rename from extra/modules/using/using-docs.factor rename to unmaintained/modules/using/using-docs.factor diff --git a/extra/modules/using/using.factor b/unmaintained/modules/using/using.factor similarity index 100% rename from extra/modules/using/using.factor rename to unmaintained/modules/using/using.factor diff --git a/vm/Config.windows b/vm/Config.windows index cdb72f4e24..b0b1352cb2 100644 --- a/vm/Config.windows +++ b/vm/Config.windows @@ -6,5 +6,5 @@ EXE_EXTENSION=.exe CONSOLE_EXTENSION=.com DLL_EXTENSION=.dll SHARED_DLL_EXTENSION=.dll -LINKER = $(CC) -shared -mno-cygwin -o +LINKER = $(CPP) -shared -mno-cygwin -o LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX) diff --git a/vm/alien.cpp b/vm/alien.cpp index 06dee31a14..49afd608ec 100755 --- a/vm/alien.cpp +++ b/vm/alien.cpp @@ -77,7 +77,7 @@ PRIMITIVE(alien_address) } /* pop ( alien n ) from datastack, return alien's address plus n */ -static void *alien_pointer(void) +static void *alien_pointer() { fixnum offset = to_fixnum(dpop()); return unbox_alien() + offset; @@ -128,7 +128,7 @@ PRIMITIVE(dlsym) gc_root name(dpop()); name.untag_check(); - vm_char *sym = (vm_char *)(name.untagged() + 1); + symbol_char *sym = name->data(); if(library.value() == F) box_alien(ffi_dlsym(NULL,sym)); @@ -182,7 +182,7 @@ VM_C_API char *alien_offset(cell obj) } /* pop an object representing a C pointer */ -VM_C_API char *unbox_alien(void) +VM_C_API char *unbox_alien() { return alien_offset(dpop()); } diff --git a/vm/alien.hpp b/vm/alien.hpp index a66135cf92..6235a2d6c7 100755 --- a/vm/alien.hpp +++ b/vm/alien.hpp @@ -39,7 +39,7 @@ PRIMITIVE(dlclose); PRIMITIVE(dll_validp); VM_C_API char *alien_offset(cell object); -VM_C_API char *unbox_alien(void); +VM_C_API char *unbox_alien(); VM_C_API void box_alien(void *ptr); VM_C_API void to_value_struct(cell src, void *dest, cell size); VM_C_API void box_value_struct(void *src, cell size); diff --git a/vm/callstack.cpp b/vm/callstack.cpp index 2ad58534b5..d9ac8d6073 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -54,7 +54,7 @@ This means that if 'callstack' is called in tail position, we will have popped a necessary frame... however this word is only called by continuation implementation, and user code shouldn't be calling it at all, so we leave it as it is for now. */ -stack_frame *capture_start(void) +stack_frame *capture_start() { stack_frame *frame = stack_chain->callstack_bottom - 1; while(frame >= stack_chain->callstack_top diff --git a/vm/code_block.cpp b/vm/code_block.cpp old mode 100644 new mode 100755 index 80adb1feac..083f7f49e6 --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -8,6 +8,159 @@ void flush_icache_for(code_block *block) flush_icache((cell)block,block->size); } +static int number_of_parameters(relocation_type type) +{ + switch(type) + { + case RT_PRIMITIVE: + case RT_XT: + case RT_XT_PIC: + case RT_XT_PIC_TAIL: + case RT_IMMEDIATE: + case RT_HERE: + case RT_UNTAGGED: + return 1; + case RT_DLSYM: + return 2; + case RT_THIS: + case RT_STACK_CHAIN: + case RT_MEGAMORPHIC_CACHE_HITS: + return 0; + default: + critical_error("Bad rel type",type); + return -1; /* Can't happen */ + } +} + +void *object_xt(cell obj) +{ + switch(tagged(obj).type()) + { + case WORD_TYPE: + return untag(obj)->xt; + case QUOTATION_TYPE: + return untag(obj)->xt; + default: + critical_error("Expected word or quotation",obj); + return NULL; + } +} + +static void *xt_pic(word *w, cell tagged_quot) +{ + if(tagged_quot == F || max_pic_size == 0) + return w->xt; + else + { + quotation *quot = untag(tagged_quot); + if(quot->compiledp == F) + return w->xt; + else + return quot->xt; + } +} + +void *word_xt_pic(word *w) +{ + return xt_pic(w,w->pic_def); +} + +void *word_xt_pic_tail(word *w) +{ + return xt_pic(w,w->pic_tail_def); +} + +/* References to undefined symbols are patched up to call this function on +image load */ +void undefined_symbol() +{ + general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL); +} + +/* Look up an external library symbol referenced by a compiled code block */ +void *get_rel_symbol(array *literals, cell index) +{ + cell symbol = array_nth(literals,index); + cell library = array_nth(literals,index + 1); + + dll *d = (library == F ? NULL : untag(library)); + + if(d != NULL && !d->dll) + return (void *)undefined_symbol; + + switch(tagged(symbol).type()) + { + case BYTE_ARRAY_TYPE: + { + symbol_char *name = alien_offset(symbol); + void *sym = ffi_dlsym(d,name); + + if(sym) + return sym; + else + { + return (void *)undefined_symbol; + } + } + case ARRAY_TYPE: + { + cell i; + array *names = untag(symbol); + for(i = 0; i < array_capacity(names); i++) + { + symbol_char *name = alien_offset(array_nth(names,i)); + void *sym = ffi_dlsym(d,name); + + if(sym) + return sym; + } + return (void *)undefined_symbol; + } + default: + critical_error("Bad symbol specifier",symbol); + return (void *)undefined_symbol; + } +} + +cell compute_relocation(relocation_entry rel, cell index, code_block *compiled) +{ + array *literals = untag(compiled->literals); + cell offset = REL_OFFSET(rel) + (cell)compiled->xt(); + +#define ARG array_nth(literals,index) + + switch(REL_TYPE(rel)) + { + case RT_PRIMITIVE: + return (cell)primitives[untag_fixnum(ARG)]; + case RT_DLSYM: + return (cell)get_rel_symbol(literals,index); + case RT_IMMEDIATE: + return ARG; + case RT_XT: + return (cell)object_xt(ARG); + case RT_XT_PIC: + return (cell)word_xt_pic(untag(ARG)); + case RT_XT_PIC_TAIL: + return (cell)word_xt_pic_tail(untag(ARG)); + case RT_HERE: + return offset + (short)untag_fixnum(ARG); + case RT_THIS: + return (cell)(compiled + 1); + case RT_STACK_CHAIN: + return (cell)&stack_chain; + case RT_UNTAGGED: + return untag_fixnum(ARG); + case RT_MEGAMORPHIC_CACHE_HITS: + return (cell)&megamorphic_cache_hits; + default: + critical_error("Bad rel type",rel); + return 0; /* Can't happen */ + } + +#undef ARG +} + void iterate_relocations(code_block *compiled, relocation_iterator iter) { if(compiled->relocation != F) @@ -20,29 +173,8 @@ void iterate_relocations(code_block *compiled, relocation_iterator iter) for(cell i = 0; i < length; i++) { relocation_entry rel = relocation->data()[i]; - iter(rel,index,compiled); - - switch(REL_TYPE(rel)) - { - case RT_PRIMITIVE: - case RT_XT: - case RT_XT_DIRECT: - case RT_IMMEDIATE: - case RT_HERE: - case RT_UNTAGGED: - index++; - break; - case RT_DLSYM: - index += 2; - break; - case RT_THIS: - case RT_STACK_CHAIN: - break; - default: - critical_error("Bad rel type",rel); - return; /* Can't happen */ - } + index += number_of_parameters(REL_TYPE(rel)); } } } @@ -84,6 +216,9 @@ void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value) case RC_ABSOLUTE_PPC_2_2: store_address_2_2((cell *)offset,absolute_value); break; + case RC_ABSOLUTE_PPC_2: + store_address_masked((cell *)offset,absolute_value,REL_ABSOLUTE_PPC_2_MASK,0); + break; case RC_RELATIVE_PPC_2: store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_2_MASK,0); break; @@ -154,52 +289,24 @@ void copy_literal_references(code_block *compiled) } } -void *object_xt(cell obj) +/* Compute an address to store at a relocation */ +void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled) { - switch(tagged(obj).type()) - { - case WORD_TYPE: - return untag(obj)->xt; - case QUOTATION_TYPE: - return untag(obj)->xt; - default: - critical_error("Expected word or quotation",obj); - return NULL; - } -} +#ifdef FACTOR_DEBUG + tagged(compiled->literals).untag_check(); + tagged(compiled->relocation).untag_check(); +#endif -void *word_direct_xt(word *w) -{ - cell tagged_quot = w->direct_entry_def; - if(tagged_quot == F || max_pic_size == 0) - return w->xt; - else - { - quotation *quot = untag(tagged_quot); - if(quot->compiledp == F) - return w->xt; - else - return quot->xt; - } + store_address_in_code_block(REL_CLASS(rel), + REL_OFFSET(rel) + (cell)compiled->xt(), + compute_relocation(rel,index,compiled)); } void update_word_references_step(relocation_entry rel, cell index, code_block *compiled) { relocation_type type = REL_TYPE(rel); - if(type == RT_XT || type == RT_XT_DIRECT) - { - cell offset = REL_OFFSET(rel) + (cell)(compiled + 1); - array *literals = untag(compiled->literals); - cell obj = array_nth(literals,index); - - void *xt; - if(type == RT_XT) - xt = object_xt(obj); - else - xt = word_direct_xt(untag(obj)); - - store_address_in_code_block(REL_CLASS(rel),offset,(cell)xt); - } + if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL) + relocate_code_block_step(rel,index,compiled); } /* Relocate new code blocks completely; updating references to literals, @@ -300,108 +407,6 @@ void mark_object_code_block(object *object) } } -/* References to undefined symbols are patched up to call this function on -image load */ -void undefined_symbol(void) -{ - general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL); -} - -/* Look up an external library symbol referenced by a compiled code block */ -void *get_rel_symbol(array *literals, cell index) -{ - cell symbol = array_nth(literals,index); - cell library = array_nth(literals,index + 1); - - dll *d = (library == F ? NULL : untag(library)); - - if(d != NULL && !d->dll) - return (void *)undefined_symbol; - - switch(tagged(symbol).type()) - { - case BYTE_ARRAY_TYPE: - { - symbol_char *name = alien_offset(symbol); - void *sym = ffi_dlsym(d,name); - - if(sym) - return sym; - else - { - printf("%s\n",name); - return (void *)undefined_symbol; - } - } - case ARRAY_TYPE: - { - cell i; - array *names = untag(symbol); - for(i = 0; i < array_capacity(names); i++) - { - symbol_char *name = alien_offset(array_nth(names,i)); - void *sym = ffi_dlsym(d,name); - - if(sym) - return sym; - } - return (void *)undefined_symbol; - } - default: - critical_error("Bad symbol specifier",symbol); - return (void *)undefined_symbol; - } -} - -/* Compute an address to store at a relocation */ -void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled) -{ -#ifdef FACTOR_DEBUG - tagged(compiled->literals).untag_check(); - tagged(compiled->relocation).untag_check(); -#endif - - cell offset = REL_OFFSET(rel) + (cell)(compiled + 1); - array *literals = untag(compiled->literals); - fixnum absolute_value; - - switch(REL_TYPE(rel)) - { - case RT_PRIMITIVE: - absolute_value = (cell)primitives[untag_fixnum(array_nth(literals,index))]; - break; - case RT_DLSYM: - absolute_value = (cell)get_rel_symbol(literals,index); - break; - case RT_IMMEDIATE: - absolute_value = array_nth(literals,index); - break; - case RT_XT: - absolute_value = (cell)object_xt(array_nth(literals,index)); - break; - case RT_XT_DIRECT: - absolute_value = (cell)word_direct_xt(untag(array_nth(literals,index))); - break; - case RT_HERE: - absolute_value = offset + (short)untag_fixnum(array_nth(literals,index)); - break; - case RT_THIS: - absolute_value = (cell)(compiled + 1); - break; - case RT_STACK_CHAIN: - absolute_value = (cell)&stack_chain; - break; - case RT_UNTAGGED: - absolute_value = untag_fixnum(array_nth(literals,index)); - break; - default: - critical_error("Bad rel type",rel); - return; /* Can't happen */ - } - - store_address_in_code_block(REL_CLASS(rel),offset,absolute_value); -} - /* Perform all fixups on a code block */ void relocate_code_block(code_block *compiled) { diff --git a/vm/code_block.hpp b/vm/code_block.hpp index 9689ea5419..fef5b15da4 100644 --- a/vm/code_block.hpp +++ b/vm/code_block.hpp @@ -8,10 +8,12 @@ enum relocation_type { RT_DLSYM, /* a pointer to a compiled word reference */ RT_DISPATCH, - /* a word's general entry point XT */ + /* a word or quotation's general entry point */ RT_XT, - /* a word's direct entry point XT */ - RT_XT_DIRECT, + /* a word's PIC entry point */ + RT_XT_PIC, + /* a word's tail-call PIC entry point */ + RT_XT_PIC_TAIL, /* current offset */ RT_HERE, /* current code block */ @@ -22,6 +24,8 @@ enum relocation_type { RT_STACK_CHAIN, /* untagged fixnum literal */ RT_UNTAGGED, + /* address of megamorphic_cache_hits var */ + RT_MEGAMORPHIC_CACHE_HITS, }; enum relocation_class { @@ -31,8 +35,10 @@ enum relocation_class { RC_ABSOLUTE, /* relative address in a 32-bit location */ RC_RELATIVE, - /* relative address in a PowerPC LIS/ORI sequence */ + /* absolute address in a PowerPC LIS/ORI sequence */ RC_ABSOLUTE_PPC_2_2, + /* absolute address in a PowerPC LWZ instruction */ + RC_ABSOLUTE_PPC_2, /* relative address in a PowerPC LWZ/STW/BC instruction */ RC_RELATIVE_PPC_2, /* relative address in a PowerPC B/BL instruction */ @@ -45,6 +51,7 @@ enum relocation_class { RC_INDIRECT_ARM_PC }; +#define REL_ABSOLUTE_PPC_2_MASK 0xffff #define REL_RELATIVE_PPC_2_MASK 0xfffc #define REL_RELATIVE_PPC_3_MASK 0x3fffffc #define REL_INDIRECT_ARM_MASK 0xfff @@ -82,7 +89,7 @@ void mark_object_code_block(object *scan); void relocate_code_block(code_block *relocating); -inline static bool stack_traces_p(void) +inline static bool stack_traces_p() { return userenv[STACK_TRACES_ENV] != F; } diff --git a/vm/code_gc.cpp b/vm/code_gc.cpp index 721c3f3a7a..48cf8f7661 100755 --- a/vm/code_gc.cpp +++ b/vm/code_gc.cpp @@ -303,7 +303,7 @@ cell heap_size(heap *heap) } /* Compute where each block is going to go, after compaction */ - cell compute_heap_forwarding(heap *heap, std::tr1::unordered_map &forwarding) +cell compute_heap_forwarding(heap *heap, unordered_map &forwarding) { heap_block *scan = first_block(heap); char *address = (char *)first_block(heap); @@ -324,7 +324,7 @@ cell heap_size(heap *heap) return (cell)address - heap->seg->start; } - void compact_heap(heap *heap, std::tr1::unordered_map &forwarding) +void compact_heap(heap *heap, unordered_map &forwarding) { heap_block *scan = first_block(heap); diff --git a/vm/code_gc.hpp b/vm/code_gc.hpp index 1ad68f46fd..ebd6349ab9 100755 --- a/vm/code_gc.hpp +++ b/vm/code_gc.hpp @@ -25,8 +25,8 @@ void unmark_marked(heap *heap); void free_unmarked(heap *heap, heap_iterator iter); void heap_usage(heap *h, cell *used, cell *total_free, cell *max_free); cell heap_size(heap *h); -cell compute_heap_forwarding(heap *h, std::tr1::unordered_map &forwarding); -void compact_heap(heap *h, std::tr1::unordered_map &forwarding); +cell compute_heap_forwarding(heap *h, unordered_map &forwarding); +void compact_heap(heap *h, unordered_map &forwarding); inline static heap_block *next_block(heap *h, heap_block *block) { diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index 2342a3dd09..c8c7639930 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -26,8 +26,8 @@ void jit_compile_word(cell word_, cell def_, bool relocate) word->code = def->code; - if(word->direct_entry_def != F) - jit_compile(word->direct_entry_def,relocate); + if(word->pic_def != F) jit_compile(word->pic_def,relocate); + if(word->pic_tail_def != F) jit_compile(word->pic_tail_def,relocate); } /* Apply a function to every code block */ @@ -45,14 +45,14 @@ void iterate_code_heap(code_heap_iterator iter) /* Copy literals referenced from all code blocks to newspace. Only for aging and nursery collections */ -void copy_code_heap_roots(void) +void copy_code_heap_roots() { iterate_code_heap(copy_literal_references); } /* Update pointers to words referenced from all code blocks. Only after defining a new word. */ -void update_code_heap_words(void) +void update_code_heap_words() { iterate_code_heap(update_word_references); } @@ -119,7 +119,7 @@ PRIMITIVE(code_room) dpush(tag_fixnum(max_free / 1024)); } -static std::tr1::unordered_map forwarding; +static unordered_map forwarding; code_block *forward_xt(code_block *compiled) { @@ -178,7 +178,7 @@ void forward_object_xts() } /* Set the XT fields now that the heap has been compacted */ -void fixup_object_xts(void) +void fixup_object_xts() { begin_scan(); @@ -211,7 +211,7 @@ void fixup_object_xts(void) since it makes several passes over the code and data heaps, but we only ever do this before saving a deployed image and exiting, so performaance is not critical here */ -void compact_code_heap(void) +void compact_code_heap() { /* Free all unreachable code blocks */ gc(); diff --git a/vm/code_heap.hpp b/vm/code_heap.hpp index 056a6a88c6..6f139a4728 100755 --- a/vm/code_heap.hpp +++ b/vm/code_heap.hpp @@ -14,13 +14,13 @@ typedef void (*code_heap_iterator)(code_block *compiled); void iterate_code_heap(code_heap_iterator iter); -void copy_code_heap_roots(void); +void copy_code_heap_roots(); PRIMITIVE(modify_code_heap); PRIMITIVE(code_room); -void compact_code_heap(void); +void compact_code_heap(); inline static void check_code_pointer(cell ptr) { diff --git a/vm/contexts.cpp b/vm/contexts.cpp index 66570abc31..239b70876a 100644 --- a/vm/contexts.cpp +++ b/vm/contexts.cpp @@ -8,19 +8,19 @@ namespace factor cell ds_size, rs_size; context *unused_contexts; -void reset_datastack(void) +void reset_datastack() { ds = ds_bot - sizeof(cell); } -void reset_retainstack(void) +void reset_retainstack() { rs = rs_bot - sizeof(cell); } #define RESERVED (64 * sizeof(cell)) -void fix_stacks(void) +void fix_stacks() { if(ds + sizeof(cell) < ds_bot || ds + RESERVED >= ds_top) reset_datastack(); if(rs + sizeof(cell) < rs_bot || rs + RESERVED >= rs_top) reset_retainstack(); @@ -28,7 +28,7 @@ void fix_stacks(void) /* called before entry into foreign C code. Note that ds and rs might be stored in registers, so callbacks must save and restore the correct values */ -void save_stacks(void) +void save_stacks() { if(stack_chain) { @@ -37,7 +37,7 @@ void save_stacks(void) } } -context *alloc_context(void) +context *alloc_context() { context *new_context; @@ -63,7 +63,7 @@ void dealloc_context(context *old_context) } /* called on entry into a compiled callback */ -void nest_stacks(void) +void nest_stacks() { context *new_context = alloc_context(); @@ -95,7 +95,7 @@ void nest_stacks(void) } /* called when leaving a compiled callback */ -void unnest_stacks(void) +void unnest_stacks() { ds = stack_chain->datastack_save; rs = stack_chain->retainstack_save; diff --git a/vm/contexts.hpp b/vm/contexts.hpp index 13af17f2f0..4a6f401f0b 100644 --- a/vm/contexts.hpp +++ b/vm/contexts.hpp @@ -46,9 +46,9 @@ extern cell ds_size, rs_size; DEFPUSHPOP(d,ds) DEFPUSHPOP(r,rs) -void reset_datastack(void); -void reset_retainstack(void); -void fix_stacks(void); +void reset_datastack(); +void reset_retainstack(); +void fix_stacks(); void init_stacks(cell ds_size, cell rs_size); PRIMITIVE(datastack); @@ -57,9 +57,9 @@ PRIMITIVE(set_datastack); PRIMITIVE(set_retainstack); PRIMITIVE(check_datastack); -VM_C_API void save_stacks(void); -VM_C_API void nest_stacks(void); -VM_C_API void unnest_stacks(void); +VM_C_API void save_stacks(); +VM_C_API void nest_stacks(); +VM_C_API void unnest_stacks(); } diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S index 5e77c004aa..f8dad4b2b2 100755 --- a/vm/cpu-ppc.S +++ b/vm/cpu-ppc.S @@ -2,7 +2,7 @@ in the public domain. */ #include "asm.h" -#define DS_REG r29 +#define DS_REG r13 DEF(void,primitive_fixnum_add,(void)): lwz r3,0(DS_REG) @@ -45,7 +45,7 @@ multiply_overflow: /* Note that the XT is passed to the quotation in r11 */ #define CALL_OR_JUMP_QUOT \ - lwz r11,14(r3) /* load quotation-xt slot */ XX \ + lwz r11,16(r3) /* load quotation-xt slot */ XX \ #define CALL_QUOT \ CALL_OR_JUMP_QUOT XX \ @@ -100,22 +100,22 @@ the Factor compiler treats the entire register file as volatile. */ DEF(void,c_to_factor,(CELL quot)): PROLOGUE - SAVE_INT(r13,0) /* save GPRs */ - SAVE_INT(r14,1) - SAVE_INT(r15,2) - SAVE_INT(r16,3) - SAVE_INT(r17,4) - SAVE_INT(r18,5) - SAVE_INT(r19,6) - SAVE_INT(r20,7) - SAVE_INT(r21,8) - SAVE_INT(r22,9) - SAVE_INT(r23,10) - SAVE_INT(r24,11) - SAVE_INT(r25,12) - SAVE_INT(r26,13) - SAVE_INT(r27,14) - SAVE_INT(r28,15) + SAVE_INT(r15,0) /* save GPRs */ + SAVE_INT(r16,1) + SAVE_INT(r17,2) + SAVE_INT(r18,3) + SAVE_INT(r19,4) + SAVE_INT(r20,5) + SAVE_INT(r21,6) + SAVE_INT(r22,7) + SAVE_INT(r23,8) + SAVE_INT(r24,9) + SAVE_INT(r25,10) + SAVE_INT(r26,11) + SAVE_INT(r27,12) + SAVE_INT(r28,13) + SAVE_INT(r29,14) + SAVE_INT(r30,15) SAVE_INT(r31,16) SAVE_FP(f14,20) /* save FPRs */ @@ -165,22 +165,22 @@ DEF(void,c_to_factor,(CELL quot)): RESTORE_FP(f14,20) /* save FPRs */ RESTORE_INT(r31,16) /* restore GPRs */ - RESTORE_INT(r28,15) - RESTORE_INT(r27,14) - RESTORE_INT(r26,13) - RESTORE_INT(r25,12) - RESTORE_INT(r24,11) - RESTORE_INT(r23,10) - RESTORE_INT(r22,9) - RESTORE_INT(r21,8) - RESTORE_INT(r20,7) - RESTORE_INT(r19,6) - RESTORE_INT(r18,5) - RESTORE_INT(r17,4) - RESTORE_INT(r16,3) - RESTORE_INT(r15,2) - RESTORE_INT(r14,1) - RESTORE_INT(r13,0) + RESTORE_INT(r30,15) + RESTORE_INT(r29,14) + RESTORE_INT(r28,13) + RESTORE_INT(r27,12) + RESTORE_INT(r26,11) + RESTORE_INT(r25,10) + RESTORE_INT(r24,9) + RESTORE_INT(r23,8) + RESTORE_INT(r22,7) + RESTORE_INT(r21,6) + RESTORE_INT(r20,5) + RESTORE_INT(r19,4) + RESTORE_INT(r18,3) + RESTORE_INT(r17,2) + RESTORE_INT(r16,1) + RESTORE_INT(r15,0) EPILOGUE blr @@ -234,3 +234,11 @@ DEF(void,flush_icache,(void *start, int len)): sync /* finish up */ isync blr + +DEF(void,primitive_inline_cache_miss,(void)): + mflr r3 + PROLOGUE + bl MANGLE(inline_cache_miss) + EPILOGUE + mtctr r3 + bctr diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp index 7e8ae05fac..d393223d8d 100755 --- a/vm/cpu-ppc.hpp +++ b/vm/cpu-ppc.hpp @@ -2,16 +2,58 @@ namespace factor { #define FACTOR_CPU_STRING "ppc" -#define VM_ASM_API +#define VM_ASM_API VM_C_API -register cell ds asm("r29"); -register cell rs asm("r30"); +register cell ds asm("r13"); +register cell rs asm("r14"); -void c_to_factor(cell quot); -void undefined(cell word); -void set_callstack(stack_frame *to, stack_frame *from, cell length, void *memcpy); -void throw_impl(cell quot, stack_frame *rewind); -void lazy_jit_compile(cell quot); -void flush_icache(cell start, cell len); +inline static void check_call_site(cell return_address) +{ +#ifdef FACTOR_DEBUG + cell insn = *(cell *)return_address; + assert((insn & 0x3) == 0x1); + assert((insn >> 26) == 0x12); +#endif +} + +#define B_MASK 0x3fffffc + +inline static void *get_call_target(cell return_address) +{ + return_address -= sizeof(cell); + + check_call_site(return_address); + cell insn = *(cell *)return_address; + cell unsigned_addr = (insn & B_MASK); + fixnum signed_addr = (fixnum)(unsigned_addr << 6) >> 6; + return (void *)(signed_addr + return_address); +} + +inline static void set_call_target(cell return_address, void *target) +{ + return_address -= sizeof(cell); + +#ifdef FACTOR_DEBUG + assert((return_address & ~B_MASK) == 0); + check_call_site(return_address); +#endif + cell insn = *(cell *)return_address; + insn = ((insn & ~B_MASK) | (((cell)target - return_address) & B_MASK)); + *(cell *)return_address = insn; + + /* Flush the cache line containing the call we just patched */ + __asm__ __volatile__ ("icbi 0, %0\n" "sync\n"::"r" (return_address):); +} + +/* Defined in assembly */ +VM_ASM_API void c_to_factor(cell quot); +VM_ASM_API void throw_impl(cell quot, stack_frame *rewind); +VM_ASM_API void lazy_jit_compile(cell quot); +VM_ASM_API void flush_icache(cell start, cell len); + +VM_ASM_API void set_callstack(stack_frame *to, + stack_frame *from, + cell length, + void *(*memcpy)(void*,const void*, size_t)); } diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index 3c0db36935..ff45f48066 100755 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -1,9 +1,5 @@ #include "asm.h" -/* Note that primitive word definitions are compiled with -__attribute__((regparm 2), so the pointer to the word object is passed in EAX, -and the callstack top is passed in EDX */ - #define ARG0 %eax #define ARG1 %edx #define STACK_REG %esp @@ -30,7 +26,6 @@ and the callstack top is passed in EDX */ pop %ebx #define QUOT_XT_OFFSET 16 -#define WORD_XT_OFFSET 30 /* We pass a function pointer to memcpy to work around a Mac OS X ABI limitation which would otherwise require us to do a bizzaro PC-relative @@ -60,10 +55,11 @@ DEF(bool,check_sse2,(void)): mov %edx,%eax ret -DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)): - mov (%esp),%eax +DEF(void,primitive_inline_cache_miss,(void)): + mov (%esp),%ebx +DEF(void,primitive_inline_cache_miss_tail,(void)): sub $8,%esp - push %eax + push %ebx call MANGLE(inline_cache_miss) add $12,%esp jmp *%eax diff --git a/vm/cpu-x86.32.hpp b/vm/cpu-x86.32.hpp index 6b6328aa4f..902b33b0b4 100755 --- a/vm/cpu-x86.32.hpp +++ b/vm/cpu-x86.32.hpp @@ -6,6 +6,6 @@ namespace factor register cell ds asm("esi"); register cell rs asm("edi"); -#define VM_ASM_API extern "C" __attribute__ ((regparm (2))) +#define VM_ASM_API VM_C_API __attribute__ ((regparm (2))) } diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index a110bf1d51..6b2faa1c0b 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -62,7 +62,6 @@ #endif #define QUOT_XT_OFFSET 36 -#define WORD_XT_OFFSET 66 /* We pass a function pointer to memcpy to work around a Mac OS X ABI limitation which would otherwise require us to do a bizzaro PC-relative @@ -73,9 +72,11 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi call *ARG3 /* call memcpy */ ret /* return _with new stack_ */ -DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)): - mov (%rsp),ARG0 +DEF(void,primitive_inline_cache_miss,(void)): + mov (%rsp),%rbx +DEF(void,primitive_inline_cache_miss_tail,(void)): sub $STACK_PADDING,%rsp + mov %rbx,ARG0 call MANGLE(inline_cache_miss) add $STACK_PADDING,%rsp jmp *%rax diff --git a/vm/cpu-x86.64.hpp b/vm/cpu-x86.64.hpp old mode 100644 new mode 100755 index be71a78aa8..679c301548 --- a/vm/cpu-x86.64.hpp +++ b/vm/cpu-x86.64.hpp @@ -6,6 +6,6 @@ namespace factor register cell ds asm("r14"); register cell rs asm("r15"); -#define VM_ASM_API extern "C" +#define VM_ASM_API VM_C_API } diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp index c0b4651811..e5852f9ad9 100755 --- a/vm/cpu-x86.hpp +++ b/vm/cpu-x86.hpp @@ -7,15 +7,29 @@ namespace factor inline static void flush_icache(cell start, cell len) {} +/* In the instruction sequence: + + MOV EBX,... + JMP blah + + the offset from the immediate operand to MOV to the instruction after + the jump is a cell for the immediate operand, 4 bytes for the JMP + destination, and one byte for the JMP opcode. */ +static const fixnum xt_tail_pic_offset = sizeof(cell) + 4 + 1; + +static const unsigned char call_opcode = 0xe8; +static const unsigned char jmp_opcode = 0xe9; + +inline static unsigned char call_site_opcode(cell return_address) +{ + return *(unsigned char *)(return_address - 5); +} + inline static void check_call_site(cell return_address) { - /* An x86 CALL instruction looks like so: - |e8|..|..|..|..| - where the ... are a PC-relative jump address. - The return_address points to right after the - instruction. */ #ifdef FACTOR_DEBUG - assert(*(unsigned char *)(return_address - 5) == 0xe8); + unsigned char opcode = call_site_opcode(return_address); + assert(opcode == call_opcode || opcode == jmp_opcode); #endif } @@ -31,6 +45,11 @@ inline static void set_call_target(cell return_address, void *target) *(int *)(return_address - 4) = ((cell)target - return_address); } +inline static bool tail_call_site_p(cell return_address) +{ + return call_site_opcode(return_address) == jmp_opcode; +} + /* Defined in assembly */ VM_ASM_API void c_to_factor(cell quot); VM_ASM_API void throw_impl(cell quot, stack_frame *rewind_to); diff --git a/vm/data_gc.cpp b/vm/data_gc.cpp index e26edc9721..c9dbe9a953 100755 --- a/vm/data_gc.cpp +++ b/vm/data_gc.cpp @@ -33,7 +33,7 @@ cell last_code_heap_scan; bool growing_data_heap; data_heap *old_data_heap; -void init_data_gc(void) +void init_data_gc() { performing_gc = false; last_code_heap_scan = NURSERY; @@ -244,7 +244,7 @@ static void copy_gen_cards(cell gen) /* Scan cards in all generations older than the one being collected, copying old->new references */ -static void copy_cards(void) +static void copy_cards() { u64 start = current_micros(); @@ -264,7 +264,7 @@ static void copy_stack_elements(segment *region, cell top) copy_handle((cell*)ptr); } -static void copy_registered_locals(void) +static void copy_registered_locals() { cell scan = gc_locals_region->start; @@ -272,7 +272,7 @@ static void copy_registered_locals(void) copy_handle(*(cell **)scan); } -static void copy_registered_bignums(void) +static void copy_registered_bignums() { cell scan = gc_bignums_region->start; @@ -295,7 +295,7 @@ static void copy_registered_bignums(void) /* Copy roots over at the start of GC, namely various constants, stacks, the user environment and extra roots registered by local_roots.hpp */ -static void copy_roots(void) +static void copy_roots() { copy_handle(&T); copy_handle(&bignum_zero); @@ -593,7 +593,7 @@ void garbage_collection(cell gen, performing_gc = false; } -void gc(void) +void gc() { garbage_collection(TENURED,false,0); } @@ -633,7 +633,7 @@ PRIMITIVE(gc_stats) dpush(result.elements.value()); } -void clear_gc_stats(void) +void clear_gc_stats() { int i; for(i = 0; i < MAX_GEN_COUNT; i++) @@ -681,7 +681,7 @@ PRIMITIVE(become) compile_all_words(); } -VM_C_API void minor_gc(void) +VM_C_API void minor_gc() { garbage_collection(NURSERY,false,0); } diff --git a/vm/data_gc.hpp b/vm/data_gc.hpp index 2869179394..01bff2ef68 100755 --- a/vm/data_gc.hpp +++ b/vm/data_gc.hpp @@ -18,11 +18,11 @@ extern bool collecting_aging_again; extern cell last_code_heap_scan; -void init_data_gc(void); +void init_data_gc(); -void gc(void); +void gc(); -inline static bool collecting_accumulation_gen_p(void) +inline static bool collecting_accumulation_gen_p() { return ((HAVE_AGING_P && collecting_gen == AGING @@ -114,7 +114,7 @@ void copy_reachable_objects(cell scan, cell *end); PRIMITIVE(gc); PRIMITIVE(gc_stats); -void clear_gc_stats(void); +void clear_gc_stats(); PRIMITIVE(clear_gc_stats); PRIMITIVE(become); @@ -143,6 +143,6 @@ inline static void check_tagged_pointer(cell tagged) #endif } -VM_C_API void minor_gc(void); +VM_C_API void minor_gc(); } diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp old mode 100644 new mode 100755 index d83773de9c..9c84a993c8 --- a/vm/data_heap.cpp +++ b/vm/data_heap.cpp @@ -24,7 +24,7 @@ cell init_zone(zone *z, cell size, cell start) return z->end; } -void init_card_decks(void) +void init_card_decks() { cell start = align(data->seg->start,DECK_SIZE); allot_markers_offset = (cell)data->allot_markers - (start >> CARD_BITS); @@ -241,7 +241,7 @@ cell unaligned_object_size(object *pointer) return callstack_size(untag_fixnum(((callstack *)pointer)->length)); default: critical_error("Invalid header",(cell)pointer); - return -1; /* can't happen */ + return 0; /* can't happen */ } } @@ -283,7 +283,7 @@ cell binary_payload_start(object *pointer) return sizeof(wrapper); default: critical_error("Invalid header",(cell)pointer); - return -1; /* can't happen */ + return 0; /* can't happen */ } } @@ -312,7 +312,7 @@ references to an object for debugging purposes. */ cell heap_scan_ptr; /* Disables GC and activates next-object ( -- obj ) primitive */ -void begin_scan(void) +void begin_scan() { heap_scan_ptr = data->generations[TENURED].start; gc_off = true; @@ -323,7 +323,7 @@ PRIMITIVE(begin_scan) begin_scan(); } -cell next_object(void) +cell next_object() { if(!gc_off) general_error(ERROR_HEAP_SCAN,F,F,NULL); @@ -348,7 +348,7 @@ PRIMITIVE(end_scan) gc_off = false; } -cell find_all_words(void) +cell find_all_words() { growable_array words; diff --git a/vm/data_heap.hpp b/vm/data_heap.hpp index bb8b35341e..bec86a2d0d 100644 --- a/vm/data_heap.hpp +++ b/vm/data_heap.hpp @@ -56,7 +56,7 @@ inline static bool in_zone(zone *z, object *pointer) cell init_zone(zone *z, cell size, cell base); -void init_card_decks(void); +void init_card_decks(); data_heap *grow_data_heap(data_heap *data, cell requested_bytes); @@ -86,8 +86,8 @@ cell unaligned_object_size(object *pointer); cell binary_payload_start(object *pointer); cell object_size(cell tagged); -void begin_scan(void); -cell next_object(void); +void begin_scan(); +cell next_object(); PRIMITIVE(data_room); PRIMITIVE(size); @@ -99,7 +99,7 @@ PRIMITIVE(end_scan); /* GC is off during heap walking */ extern bool gc_off; -cell find_all_words(void); +cell find_all_words(); /* Every object has a regular representation in the runtime, which makes GC much simpler. Every slot of the object until binary_payload_start is a pointer diff --git a/vm/debug.cpp b/vm/debug.cpp index 3cd05711ad..49fdd92541 100755 --- a/vm/debug.cpp +++ b/vm/debug.cpp @@ -155,13 +155,13 @@ void print_objects(cell *start, cell *end) } } -void print_datastack(void) +void print_datastack() { print_string("==== DATA STACK:\n"); print_objects((cell *)ds_bot,(cell *)ds); } -void print_retainstack(void) +void print_retainstack() { print_string("==== RETAIN STACK:\n"); print_objects((cell *)rs_bot,(cell *)rs); @@ -179,7 +179,7 @@ void print_stack_frame(stack_frame *frame) print_string("\n"); } -void print_callstack(void) +void print_callstack() { print_string("==== CALL STACK:\n"); cell bottom = (cell)stack_chain->callstack_bottom; @@ -210,7 +210,7 @@ void dump_zone(zone *z) print_string(", here="); print_cell(z->here - z->start); nl(); } -void dump_generations(void) +void dump_generations() { cell i; @@ -285,7 +285,7 @@ void find_data_references(cell look_for_) } /* Dump all code blocks for debugging */ -void dump_code_heap(void) +void dump_code_heap() { cell reloc_size = 0, literal_size = 0; @@ -325,7 +325,7 @@ void dump_code_heap(void) print_cell(literal_size); print_string(" bytes of literal data\n"); } -void factorbug(void) +void factorbug() { if(fep_disabled) { diff --git a/vm/debug.hpp b/vm/debug.hpp index 81874bf2ac..cb84c9256c 100755 --- a/vm/debug.hpp +++ b/vm/debug.hpp @@ -3,8 +3,8 @@ namespace factor void print_obj(cell obj); void print_nested_obj(cell obj, fixnum nesting); -void dump_generations(void); -void factorbug(void); +void dump_generations(); +void factorbug(); void dump_zone(zone *z); PRIMITIVE(die); diff --git a/vm/dispatch.cpp b/vm/dispatch.cpp old mode 100644 new mode 100755 index bbcf20c57b..847a19d738 --- a/vm/dispatch.cpp +++ b/vm/dispatch.cpp @@ -103,7 +103,7 @@ static cell lookup_hairy_method(cell obj, cell methods) break; default: critical_error("Bad methods array",methods); - return -1; + return 0; } } } diff --git a/vm/dispatch.hpp b/vm/dispatch.hpp index f5648c7ebe..75368191a7 100644 --- a/vm/dispatch.hpp +++ b/vm/dispatch.hpp @@ -1,6 +1,9 @@ namespace factor { +extern cell megamorphic_cache_hits; +extern cell megamorphic_cache_misses; + cell lookup_method(cell object, cell methods); PRIMITIVE(lookup_method); diff --git a/vm/errors.cpp b/vm/errors.cpp index f2ba355293..610482f576 100755 --- a/vm/errors.cpp +++ b/vm/errors.cpp @@ -9,7 +9,7 @@ cell signal_number; cell signal_fault_addr; stack_frame *signal_callstack_top; -void out_of_memory(void) +void out_of_memory() { print_string("Out of memory\n\n"); dump_generations(); @@ -88,7 +88,7 @@ void type_error(cell type, cell tagged) general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL); } -void not_implemented_error(void) +void not_implemented_error() { general_error(ERROR_NOT_IMPLEMENTED,F,F,NULL); } @@ -125,7 +125,7 @@ void signal_error(int signal, stack_frame *native_stack) general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack); } -void divide_by_zero_error(void) +void divide_by_zero_error() { general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL); } @@ -141,12 +141,12 @@ PRIMITIVE(unimplemented) not_implemented_error(); } -void memory_signal_handler_impl(void) +void memory_signal_handler_impl() { memory_protection_error(signal_fault_addr,signal_callstack_top); } -void misc_signal_handler_impl(void) +void misc_signal_handler_impl() { signal_error(signal_number,signal_callstack_top); } diff --git a/vm/errors.hpp b/vm/errors.hpp index e5968468a5..11180508e5 100755 --- a/vm/errors.hpp +++ b/vm/errors.hpp @@ -22,7 +22,7 @@ enum vm_error_type ERROR_MEMORY, }; -void out_of_memory(void); +void out_of_memory(); void fatal_error(const char* msg, cell tagged); void critical_error(const char* msg, cell tagged); @@ -30,11 +30,11 @@ PRIMITIVE(die); void throw_error(cell error, stack_frame *native_stack); void general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *native_stack); -void divide_by_zero_error(void); +void divide_by_zero_error(); void memory_protection_error(cell addr, stack_frame *native_stack); void signal_error(int signal, stack_frame *native_stack); void type_error(cell type, cell tagged); -void not_implemented_error(void); +void not_implemented_error(); PRIMITIVE(call_clear); PRIMITIVE(unimplemented); @@ -45,7 +45,7 @@ extern cell signal_number; extern cell signal_fault_addr; extern stack_frame *signal_callstack_top; -void memory_signal_handler_impl(void); -void misc_signal_handler_impl(void); +void memory_signal_handler_impl(); +void misc_signal_handler_impl(); } diff --git a/vm/factor.cpp b/vm/factor.cpp index f8f7901304..33d8b73dfe 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -81,7 +81,7 @@ VM_C_API void init_parameters_from_args(vm_parameters *p, int argc, vm_char **ar } /* Do some initialization that we do once only */ -static void do_stage1_init(void) +static void do_stage1_init() { print_string("*** Stage 2 early init... "); fflush(stdout); @@ -198,9 +198,9 @@ VM_C_API void factor_eval_free(char *result) free(result); } -VM_C_API void factor_yield(void) +VM_C_API void factor_yield() { - void (*callback)(void) = (void (*)(void))alien_offset(userenv[YIELD_CALLBACK_ENV]); + void (*callback)() = (void (*)())alien_offset(userenv[YIELD_CALLBACK_ENV]); callback(); } diff --git a/vm/factor.hpp b/vm/factor.hpp index e9ba920e9f..6e00bc012e 100644 --- a/vm/factor.hpp +++ b/vm/factor.hpp @@ -10,7 +10,7 @@ VM_C_API void start_standalone_factor(int argc, vm_char **argv); VM_C_API char *factor_eval_string(char *string); VM_C_API void factor_eval_free(char *result); -VM_C_API void factor_yield(void); +VM_C_API void factor_yield(); VM_C_API void factor_sleep(long ms); } diff --git a/vm/ffi_test.c b/vm/ffi_test.c index 680b144140..d45ceb4514 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -319,3 +319,8 @@ _Complex float ffi_test_47(_Complex float x, _Complex double y) { return x + 2 * y; } + +short ffi_test_48(struct bool_field_test x) +{ + return x.parents; +} diff --git a/vm/ffi_test.h b/vm/ffi_test.h index 835f9e942f..af0c0b46a4 100755 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -1,3 +1,5 @@ +#include + #if defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32) #define F_STDCALL __attribute__((stdcall)) #else @@ -102,3 +104,11 @@ F_EXPORT _Complex float ffi_test_45(int x); F_EXPORT _Complex double ffi_test_46(int x); F_EXPORT _Complex float ffi_test_47(_Complex float x, _Complex double y); + +struct bool_field_test { + char *name; + bool on; + short parents; +}; + +F_EXPORT short ffi_test_48(struct bool_field_test x); diff --git a/vm/inline_cache.cpp b/vm/inline_cache.cpp old mode 100644 new mode 100755 index 23c4b27c47..e9e098de70 --- a/vm/inline_cache.cpp +++ b/vm/inline_cache.cpp @@ -21,6 +21,8 @@ void deallocate_inline_cache(cell return_address) { /* Find the call target. */ void *old_xt = get_call_target(return_address); + check_code_pointer((cell)old_xt); + code_block *old_block = (code_block *)old_xt - 1; cell old_type = old_block->type; @@ -70,7 +72,7 @@ static cell determine_inline_cache_type(array *cache_entries) if(!seen_hi_tag && !seen_tuple) return PIC_TAG; critical_error("Oops",0); - return -1; + return 0; } static void update_pic_count(cell type) @@ -84,7 +86,11 @@ struct inline_cache_jit : public jit { inline_cache_jit(cell generic_word_) : jit(PIC_TYPE,generic_word_) {}; void emit_check(cell klass); - void compile_inline_cache(fixnum index, cell generic_word_, cell methods_, cell cache_entries_); + void compile_inline_cache(fixnum index, + cell generic_word_, + cell methods_, + cell cache_entries_, + bool tail_call_p); }; void inline_cache_jit::emit_check(cell klass) @@ -100,7 +106,11 @@ void inline_cache_jit::emit_check(cell klass) /* index: 0 = top of stack, 1 = item underneath, etc cache_entries: array of class/method pairs */ -void inline_cache_jit::compile_inline_cache(fixnum index, cell generic_word_, cell methods_, cell cache_entries_) +void inline_cache_jit::compile_inline_cache(fixnum index, + cell generic_word_, + cell methods_, + cell cache_entries_, + bool tail_call_p) { gc_root generic_word(generic_word_); gc_root methods(methods_); @@ -134,20 +144,25 @@ void inline_cache_jit::compile_inline_cache(fixnum index, cell generic_word_, ce push(methods.value()); push(tag_fixnum(index)); push(cache_entries.value()); - word_jump(userenv[PIC_MISS_WORD]); + word_special(userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]); } static code_block *compile_inline_cache(fixnum index, - cell generic_word_, - cell methods_, - cell cache_entries_) + cell generic_word_, + cell methods_, + cell cache_entries_, + bool tail_call_p) { gc_root generic_word(generic_word_); gc_root methods(methods_); gc_root cache_entries(cache_entries_); inline_cache_jit jit(generic_word.value()); - jit.compile_inline_cache(index,generic_word.value(),methods.value(),cache_entries.value()); + jit.compile_inline_cache(index, + generic_word.value(), + methods.value(), + cache_entries.value(), + tail_call_p); code_block *code = jit.to_code_block(); relocate_code_block(code); return code; @@ -225,14 +240,18 @@ void *inline_cache_miss(cell return_address) xt = compile_inline_cache(index, generic_word.value(), methods.value(), - new_cache_entries.value()) + 1; + new_cache_entries.value(), + tail_call_site_p(return_address))->xt(); } /* Install the new stub. */ set_call_target(return_address,xt); #ifdef PIC_DEBUG - printf("Updated call site 0x%lx with 0x%lx\n",return_address,(cell)xt); + printf("Updated %s call site 0x%lx with 0x%lx\n", + tail_call_site_p(return_address) ? "tail" : "non-tail", + return_address, + (cell)xt); #endif return xt; diff --git a/vm/inline_cache.hpp b/vm/inline_cache.hpp index 84334efc78..e2a6ae8cf9 100644 --- a/vm/inline_cache.hpp +++ b/vm/inline_cache.hpp @@ -8,7 +8,8 @@ void init_inline_caching(int max_size); PRIMITIVE(reset_inline_cache_stats); PRIMITIVE(inline_cache_stats); PRIMITIVE(inline_cache_miss); +PRIMITIVE(inline_cache_miss_tail); -extern "C" void *inline_cache_miss(cell return_address); +VM_C_API void *inline_cache_miss(cell return_address); } diff --git a/vm/io.cpp b/vm/io.cpp index 2d6c94faf0..5bb5834691 100755 --- a/vm/io.cpp +++ b/vm/io.cpp @@ -14,14 +14,14 @@ The Factor library provides platform-specific code for Unix and Windows with many more capabilities so these words are not usually used in normal operation. */ -void init_c_io(void) +void init_c_io() { userenv[STDIN_ENV] = allot_alien(F,(cell)stdin); userenv[STDOUT_ENV] = allot_alien(F,(cell)stdout); userenv[STDERR_ENV] = allot_alien(F,(cell)stderr); } -void io_error(void) +void io_error() { #ifndef WINCE if(errno == EINTR) @@ -216,12 +216,12 @@ PRIMITIVE(fclose) /* This function is used by FFI I/O. Accessing the errno global directly is not portable, since on some libc's errno is not a global but a funky macro that reads thread-local storage. */ -VM_C_API int err_no(void) +VM_C_API int err_no() { return errno; } -VM_C_API void clear_err_no(void) +VM_C_API void clear_err_no() { errno = 0; } diff --git a/vm/io.hpp b/vm/io.hpp index 968e96f0b5..d94d6402d9 100755 --- a/vm/io.hpp +++ b/vm/io.hpp @@ -1,8 +1,8 @@ namespace factor { -void init_c_io(void); -void io_error(void); +void init_c_io(); +void io_error(); PRIMITIVE(fopen); PRIMITIVE(fgetc); @@ -18,7 +18,7 @@ PRIMITIVE(open_file); PRIMITIVE(existsp); PRIMITIVE(read_dir); -VM_C_API int err_no(void); -VM_C_API void clear_err_no(void); +VM_C_API int err_no(); +VM_C_API void clear_err_no(); } diff --git a/vm/jit.cpp b/vm/jit.cpp index bb86506058..a3f222a953 100644 --- a/vm/jit.cpp +++ b/vm/jit.cpp @@ -23,24 +23,21 @@ jit::jit(cell type_, cell owner_) if(stack_traces_p()) literal(owner.value()); } -relocation_entry jit::rel_to_emit(cell code_template, bool *rel_p) +void jit::emit_relocation(cell code_template_) { - array *quadruple = untag(code_template); - cell rel_class = array_nth(quadruple,1); - cell rel_type = array_nth(quadruple,2); - cell offset = array_nth(quadruple,3); + gc_root code_template(code_template_); + cell capacity = array_capacity(code_template.untagged()); + for(cell i = 1; i < capacity; i += 3) + { + cell rel_class = array_nth(code_template.untagged(),i); + cell rel_type = array_nth(code_template.untagged(),i + 1); + cell offset = array_nth(code_template.untagged(),i + 2); - if(rel_class == F) - { - *rel_p = false; - return 0; - } - else - { - *rel_p = true; - return (untag_fixnum(rel_type) << 28) + relocation_entry new_entry + = (untag_fixnum(rel_type) << 28) | (untag_fixnum(rel_class) << 24) | ((code.count + untag_fixnum(offset))); + relocation.append_bytes(&new_entry,sizeof(relocation_entry)); } } @@ -49,9 +46,7 @@ void jit::emit(cell code_template_) { gc_root code_template(code_template_); - bool rel_p; - relocation_entry rel = rel_to_emit(code_template.value(),&rel_p); - if(rel_p) relocation.append_bytes(&rel,sizeof(relocation_entry)); + emit_relocation(code_template.value()); gc_root insns(array_nth(code_template.untagged(),0)); diff --git a/vm/jit.hpp b/vm/jit.hpp index 30b5163b4a..50b40eca30 100644 --- a/vm/jit.hpp +++ b/vm/jit.hpp @@ -14,7 +14,7 @@ struct jit { jit(cell jit_type, cell owner); void compute_position(cell offset); - relocation_entry rel_to_emit(cell code_template, bool *rel_p); + void emit_relocation(cell code_template); void emit(cell code_template); void literal(cell literal) { literals.add(literal); } @@ -25,17 +25,23 @@ struct jit { } void word_jump(cell word) { - emit_with(userenv[JIT_WORD_JUMP],word); + literal(tag_fixnum(xt_tail_pic_offset)); + literal(word); + emit(userenv[JIT_WORD_JUMP]); } void word_call(cell word) { emit_with(userenv[JIT_WORD_CALL],word); } + void word_special(cell word) { + emit_with(userenv[JIT_WORD_SPECIAL],word); + } + void emit_subprimitive(cell word_) { gc_root word(word_); gc_root code_template(word->subprimitive); - if(array_nth(code_template.untagged(),1) != F) literal(T); + if(array_capacity(code_template.untagged()) > 1) literal(T); emit(code_template.value()); } diff --git a/vm/layouts.hpp b/vm/layouts.hpp index 114b88b925..f8d114210a 100755 --- a/vm/layouts.hpp +++ b/vm/layouts.hpp @@ -93,6 +93,9 @@ class object; struct header { cell value; + /* Default ctor to make gcc 3.x happy */ + header() { abort(); } + header(cell value_) : value(value_ << TAG_BITS) {} void check_header() { @@ -226,7 +229,9 @@ struct word : public object { /* TAGGED property assoc for library code */ cell props; /* TAGGED alternative entry point for direct non-tail calls. Used for inline caching */ - cell direct_entry_def; + cell pic_def; + /* TAGGED alternative entry point for direct tail calls. Used for inline caching */ + cell pic_tail_def; /* TAGGED call count for profiling */ cell counter; /* TAGGED machine code for sub-primitive */ diff --git a/vm/mach_signal.cpp b/vm/mach_signal.cpp index f752c3cb8f..03edf862a8 100644 --- a/vm/mach_signal.cpp +++ b/vm/mach_signal.cpp @@ -169,7 +169,7 @@ mach_exception_thread (void *arg) } /* Initialize the Mach exception handler thread. */ -void mach_initialize (void) +void mach_initialize () { mach_port_t self; exception_mask_t mask; diff --git a/vm/mach_signal.hpp b/vm/mach_signal.hpp index 5dd344c080..a2ef07b0ec 100644 --- a/vm/mach_signal.hpp +++ b/vm/mach_signal.hpp @@ -79,6 +79,6 @@ catch_exception_raise_state_identity (mach_port_t exception_port, namespace factor { -void mach_initialize (void); +void mach_initialize (); } diff --git a/vm/master.hpp b/vm/master.hpp old mode 100644 new mode 100755 index 65d17fab4b..6409d65494 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -22,7 +22,15 @@ #include /* C++ headers */ -#include +#if __GNUC__ == 4 + #include + #define unordered_map std::tr1::unordered_map +#elif __GNUC__ == 3 + #include + #define unordered_map boost::unordered_map +#else + #error Factor requires GCC 3.x or later +#endif /* Factor headers */ #include "layouts.hpp" diff --git a/vm/math.cpp b/vm/math.cpp old mode 100644 new mode 100755 index 57d5e4a517..7a2abe7463 --- a/vm/math.cpp +++ b/vm/math.cpp @@ -219,7 +219,7 @@ PRIMITIVE(byte_array_to_bignum) drepl(tag(result)); } -cell unbox_array_size(void) +cell unbox_array_size() { switch(tagged(dpeek()).type()) { @@ -377,7 +377,7 @@ VM_C_API fixnum to_fixnum(cell tagged) return bignum_to_fixnum(untag(tagged)); default: type_error(FIXNUM_TYPE,tagged); - return -1; /* can't happen */ + return 0; /* can't happen */ } } @@ -444,7 +444,7 @@ VM_C_API s64 to_signed_8(cell obj) return bignum_to_long_long(untag(obj)); default: type_error(BIGNUM_TYPE,obj); - return -1; + return 0; } } @@ -466,7 +466,7 @@ VM_C_API u64 to_unsigned_8(cell obj) return bignum_to_ulong_long(untag(obj)); default: type_error(BIGNUM_TYPE,obj); - return -1; + return 0; } } diff --git a/vm/math.hpp b/vm/math.hpp index 763ed55f9a..198960d3b5 100644 --- a/vm/math.hpp +++ b/vm/math.hpp @@ -59,7 +59,7 @@ inline static cell allot_cell(cell x) return tag_fixnum(x); } -cell unbox_array_size(void); +cell unbox_array_size(); inline static double untag_float(cell tagged) { diff --git a/vm/os-freebsd.cpp b/vm/os-freebsd.cpp index 63313f61e0..d259658284 100644 --- a/vm/os-freebsd.cpp +++ b/vm/os-freebsd.cpp @@ -4,7 +4,7 @@ namespace factor { /* From SBCL */ -const char *vm_executable_path(void) +const char *vm_executable_path() { char path[PATH_MAX + 1]; diff --git a/vm/os-freebsd.hpp b/vm/os-freebsd.hpp index 0acf537d45..7797a7199b 100644 --- a/vm/os-freebsd.hpp +++ b/vm/os-freebsd.hpp @@ -1,7 +1,7 @@ #include #include -extern "C" int getosreldate(void); +extern "C" int getosreldate(); #ifndef KERN_PROC_PATHNAME #define KERN_PROC_PATHNAME 12 diff --git a/vm/os-genunix.cpp b/vm/os-genunix.cpp index 731527d208..6cca455eb7 100755 --- a/vm/os-genunix.cpp +++ b/vm/os-genunix.cpp @@ -8,17 +8,17 @@ void c_to_factor_toplevel(cell quot) c_to_factor(quot); } -void init_signals(void) +void init_signals() { unix_init_signals(); } -void early_init(void) { } +void early_init() { } #define SUFFIX ".image" #define SUFFIX_LEN 6 -const char *default_image_path(void) +const char *default_image_path() { const char *path = vm_executable_path(); diff --git a/vm/os-genunix.hpp b/vm/os-genunix.hpp index bc12f716cf..1972a728e6 100644 --- a/vm/os-genunix.hpp +++ b/vm/os-genunix.hpp @@ -5,9 +5,9 @@ namespace factor #define NULL_DLL NULL void c_to_factor_toplevel(cell quot); -void init_signals(void); -void early_init(void); -const char *vm_executable_path(void); -const char *default_image_path(void); +void init_signals(); +void early_init(); +const char *vm_executable_path(); +const char *default_image_path(); } diff --git a/vm/os-linux.cpp b/vm/os-linux.cpp index ecc8973ebe..f5814d7f18 100644 --- a/vm/os-linux.cpp +++ b/vm/os-linux.cpp @@ -4,7 +4,7 @@ namespace factor { /* Snarfed from SBCL linux-so.c. You must free() this yourself. */ -const char *vm_executable_path(void) +const char *vm_executable_path() { char *path = (char *)safe_malloc(PATH_MAX + 1); @@ -23,7 +23,7 @@ const char *vm_executable_path(void) #ifdef SYS_inotify_init -int inotify_init(void) +int inotify_init() { return syscall(SYS_inotify_init); } @@ -40,7 +40,7 @@ int inotify_rm_watch(int fd, u32 wd) #else -int inotify_init(void) +int inotify_init() { not_implemented_error(); return -1; diff --git a/vm/os-linux.hpp b/vm/os-linux.hpp index 4e2f22b95f..257a6b0692 100644 --- a/vm/os-linux.hpp +++ b/vm/os-linux.hpp @@ -3,7 +3,7 @@ namespace factor { -int inotify_init(void); +int inotify_init(); int inotify_add_watch(int fd, const char *name, u32 mask); int inotify_rm_watch(int fd, u32 wd); diff --git a/vm/os-macosx.hpp b/vm/os-macosx.hpp index aa166910f5..cdc0ff7b42 100644 --- a/vm/os-macosx.hpp +++ b/vm/os-macosx.hpp @@ -5,11 +5,11 @@ namespace factor #define FACTOR_OS_STRING "macosx" #define NULL_DLL "libfactor.dylib" -void init_signals(void); -void early_init(void); +void init_signals(); +void early_init(); -const char *vm_executable_path(void); -const char *default_image_path(void); +const char *vm_executable_path(); +const char *default_image_path(); inline static void *ucontext_stack_pointer(void *uap) { diff --git a/vm/os-netbsd.cpp b/vm/os-netbsd.cpp index 7a3cb30652..e280d99a80 100755 --- a/vm/os-netbsd.cpp +++ b/vm/os-netbsd.cpp @@ -5,7 +5,7 @@ namespace factor extern "C" int main(); -const char *vm_executable_path(void) +const char *vm_executable_path() { static Dl_info info = {0}; if (!info.dli_fname) diff --git a/vm/os-openbsd.cpp b/vm/os-openbsd.cpp index fc8aac8cf7..f763f8055f 100644 --- a/vm/os-openbsd.cpp +++ b/vm/os-openbsd.cpp @@ -3,7 +3,7 @@ namespace factor { -const char *vm_executable_path(void) +const char *vm_executable_path() { return NULL; } diff --git a/vm/os-solaris.cpp b/vm/os-solaris.cpp index fc8aac8cf7..f763f8055f 100644 --- a/vm/os-solaris.cpp +++ b/vm/os-solaris.cpp @@ -3,7 +3,7 @@ namespace factor { -const char *vm_executable_path(void) +const char *vm_executable_path() { return NULL; } diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index c0a268018e..18300949bd 100755 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -19,7 +19,7 @@ void start_thread(void *(*start_routine)(void *)) static void *null_dll; -s64 current_micros(void) +s64 current_micros() { struct timeval t; gettimeofday(&t,NULL); @@ -31,7 +31,7 @@ void sleep_micros(cell usec) usleep(usec); } -void init_ffi(void) +void init_ffi() { /* NULL_DLL is "libfactor.dylib" for OS X and NULL for generic unix */ null_dll = dlopen(NULL_DLL,RTLD_LAZY); @@ -145,7 +145,7 @@ static void sigaction_safe(int signum, const struct sigaction *act, struct sigac fatal_error("sigaction failed", 0); } -void unix_init_signals(void) +void unix_init_signals() { struct sigaction memory_sigaction; struct sigaction misc_sigaction; @@ -279,7 +279,7 @@ void *stdin_loop(void *arg) return NULL; } -void open_console(void) +void open_console() { int filedes[2]; @@ -304,7 +304,7 @@ void open_console(void) start_thread(stdin_loop); } -VM_C_API void wait_for_stdin(void) +VM_C_API void wait_for_stdin() { if(write(control_write,"X",1) != 1) { diff --git a/vm/os-unix.hpp b/vm/os-unix.hpp index 24e8016db4..07ec385763 100755 --- a/vm/os-unix.hpp +++ b/vm/os-unix.hpp @@ -42,18 +42,18 @@ typedef char symbol_char; void start_thread(void *(*start_routine)(void *)); -void init_ffi(void); +void init_ffi(); void ffi_dlopen(dll *dll); void *ffi_dlsym(dll *dll, symbol_char *symbol); void ffi_dlclose(dll *dll); -void unix_init_signals(void); +void unix_init_signals(); void signal_handler(int signal, siginfo_t* siginfo, void* uap); void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap); -s64 current_micros(void); +s64 current_micros(); void sleep_micros(cell usec); -void open_console(void); +void open_console(); } diff --git a/vm/os-windows-ce.cpp b/vm/os-windows-ce.cpp index 71c72e55f8..2e69a1eb5b 100755 --- a/vm/os-windows-ce.cpp +++ b/vm/os-windows-ce.cpp @@ -3,7 +3,7 @@ namespace factor { -s64 current_micros(void) +s64 current_micros() { SYSTEMTIME st; FILETIME ft; @@ -40,6 +40,6 @@ void c_to_factor_toplevel(cell quot) c_to_factor(quot); } -void open_console(void) { } +void open_console() { } } diff --git a/vm/os-windows-ce.hpp b/vm/os-windows-ce.hpp index 49450f91c7..f41262e54b 100755 --- a/vm/os-windows-ce.hpp +++ b/vm/os-windows-ce.hpp @@ -22,8 +22,8 @@ char *getenv(char *name); #define snprintf _snprintf #define snwprintf _snwprintf -s64 current_micros(void); +s64 current_micros(); void c_to_factor_toplevel(cell quot); -void open_console(void); +void open_console(); } diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp index 0a63dce513..c4349f243b 100755 --- a/vm/os-windows-nt.cpp +++ b/vm/os-windows-nt.cpp @@ -3,7 +3,7 @@ namespace factor { -s64 current_micros(void) +s64 current_micros() { FILETIME t; GetSystemTimeAsFileTime(&t); @@ -11,13 +11,13 @@ s64 current_micros(void) - EPOCH_OFFSET) / 10; } -long exception_handler(PEXCEPTION_POINTERS pe) +FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe) { PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord; CONTEXT *c = (CONTEXT*)pe->ContextRecord; if(in_code_heap_p(c->EIP)) - signal_callstack_top = (void *)c->ESP; + signal_callstack_top = (stack_frame *)c->ESP; else signal_callstack_top = NULL; @@ -43,13 +43,13 @@ long exception_handler(PEXCEPTION_POINTERS pe) void c_to_factor_toplevel(cell quot) { - if(!AddVectoredExceptionHandler(0, (void*)exception_handler)) + if(!AddVectoredExceptionHandler(0, (PVECTORED_EXCEPTION_HANDLER)exception_handler)) fatal_error("AddVectoredExceptionHandler failed", 0); c_to_factor(quot); - RemoveVectoredExceptionHandler((void*)exception_handler); + RemoveVectoredExceptionHandler((void *)exception_handler); } -void open_console(void) +void open_console() { } diff --git a/vm/os-windows-nt.hpp b/vm/os-windows-nt.hpp index 107e42ea2e..4371771c13 100755 --- a/vm/os-windows-nt.hpp +++ b/vm/os-windows-nt.hpp @@ -5,8 +5,8 @@ #define UNICODE #endif -#include #include +#include namespace factor { @@ -17,8 +17,10 @@ typedef char symbol_char; #define FACTOR_DLL L"factor.dll" #define FACTOR_DLL_NAME "factor.dll" +#define FACTOR_STDCALL __attribute__((stdcall)) + void c_to_factor_toplevel(cell quot); -long exception_handler(PEXCEPTION_POINTERS pe); -void open_console(void); +FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe); +void open_console(); } diff --git a/vm/os-windows.cpp b/vm/os-windows.cpp index 796a1c7184..7db19ff560 100755 --- a/vm/os-windows.cpp +++ b/vm/os-windows.cpp @@ -5,7 +5,7 @@ namespace factor HMODULE hFactorDll; -void init_ffi(void) +void init_ffi() { hFactorDll = GetModuleHandle(FACTOR_DLL); if(!hFactorDll) @@ -14,12 +14,12 @@ void init_ffi(void) void ffi_dlopen(dll *dll) { - dll->dll = LoadLibraryEx(alien_offset(dll->path), NULL, 0); + dll->dll = LoadLibraryEx((WCHAR *)alien_offset(dll->path), NULL, 0); } void *ffi_dlsym(dll *dll, symbol_char *symbol) { - return GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol); + return (void *)GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol); } void ffi_dlclose(dll *dll) @@ -63,7 +63,7 @@ void windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int len } /* You must free() this yourself. */ -const vm_char *default_image_path(void) +const vm_char *default_image_path() { vm_char full_path[MAX_UNICODE_PATH]; vm_char *ptr; @@ -82,7 +82,7 @@ const vm_char *default_image_path(void) } /* You must free() this yourself. */ -const vm_char *vm_executable_path(void) +const vm_char *vm_executable_path() { vm_char full_path[MAX_UNICODE_PATH]; if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH)) @@ -93,7 +93,7 @@ const vm_char *vm_executable_path(void) PRIMITIVE(existsp) { - vm_char *path = (vm_char *)(untag_check(dpop()) + 1); + vm_char *path = untag_check(dpop())->data(); box_boolean(windows_stat(path)); } @@ -113,7 +113,7 @@ segment *alloc_segment(cell size) getpagesize(), PAGE_NOACCESS, &ignore)) fatal_error("Cannot allocate high guard page", (cell)mem); - segment *block = safe_malloc(sizeof(segment)); + segment *block = (segment *)safe_malloc(sizeof(segment)); block->start = (cell)mem + getpagesize(); block->size = size; @@ -131,7 +131,7 @@ void dealloc_segment(segment *block) free(block); } -long getpagesize(void) +long getpagesize() { static long g_pagesize = 0; if (! g_pagesize) diff --git a/vm/os-windows.hpp b/vm/os-windows.hpp index 2926ea50a8..5422216593 100755 --- a/vm/os-windows.hpp +++ b/vm/os-windows.hpp @@ -41,19 +41,19 @@ typedef wchar_t vm_char; /* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */ #define EPOCH_OFFSET 0x019db1ded53e8000LL -void init_ffi(void); +void init_ffi(); void ffi_dlopen(dll *dll); void *ffi_dlsym(dll *dll, symbol_char *symbol); void ffi_dlclose(dll *dll); void sleep_micros(u64 msec); -inline static void init_signals(void) {} -inline static void early_init(void) {} -const vm_char *vm_executable_path(void); -const vm_char *default_image_path(void); -long getpagesize (void); +inline static void init_signals() {} +inline static void early_init() {} +const vm_char *vm_executable_path(); +const vm_char *default_image_path(); +long getpagesize (); -s64 current_micros(void); +s64 current_micros(); } diff --git a/vm/primitives.cpp b/vm/primitives.cpp index f1c5468949..bd761625d8 100755 --- a/vm/primitives.cpp +++ b/vm/primitives.cpp @@ -147,6 +147,7 @@ const primitive_type primitives[] = { primitive_load_locals, primitive_check_datastack, primitive_inline_cache_miss, + primitive_inline_cache_miss_tail, primitive_mega_cache_miss, primitive_lookup_method, primitive_reset_dispatch_stats, diff --git a/vm/profiler.cpp b/vm/profiler.cpp index 9651e4a27e..a3265e0ffa 100755 --- a/vm/profiler.cpp +++ b/vm/profiler.cpp @@ -5,7 +5,7 @@ namespace factor bool profiling_p; -void init_profiler(void) +void init_profiler() { profiling_p = false; } diff --git a/vm/profiler.hpp b/vm/profiler.hpp index 00f3e8067b..b83ef3d354 100755 --- a/vm/profiler.hpp +++ b/vm/profiler.hpp @@ -2,7 +2,7 @@ namespace factor { extern bool profiling_p; -void init_profiler(void); +void init_profiler(); code_block *compile_profiling_stub(cell word); PRIMITIVE(profiling); diff --git a/vm/quotations.cpp b/vm/quotations.cpp index af00bb468b..b049f528e4 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -152,7 +152,23 @@ void quotation_jit::iterate_quotation() { if(stack_frame) emit(userenv[JIT_EPILOG]); tail_call = true; - word_jump(obj.value()); + /* Inline cache misses are special-cased. + The calling convention for tail + calls stores the address of the next + instruction in a register. However, + PIC miss stubs themselves tail-call + the inline cache miss primitive, and + we don't want to clobber the saved + address. */ + if(obj.value() == userenv[PIC_MISS_WORD] + || obj.value() == userenv[PIC_MISS_TAIL_WORD]) + { + word_special(obj.value()); + } + else + { + word_jump(obj.value()); + } } else word_call(obj.value()); @@ -165,7 +181,6 @@ void quotation_jit::iterate_quotation() /* Primitive calls */ if(primitive_call_p(i)) { - emit(userenv[JIT_SAVE_STACK]); emit_with(userenv[JIT_PRIMITIVE],obj.value()); i++; @@ -187,8 +202,9 @@ void quotation_jit::iterate_quotation() jit_compile(array_nth(elements.untagged(),i + 1),relocate); } - emit_with(userenv[JIT_IF_1],array_nth(elements.untagged(),i)); - emit_with(userenv[JIT_IF_2],array_nth(elements.untagged(),i + 1)); + literal(array_nth(elements.untagged(),i)); + literal(array_nth(elements.untagged(),i + 1)); + emit(userenv[JIT_IF]); i += 2; @@ -297,7 +313,7 @@ PRIMITIVE(quotation_xt) drepl(allot_cell((cell)quot->xt)); } -void compile_all_words(void) +void compile_all_words() { gc_root words(find_all_words()); diff --git a/vm/quotations.hpp b/vm/quotations.hpp index a4545f3956..719a94176e 100755 --- a/vm/quotations.hpp +++ b/vm/quotations.hpp @@ -28,7 +28,7 @@ fixnum quot_code_offset_to_scan(cell quot, cell offset); PRIMITIVE(jit_compile); -void compile_all_words(void); +void compile_all_words(); PRIMITIVE(array_to_quotation); PRIMITIVE(quotation_xt); diff --git a/vm/run.hpp b/vm/run.hpp index 829e25d2f7..7527889efb 100755 --- a/vm/run.hpp +++ b/vm/run.hpp @@ -41,14 +41,13 @@ enum special_object { JIT_PRIMITIVE, JIT_WORD_JUMP, JIT_WORD_CALL, + JIT_WORD_SPECIAL, JIT_IF_WORD, - JIT_IF_1, - JIT_IF_2, - JIT_EPILOG = 33, + JIT_IF, + JIT_EPILOG, JIT_RETURN, JIT_PROFILING, JIT_PUSH_IMMEDIATE, - JIT_SAVE_STACK = 38, JIT_DIP_WORD, JIT_DIP, JIT_2DIP_WORD, @@ -60,7 +59,7 @@ enum special_object { JIT_EXECUTE_CALL, /* Polymorphic inline cache generation in inline_cache.c */ - PIC_LOAD = 48, + PIC_LOAD = 47, PIC_TAG, PIC_HI_TAG, PIC_TUPLE, @@ -69,6 +68,7 @@ enum special_object { PIC_CHECK, PIC_HIT, PIC_MISS_WORD, + PIC_MISS_TAIL_WORD, /* Megamorphic cache generation in dispatch.c */ MEGA_LOOKUP = 57, diff --git a/vm/stacks.hpp b/vm/stacks.hpp index 4af31e17d9..bc1aac8154 100644 --- a/vm/stacks.hpp +++ b/vm/stacks.hpp @@ -4,7 +4,7 @@ namespace factor #define DEFPUSHPOP(prefix,ptr) \ inline static cell prefix##peek() { return *(cell *)ptr; } \ inline static void prefix##repl(cell tagged) { *(cell *)ptr = tagged; } \ - inline static cell prefix##pop(void) \ + inline static cell prefix##pop() \ { \ cell value = prefix##peek(); \ ptr -= sizeof(cell); \ diff --git a/vm/utilities.cpp b/vm/utilities.cpp index 532de80ed1..df5c09847d 100755 --- a/vm/utilities.cpp +++ b/vm/utilities.cpp @@ -20,7 +20,7 @@ vm_char *safe_strdup(const vm_char *str) /* We don't use printf directly, because format directives are not portable. Instead we define the common cases here. */ -void nl(void) +void nl() { fputs("\n",stdout); } @@ -50,7 +50,7 @@ void print_fixnum(fixnum x) printf(FIXNUM_FORMAT,x); } -cell read_cell_hex(void) +cell read_cell_hex() { cell cell; if(scanf(cell_HEX_FORMAT,&cell) < 0) exit(1); diff --git a/vm/utilities.hpp b/vm/utilities.hpp index d311b954ed..7e7765170e 100755 --- a/vm/utilities.hpp +++ b/vm/utilities.hpp @@ -4,12 +4,12 @@ namespace factor void *safe_malloc(size_t size); vm_char *safe_strdup(const vm_char *str); -void nl(void); +void nl(); void print_string(const char *str); void print_cell(cell x); void print_cell_hex(cell x); void print_cell_hex_pad(cell x); void print_fixnum(fixnum x); -cell read_cell_hex(void); +cell read_cell_hex(); } diff --git a/vm/words.cpp b/vm/words.cpp index 6e7c633c84..fa090c9cea 100644 --- a/vm/words.cpp +++ b/vm/words.cpp @@ -16,7 +16,8 @@ word *allot_word(cell vocab_, cell name_) new_word->def = userenv[UNDEFINED_ENV]; new_word->props = F; new_word->counter = tag_fixnum(0); - new_word->direct_entry_def = F; + new_word->pic_def = F; + new_word->pic_tail_def = F; new_word->subprimitive = F; new_word->profiling = NULL; new_word->code = NULL; diff --git a/vm/write_barrier.cpp b/vm/write_barrier.cpp old mode 100644 new mode 100755 index 4137b0a6eb..0e87434b56 --- a/vm/write_barrier.cpp +++ b/vm/write_barrier.cpp @@ -4,4 +4,8 @@ using namespace factor; cell cards_offset; cell decks_offset; -cell allot_markers_offset; + +namespace factor +{ + cell allot_markers_offset; +} diff --git a/vm/write_barrier.hpp b/vm/write_barrier.hpp old mode 100644 new mode 100755 index ae7fbb25dd..eaede538ed --- a/vm/write_barrier.hpp +++ b/vm/write_barrier.hpp @@ -6,6 +6,9 @@ card has a slot written to. the offset of the first object is set by the allocator. */ +VM_C_API factor::cell cards_offset; +VM_C_API factor::cell decks_offset; + namespace factor { @@ -19,8 +22,6 @@ typedef u8 card; #define CARD_SIZE (1<> CARD_BITS) + cards_offset); @@ -42,8 +43,6 @@ typedef u8 card_deck; #define DECK_SIZE (1<> DECK_BITS) + decks_offset); @@ -61,7 +60,7 @@ inline static card *deck_to_card(card_deck *d) #define INVALID_ALLOT_MARKER 0xff -VM_C_API cell allot_markers_offset; +extern cell allot_markers_offset; inline static card *addr_to_allot_marker(object *a) {