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

release
Joe Groff 2010-01-28 21:48:57 -08:00
commit e068fa0e98
24 changed files with 638 additions and 468 deletions

View File

@ -554,12 +554,19 @@ M: quotation '
: fixup-header ( -- )
heap-size data-heap-size-offset fixup ;
: build-generics ( -- )
[
all-words
[ generic? ] filter
[ make-generic ] each
] with-compilation-unit ;
: build-image ( -- image )
800000 <vector> image set
20000 <hashtable> objects set
emit-image-header t, 0, 1, -1,
"Building generic words..." print flush
remake-generics
build-generics
"Serializing words..." print flush
emit-words
"Serializing JIT data..." print flush

View File

@ -53,3 +53,9 @@ IN: combinators.smart.tests
{ 2 0 } [ [ + ] nullary ] must-infer-as
{ 2 2 } [ [ [ + ] nullary ] preserving ] must-infer-as
: smart-if-test ( a b -- b )
[ < ] [ swap - ] [ - ] smart-if ;
[ 7 ] [ 10 3 smart-if-test ] unit-test
[ 16 ] [ 25 41 smart-if-test ] unit-test

View File

@ -50,4 +50,4 @@ MACRO: nullary ( quot -- quot' )
dup outputs '[ @ _ ndrop ] ;
MACRO: smart-if ( pred true false -- )
'[ _ preserving _ _ if ] ; inline
'[ _ preserving _ _ if ] ;

View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: slots arrays definitions generic hashtables summary io kernel
math namespaces make prettyprint prettyprint.config sequences assocs
@ -252,6 +252,8 @@ M: decode-error summary drop "Character decoding error" ;
M: bad-create summary drop "Bad parameters to create" ;
M: cannot-be-inline summary drop "This type of word cannot be inlined" ;
M: attempt-all-error summary drop "Nothing to attempt" ;
M: already-disposed summary drop "Attempting to operate on disposed object" ;

View File

@ -287,7 +287,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
: decode-macroblock ( -- blocks )
jpeg> components>>
[
[ mb-dim first2 * iota ]
[ mb-dim first2 * ]
[ [ decode-block ] curry replicate ] bi
] map concat ;

View File

@ -193,13 +193,12 @@ SYMBOL: interactive-vocabs
: with-interactive-vocabs ( quot -- )
[
<manifest> manifest set
"scratchpad" set-current-vocab
interactive-vocabs get only-use-vocabs
call
] with-scope ; inline
] with-manifest ; inline
: listener ( -- )
[ [ { } (listener) ] with-interactive-vocabs ] with-return ;
[ [ { } (listener) ] with-return ] with-interactive-vocabs ;
MAIN: listener

View File

@ -21,3 +21,5 @@ unit-test
[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test
[ ] [ "IN: macros.tests USE: macros MACRO: foo ( -- x ) [ ] ;" eval( -- ) ] unit-test
[ "IN: macros.tests USE: macros MACRO: foo ( -- x ) [ ] ; inline" eval( -- ) ] must-fail

View File

@ -1,4 +1,4 @@
! Copyright (C) 2007, 2009 Slava Pestov.
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel sequences words effects combinators assocs
definitions quotations namespaces memoize accessors
@ -23,6 +23,8 @@ SYNTAX: MACRO: (:) define-macro ;
PREDICATE: macro < word "macro" word-prop >boolean ;
M: macro make-inline cannot-be-inline ;
M: macro definer drop \ MACRO: \ ; ;
M: macro definition "macro" word-prop ;

View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel layouts math math.order namespaces sequences
sequences.private accessors classes.tuple arrays ;
@ -16,10 +16,8 @@ M: range length ( seq -- n ) length>> ; inline
M: range nth-unsafe ( n range -- obj ) [ step>> * ] keep from>> + ; inline
! For ranges with many elements, the default element-wise methods
! sequences define are unsuitable because they're O(n)
M: range equal? over range? [ tuple= ] [ 2drop f ] if ;
! We want M\ tuple hashcode, not M\ sequence hashcode here!
! sequences hashcode is O(n) in number of elements
M: range hashcode* tuple-hashcode ;
INSTANCE: range immutable-sequence

View File

@ -1,7 +1,8 @@
USING: accessors alien.c-types alien.data byte-arrays
combinators.short-circuit continuations destructors init kernel
locals namespaces random windows.advapi32 windows.errors
windows.kernel32 windows.types math.bitwise ;
windows.kernel32 windows.types math.bitwise sequences fry
literals ;
IN: random.windows
TUPLE: windows-rng provider type ;
@ -58,13 +59,23 @@ M: windows-rng random-bytes* ( n tuple -- bytes )
[ CryptGenRandom win32-error=0/f ] keep
] with-destructors ;
[
MS_DEF_PROV
PROV_RSA_FULL <windows-rng> system-random-generator set-global
ERROR: no-windows-crypto-provider error ;
[ MS_STRONG_PROV PROV_RSA_FULL <windows-rng> ]
[ drop MS_ENH_RSA_AES_PROV PROV_RSA_AES <windows-rng> ] recover
secure-random-generator set-global
: try-crypto-providers ( seq -- windows-rng )
[ first2 <windows-rng> ] attempt-all
dup windows-rng? [ no-windows-crypto-provider ] unless ;
[
{
${ MS_ENHANCED_PROV PROV_RSA_FULL }
${ MS_DEF_PROV PROV_RSA_FULL }
} try-crypto-providers
system-random-generator set-global
{
${ MS_STRONG_PROV PROV_RSA_FULL }
${ MS_ENH_RSA_AES_PROV PROV_RSA_AES }
} try-crypto-providers secure-random-generator set-global
] "random.windows" add-startup-hook
[

View File

@ -64,12 +64,15 @@ M: rename pprint-qualified ( rename -- )
tri
] with-pprint ;
: filter-interesting ( seq -- seq' )
[ [ vocab? ] [ extra-words? ] bi or not ] filter ;
PRIVATE>
: (pprint-manifest ( manifest -- quots )
[
[ search-vocabs>> [ '[ _ pprint-using ] , ] unless-empty ]
[ qualified-vocabs>> [ extra-words? not ] filter [ '[ _ pprint-qualified ] , ] each ]
[ qualified-vocabs>> filter-interesting [ '[ _ pprint-qualified ] , ] each ]
[ current-vocab>> [ '[ _ pprint-in ] , ] when* ]
tri
] { } make ;

View File

@ -31,32 +31,31 @@ architecture get {
! Now we have ( syntax-quot arch-quot layouts-quot ) on the stack
! Bring up a bare cross-compiling vocabulary.
"syntax" vocab vocab-words bootstrap-syntax set {
dictionary
new-classes
changed-definitions changed-generics changed-effects
outdated-generics forgotten-definitions
root-cache source-files update-map implementors-map
} [ H{ } clone swap set ] each
"syntax" vocab vocab-words bootstrap-syntax set
H{ } clone dictionary set
H{ } clone root-cache set
H{ } clone source-files set
H{ } clone update-map set
H{ } clone implementors-map set
init-caches
bootstrapping? on
call( -- )
call( -- )
! Vocabulary for slot accessors
"accessors" create-vocab drop
dummy-compiler compiler-impl set
call( -- )
call( -- )
call( -- )
! After we execute bootstrap/layouts
num-types get f <array> builtins set
bootstrapping? on
[
call( -- )
! Create some empty vocabs where the below primitives and
! classes will go
{

View File

@ -6,7 +6,7 @@ io.streams.string kernel kernel.private math math.constants
math.order namespaces parser parser.notes prettyprint
quotations random see sequences sequences.private slots
slots.private splitting strings summary threads tools.test
vectors vocabs words words.symbol fry literals ;
vectors vocabs words words.symbol fry literals memory ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
@ -443,14 +443,14 @@ TUPLE: redefinition-problem-2 ;
[ ] [
[
\ vocab tuple { "xxx" } "slots" get append
\ vocab identity-tuple { "xxx" } "slots" get append
define-tuple-class
] with-compilation-unit
all-words drop
[
\ vocab tuple "slots" get
\ vocab identity-tuple "slots" get
define-tuple-class
] with-compilation-unit
] unit-test
@ -765,3 +765,22 @@ USE: classes.struct
[ "prototype" word-prop ] map
[ '[ _ hashcode drop f ] [ drop t ] recover ] filter
] unit-test
! Make sure that tuple reshaping updates code heap roots
TUPLE: code-heap-ref ;
: code-heap-ref' ( -- a ) T{ code-heap-ref } ;
! Push foo's literal to tenured space
[ ] [ gc ] unit-test
! Reshape!
[ ] [ "IN: classes.tuple.tests USE: math TUPLE: code-heap-ref { x integer initial: 5 } ;" eval( -- ) ] unit-test
! Code heap reference
[ t ] [ code-heap-ref' code-heap-ref? ] unit-test
[ 5 ] [ code-heap-ref' x>> ] unit-test
! Data heap reference
[ t ] [ \ code-heap-ref' def>> first code-heap-ref? ] unit-test
[ 5 ] [ \ code-heap-ref' def>> first x>> ] unit-test

View File

@ -64,16 +64,6 @@ M: f process-forgotten-words drop ;
: without-optimizer ( quot -- )
[ f compiler-impl ] dip with-variable ; inline
! Trivial compiler. We don't want to touch the code heap
! during stage1 bootstrap, it would just waste time.
SINGLETON: dummy-compiler
M: dummy-compiler to-recompile f ;
M: dummy-compiler recompile drop { } ;
M: dummy-compiler process-forgotten-words drop ;
: <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
SYMBOL: definition-observers
@ -143,13 +133,15 @@ M: object bump-effect-counter* drop f ;
[ drop ] [ notify-definition-observers notify-error-observers ] if ;
: finish-compilation-unit ( -- )
[ ] [
remake-generics
to-recompile recompile
update-tuples
process-forgotten-definitions
modify-code-heap
bump-effect-counter
notify-observers ;
notify-observers
] if-bootstrapping ;
PRIVATE>

View File

@ -282,3 +282,6 @@ M: growable call-next-hooker call-next-method "growable " prepend ;
[ "IN: generic.single.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ]
[ error>> bad-dispatch-position? ]
must-fail-with
[ ] [ "IN: generic.single.tests GENERIC: foo ( -- x )" eval( -- ) ] unit-test
[ "IN: generic.single.tests GENERIC: foo ( -- x ) inline" eval( -- ) ] must-fail

View File

@ -1,4 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.algebra
combinators definitions generic hashtables kernel
@ -16,6 +16,8 @@ TUPLE: single-combination ;
PREDICATE: single-generic < generic
"combination" word-prop single-combination? ;
M: single-generic make-inline cannot-be-inline ;
GENERIC: dispatch# ( word -- n )
M: generic dispatch# "combination" word-prop dispatch# ;

View File

@ -111,11 +111,10 @@ SYMBOL: bootstrap-syntax
: with-file-vocabs ( quot -- )
[
<manifest> manifest set
"syntax" use-vocab
bootstrap-syntax get [ use-words ] when*
call
] with-scope ; inline
] with-manifest ; inline
SYMBOL: print-use-hook

View File

@ -16,7 +16,8 @@ checksum
definitions ;
: record-top-level-form ( quot file -- )
(>>top-level-form) H{ } notify-definition-observers ;
(>>top-level-form)
[ ] [ H{ } notify-definition-observers ] if-bootstrapping ;
: record-checksum ( lines source-file -- )
[ crc32 checksum-lines ] dip (>>checksum) ;

View File

@ -1,5 +1,6 @@
IN: vocabs.parser.tests
USING: vocabs.parser tools.test eval kernel accessors ;
USING: vocabs.parser tools.test eval kernel accessors definitions
compiler.units words vocabs ;
[ "FROM: kernel => doesnotexist ;" eval( -- ) ]
[ error>> T{ no-word-in-vocab { word "doesnotexist" } { vocab "kernel" } } = ]
@ -8,3 +9,43 @@ must-fail-with
[ "RENAME: doesnotexist kernel => newname" eval( -- ) ]
[ error>> T{ no-word-in-vocab { word "doesnotexist" } { vocab "kernel" } } = ]
must-fail-with
: aaa ( -- ) ;
[
[ ] [ "aaa" "vocabs.parser.tests" "uutt" add-renamed-word ] unit-test
[ ] [ "vocabs.parser.tests" dup add-qualified ] unit-test
[ aaa ] [ "uutt" search ] unit-test
[ aaa ] [ "vocabs.parser.tests:aaa" search ] unit-test
[ ] [ [ "bbb" "vocabs.parser.tests" create drop ] with-compilation-unit ] unit-test
[ "bbb" ] [ "vocabs.parser.tests:bbb" search name>> ] unit-test
[ ] [ [ \ aaa forget ] with-compilation-unit ] unit-test
[ ] [ [ "bbb" "vocabs.parser.tests" lookup forget ] with-compilation-unit ] unit-test
[ f ] [ "uutt" search ] unit-test
[ f ] [ "vocabs.parser.tests:aaa" search ] unit-test
[ ] [ "vocabs.parser.tests.foo" set-current-vocab ] unit-test
[ ] [ [ "bbb" current-vocab create drop ] with-compilation-unit ] unit-test
[ t ] [ "bbb" search >boolean ] unit-test
[ ] [ [ "vocabs.parser.tests.foo" forget-vocab ] with-compilation-unit ] unit-test
[ [ "bbb" current-vocab create drop ] with-compilation-unit ] [ error>> no-current-vocab? ] must-fail-with
[ begin-private ] [ error>> no-current-vocab? ] must-fail-with
[ end-private ] [ error>> no-current-vocab? ] must-fail-with
[ f ] [ "bbb" search >boolean ] unit-test
] with-manifest

View File

@ -1,9 +1,9 @@
! Copyright (C) 2007, 2009 Daniel Ehrenberg, Bruno Deferrari,
! Copyright (C) 2007, 2010 Daniel Ehrenberg, Bruno Deferrari,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel namespaces sequences
sets strings vocabs sorting accessors arrays compiler.units
combinators vectors splitting continuations math
combinators vectors splitting continuations math words
parser.notes ;
IN: vocabs.parser
@ -26,7 +26,6 @@ current-vocab
{ search-vocab-names hashtable }
{ search-vocabs vector }
{ qualified-vocabs vector }
{ extra-words vector }
{ auto-used vector } ;
: <manifest> ( -- manifest )
@ -34,7 +33,6 @@ current-vocab
H{ } clone >>search-vocab-names
V{ } clone >>search-vocabs
V{ } clone >>qualified-vocabs
V{ } clone >>extra-words
V{ } clone >>auto-used ;
M: manifest clone
@ -42,7 +40,6 @@ M: manifest clone
[ clone ] change-search-vocab-names
[ clone ] change-search-vocabs
[ clone ] change-qualified-vocabs
[ clone ] change-extra-words
[ clone ] change-auto-used ;
TUPLE: extra-words words ;
@ -69,10 +66,16 @@ ERROR: no-word-in-vocab word vocab ;
: (from) ( vocab words -- vocab words words' vocab )
2dup swap load-vocab ;
: extract-words ( seq vocab -- assoc' )
: extract-words ( seq vocab -- assoc )
[ words>> extract-keys dup ] [ name>> ] bi
[ swap [ 2drop ] [ no-word-in-vocab ] if ] curry assoc-each ;
: excluding-words ( seq vocab -- assoc )
[ nip words>> ] [ extract-words ] 2bi assoc-diff ;
: qualified-words ( prefix vocab -- assoc )
words>> swap [ swap [ swap ":" glue ] dip ] curry assoc-map ;
: (lookup) ( name assoc -- word/f )
at dup forward-reference? [ drop f ] when ;
@ -83,8 +86,7 @@ PRIVATE>
: set-current-vocab ( name -- )
create-vocab
[ manifest get (>>current-vocab) ]
[ words>> <extra-words> (add-qualified) ] bi ;
[ manifest get (>>current-vocab) ] [ (add-qualified) ] bi ;
: with-current-vocab ( name quot -- )
manifest get clone manifest [
@ -102,11 +104,11 @@ TUPLE: no-current-vocab ;
manifest get current-vocab>> [ no-current-vocab ] unless* ;
: begin-private ( -- )
manifest get current-vocab>> vocab-name ".private" ?tail
current-vocab name>> ".private" ?tail
[ drop ] [ ".private" append set-current-vocab ] if ;
: end-private ( -- )
manifest get current-vocab>> vocab-name ".private" ?tail
current-vocab name>> ".private" ?tail
[ set-current-vocab ] [ drop ] if ;
: using-vocab? ( vocab -- ? )
@ -137,10 +139,7 @@ TUPLE: no-current-vocab ;
TUPLE: qualified vocab prefix words ;
: <qualified> ( vocab prefix -- qualified )
2dup
[ load-vocab words>> ] [ CHAR: : suffix ] bi*
[ swap [ prepend ] dip ] curry assoc-map
qualified boa ;
(from) qualified-words qualified boa ;
: add-qualified ( vocab prefix -- )
<qualified> (add-qualified) ;
@ -156,7 +155,7 @@ TUPLE: from vocab names words ;
TUPLE: exclude vocab names words ;
: <exclude> ( vocab words -- from )
(from) [ nip words>> ] [ extract-words ] 2bi assoc-diff exclude boa ;
(from) excluding-words exclude boa ;
: add-words-excluding ( vocab words -- )
<exclude> (add-qualified) ;
@ -207,3 +206,45 @@ PRIVATE>
: search ( name -- word/f )
manifest get search-manifest ;
<PRIVATE
GENERIC: update ( search-path-elt -- valid? )
: trim-forgotten ( qualified-vocab -- valid? )
[ [ nip "forgotten" word-prop not ] assoc-filter ] change-words
words>> assoc-empty? not ;
M: from update trim-forgotten ;
M: rename update trim-forgotten ;
M: extra-words update trim-forgotten ;
M: exclude update trim-forgotten ;
M: qualified update
dup vocab>> vocab [
dup [ prefix>> ] [ vocab>> load-vocab ] bi qualified-words
>>words
] [ drop f ] if ;
M: vocab update dup name>> vocab eq? ;
: update-manifest ( manifest -- )
[ dup [ name>> vocab ] when ] change-current-vocab
[ [ drop vocab ] assoc-filter ] change-search-vocab-names
dup search-vocab-names>> keys [ vocab ] V{ } map-as >>search-vocabs
qualified-vocabs>> [ update ] filter! drop ;
M: manifest definitions-changed ( assoc manifest -- )
nip update-manifest ;
PRIVATE>
: with-manifest ( quot -- )
<manifest> manifest [
[ call ] [
[ manifest get add-definition-observer call ]
[ manifest get remove-definition-observer ]
[ ]
cleanup
] if-bootstrapping
] with-variable ; inline

View File

@ -87,7 +87,11 @@ M: word subwords drop f ;
: make-deprecated ( word -- )
t "deprecated" set-word-prop ;
: make-inline ( word -- )
ERROR: cannot-be-inline word ;
GENERIC: make-inline ( word -- )
M: word make-inline
dup inline? [ drop ] [
[ t "inline" set-word-prop ]
[ changed-effect ]
@ -155,7 +159,12 @@ ERROR: bad-create name vocab ;
: create ( name vocab -- word )
check-create 2dup lookup
dup [ 2nip ] [ drop vocab-name <word> dup reveal ] if ;
dup [ 2nip ] [
drop
vocab-name <word>
dup reveal
dup changed-definition
] if ;
: constructor-word ( name vocab -- word )
[ "<" ">" surround ] dip create ;

View File

@ -110,6 +110,31 @@ struct object_become_visitor {
}
};
struct code_block_become_visitor {
slot_visitor<slot_become_visitor> *workhorse;
explicit code_block_become_visitor(slot_visitor<slot_become_visitor> *workhorse_) :
workhorse(workhorse_) {}
void operator()(code_block *compiled, cell size)
{
workhorse->visit_code_block_objects(compiled);
workhorse->visit_embedded_literals(compiled);
}
};
struct code_block_write_barrier_visitor {
code_heap *code;
explicit code_block_write_barrier_visitor(code_heap *code_) :
code(code_) {}
void operator()(code_block *compiled, cell size)
{
code->write_barrier(compiled);
}
};
/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
to coalesce equal but distinct quotations and wrappers. */
void factor_vm::primitive_become()
@ -134,6 +159,7 @@ void factor_vm::primitive_become()
}
/* Update all references to old objects to point to new objects */
{
slot_visitor<slot_become_visitor> workhorse(this,slot_become_visitor(&become_map));
workhorse.visit_roots();
workhorse.visit_contexts();
@ -141,10 +167,18 @@ void factor_vm::primitive_become()
object_become_visitor object_visitor(&workhorse);
each_object(object_visitor);
code_block_become_visitor code_block_visitor(&workhorse);
each_code_block(code_block_visitor);
}
/* Since we may have introduced old->new references, need to revisit
all objects on a minor GC. */
all objects and code blocks on a minor GC. */
data->mark_all_cards();
primitive_minor_gc();
{
code_block_write_barrier_visitor code_block_visitor(code);
each_code_block(code_block_visitor);
}
}
}