diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index 15e67bf0fe..e4a0e4dcf0 100755 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.strings alien.c-types alien.accessors alien.structs arrays words sequences math kernel namespaces fry libc cpu.architecture -io.encodings.utf8 io.encodings.utf16n ; +io.encodings.utf8 ; IN: alien.arrays UNION: value-type array struct-type ; @@ -95,5 +95,4 @@ M: string-type c-type-setter { "char*" utf8 } "char*" typedef "char*" "uchar*" typedef -{ "char*" utf16n } "wchar_t*" typedef diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 92d75604e0..4a7a558703 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -448,7 +448,6 @@ M: quotation ' array>> ' quotation [ emit ! array - f ' emit ! compiled f ' emit ! cached-effect f ' emit ! cache-counter 0 emit ! xt diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 9d19e4a231..3cbe155dd2 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -12,6 +12,16 @@ SYMBOL: core-bootstrap-time SYMBOL: bootstrap-time +: strip-encodings ( -- ) + os unix? [ + [ + P" resource:core/io/encodings/utf16/utf16.factor" + P" resource:core/io/encodings/utf16n/utf16n.factor" [ forget ] bi@ + "io.encodings.utf16" + "io.encodings.utf16n" [ child-vocabs [ forget-vocab ] each ] bi@ + ] with-compilation-unit + ] when ; + : default-image-name ( -- string ) vm file-name os windows? [ "." split1-last drop ] when ".image" append resource-path ; @@ -55,6 +65,8 @@ SYMBOL: bootstrap-time "math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global "" "exclude" set-global + strip-encodings + (command-line) parse-command-line ! Set dll paths diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index 9519847810..751a1f52e1 100644 --- a/basis/combinators/smart/smart.factor +++ b/basis/combinators/smart/smart.factor @@ -11,8 +11,8 @@ MACRO: output>sequence ( quot exemplar -- newquot ) [ dup infer out>> ] dip '[ @ _ _ nsequence ] ; -: output>array ( quot -- newquot ) - { } output>sequence ; inline +MACRO: output>array ( quot -- newquot ) + '[ _ { } output>sequence ] ; MACRO: input> ] keep @@ -25,8 +25,8 @@ MACRO: input> 1 [-] ] dip n*quot compose ; -: sum-outputs ( quot -- n ) - [ + ] reduce-outputs ; inline +MACRO: sum-outputs ( quot -- n ) + '[ _ [ + ] reduce-outputs ] ; MACRO: map-reduce-outputs ( quot mapper reducer -- newquot ) [ dup infer out>> ] 2dip @@ -37,5 +37,5 @@ MACRO: map-reduce-outputs ( quot mapper reducer -- newquot ) MACRO: append-outputs-as ( quot exemplar -- newquot ) [ dup infer out>> ] dip '[ @ _ _ nappend-as ] ; -: append-outputs ( quot -- seq ) - { } append-outputs-as ; inline +MACRO: append-outputs ( quot -- seq ) + '[ _ { } append-outputs-as ] ; diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index 6b383388ef..b795862970 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -20,7 +20,7 @@ CONSTANT: deck-bits 18 : underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline : tuple-class-offset ( -- n ) bootstrap-cell tuple 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 +: quot-xt-offset ( -- n ) 4 bootstrap-cells quotation 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 ) 4 bootstrap-cells ; inline diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index f210180517..1a52ce6f34 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -173,10 +173,11 @@ M: stdin refill size-read-fd init-fd >>size data-read-fd >>data ; -M: unix (init-stdio) +M: unix init-stdio 1 - 2 t ; + 2 + set-stdio ; ! mx io-task for embedding an fd-based mx inside another mx TUPLE: mx-port < port mx ; diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 4dfe02d651..69a695ac72 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -1,9 +1,9 @@ -USING: alien alien.c-types arrays assocs combinators -continuations destructors io io.backend io.ports io.timeouts -io.backend.windows io.files.windows io.files.windows.nt io.files -io.pathnames io.buffers io.streams.c libc kernel math namespaces -sequences threads windows windows.errors windows.kernel32 -strings splitting ascii system accessors locals ; +USING: alien alien.c-types arrays assocs combinators continuations +destructors io io.backend io.ports io.timeouts io.backend.windows +io.files.windows io.files.windows.nt io.files io.pathnames io.buffers +io.streams.c io.streams.null libc kernel math namespaces sequences +threads windows windows.errors windows.kernel32 strings splitting +ascii system accessors locals ; QUALIFIED: windows.winsock IN: io.backend.windows.nt @@ -140,7 +140,9 @@ M: winnt (wait-to-read) ( port -- ) : console-app? ( -- ? ) GetConsoleWindow >boolean ; -M: winnt (init-stdio) - console-app? [ init-c-stdio t ] [ f f f f ] if ; +M: winnt init-stdio + console-app? + [ init-c-stdio ] + [ null-reader null-writer null-writer set-stdio ] if ; winnt set-io-backend diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index 838c09c657..7451499978 100755 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: system kernel namespaces strings hashtables sequences -assocs combinators vocabs.loader init threads continuations -math accessors concurrency.flags destructors environment -io io.encodings.ascii io.backend io.timeouts io.pipes -io.pipes.private io.encodings io.streams.duplex io.ports -debugger prettyprint summary calendar ; +USING: system kernel namespaces strings hashtables sequences assocs +combinators vocabs.loader init threads continuations math accessors +concurrency.flags destructors environment io io.encodings.ascii +io.backend io.timeouts io.pipes io.pipes.private io.encodings +io.encodings.utf8 io.streams.duplex io.ports debugger prettyprint +summary calendar ; IN: io.launcher TUPLE: process < identity-tuple @@ -254,6 +254,21 @@ M: object run-pipeline-element swap [ with-stream ] dip wait-for-success ; inline +ERROR: output-process-error { output string } { process process } ; + +M: output-process-error error. + [ "Process:" print process>> . nl ] + [ "Output:" print output>> print ] + bi ; + +: try-output-process ( command -- ) + >process + +stdout+ >>stderr + +closed+ >>stdin + utf8 + [ stream-contents ] [ dup wait-for-process ] bi* + 0 = [ 2drop ] [ output-process-error ] if ; + : notify-exit ( process status -- ) >>status [ processes get delete-at* drop [ resume ] each ] keep diff --git a/core/io/streams/null/authors.txt b/basis/io/streams/null/authors.txt similarity index 100% rename from core/io/streams/null/authors.txt rename to basis/io/streams/null/authors.txt diff --git a/core/io/streams/null/null-docs.factor b/basis/io/streams/null/null-docs.factor similarity index 100% rename from core/io/streams/null/null-docs.factor rename to basis/io/streams/null/null-docs.factor diff --git a/core/io/streams/null/null.factor b/basis/io/streams/null/null.factor similarity index 100% rename from core/io/streams/null/null.factor rename to basis/io/streams/null/null.factor diff --git a/core/io/streams/null/summary.txt b/basis/io/streams/null/summary.txt similarity index 100% rename from core/io/streams/null/summary.txt rename to basis/io/streams/null/summary.txt diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index cdd66cc6e8..6816445508 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -1,10 +1,12 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays accessors io.backend io.streams.c init fry namespaces -make assocs kernel parser lexer strings.parser vocabs sequences words -memory kernel.private continuations io vocabs.loader system strings -sets vectors quotations byte-arrays sorting compiler.units definitions -generic generic.standard tools.deploy.config combinators classes ; +math make assocs kernel parser lexer strings.parser vocabs sequences +sequences.private words memory kernel.private continuations io +vocabs.loader system strings sets vectors quotations byte-arrays +sorting compiler.units definitions generic generic.standard +generic.single tools.deploy.config combinators classes +slots.private ; QUALIFIED: bootstrap.stage2 QUALIFIED: command-line QUALIFIED: compiler.errors @@ -38,6 +40,7 @@ IN: tools.deploy.shaker strip-io? [ "io.files" init-hooks get delete-at "io.backend" init-hooks get delete-at + "io.thread" init-hooks get delete-at ] when strip-dictionary? [ { @@ -193,7 +196,8 @@ IN: tools.deploy.shaker : strip-compiler-classes ( -- ) "Stripping compiler classes" show - "compiler" child-vocabs [ words ] map concat [ class? ] filter + { "compiler" "stack-checker" } + [ child-vocabs [ words ] map concat [ class? ] filter ] map concat [ dup implementors [ "methods" word-prop delete-at ] with each ] each ; : strip-default-methods ( -- ) @@ -325,12 +329,17 @@ IN: tools.deploy.shaker ] [ drop ] if ; : strip-c-io ( -- ) - deploy-io get 2 = os windows? or [ + strip-io? + deploy-io get 3 = os windows? not and + or [ [ c-io-backend forget "io.streams.c" forget-vocab + "io-thread-running?" "io.thread" lookup [ + global delete-at + ] when* ] with-compilation-unit - ] unless ; + ] when ; : compress ( pred post-process string -- ) "Compressing " prepend show @@ -353,7 +362,7 @@ IN: tools.deploy.shaker #! Quotations which were formerly compiled must remain #! compiled. 2dup [ - 2dup [ compiled>> ] [ compiled>> not ] bi* and + 2dup [ quot-compiled? ] [ quot-compiled? not ] bi* and [ nip jit-compile ] [ 2drop ] if ] 2each ; @@ -406,6 +415,23 @@ SYMBOL: deploy-vocab ] each "vocab:tools/deploy/shaker/next-methods.factor" run-file ; +: (clear-megamorphic-cache) ( i array -- ) + 2dup 1 slot < [ + 2dup [ f ] 2dip set-array-nth + [ 1 + ] dip (clear-megamorphic-cache) + ] [ 2drop ] if ; + +: clear-megamorphic-cache ( array -- ) + [ 0 ] dip (clear-megamorphic-cache) ; + +: find-megamorphic-caches ( -- seq ) + "Finding megamorphic caches" show + [ standard-generic? ] instances [ def>> third ] map ; + +: clear-megamorphic-caches ( cache -- ) + "Clearing megamorphic caches" show + [ clear-megamorphic-cache ] each ; + : strip ( -- ) init-stripper strip-libc @@ -419,11 +445,13 @@ SYMBOL: deploy-vocab strip-default-methods f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore deploy-vocab get vocab-main deploy-boot-quot + find-megamorphic-caches stripped-word-props stripped-globals strip-globals compress-objects compress-quotations - strip-words ; + strip-words + clear-megamorphic-caches ; : deploy-error-handler ( quot -- ) [ diff --git a/basis/tools/deploy/test/test.factor b/basis/tools/deploy/test/test.factor index f997a6eb3a..9a54e65f1a 100644 --- a/basis/tools/deploy/test/test.factor +++ b/basis/tools/deploy/test/test.factor @@ -1,5 +1,5 @@ USING: accessors arrays continuations io.directories io.files.info -io.files.temp io.launcher kernel layouts math sequences system +io.files.temp io.launcher io.backend kernel layouts math sequences system tools.deploy.backend tools.deploy.config.editor ; IN: tools.deploy.test @@ -14,7 +14,6 @@ IN: tools.deploy.test [ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ; : run-temp-image ( -- ) - vm - "-i=" "test.image" temp-file append - 2array - swap >>command +closed+ >>stdin try-process ; \ No newline at end of file + os macosx? + "resource:Factor.app/Contents/MacOS/factor" normalize-path vm ? + "-i=" "test.image" temp-file append 2array try-output-process ; \ No newline at end of file diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index af998c08b9..38fb220c69 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -4,7 +4,7 @@ USING: accessors arrays assocs continuations kernel math models namespaces opengl opengl.textures sequences io combinators combinators.short-circuit fry math.vectors math.rectangles cache ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks -ui.commands ui.pixel-formats destructors literals strings ; +ui.pixel-formats destructors literals strings ; IN: ui.gadgets.worlds CONSTANT: default-world-pixel-format-attributes diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index 062196c3f8..b99e7ffe6f 100755 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax namespaces kernel words -sequences math math.bitwise math.vectors colors ; +sequences math math.bitwise math.vectors colors +io.encodings.utf16n ; IN: windows.types TYPEDEF: char CHAR @@ -68,6 +69,8 @@ TYPEDEF: ulonglong ULARGE_INTEGER TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER TYPEDEF: ULARGE_INTEGER* PULARGE_INTEGER +<< { "char*" utf16n } "wchar_t*" typedef >> + TYPEDEF: wchar_t* LPCSTR TYPEDEF: wchar_t* LPWSTR TYPEDEF: WCHAR TCHAR diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 57bc61a005..d94cd45c3d 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -211,7 +211,6 @@ bi "quotation" "quotations" create { { "array" { "array" "arrays" } read-only } - { "compiled" read-only } "cached-effect" "cache-counter" } define-builtin @@ -514,6 +513,7 @@ tuple { "reset-inline-cache-stats" "generic.single" (( -- )) } { "inline-cache-stats" "generic.single" (( -- stats )) } { "optimized?" "words" (( word -- ? )) } + { "quot-compiled?" "quotations" (( quot -- ? )) } } [ [ first3 ] dip swap make-primitive ] each-index ! Bump build number diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index 4c91a519c6..ac3fbef8d0 100644 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: init kernel system namespaces io io.encodings -io.encodings.utf8 init assocs splitting alien io.streams.null ; +io.encodings.utf8 init assocs splitting alien ; IN: io.backend SYMBOL: io-backend @@ -12,22 +12,12 @@ io-backend [ c-io-backend ] initialize HOOK: init-io io-backend ( -- ) -HOOK: (init-stdio) io-backend ( -- stdin stdout stderr ? ) +HOOK: init-stdio io-backend ( -- ) -: set-stdio ( input-handle output-handle error-handle -- ) - [ input-stream set-global ] - [ output-stream set-global ] - [ error-stream set-global ] tri* ; - -: init-stdio ( -- ) - (init-stdio) [ - [ utf8 ] - [ utf8 ] - [ utf8 ] tri* - ] [ - 3drop - null-reader null-writer null-writer - ] if set-stdio ; +: set-stdio ( input output error -- ) + [ utf8 input-stream set-global ] + [ utf8 output-stream set-global ] + [ utf8 error-stream set-global ] tri* ; HOOK: io-multiplex io-backend ( us -- ) diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index d3fd593a7b..7a7ac5a97c 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -60,12 +60,13 @@ M: c-io-backend init-io ; : stdout-handle ( -- alien ) 12 getenv ; : stderr-handle ( -- alien ) 61 getenv ; -: init-c-stdio ( -- stdin stdout stderr ) +: init-c-stdio ( -- ) stdin-handle stdout-handle - stderr-handle ; + stderr-handle + set-stdio ; -M: c-io-backend (init-stdio) init-c-stdio t ; +M: c-io-backend init-stdio init-c-stdio ; M: c-io-backend io-multiplex 60 60 * 1000 * 1000 * or (sleep) ; diff --git a/extra/bloom-filters/authors.txt b/extra/bloom-filters/authors.txt new file mode 100644 index 0000000000..528e5dfe6b --- /dev/null +++ b/extra/bloom-filters/authors.txt @@ -0,0 +1 @@ +Alec Berryman diff --git a/extra/bloom-filters/bloom-filters-docs.factor b/extra/bloom-filters/bloom-filters-docs.factor new file mode 100644 index 0000000000..bc5df8611c --- /dev/null +++ b/extra/bloom-filters/bloom-filters-docs.factor @@ -0,0 +1,38 @@ +USING: help.markup help.syntax kernel math ; +IN: bloom-filters + +HELP: +{ $values { "error-rate" "The desired false positive rate. A " { $link float } " between 0 and 1." } + { "number-objects" "The expected number of object in the set. A positive " { $link integer } "." } + { "bloom-filter" bloom-filter } } +{ $description "Creates an empty Bloom filter." } +{ $errors "Throws a " { $link capacity-error } " when unable to produce a filter meeting the given constraints. Throws a " { $link invalid-error-rate } " or a " { $link invalid-n-objects } " when input is invalid." } ; + + +HELP: bloom-filter-insert +{ $values { "object" object } + { "bloom-filter" bloom-filter } } +{ $description "Records the item as a member of the filter." } +{ $side-effects "bloom-filter" } ; + +HELP: bloom-filter-member? +{ $values { "object" object } + { "bloom-filter" bloom-filter } + { "?" boolean } } +{ $description "Returns " { $link t } " if the object may be a member of Bloom filter, " { $link f } " otherwise. The false positive rate is configurable; there are no false negatives." } ; + +HELP: bloom-filter +{ $class-description "This is the class for Bloom filters. These provide constant-time insertion and probabilistic membership-testing operations, but do not actually store any elements." } ; + +ARTICLE: "bloom-filters" "Bloom filters" +"This is a library for Bloom filters, sets that provide a constant-time insertion operation and probabilistic membership tests, but do not actually store any elements." +$nl +"The accuracy of the membership test is configurable; a Bloom filter will never incorrectly report an item is not a member of the set, but may incorrectly report than an item is a member of the set." +$nl +"Bloom filters cannot be resized and do not support removal." +$nl +{ $subsection } +{ $subsection bloom-filter-insert } +{ $subsection bloom-filter-member? } ; + +ABOUT: "bloom-filters" diff --git a/extra/bloom-filters/bloom-filters-tests.factor b/extra/bloom-filters/bloom-filters-tests.factor new file mode 100644 index 0000000000..6dce1c2ca9 --- /dev/null +++ b/extra/bloom-filters/bloom-filters-tests.factor @@ -0,0 +1,81 @@ +USING: accessors bit-arrays bloom-filters bloom-filters.private kernel layouts +math random sequences tools.test ; +IN: bloom-filters.tests + + +[ { 200 5 } ] [ { 100 7 } { 200 5 } smaller-second ] unit-test +[ { 200 5 } ] [ { 200 5 } { 100 7 } smaller-second ] unit-test + +! The sizing information was generated using the subroutine +! calculate_shortest_filter_length from +! http://www.perl.com/pub/a/2004/04/08/bloom_filters.html. + +! Test bloom-filter creation +[ 47965 ] [ 7 0.01 5000 bits-to-satisfy-error-rate ] unit-test +[ 7 47965 ] [ 0.01 5000 size-bloom-filter ] unit-test +[ 7 ] [ 0.01 5000 n-hashes>> ] unit-test +[ 47965 ] [ 0.01 5000 bits>> length ] unit-test +[ 5000 ] [ 0.01 5000 maximum-n-objects>> ] unit-test +[ 0 ] [ 0.01 5000 current-n-objects>> ] unit-test + +! Should return the fewest hashes to satisfy the bits requested, not the most. +[ 32 ] [ 4 0.05 5 bits-to-satisfy-error-rate ] unit-test +[ 32 ] [ 5 0.05 5 bits-to-satisfy-error-rate ] unit-test +[ 4 32 ] [ 0.05 5 size-bloom-filter ] unit-test + +! This is a lot of bits. +: oversized-filter-params ( -- error-rate n-objects ) + 0.00000001 400000000000000 ; +! [ oversized-filter-params size-bloom-filter ] [ capacity-error? ] must-fail-with +! [ oversized-filter-params ] [ capacity-error? ] must-fail-with + +! Other error conditions. +[ 1.0 2000 ] [ invalid-error-rate? ] must-fail-with +[ 20 2000 ] [ invalid-error-rate? ] must-fail-with +[ 0.0 2000 ] [ invalid-error-rate? ] must-fail-with +[ -2 2000 ] [ invalid-error-rate? ] must-fail-with +[ 0.5 0 ] [ invalid-n-objects? ] must-fail-with +[ 0.5 -5 ] [ invalid-n-objects? ] must-fail-with + +! Should not generate bignum hash codes. Enhanced double hashing may generate a +! lot of hash codes, and it's better to do this earlier than later. +[ t ] [ 10000 iota [ hashcodes-from-object [ fixnum? ] both? ] map [ ] all? ] unit-test + +[ ?{ t f t f t f } ] [ { 0 2 4 } 6 [ set-indices ] keep ] unit-test + +: empty-bloom-filter ( -- bloom-filter ) + 0.01 2000 ; + +[ 1 ] [ empty-bloom-filter dup increment-n-objects current-n-objects>> ] unit-test + +: basic-insert-test-setup ( -- bloom-filter ) + 1 empty-bloom-filter [ bloom-filter-insert ] keep ; + +! Basic tests that insert does something +[ t ] [ basic-insert-test-setup bits>> [ ] any? ] unit-test +[ 1 ] [ basic-insert-test-setup current-n-objects>> ] unit-test + +: non-empty-bloom-filter ( -- bloom-filter ) + 1000 iota + empty-bloom-filter + [ [ bloom-filter-insert ] curry each ] keep ; + +: full-bloom-filter ( -- bloom-filter ) + 2000 iota + empty-bloom-filter + [ [ bloom-filter-insert ] curry each ] keep ; + +! Should find what we put in there. +[ t ] [ 2000 iota + full-bloom-filter + [ bloom-filter-member? ] curry map + [ ] all? ] unit-test + +! We shouldn't have more than 0.01 false-positive rate. +[ t ] [ 1000 iota [ drop most-positive-fixnum random 1000 + ] map + full-bloom-filter + [ bloom-filter-member? ] curry map + [ ] filter + ! TODO: This should be 10, but the false positive rate is currently very + ! high. It shouldn't be much more than this. + length 150 <= ] unit-test diff --git a/extra/bloom-filters/bloom-filters.factor b/extra/bloom-filters/bloom-filters.factor new file mode 100644 index 0000000000..308d10ad84 --- /dev/null +++ b/extra/bloom-filters/bloom-filters.factor @@ -0,0 +1,158 @@ +! Copyright (C) 2009 Alec Berryman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays bit-arrays fry infix kernel layouts locals math +math.functions multiline sequences ; +IN: bloom-filters + +FROM: math.ranges => [1,b] [0,b) ; +FROM: math.intervals => (a,b) interval-contains? ; + +/* + +TODO: + +- The false positive rate is 10x what it should be, based on informal testing. + Better object hashes or a better method of generating extra hash codes would + help. Another way is to increase the number of bits used. + + - Try something smarter than the bitwise complement for a second hash code. + + - http://spyced.blogspot.com/2009/01/all-you-ever-wanted-to-know-about.html + makes a case for http://murmurhash.googlepages.com/ instead of enhanced + double-hashing. + + - Be sure to adjust the test that asserts the number of false positives isn't + unreasonable. + +- Could round bits up to next power of two and use wrap instead of mod. This + would cost a lot of bits on 32-bit platforms, though, and limit the bit-array + to 8MB. + +- Should allow user to specify the hash codes, either as inputs to enhanced + double hashing or for direct use. + +- Support for serialization. + +- Wrappers for combining filters. + +- Should we signal an error when inserting past the number of objects the filter + is sized for? The filter will continue to work, just not very well. + +*/ + +TUPLE: bloom-filter +{ n-hashes fixnum read-only } +{ bits bit-array read-only } +{ maximum-n-objects fixnum read-only } +{ current-n-objects fixnum } ; + +ERROR: capacity-error ; +ERROR: invalid-error-rate ; +ERROR: invalid-n-objects ; + +integer ; + +! 100 hashes ought to be enough for anybody. +: n-hashes-range ( -- range ) + 100 [1,b] ; + +! { n-hashes n-bits } +: identity-configuration ( -- 2seq ) + 0 max-array-capacity 2array ; + +: smaller-second ( 2seq 2seq -- 2seq ) + [ [ second ] bi@ <= ] most ; + +! If the number of hashes isn't positive, we haven't found anything smaller than the +! identity configuration. +: validate-sizes ( 2seq -- ) + first 0 <= [ capacity-error ] when ; + +! The consensus on the tradeoff between increasing the number of bits and +! increasing the number of hash functions seems to be "go for the smallest +! number of bits", probably because most implementations just generate one hash +! value and cheaply mangle it into the number of hashes they need. I have not +! seen any usage studies from the implementations that made this tradeoff to +! support it, and I haven't done my own, but we'll go with it anyway. +! +: size-bloom-filter ( error-rate number-objects -- number-hashes number-bits ) + [ n-hashes-range identity-configuration ] 2dip + '[ dup [ _ _ bits-to-satisfy-error-rate ] + call 2array smaller-second ] + reduce + dup validate-sizes + first2 ; + +: validate-n-objects ( n-objects -- ) + 0 <= [ invalid-n-objects ] when ; + +: valid-error-rate-interval ( -- interval ) + 0 1 (a,b) ; + +: validate-error-rate ( error-rate -- ) + valid-error-rate-interval interval-contains? + [ invalid-error-rate ] unless ; + +: validate-constraints ( error-rate n-objects -- ) + validate-n-objects validate-error-rate ; + +PRIVATE> + +: ( error-rate number-objects -- bloom-filter ) + [ validate-constraints ] 2keep + [ size-bloom-filter ] keep + 0 ! initially empty + bloom-filter boa ; + +fixnum bitxor ; + +: hashcodes-from-object ( obj -- n n ) + hashcode abs hashcodes-from-hashcode ; + +: set-indices ( indices bit-array -- ) + [ [ drop t ] change-nth ] curry each ; + +: increment-n-objects ( bloom-filter -- ) + [ 1 + ] change-current-n-objects drop ; + +: n-hashes-and-length ( bloom-filter -- n-hashes length ) + [ n-hashes>> ] [ bits>> length ] bi ; + +: relevant-indices ( value bloom-filter -- indices ) + [ hashcodes-from-object ] [ n-hashes-and-length ] bi* + [ enhanced-double-hashes ] dip '[ _ mod ] map ; + +PRIVATE> + +: bloom-filter-insert ( object bloom-filter -- ) + [ increment-n-objects ] + [ relevant-indices ] + [ bits>> set-indices ] + tri ; + +: bloom-filter-member? ( object bloom-filter -- ? ) + [ relevant-indices ] keep + bits>> nths [ ] all? ; diff --git a/extra/hello-ui/deploy.factor b/extra/hello-ui/deploy.factor index 7fcc167cea..784c34cf70 100644 --- a/extra/hello-ui/deploy.factor +++ b/extra/hello-ui/deploy.factor @@ -1,14 +1,14 @@ USING: tools.deploy.config ; H{ - { deploy-ui? t } - { deploy-reflection 1 } - { deploy-unicode? f } - { deploy-math? t } - { deploy-io 2 } { deploy-c-types? f } - { deploy-name "Hello world" } - { deploy-word-props? f } + { deploy-unicode? f } { deploy-word-defs? f } + { deploy-name "Hello world" } { "stop-after-last-window?" t } + { deploy-reflection 1 } + { deploy-ui? t } + { deploy-math? t } + { deploy-io 1 } + { deploy-word-props? f } { deploy-threads? t } } diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index b7545a3c9e..a743c3fe9a 100755 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -10,18 +10,6 @@ IN: mason.common SYMBOL: current-git-id -ERROR: output-process-error { output string } { process process } ; - -M: output-process-error error. - [ "Process:" print process>> . nl ] - [ "Output:" print output>> print ] - bi ; - -: try-output-process ( command -- ) - >process +stdout+ >>stderr utf8 - [ stream-contents ] [ dup wait-for-process ] bi* - 0 = [ 2drop ] [ output-process-error ] if ; - HOOK: really-delete-tree os ( path -- ) M: windows really-delete-tree diff --git a/extra/spheres/deploy.factor b/extra/spheres/deploy.factor index df314317cf..8c72e4a26c 100644 --- a/extra/spheres/deploy.factor +++ b/extra/spheres/deploy.factor @@ -1,14 +1,14 @@ USING: tools.deploy.config ; H{ - { deploy-ui? t } - { deploy-reflection 1 } - { deploy-unicode? f } - { deploy-math? t } - { deploy-io 2 } { deploy-c-types? f } - { deploy-name "Spheres" } - { deploy-word-props? f } + { deploy-unicode? f } { deploy-word-defs? f } + { deploy-name "Spheres" } { "stop-after-last-window?" t } + { deploy-reflection 1 } + { deploy-ui? t } + { deploy-math? t } + { deploy-io 1 } + { deploy-word-props? f } { deploy-threads? t } } diff --git a/vm/code_block.cpp b/vm/code_block.cpp index c34f651750..2ce69ebfde 100755 --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -68,10 +68,10 @@ static void *xt_pic(word *w, cell tagged_quot) else { quotation *quot = untag(tagged_quot); - if(quot->compiledp == F) - return w->xt; - else + if(quot->code) return quot->xt; + else + return w->xt; } } @@ -409,7 +409,7 @@ void mark_object_code_block(object *object) case QUOTATION_TYPE: { quotation *q = (quotation *)object; - if(q->compiledp != F) + if(q->code) mark_code_block(q->code); break; } diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index c8c7639930..2260d133fc 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -158,7 +158,7 @@ void forward_object_xts() { quotation *quot = untag(obj); - if(quot->compiledp != F) + if(quot->code) quot->code = forward_xt(quot->code); } break; @@ -194,7 +194,7 @@ void fixup_object_xts() case QUOTATION_TYPE: { quotation *quot = untag(obj); - if(quot->compiledp != F) + if(quot->code) set_quot_xt(quot,quot->code); break; } diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S index a372b2b1f5..964882c8ae 100755 --- a/vm/cpu-ppc.S +++ b/vm/cpu-ppc.S @@ -45,7 +45,7 @@ multiply_overflow: /* Note that the XT is passed to the quotation in r11 */ #define CALL_OR_JUMP_QUOT \ - lwz r11,16(r3) /* load quotation-xt slot */ XX \ + lwz r11,12(r3) /* load quotation-xt slot */ XX \ #define CALL_QUOT \ CALL_OR_JUMP_QUOT XX \ diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index ff45f48066..afda9d31cd 100755 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -25,7 +25,7 @@ pop %ebp ; \ pop %ebx -#define QUOT_XT_OFFSET 16 +#define QUOT_XT_OFFSET 12 /* 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 diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index 6b2faa1c0b..8cf7423239 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -61,7 +61,7 @@ #endif -#define QUOT_XT_OFFSET 36 +#define QUOT_XT_OFFSET 28 /* 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 diff --git a/vm/image.cpp b/vm/image.cpp index 9205aad260..f8aa07ded9 100755 --- a/vm/image.cpp +++ b/vm/image.cpp @@ -187,13 +187,13 @@ static void fixup_word(word *word) static void fixup_quotation(quotation *quot) { - if(quot->compiledp == F) - quot->xt = (void *)lazy_jit_compile; - else + if(quot->code) { code_fixup("->xt); code_fixup("->code); } + else + quot->xt = (void *)lazy_jit_compile; } static void fixup_alien(alien *d) diff --git a/vm/layouts.hpp b/vm/layouts.hpp index 40fd699e18..f8672e4522 100755 --- a/vm/layouts.hpp +++ b/vm/layouts.hpp @@ -269,8 +269,6 @@ struct quotation : public object { /* tagged */ cell array; /* tagged */ - cell compiledp; - /* tagged */ cell cached_effect; /* tagged */ cell cache_counter; diff --git a/vm/primitives.cpp b/vm/primitives.cpp index bd761625d8..2359173d9b 100755 --- a/vm/primitives.cpp +++ b/vm/primitives.cpp @@ -155,6 +155,7 @@ const primitive_type primitives[] = { primitive_reset_inline_cache_stats, primitive_inline_cache_stats, primitive_optimized_p, + primitive_quot_compiled_p, }; } diff --git a/vm/quotations.cpp b/vm/quotations.cpp index b049f528e4..e96af39766 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -272,14 +272,13 @@ void set_quot_xt(quotation *quot, code_block *code) quot->code = code; quot->xt = code->xt(); - quot->compiledp = T; } /* Allocates memory */ void jit_compile(cell quot_, bool relocating) { gc_root quot(quot_); - if(quot->compiledp != F) return; + if(quot->code) return; quotation_jit compiler(quot.value(),true,relocating); compiler.iterate_quotation(); @@ -300,10 +299,10 @@ PRIMITIVE(array_to_quotation) { quotation *quot = allot(sizeof(quotation)); quot->array = dpeek(); - quot->xt = (void *)lazy_jit_compile; - quot->compiledp = F; quot->cached_effect = F; quot->cache_counter = F; + quot->xt = (void *)lazy_jit_compile; + quot->code = NULL; drepl(tag(quot)); } @@ -354,4 +353,11 @@ VM_ASM_API cell lazy_jit_compile_impl(cell quot_, stack_frame *stack) return quot.value(); } +PRIMITIVE(quot_compiled_p) +{ + tagged quot(dpop()); + quot.untag_check(); + dpush(tag_boolean(quot->code != NULL)); +} + } diff --git a/vm/quotations.hpp b/vm/quotations.hpp index 719a94176e..c1a2a92bd1 100755 --- a/vm/quotations.hpp +++ b/vm/quotations.hpp @@ -35,4 +35,6 @@ PRIMITIVE(quotation_xt); VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack); +PRIMITIVE(quot_compiled_p); + }