steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2009-05-12 16:23:26 -05:00
parent e0f4b18709 8ddbfb5161
commit 3987468ff3
36 changed files with 428 additions and 106 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
basis/alien/arrays/arrays.factor
View File

@ -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

1
basis/bootstrap/image/image.factor
View File

@ -448,7 +448,6 @@ M: quotation '
array>> '
quotation [
emit ! array
f ' emit ! compiled
f ' emit ! cached-effect
f ' emit ! cache-counter
0 emit ! xt

12
basis/bootstrap/stage2.factor
View File

@ -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

12
basis/combinators/smart/smart.factor
View File

@ -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<sequence ( quot -- newquot )
[ infer in>> ] keep
@ -25,8 +25,8 @@ MACRO: input<sequence-unsafe ( quot -- newquot )
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
@ -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 ] ;

2
basis/compiler/constants/constants.factor
View File

@ -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

5
basis/io/backend/unix/unix.factor
View File

@ -173,10 +173,11 @@ M: stdin refill
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 ;

18
basis/io/backend/windows/nt/nt.factor
View File

@ -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

27
basis/io/launcher/launcher.factor
View File

@ -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 <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

0
core/io/streams/null/authors.txt → basis/io/streams/null/authors.txt
View File

0
core/io/streams/null/null-docs.factor → basis/io/streams/null/null-docs.factor
View File

0
core/io/streams/null/null.factor → basis/io/streams/null/null.factor
View File

0
core/io/streams/null/summary.txt → basis/io/streams/null/summary.txt
View File

46
basis/tools/deploy/shaker/shaker.factor
View File

@ -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 -- )
[

9
basis/tools/deploy/test/test.factor
View File

@ -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
<process> swap >>command +closed+ >>stdin try-process ;
os macosx?
"resource:Factor.app/Contents/MacOS/factor" normalize-path vm ?
"-i=" "test.image" temp-file append 2array try-output-process ;

2
basis/ui/gadgets/worlds/worlds.factor
View File

@ -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

5
basis/windows/types/types.factor
View File

@ -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

2
core/bootstrap/primitives.factor
View File

@ -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

22
core/io/backend/backend.factor
View File

@ -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 <decoder> ]
[ utf8 <encoder> ]
[ utf8 <encoder> ] tri*
] [
3drop
null-reader null-writer null-writer
] if set-stdio ;
: 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 -- )

7
core/io/streams/c/c.factor
View File

@ -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 <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) ;

1
extra/bloom-filters/authors.txt Normal file
View File

@ -0,0 +1 @@
Alec Berryman

38
extra/bloom-filters/bloom-filters-docs.factor Normal file
View File

@ -0,0 +1,38 @@
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"

81
extra/bloom-filters/bloom-filters-tests.factor Normal file
View File

@ -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 <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

158
extra/bloom-filters/bloom-filters.factor Normal file
View File

@ -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 ;
<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? ;

14
extra/hello-ui/deploy.factor
View File

@ -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 }
}

12
extra/mason/common/common.factor
View File

@ -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 <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

14
extra/spheres/deploy.factor
View File

@ -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 }
}

8
vm/code_block.cpp
View File

@ -68,10 +68,10 @@ static void *xt_pic(word *w, cell tagged_quot)
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;
}
}
@ -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;
}

4
vm/code_heap.cpp
View File

@ -158,7 +158,7 @@ void forward_object_xts()
{
quotation *quot = untag<quotation>(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<quotation>(obj);
if(quot->compiledp != F)
if(quot->code)
set_quot_xt(quot,quot->code);
break;
}

2
vm/cpu-ppc.S
View File

@ -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 \

2
vm/cpu-x86.32.S
View File

@ -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

2
vm/cpu-x86.64.S
View File

@ -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

6
vm/image.cpp
View File

@ -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(&quot->xt);
code_fixup(&quot->code);
}
else
quot->xt = (void *)lazy_jit_compile;
}
static void fixup_alien(alien *d)

2
vm/layouts.hpp
View File

@ -269,8 +269,6 @@ struct quotation : public object {
/* tagged */
cell array;
/* tagged */
cell compiledp;
/* tagged */
cell cached_effect;
/* tagged */
cell cache_counter;

1
vm/primitives.cpp
View File

@ -155,6 +155,7 @@ const primitive_type primitives[] = {
primitive_reset_inline_cache_stats,
primitive_inline_cache_stats,
primitive_optimized_p,
primitive_quot_compiled_p,
};
}

14
vm/quotations.cpp
View File

@ -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<quotation> 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<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));
}
@ -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<quotation> quot(dpop());
quot.untag_check();
dpush(tag_boolean(quot->code != NULL));
}
}

2
vm/quotations.hpp
View File

@ -35,4 +35,6 @@ PRIMITIVE(quotation_xt);
VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack);
PRIMITIVE(quot_compiled_p);
}