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

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

db4
Doug Coleman 2009-11-13 15:03:16 -06:00
parent c6ddc40958 ea36783fb3
commit ccd35c2f4f
19 changed files with 218 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
basis/compiler/tree/propagation/branches/branches.factor
View File

@ -97,7 +97,7 @@ M: #phi propagate-before ( #phi -- )
constraints get last update-constraints ;
: branch-phi-constraints ( output values booleans -- )
{
{
{
{ { t } { f } }
[
@ -130,6 +130,22 @@ M: #phi propagate-before ( #phi -- )
swap t-->
]
}
{
{ { t f } { t } }
[
first =f
condition-value get =t /\
swap f-->
]
}
{
{ { t } { t f } }
[
second =f
condition-value get =f /\
swap f-->
]
}
{
{ { t f } { } }
[

19
basis/compiler/tree/propagation/call-effect/call-effect.factor
View File

@ -4,7 +4,7 @@ USING: accessors combinators combinators.private effects fry
kernel kernel.private make sequences continuations quotations
words math stack-checker combinators.short-circuit
stack-checker.transforms compiler.tree.propagation.info
compiler.tree.propagation.inlining ;
compiler.tree.propagation.inlining compiler.units ;
IN: compiler.tree.propagation.call-effect
! call( and execute( have complex expansions.
@ -15,22 +15,19 @@ IN: compiler.tree.propagation.call-effect
! and compare it with declaration. If matches, call it unsafely.
! - Fallback. If the above doesn't work, call it and compare the datastack before
! and after to make sure it didn't mess anything up.
! - Inline caches and cached effects are invalidated whenever a macro is redefined, or
! a word's effect changes, by comparing a global counter against the counter value
! last observed. The counter is incremented by compiler.units.
! execute( uses a similar strategy.
: definition-counter ( -- n ) 46 getenv ; inline
TUPLE: inline-cache value counter ;
: inline-cache-hit? ( word/quot ic -- ? )
{
[ nip value>> ]
[ value>> eq? ]
[ nip counter>> definition-counter eq? ]
} 2&& ; inline
{ [ value>> eq? ] [ nip counter>> effect-counter eq? ] } 2&& ; inline
: update-inline-cache ( word/quot ic -- )
[ definition-counter ] dip
[ effect-counter ] dip
[ (>>value) ] [ (>>counter) ] bi-curry bi* ; inline
SINGLETON: +unknown+
@ -64,10 +61,10 @@ M: compose cached-effect
[ infer ] [ 2drop +unknown+ ] recover ;
: cached-effect-valid? ( quot -- ? )
cache-counter>> definition-counter eq? ; inline
cache-counter>> effect-counter eq? ; inline
: save-effect ( effect quot -- )
[ definition-counter ] dip
[ effect-counter ] dip
[ (>>cached-effect) ] [ (>>cache-counter) ] bi-curry bi* ;
M: quotation cached-effect

8
basis/compiler/tree/propagation/constraints/constraints.factor
View File

@ -39,8 +39,8 @@ M: true-constraint assume*
bi ;
M: true-constraint satisfied?
value>> value-info class>>
{ [ true-class? ] [ null-class? not ] } 1&& ;
value>> value-info*
[ class>> true-class? ] [ drop f ] if ;
TUPLE: false-constraint value ;
@ -52,8 +52,8 @@ M: false-constraint assume*
bi ;
M: false-constraint satisfied?
value>> value-info class>>
{ [ false-class? ] [ null-class? not ] } 1&& ;
value>> value-info*
[ class>> false-class? ] [ drop f ] if ;
! Class constraints
TUPLE: class-constraint value class ;

5
basis/compiler/tree/propagation/info/info.factor
View File

@ -294,8 +294,11 @@ DEFER: (value-info-union)
! Assoc stack of current value --> info mapping
SYMBOL: value-infos
: value-info* ( value -- info ? )
resolve-copy value-infos get assoc-stack [ null-info or ] [ >boolean ] bi ; inline
: value-info ( value -- info )
resolve-copy value-infos get assoc-stack null-info or ;
value-info* drop ;
: set-value-info ( info value -- )
resolve-copy value-infos get last set-at ;

17
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -224,6 +224,14 @@ IN: compiler.tree.propagation.tests
[ t ] [ [ over [ drop f ] when [ "A" throw ] unless ] final-classes first false-class? ] unit-test
[ V{ fixnum } ] [
[
[ { fixnum } declare ] [ drop f ] if
dup [ dup 13 eq? [ t ] [ f ] if ] [ t ] if
[ "Oops" throw ] when
] final-classes
] unit-test
[ V{ fixnum } ] [
[
>fixnum
@ -231,6 +239,14 @@ IN: compiler.tree.propagation.tests
] final-classes
] unit-test
[ ] [
[
dup dup dup [ 100 < ] [ drop f ] if dup
[ 2drop f ] [ 2drop f ] if
[ ] [ dup [ ] [ ] if ] if
] final-info drop
] unit-test
[ V{ fixnum } ] [
[ { fixnum } declare (clone) ] final-classes
] unit-test
@ -925,3 +941,4 @@ M: tuple-with-read-only-slot clone
! Could be bignum not integer but who cares
[ V{ integer } ] [ [ 10 >bignum bitand ] final-classes ] unit-test

9
basis/compiler/tree/propagation/transforms/transforms.factor
View File

@ -6,7 +6,7 @@ stack-checker.dependencies quotations classes.tuple.private math
math.partial-dispatch math.private math.intervals sets.private
math.floats.private math.integers.private layouts math.order
vectors hashtables combinators effects generalizations assocs
sets combinators.short-circuit sequences.private locals
sets combinators.short-circuit sequences.private locals growable
stack-checker namespaces compiler.tree.propagation.info ;
IN: compiler.tree.propagation.transforms
@ -300,3 +300,10 @@ CONSTANT: lookup-table-at-max 256
tester '[ _ filter ] ;
\ intersect [ intersect-quot ] 1 define-partial-eval
! Speeds up sum-file, sort and reverse-complement benchmarks by
! compiling decoder-readln better
\ push [
in-d>> second value-info class>> growable class<=
[ \ push def>> ] [ f ] if
] "custom-inlining" set-word-prop

5
basis/macros/macros.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel sequences words effects combinators assocs
definitions quotations namespaces memoize accessors ;
definitions quotations namespaces memoize accessors
compiler.units ;
IN: macros
<PRIVATE
@ -28,3 +29,5 @@ M: macro definition "macro" word-prop ;
M: macro reset-word
[ call-next-method ] [ f "macro" set-word-prop ] bi ;
M: macro bump-effect-counter* drop t ;

2
basis/stack-checker/alien/alien.factor
View File

@ -69,6 +69,6 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
pop-literal nip >>abi
pop-literal nip >>parameters
pop-literal nip >>return
"( callback )" f <word> >>xt
"( callback )" <uninterned-word> >>xt
dup callback-bottom
#alien-callback, ;

171
core/bootstrap/syntax.factor
View File

@ -1,90 +1,93 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words words.symbol sequences vocabs kernel ;
USING: words words.symbol sequences vocabs kernel
compiler.units ;
IN: bootstrap.syntax
"syntax" create-vocab drop
[
"syntax" create-vocab drop
{
"!"
"\""
"#!"
"("
"(("
":"
";"
"<PRIVATE"
"BIN:"
"B{"
"BV{"
"C:"
"CHAR:"
"DEFER:"
"ERROR:"
"FORGET:"
"GENERIC#"
"GENERIC:"
"HEX:"
"HOOK:"
"H{"
"IN:"
"INSTANCE:"
"M:"
"MAIN:"
"MATH:"
"MIXIN:"
"NAN:"
"OCT:"
"P\""
"POSTPONE:"
"PREDICATE:"
"PRIMITIVE:"
"PRIVATE>"
"SBUF\""
"SINGLETON:"
"SINGLETONS:"
"SYMBOL:"
"SYMBOLS:"
"CONSTANT:"
"TUPLE:"
"SLOT:"
"T{"
"UNION:"
"INTERSECTION:"
"USE:"
"UNUSE:"
"USING:"
"QUALIFIED:"
"QUALIFIED-WITH:"
"FROM:"
"EXCLUDE:"
"RENAME:"
"ALIAS:"
"SYNTAX:"
"V{"
"W{"
"["
"\\"
"M\\"
"]"
"delimiter"
"deprecated"
"f"
"flushable"
"foldable"
"inline"
"recursive"
"t"
"{"
"}"
"CS{"
"<<"
">>"
"call-next-method"
"initial:"
"read-only"
"call("
"execute("
} [ "syntax" create drop ] each
{
"!"
"\""
"#!"
"("
"(("
":"
";"
"<PRIVATE"
"BIN:"
"B{"
"BV{"
"C:"
"CHAR:"
"DEFER:"
"ERROR:"
"FORGET:"
"GENERIC#"
"GENERIC:"
"HEX:"
"HOOK:"
"H{"
"IN:"
"INSTANCE:"
"M:"
"MAIN:"
"MATH:"
"MIXIN:"
"NAN:"
"OCT:"
"P\""
"POSTPONE:"
"PREDICATE:"
"PRIMITIVE:"
"PRIVATE>"
"SBUF\""
"SINGLETON:"
"SINGLETONS:"
"SYMBOL:"
"SYMBOLS:"
"CONSTANT:"
"TUPLE:"
"SLOT:"
"T{"
"UNION:"
"INTERSECTION:"
"USE:"
"UNUSE:"
"USING:"
"QUALIFIED:"
"QUALIFIED-WITH:"
"FROM:"
"EXCLUDE:"
"RENAME:"
"ALIAS:"
"SYNTAX:"
"V{"
"W{"
"["
"\\"
"M\\"
"]"
"delimiter"
"deprecated"
"f"
"flushable"
"foldable"
"inline"
"recursive"
"t"
"{"
"}"
"CS{"
"<<"
">>"
"call-next-method"
"initial:"
"read-only"
"call("
"execute("
} [ "syntax" create drop ] each
"t" "syntax" lookup define-symbol
"t" "syntax" lookup define-symbol
] with-compilation-unit

5
core/classes/algebra/algebra-tests.factor
View File

@ -37,6 +37,8 @@ INTERSECTION: empty-intersection ;
INTERSECTION: generic-class generic class ;
UNION: union-with-one-member a ;
! class<=
[ t ] [ \ fixnum \ integer class<= ] unit-test
[ t ] [ \ fixnum \ fixnum class<= ] unit-test
@ -122,6 +124,9 @@ INTERSECTION: generic-class generic class ;
[ t ] [ generic-class generic class<= ] unit-test
[ t ] [ generic-class \ class class<= ] unit-test
[ t ] [ a union-with-one-member class<= ] unit-test
[ f ] [ union-with-one-member class-not integer class<= ] unit-test
! class-and
: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;

12
core/classes/algebra/algebra.factor
View File

@ -9,11 +9,14 @@ IN: classes.algebra
TUPLE: anonymous-union { members read-only } ;
C: <anonymous-union> anonymous-union
: <anonymous-union> ( members -- class )
[ null eq? not ] filter prune
dup length 1 = [ first ] [ anonymous-union boa ] if ;
TUPLE: anonymous-intersection { participants read-only } ;
C: <anonymous-intersection> anonymous-intersection
: <anonymous-intersection> ( participants -- class )
prune dup length 1 = [ first ] [ anonymous-intersection boa ] if ;
TUPLE: anonymous-complement { class read-only } ;
@ -114,6 +117,7 @@ M: word valid-class? drop f ;
[ class-not normalize-class ] map
<anonymous-union>
] }
[ <anonymous-complement> ]
} cond ;
: left-anonymous-complement<= ( first second -- ? )
@ -133,8 +137,10 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
: (class<=) ( first second -- ? )
2dup eq? [ 2drop t ] [
[ normalize-class ] bi@
2dup superclass<= [ 2drop t ] [
[ normalize-class ] bi@ {
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ dup empty-intersection? ] [ 2drop t ] }
{ [ over empty-union? ] [ 2drop t ] }
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }

2
core/compiler/units/units-tests.factor
View File

@ -7,7 +7,7 @@ IN: compiler.units.tests
! Non-optimizing compiler bugs
[ 1 1 ] [
"A" "B" <word> [ [ [ 1 ] dip ] 2array 1array modify-code-heap ] keep
"A" <uninterned-word> [ [ [ 1 ] dip ] 2array 1array modify-code-heap ] keep
1 swap execute
] unit-test

42
core/compiler/units/units.factor
View File

@ -3,7 +3,8 @@
USING: accessors arrays kernel continuations assocs namespaces
sequences words vocabs definitions hashtables init sets
math math.order classes classes.algebra classes.tuple
classes.tuple.private generic source-files.errors ;
classes.tuple.private generic source-files.errors
kernel.private ;
IN: compiler.units
SYMBOL: old-definitions
@ -15,12 +16,16 @@ TUPLE: redefine-error def ;
\ redefine-error boa
{ { "Continue" t } } throw-restarts drop ;
<PRIVATE
: add-once ( key assoc -- )
2dup key? [ over redefine-error ] when conjoin ;
: (remember-definition) ( definition loc assoc -- )
[ over set-where ] dip add-once ;
PRIVATE>
: remember-definition ( definition loc -- )
new-definitions get first (remember-definition) ;
@ -44,6 +49,8 @@ HOOK: to-recompile compiler-impl ( -- words )
HOOK: process-forgotten-words compiler-impl ( words -- )
: compile ( words -- ) recompile modify-code-heap ;
! Non-optimizing compiler
M: f recompile
[ dup def>> ] { } map>assoc ;
@ -90,6 +97,17 @@ GENERIC: definitions-changed ( assoc obj -- )
definition-observers get
[ definitions-changed ] with each ;
! Incremented each time stack effects potentially changed, used
! by compiler.tree.propagation.call-effect for call( and execute(
! inline caching
: effect-counter ( -- n ) 46 getenv ; inline
GENERIC: bump-effect-counter* ( defspec -- ? )
M: object bump-effect-counter* drop f ;
<PRIVATE
: changed-vocabs ( assoc -- vocabs )
[ drop word? ] assoc-filter
[ drop vocabulary>> dup [ vocab ] when dup ] assoc-map ;
@ -102,22 +120,34 @@ GENERIC: definitions-changed ( assoc obj -- )
dup changed-definitions get update
dup dup changed-vocabs update ;
: compile ( words -- ) recompile modify-code-heap ;
: process-forgotten-definitions ( -- )
forgotten-definitions get keys
[ [ word? ] filter process-forgotten-words ]
[ [ delete-definition-errors ] each ]
bi ;
: bump-effect-counter? ( -- ? )
changed-effects get new-words get assoc-diff assoc-empty? not
changed-definitions get [ drop bump-effect-counter* ] assoc-any?
or ;
: bump-effect-counter ( -- )
bump-effect-counter? [ 46 getenv 0 or 1 + 46 setenv ] when ;
: notify-observers ( -- )
updated-definitions dup assoc-empty?
[ drop ] [ notify-definition-observers notify-error-observers ] if ;
: finish-compilation-unit ( -- )
remake-generics
to-recompile recompile
update-tuples
process-forgotten-definitions
modify-code-heap
updated-definitions dup assoc-empty?
[ drop ] [ notify-definition-observers notify-error-observers ] if ;
bump-effect-counter
notify-observers ;
PRIVATE>
: with-nested-compilation-unit ( quot -- )
[
@ -126,6 +156,7 @@ GENERIC: definitions-changed ( assoc obj -- )
H{ } clone changed-effects set
H{ } clone outdated-generics set
H{ } clone outdated-tuples set
H{ } clone new-words set
H{ } clone new-classes set
[ finish-compilation-unit ] [ ] cleanup
] with-scope ; inline
@ -138,6 +169,7 @@ GENERIC: definitions-changed ( assoc obj -- )
H{ } clone outdated-generics set
H{ } clone forgotten-definitions set
H{ } clone outdated-tuples set
H{ } clone new-words set
H{ } clone new-classes set
<definitions> new-definitions set
<definitions> old-definitions set

8
core/definitions/definitions.factor
View File

@ -21,8 +21,16 @@ SYMBOL: changed-generics
SYMBOL: outdated-generics
SYMBOL: new-words
SYMBOL: new-classes
: new-word ( word -- )
dup new-words get set-in-unit ;
: new-word? ( word -- ? )
new-words get key? ;
: new-class ( word -- )
dup new-classes get set-in-unit ;

4
core/sequences/sequences.factor
View File

@ -659,9 +659,9 @@ PRIVATE>
[ 0 swap copy ] keep
] new-like ;
: suffix! ( seq elt -- seq ) over push ;
: suffix! ( seq elt -- seq ) over push ; inline
: append! ( seq1 seq2 -- seq1 ) over push-all ;
: append! ( seq1 seq2 -- seq1 ) over push-all ; inline
: last ( seq -- elt ) [ length 1 - ] [ nth ] bi ;

7
core/words/words.factor
View File

@ -135,10 +135,13 @@ M: word reset-word
] tri ;
: <word> ( name vocab -- word )
2dup [ hashcode ] bi@ bitxor >fixnum (word) ;
2dup [ hashcode ] bi@ bitxor >fixnum (word) dup new-word ;
: <uninterned-word> ( name -- word )
f \ <uninterned-word> counter >fixnum (word) ;
: gensym ( -- word )
"( gensym )" f \ gensym counter >fixnum (word) ;
"( gensym )" <uninterned-word> ;
: define-temp ( quot effect -- word )
[ gensym dup ] 2dip define-declared ;

2
extra/benchmark/fannkuch/fannkuch.factor
View File

@ -24,7 +24,7 @@ IN: benchmark.fannkuch
: fannkuch ( n -- )
[
[ 0 0 ] dip [ 1 + ] B{ } map-as
[ 0 0 ] dip iota [ 1 + ] B{ } map-as
[ fannkuch-step ] each-permutation nip
] keep
"Pfannkuchen(" write pprint ") = " write . ;

13
vm/code_heap.cpp
View File

@ -135,18 +135,6 @@ struct code_heap_relocator {
}
};
void factor_vm::increment_definition_counter()
{
/* Increment redefinition counter for call( */
cell counter_ = special_objects[REDEFINITION_COUNTER];
cell counter;
if(counter_ == false_object)
counter = 0;
else
counter = untag_fixnum(counter_) + 1;
special_objects[REDEFINITION_COUNTER] = tag_fixnum(counter);
}
void factor_vm::primitive_modify_code_heap()
{
data_root<array> alist(dpop(),this);
@ -197,7 +185,6 @@ void factor_vm::primitive_modify_code_heap()
}
update_code_heap_words();
increment_definition_counter();
}
code_heap_room factor_vm::code_room()

1
vm/vm.hpp
View File

@ -534,7 +534,6 @@ struct factor_vm
void jit_compile_word(cell word_, cell def_, bool relocate);
void update_code_heap_words();
void update_code_heap_words_and_literals();
void increment_definition_counter();
void primitive_modify_code_heap();
code_heap_room code_room();
void primitive_code_room();