! 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 ;
{ "char*" utf8 } "char*" typedef
"char*" "uchar*" typedef
-{ "char*" utf16n } "wchar_t*" typedef
array>> '
quotation [
emit ! array
- f ' emit ! compiled
f ' emit ! cached-effect
f ' emit ! cache-counter
0 emit ! xt
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 ;
"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
[ dup infer out>> ] dip
'[ @ _ _ nsequence ] ;
-: output>array ( quot -- newquot )
- { } output>sequence ; inline
+MACRO: output>array ( quot -- newquot )
+ '[ _ { } output>sequence ] ;
MACRO: input<sequence ( quot -- newquot )
[ infer in>> ] keep
MACRO: reduce-outputs ( quot operation -- newquot )
[ dup infer out>> 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
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 ] ;
: 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
size-read-fd <fd> init-fd <input-port> >>size
data-read-fd <fd> >>data ;
-M: unix (init-stdio)
+M: unix init-stdio
<stdin> <input-port>
1 <fd> <output-port>
- 2 <fd> <output-port> t ;
+ 2 <fd> <output-port>
+ set-stdio ;
! mx io-task for embedding an fd-based mx inside another mx
TUPLE: mx-port < port mx ;
-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
: 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
! 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
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 <process-reader*>
+ [ 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
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: io help.markup help.syntax quotations ;
+IN: io.streams.null
+
+HELP: null-reader
+{ $class-description "Singleton class of null reader streams." } ;
+
+HELP: null-writer
+{ $class-description "Singleton class of null writer streams." } ;
+
+HELP: with-null-reader
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation with " { $link input-stream } " rebound to a " { $link null-reader } " which always produces EOF." } ;
+
+HELP: with-null-writer
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation with " { $link output-stream } " rebound to a " { $link null-writer } " which ignores all output." } ;
+
+ARTICLE: "io.streams.null" "Null streams"
+"The " { $vocab-link "io.streams.null" } " vocabulary implements a pair of streams which are useful for testing. The null reader always yields EOF and the null writer ignores all output. Conceptually, they are similar to " { $snippet "/dev/null" } " on a Unix system."
+$nl
+"Null readers:"
+{ $subsection null-reader }
+{ $subsection with-null-writer }
+"Null writers:"
+{ $subsection null-writer }
+{ $subsection with-null-reader } ;
+
+ABOUT: "io.streams.null"
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2007, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel io destructors io.streams.plain ;
+IN: io.streams.null
+
+SINGLETONS: null-reader null-writer ;
+UNION: null-stream null-reader null-writer ;
+INSTANCE: null-writer plain-writer
+
+M: null-stream dispose drop ;
+
+M: null-reader stream-element-type drop +byte+ ;
+M: null-reader stream-readln drop f ;
+M: null-reader stream-read1 drop f ;
+M: null-reader stream-read-until 2drop f f ;
+M: null-reader stream-read 2drop f ;
+
+M: null-writer stream-element-type drop +byte+ ;
+M: null-writer stream-write1 2drop ;
+M: null-writer stream-write 2drop ;
+M: null-writer stream-flush drop ;
+
+: with-null-reader ( quot -- )
+ null-reader swap with-input-stream* ; inline
+
+: with-null-writer ( quot -- )
+ null-writer swap with-output-stream* ; inline
--- /dev/null
+Dummy implementation of stream protocol
! 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
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? [
{
: 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 ( -- )
] [ 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
#! 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 ;
] 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
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 -- )
[
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
[ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ;
: run-temp-image ( -- )
- vm
- "-i=" "test.image" temp-file append
- 2array
- <process> 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
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
! 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
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
"quotation" "quotations" create {
{ "array" { "array" "arrays" } read-only }
- { "compiled" read-only }
"cached-effect"
"cache-counter"
} define-builtin
{ "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
! 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
HOOK: init-io io-backend ( -- )
-HOOK: (init-stdio) io-backend ( -- stdin stdout stderr ? )
-
-: 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 <decoder> ]
- [ utf8 <encoder> ]
- [ utf8 <encoder> ] tri*
- ] [
- 3drop
- null-reader null-writer null-writer
- ] if set-stdio ;
+HOOK: init-stdio io-backend ( -- )
+
+: set-stdio ( input output error -- )
+ [ utf8 <decoder> input-stream set-global ]
+ [ utf8 <encoder> output-stream set-global ]
+ [ utf8 <encoder> error-stream set-global ] tri* ;
HOOK: io-multiplex io-backend ( us -- )
: stdout-handle ( -- alien ) 12 getenv ;
: stderr-handle ( -- alien ) 61 getenv ;
-: init-c-stdio ( -- stdin stdout stderr )
+: init-c-stdio ( -- )
stdin-handle <c-reader>
stdout-handle <c-writer>
- stderr-handle <c-writer> ;
+ stderr-handle <c-writer>
+ 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) ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: io help.markup help.syntax quotations ;
-IN: io.streams.null
-
-HELP: null-reader
-{ $class-description "Singleton class of null reader streams." } ;
-
-HELP: null-writer
-{ $class-description "Singleton class of null writer streams." } ;
-
-HELP: with-null-reader
-{ $values { "quot" quotation } }
-{ $description "Calls the quotation with " { $link input-stream } " rebound to a " { $link null-reader } " which always produces EOF." } ;
-
-HELP: with-null-writer
-{ $values { "quot" quotation } }
-{ $description "Calls the quotation with " { $link output-stream } " rebound to a " { $link null-writer } " which ignores all output." } ;
-
-ARTICLE: "io.streams.null" "Null streams"
-"The " { $vocab-link "io.streams.null" } " vocabulary implements a pair of streams which are useful for testing. The null reader always yields EOF and the null writer ignores all output. Conceptually, they are similar to " { $snippet "/dev/null" } " on a Unix system."
-$nl
-"Null readers:"
-{ $subsection null-reader }
-{ $subsection with-null-writer }
-"Null writers:"
-{ $subsection null-writer }
-{ $subsection with-null-reader } ;
-
-ABOUT: "io.streams.null"
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2007, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io destructors io.streams.plain ;
-IN: io.streams.null
-
-SINGLETONS: null-reader null-writer ;
-UNION: null-stream null-reader null-writer ;
-INSTANCE: null-writer plain-writer
-
-M: null-stream dispose drop ;
-
-M: null-reader stream-element-type drop +byte+ ;
-M: null-reader stream-readln drop f ;
-M: null-reader stream-read1 drop f ;
-M: null-reader stream-read-until 2drop f f ;
-M: null-reader stream-read 2drop f ;
-
-M: null-writer stream-element-type drop +byte+ ;
-M: null-writer stream-write1 2drop ;
-M: null-writer stream-write 2drop ;
-M: null-writer stream-flush drop ;
-
-: with-null-reader ( quot -- )
- null-reader swap with-input-stream* ; inline
-
-: with-null-writer ( quot -- )
- null-writer swap with-output-stream* ; inline
+++ /dev/null
-Dummy implementation of stream protocol
--- /dev/null
+Alec Berryman
--- /dev/null
+USING: help.markup help.syntax kernel math ;
+IN: bloom-filters
+
+HELP: <bloom-filter>
+{ $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 <bloom-filter> }
+{ $subsection bloom-filter-insert }
+{ $subsection bloom-filter-member? } ;
+
+ABOUT: "bloom-filters"
--- /dev/null
+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 <bloom-filter> n-hashes>> ] unit-test
+[ 47965 ] [ 0.01 5000 <bloom-filter> bits>> length ] unit-test
+[ 5000 ] [ 0.01 5000 <bloom-filter> maximum-n-objects>> ] unit-test
+[ 0 ] [ 0.01 5000 <bloom-filter> 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 <bloom-filter> ] [ capacity-error? ] must-fail-with
+
+! Other error conditions.
+[ 1.0 2000 <bloom-filter> ] [ invalid-error-rate? ] must-fail-with
+[ 20 2000 <bloom-filter> ] [ invalid-error-rate? ] must-fail-with
+[ 0.0 2000 <bloom-filter> ] [ invalid-error-rate? ] must-fail-with
+[ -2 2000 <bloom-filter> ] [ invalid-error-rate? ] must-fail-with
+[ 0.5 0 <bloom-filter> ] [ invalid-n-objects? ] must-fail-with
+[ 0.5 -5 <bloom-filter> ] [ 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 <bit-array> [ set-indices ] keep ] unit-test
+
+: empty-bloom-filter ( -- bloom-filter )
+ 0.01 2000 <bloom-filter> ;
+
+[ 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
--- /dev/null
+! 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 ;
+
+<PRIVATE
+
+! infix doesn't like ^
+: pow ( x y -- z )
+ ^ ; inline
+
+:: bits-to-satisfy-error-rate ( hashes error objects -- size )
+ [infix -(objects * hashes) / log(1 - pow(error, (1/hashes))) infix]
+ ceiling >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>
+
+: <bloom-filter> ( error-rate number-objects -- bloom-filter )
+ [ validate-constraints ] 2keep
+ [ size-bloom-filter <bit-array> ] keep
+ 0 ! initially empty
+ bloom-filter boa ;
+
+<PRIVATE
+
+! See "Bloom Filters in Probabilistic Verification" by Peter C. Dillinger and
+! Panagiotis Manolios, section 5.2, "Enhanced Double Hashing":
+! http://www.cc.gatech.edu/~manolios/research/bloom-filters-verification.html
+:: enhanced-double-hash ( index hash0 hash1 -- hash )
+ [infix hash0 + (index * hash1) + ((pow(index, 3) - index) / 6) infix] ;
+
+: enhanced-double-hashes ( hash0 hash1 n -- seq )
+ [0,b)
+ [ '[ _ _ enhanced-double-hash ] ] dip
+ swap map ;
+
+! Make sure it's a fixnum here to speed up double-hashing.
+: hashcodes-from-hashcode ( n -- n n )
+ dup most-positive-fixnum >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? ;
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 }
}
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 <process-reader*>
- [ stream-contents ] [ dup wait-for-process ] bi*
- 0 = [ 2drop ] [ output-process-error ] if ;
-
HOOK: really-delete-tree os ( path -- )
M: windows really-delete-tree
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 }
}
else
{
quotation *quot = untag<quotation>(tagged_quot);
- if(quot->compiledp == F)
- return w->xt;
- else
+ if(quot->code)
return quot->xt;
+ else
+ return w->xt;
}
}
case QUOTATION_TYPE:
{
quotation *q = (quotation *)object;
- if(q->compiledp != F)
+ if(q->code)
mark_code_block(q->code);
break;
}
{
quotation *quot = untag<quotation>(obj);
- if(quot->compiledp != F)
+ if(quot->code)
quot->code = forward_xt(quot->code);
}
break;
case QUOTATION_TYPE:
{
quotation *quot = untag<quotation>(obj);
- if(quot->compiledp != F)
+ if(quot->code)
set_quot_xt(quot,quot->code);
break;
}
/* 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 \
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
#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
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)
/* tagged */
cell array;
/* tagged */
- cell compiledp;
- /* tagged */
cell cached_effect;
/* tagged */
cell cache_counter;
primitive_reset_inline_cache_stats,
primitive_inline_cache_stats,
primitive_optimized_p,
+ primitive_quot_compiled_p,
};
}
quot->code = code;
quot->xt = code->xt();
- quot->compiledp = T;
}
/* Allocates memory */
void jit_compile(cell quot_, bool relocating)
{
gc_root<quotation> quot(quot_);
- if(quot->compiledp != F) return;
+ if(quot->code) return;
quotation_jit compiler(quot.value(),true,relocating);
compiler.iterate_quotation();
{
quotation *quot = allot<quotation>(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<quotation>(quot));
}
return quot.value();
}
+PRIMITIVE(quot_compiled_p)
+{
+ tagged<quotation> quot(dpop());
+ quot.untag_check();
+ dpush(tag_boolean(quot->code != NULL));
+}
+
}
VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack);
+PRIMITIVE(quot_compiled_p);
+
}
projects / factor.git / commitdiff