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

Merge branch 'master' of git://github.com/slavapestov/factor

db4
Erik Charlebois 2010-01-29 15:57:31 -08:00
parent e44973e2c7 36618bc46e
commit 1c8b4f08a4
54 changed files with 1110 additions and 774 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/combinators/smart/smart-tests.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test combinators.smart math kernel accessors ;
USING: accessors arrays combinators.smart kernel math
tools.test ;
IN: combinators.smart.tests
: test-bi ( -- 9 11 )
@ -59,3 +60,6 @@ IN: combinators.smart.tests
[ 7 ] [ 10 3 smart-if-test ] unit-test
[ 16 ] [ 25 41 smart-if-test ] unit-test
[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 3 smart-apply ] unit-test
[ { 1 2 3 } { 4 5 6 } ] [ 1 2 3 4 5 6 [ 3array ] 2 smart-apply ] unit-test

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

@ -51,3 +51,6 @@ MACRO: nullary ( quot -- quot' )
MACRO: smart-if ( pred true false -- )
'[ _ preserving _ _ if ] ;
MACRO: smart-apply ( quot n -- )
[ dup inputs ] dip '[ _ _ mnapply ] ;

33
basis/compiler/compiler.factor
View File

@ -3,18 +3,16 @@
USING: accessors kernel namespaces arrays sequences io words fry
continuations vocabs assocs dlists definitions math graphs generic
generic.single combinators deques search-deques macros
source-files.errors combinators.short-circuit
source-files.errors combinators.short-circuit classes.algebra
stack-checker stack-checker.dependencies stack-checker.inlining
stack-checker.errors
compiler.errors compiler.units compiler.utilities
compiler.errors compiler.units compiler.utilities compiler.crossref
compiler.tree.builder
compiler.tree.optimizer
compiler.crossref
compiler.cfg
compiler.cfg.builder
compiler.cfg.optimizer
@ -40,19 +38,18 @@ SYMBOL: compiled
: recompile-callers? ( word -- ? )
changed-effects get key? ;
: recompile-callers ( words -- )
#! If a word's stack effect changed, recompile all words that
#! have compiled calls to it.
: recompile-callers ( word -- )
#! If a word's stack effect changed, recompile all words
#! that have compiled calls to it.
dup recompile-callers?
[ compiled-usage keys [ queue-compile ] each ] [ drop ] if ;
[ effect-dependencies-of keys [ queue-compile ] each ] [ drop ] if ;
: compiler-message ( string -- )
"trace-compilation" get [ global [ print flush ] bind ] [ drop ] if ;
: start ( word -- )
dup name>> compiler-message
H{ } clone dependencies set
H{ } clone generic-dependencies set
init-dependencies
clear-compiler-error ;
GENERIC: no-compile? ( word -- ? )
@ -88,9 +85,9 @@ M: word combinator? inline? ;
[ compiled-unxref ]
[
dup crossref? [
dependencies get
generic-dependencies get
compiled-xref
[ dependencies get generic-dependencies get compiled-xref ]
[ conditional-dependencies get save-conditional-dependencies ]
bi
] [ drop ] if
] tri ;
@ -183,6 +180,14 @@ t compile-dependencies? set-global
SINGLETON: optimizing-compiler
M: optimizing-compiler update-call-sites ( class generic -- words )
#! Words containing call sites with inferred type 'class'
#! which inlined a method on 'generic'
compiled-generic-usage swap '[
nip dup forgotten-class?
[ drop f ] [ _ classes-intersect? ] if
] assoc-filter keys ;
M: optimizing-compiler recompile ( words -- alist )
[
<hashed-dlist> compile-queue set
@ -198,7 +203,7 @@ M: optimizing-compiler recompile ( words -- alist )
M: optimizing-compiler to-recompile ( -- words )
changed-definitions get compiled-usages
changed-generics get compiled-generic-usages
maybe-changed get outdated-conditional-usages
append assoc-combine keys ;
M: optimizing-compiler process-forgotten-words

115
basis/compiler/crossref/crossref.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes.algebra compiler.units definitions graphs
grouping kernel namespaces sequences words
stack-checker.dependencies ;
USING: arrays assocs classes.algebra compiler.units definitions
graphs grouping kernel namespaces sequences words fry
stack-checker.dependencies combinators ;
IN: compiler.crossref
SYMBOL: compiled-crossref
@ -13,56 +13,99 @@ SYMBOL: compiled-generic-crossref
compiled-generic-crossref [ H{ } clone ] initialize
: compiled-usage ( word -- assoc )
: effect-dependencies-of ( word -- assoc )
compiled-crossref get at ;
: (compiled-usages) ( word -- assoc )
#! If the word is not flushable anymore, we have to recompile
#! all words which flushable away a call (presumably when the
#! word was still flushable). If the word is flushable, we
#! don't have to recompile words that folded this away.
[ compiled-usage ]
[ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi
[ dependency>= nip ] curry assoc-filter ;
: definition-dependencies-of ( word -- assoc )
effect-dependencies-of [ nip definition-dependency dependency>= ] assoc-filter ;
: compiled-usages ( seq -- assocs )
: conditional-dependencies-of ( word -- assoc )
effect-dependencies-of [ nip conditional-dependency dependency>= ] assoc-filter ;
: compiled-usages ( assoc -- assocs )
[ drop word? ] assoc-filter
[ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ;
[ [ drop definition-dependencies-of ] { } assoc>map ] keep suffix ;
: dependencies-satisfied? ( word cache -- ? )
[ "dependency-checks" word-prop ] dip
'[ _ [ satisfied? ] cache ] all? ;
: outdated-conditional-usages ( assoc -- assocs )
H{ } clone '[
drop
conditional-dependencies-of
[ drop _ dependencies-satisfied? not ] assoc-filter
] { } assoc>map ;
: compiled-generic-usage ( word -- assoc )
compiled-generic-crossref get at ;
: (compiled-generic-usages) ( generic class -- assoc )
[ compiled-generic-usage ] dip
[
2dup [ valid-class? ] both?
[ classes-intersect? ] [ 2drop f ] if nip
] curry assoc-filter ;
: only-xref ( assoc -- assoc' )
[ drop crossref? ] { } assoc-filter-as ;
: compiled-generic-usages ( assoc -- assocs )
[ (compiled-generic-usages) ] { } assoc>map ;
: set-compiled-generic-uses ( word alist -- )
concat f like "compiled-generic-uses" set-word-prop ;
: (compiled-xref) ( word dependencies word-prop variable -- )
[ [ concat ] dip set-word-prop ] [ get add-vertex* ] bi-curry* 2bi ;
: split-dependencies ( assoc -- effect-deps cond-deps def-deps )
[ nip effect-dependency eq? ] assoc-partition
[ nip conditional-dependency eq? ] assoc-partition ;
: (store-dependencies) ( word assoc prop -- )
[ keys f like ] dip set-word-prop ;
: store-dependencies ( word assoc -- )
split-dependencies
"effect-dependencies" "definition-dependencies" "conditional-dependencies"
[ (store-dependencies) ] tri-curry@ tri-curry* tri ;
: (compiled-xref) ( word dependencies generic-dependencies -- )
compiled-crossref compiled-generic-crossref
[ get add-vertex* ] bi-curry@ bi-curry* bi ;
: compiled-xref ( word dependencies generic-dependencies -- )
[ [ drop crossref? ] { } assoc-filter-as ] bi@
[ "compiled-uses" compiled-crossref (compiled-xref) ]
[ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ]
bi-curry* bi ;
[ only-xref ] bi@
[ nip set-compiled-generic-uses ]
[ drop store-dependencies ]
[ (compiled-xref) ]
3tri ;
: (compiled-unxref) ( word word-prop variable -- )
[ [ [ dupd word-prop 2 <groups> ] dip get remove-vertex* ] 2curry ]
[ drop [ remove-word-prop ] curry ]
2bi bi ;
: set-at-each ( keys assoc value -- )
'[ _ [ _ ] 2dip set-at ] each ;
: join-dependencies ( effect-deps cond-deps def-deps -- assoc )
H{ } clone [
[ effect-dependency set-at-each ]
[ conditional-dependency set-at-each ]
[ definition-dependency set-at-each ] tri-curry tri*
] keep ;
: load-dependencies ( word -- assoc )
[ "effect-dependencies" word-prop ]
[ "definition-dependencies" word-prop ]
[ "conditional-dependencies" word-prop ] tri
join-dependencies ;
: (compiled-unxref) ( word dependencies variable -- )
get remove-vertex* ;
: compiled-generic-uses ( word -- alist )
"compiled-generic-uses" word-prop 2 <groups> ;
: compiled-unxref ( word -- )
[ "compiled-uses" compiled-crossref (compiled-unxref) ]
[ "compiled-generic-uses" compiled-generic-crossref (compiled-unxref) ]
bi ;
{
[ dup load-dependencies compiled-crossref (compiled-unxref) ]
[ dup compiled-generic-uses compiled-generic-crossref (compiled-unxref) ]
[ "effect-dependencies" remove-word-prop ]
[ "definition-dependencies" remove-word-prop ]
[ "conditional-dependencies" remove-word-prop ]
[ "compiled-generic-uses" remove-word-prop ]
} cleave ;
: delete-compiled-xref ( word -- )
[ compiled-unxref ]
[ compiled-crossref get delete-at ]
[ compiled-generic-crossref get delete-at ]
tri ;
: save-conditional-dependencies ( word deps -- )
keys f like "dependency-checks" set-word-prop ;

97
basis/compiler/tests/redefine10.factor
View File

@ -1,26 +1,83 @@
USING: eval tools.test compiler.units vocabs words kernel ;
USING: eval tools.test compiler.units vocabs words kernel
definitions sequences math classes classes.mixin kernel.private ;
IN: compiler.tests.redefine10
! Mixin redefinition did not recompile all necessary words.
! Mixin redefinition should update predicate call sites
[ ] [ [ "compiler.tests.redefine10" forget-vocab ] with-compilation-unit ] unit-test
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
: my-inline-1 ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
: my-inline-2 ( a -- b ) dup my-mixin? [ 1 + ] when ;
: my-inline-3 ( a -- b ) dup my-mixin? [ float? ] [ drop f ] if ;
: my-inline-4 ( a -- b ) dup float? [ my-mixin? ] [ drop f ] if ;
: my-inline-5 ( a -- b ) dup my-mixin? [ fixnum? ] [ drop f ] if ;
: my-inline-6 ( a -- b ) dup fixnum? [ my-mixin? ] [ drop f ] if ;
[ ] [
"USING: kernel math classes ;
IN: compiler.tests.redefine10
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;"
eval( -- )
] unit-test
GENERIC: fake-float? ( obj -- ? )
[ ] [
"USE: math
IN: compiler.tests.redefine10
INSTANCE: float my-mixin"
eval( -- )
] unit-test
M: float fake-float? drop t ;
M: object fake-float? drop f ;
[ 2.0 ] [
1.0 "my-inline" "compiler.tests.redefine10" lookup execute
] unit-test
: my-fake-inline-3 ( a -- b ) dup my-mixin? [ fake-float? ] [ drop f ] if ;
: my-baked-inline-3 ( a -- b ) { my-mixin } declare fake-float? ;
[ f ] [ 5 my-inline-3 ] unit-test
[ f ] [ 5 my-fake-inline-3 ] unit-test
[ f ] [ 5 my-baked-inline-3 ] unit-test
[ f ] [ 5 my-inline-4 ] unit-test
[ t ] [ 5 my-inline-5 ] unit-test
[ t ] [ 5 my-inline-6 ] unit-test
[ ] [ [ float my-mixin add-mixin-instance ] with-compilation-unit ] unit-test
[ 2.0 ] [ 1.0 my-inline-1 ] unit-test
[ 2.0 ] [ 1.0 my-inline-2 ] unit-test
[ t ] [ 1.0 my-inline-3 ] unit-test
[ t ] [ 1.0 my-fake-inline-3 ] unit-test
[ t ] [ 1.0 my-baked-inline-3 ] unit-test
[ t ] [ 1.0 my-inline-4 ] unit-test
[ f ] [ 1.0 my-inline-5 ] unit-test
[ f ] [ 1.0 my-inline-6 ] unit-test
[ ] [ [ fixnum my-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
[ f ] [ 5 my-inline-3 ] unit-test
[ f ] [ 5 my-fake-inline-3 ] unit-test
[ f ] [ 5 my-baked-inline-3 ] unit-test
[ f ] [ 5 my-inline-4 ] unit-test
[ f ] [ 5 my-inline-5 ] unit-test
[ f ] [ 5 my-inline-6 ] unit-test
[ ] [ [ float my-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
[ 1.0 ] [ 1.0 my-inline-1 ] unit-test
[ 1.0 ] [ 1.0 my-inline-2 ] unit-test
[ f ] [ 1.0 my-inline-3 ] unit-test
[ f ] [ 1.0 my-fake-inline-3 ] unit-test
[ f ] [ 1.0 my-inline-4 ] unit-test
[ f ] [ 1.0 my-inline-5 ] unit-test
[ f ] [ 1.0 my-inline-6 ] unit-test

25
basis/compiler/tests/redefine18.factor Normal file
View File

@ -0,0 +1,25 @@
USING: kernel tools.test eval words ;
IN: compiler.tests.redefine18
! Mixin bug found by Doug
GENERIC: g1 ( a -- b )
GENERIC: g2 ( a -- b )
MIXIN: c
SINGLETON: a
INSTANCE: a c
M: c g1 g2 ;
M: a g2 drop a ;
MIXIN: d
INSTANCE: d c
M: d g2 drop d ;
[ ] [ "IN: compiler.tests.redefine18 SINGLETON: b INSTANCE: b d" eval( -- ) ] unit-test
[ d ] [ "b" "compiler.tests.redefine18" lookup g1 ] unit-test
[ ] [ "IN: compiler.tests.redefine18 FORGET: b" eval( -- ) ] unit-test

23
basis/compiler/tests/redefine19.factor Normal file
View File

@ -0,0 +1,23 @@
USING: kernel classes.mixin compiler.units tools.test generic ;
IN: compiler.tests.redefine19
GENERIC: g ( a -- b )
MIXIN: m1 M: m1 g drop 1 ;
MIXIN: m2 M: m2 g drop 2 ;
TUPLE: c ;
INSTANCE: c m2
: foo ( -- b ) c new g ;
[ 2 ] [ foo ] unit-test
[ ] [ [ c m1 add-mixin-instance ] with-compilation-unit ] unit-test
[ { m2 m1 } ] [ \ g order ] unit-test
[ 1 ] [ foo ] unit-test
[ ] [ [ c m1 remove-mixin-instance ] with-compilation-unit ] unit-test

23
basis/compiler/tests/redefine20.factor Normal file
View File

@ -0,0 +1,23 @@
IN: compiler.tests.redefine20
USING: kernel sequences compiler.units definitions classes.mixin
tools.test ;
GENERIC: cnm-recompile-test ( a -- b )
M: object cnm-recompile-test drop object ;
M: sequence cnm-recompile-test drop sequence ;
TUPLE: funny ;
M: funny cnm-recompile-test call-next-method ;
[ object ] [ funny new cnm-recompile-test ] unit-test
[ ] [ [ funny sequence add-mixin-instance ] with-compilation-unit ] unit-test
[ sequence ] [ funny new cnm-recompile-test ] unit-test
[ ] [ [ funny sequence remove-mixin-instance ] with-compilation-unit ] unit-test
[ object ] [ funny new cnm-recompile-test ] unit-test

22
basis/compiler/tree/builder/builder.factor
View File

@ -50,17 +50,11 @@ PRIVATE>
[ f ] dip build-tree-with ;
:: build-sub-tree ( in-d out-d word/quot -- nodes/f )
#! We don't want methods on mixins to have a declaration for that mixin.
#! This slows down compiler.tree.propagation.inlining since then every
#! inlined usage of a method has an inline-dependency on the mixin, and
#! not the more specific type at the call site.
f specialize-method? [
[
in-d word/quot build-tree-with unclip-last in-d>> :> in-d'
{
{ [ dup not ] [ ] }
{ [ dup ends-with-terminate? ] [ out-d [ f swap #push ] map append ] }
[ in-d' out-d [ [ length ] bi@ assert= ] [ #copy suffix ] 2bi ]
} cond
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
] with-variable ;
[
in-d word/quot build-tree-with unclip-last in-d>> :> in-d'
{
{ [ dup not ] [ ] }
{ [ dup ends-with-terminate? ] [ out-d [ f swap #push ] map append ] }
[ in-d' out-d [ [ length ] bi@ assert= ] [ #copy suffix ] 2bi ]
} cond
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ;

39
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences combinators fry
classes.algebra namespaces assocs words math math.private
@ -36,32 +36,51 @@ GENERIC: cleanup* ( node -- node/nodes )
#! do it since the logic is a bit more involved
[ cleanup* ] map-flat ;
! Constant folding
: cleanup-folding? ( #call -- ? )
node-output-infos
[ f ] [ [ literal?>> ] all? ] if-empty ;
: cleanup-folding ( #call -- nodes )
: (cleanup-folding) ( #call -- nodes )
#! Replace a #call having a known result with a #drop of its
#! inputs followed by #push nodes for the outputs.
[ word>> inlined-dependency depends-on ]
[
[ node-output-infos ] [ out-d>> ] bi
[ [ literal>> ] dip #push ] 2map
]
[ in-d>> #drop ]
tri prefix ;
bi prefix ;
: record-predicate-folding ( #call -- )
[ node-input-infos first class>> ]
[ word>> "predicating" word-prop ]
[ node-output-infos first literal>> ] tri
[ depends-on-class<= ] [ depends-on-classes-disjoint ] if ;
: record-folding ( #call -- )
dup word>> predicate?
[ record-predicate-folding ]
[ word>> depends-on-definition ]
if ;
: cleanup-folding ( #call -- nodes )
[ (cleanup-folding) ] [ record-folding ] bi ;
! Method inlining
: add-method-dependency ( #call -- )
dup method>> word? [
[ word>> ] [ class>> ] bi depends-on-generic
[ [ class>> ] [ word>> ] bi depends-on-generic ]
[ [ class>> ] [ word>> ] [ method>> ] tri depends-on-method ]
bi
] [ drop ] if ;
: record-inlining ( #call -- )
dup method>>
[ add-method-dependency ]
[ word>> depends-on-definition ] if ;
: cleanup-inlining ( #call -- nodes )
[
dup method>>
[ add-method-dependency ]
[ word>> inlined-dependency depends-on ] if
] [ body>> cleanup ] bi ;
[ record-inlining ] [ body>> cleanup ] bi ;
! Removing overflow checks
: (remove-overflow-check?) ( #call -- ? )

10
basis/compiler/tree/dead-code/simple/simple.factor
View File

@ -9,14 +9,6 @@ compiler.tree.propagation.info
compiler.tree.dead-code.liveness ;
IN: compiler.tree.dead-code.simple
GENERIC: flushable? ( word -- ? )
M: predicate flushable? drop t ;
M: word flushable? "flushable" word-prop ;
M: method-body flushable? "method-generic" word-prop flushable? ;
: flushable-call? ( #call -- ? )
dup word>> dup flushable? [
"input-classes" word-prop dup [
@ -98,7 +90,7 @@ M: #push remove-dead-code*
] [ drop f ] if ;
: remove-flushable-call ( #call -- node )
[ word>> flushed-dependency depends-on ]
[ word>> depends-on-flushable ]
[ in-d>> #drop remove-dead-code* ]
bi ;

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

@ -79,3 +79,16 @@ TUPLE: a-tuple x ;
[ ] [ "IN: compiler.tree.propagation.call-effect.tests USE: math : call(-redefine-test ( a -- c ) 1 + ;" eval( -- ) ] unit-test
[ 1 3 test-quotatation inline-cache-invalidation-test ] [ T{ wrong-values f (( a b -- c )) } = ] must-fail-with
! See if redefining a tuple class bumps effect counter
TUPLE: my-tuple a b c ;
: my-quot ( -- quot ) [ my-tuple boa ] ;
: my-word ( a b c q -- result ) call( a b c -- result ) ;
[ T{ my-tuple f 1 2 3 } ] [ 1 2 3 my-quot my-word ] unit-test
[ ] [ "IN: compiler.tree.propagation.call-effect.tests TUPLE: my-tuple a b ;" eval( -- ) ] unit-test
[ 1 2 3 my-quot my-word ] [ wrong-values? ] must-fail-with

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

@ -2,14 +2,19 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays 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
quotations words math stack-checker stack-checker.dependencies
combinators.short-circuit stack-checker.transforms
compiler.tree.propagation.info
compiler.tree.propagation.inlining compiler.units ;
IN: compiler.tree.propagation.call-effect
! call( and execute( have complex expansions.
! call( uses the following strategy:
! If the input quotation is a literal, or built up from curry and
! compose with terminal quotations literal, it is inlined at the
! call site.
! For dynamic call sites, call( uses the following strategy:
! - Inline caching. If the quotation is the same as last time, just call it unsafely
! - Effect inference. Infer quotation's effect, caching it in the cached-effect slot,
! and compare it with declaration. If matches, call it unsafely.
@ -58,7 +63,7 @@ M: compose cached-effect
[ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
: safe-infer ( quot -- effect )
[ infer ] [ 2drop +unknown+ ] recover ;
[ [ infer ] [ 2drop +unknown+ ] recover ] without-dependencies ;
: cached-effect-valid? ( quot -- ? )
cache-counter>> effect-counter eq? ; inline

2
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -318,7 +318,7 @@ generic-comparison-ops [
dup literal>> class?
[
literal>>
[ inlined-dependency depends-on ]
[ depends-on-conditionally ]
[ predicate-output-infos ]
bi
] [ 2drop object-info ] if

7
basis/compiler/tree/propagation/simple/simple.factor
View File

@ -36,7 +36,7 @@ M: #declare propagate-before
#! classes mentioned in the declaration are redefined, since
#! now we're making assumptions but their definitions.
declaration>> [
[ inlined-dependency depends-on ]
[ depends-on-conditionally ]
[ <class-info> swap refine-value-info ]
bi
] assoc-each ;
@ -110,8 +110,9 @@ M: #declare propagate-before
#! is redefined, since now we're making assumptions but the
#! class definition itself.
[ in-d>> first value-info ]
[ "predicating" word-prop dup inlined-dependency depends-on ] bi*
predicate-output-infos 1array ;
[ "predicating" word-prop ] bi*
[ nip depends-on-conditionally ]
[ predicate-output-infos 1array ] 2bi ;
: default-output-value-infos ( #call word -- infos )
"default-output-classes" word-prop

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

@ -163,10 +163,12 @@ ERROR: bad-partial-eval quot word ;
: inline-new ( class -- quot/f )
dup tuple-class? [
dup inlined-dependency depends-on
[ all-slots [ initial>> literalize ] map ]
[ tuple-layout '[ _ <tuple-boa> ] ]
bi append >quotation
dup tuple-layout
[ depends-on-tuple-layout ]
[ drop all-slots [ initial>> literalize ] [ ] map-as ]
[ nip ]
2tri
'[ @ _ <tuple-boa> ]
] [ drop f ] if ;
\ new [ inline-new ] 1 define-partial-eval
@ -293,6 +295,6 @@ CONSTANT: lookup-table-at-max 256
! calls when a C type is redefined
\ heap-size [
dup word? [
[ inlined-dependency depends-on ] [ heap-size '[ _ ] ] bi
[ depends-on-definition ] [ heap-size '[ _ ] ] bi
] [ drop f ] if
] 1 define-partial-eval

5
basis/generalizations/generalizations-tests.factor
View File

@ -108,3 +108,8 @@ IN: generalizations.tests
2 1 0 -1 [ + ] [ - ] [ * ] [ / ] 4 spread-curry 4 spread*
] unit-test
[ { 1 2 } { 3 4 } { 5 6 } ]
[ 1 2 3 4 5 6 [ 2array ] 2 3 mnapply ] unit-test
[ { 1 2 3 } { 4 5 6 } ]
[ 1 2 3 4 5 6 [ 3array ] 3 2 mnapply ] unit-test

4
basis/generalizations/generalizations.factor
View File

@ -124,6 +124,10 @@ MACRO: cleave* ( n -- )
MACRO: mnswap ( m n -- )
1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
MACRO: mnapply ( quot m n -- )
swap
[ swap '[ _ ] replicate ] dip '[ _ _ nspread ] ;
MACRO: nweave ( n -- )
[ dup iota <reversed> [ '[ _ _ mnswap ] ] with map ] keep
'[ _ _ ncleave ] ;

8
basis/grouping/grouping.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order strings arrays vectors sequences
sequences.private accessors fry ;
@ -20,14 +20,16 @@ M: chunking-seq set-nth group@ <slice> 0 swap copy ;
M: chunking-seq like drop { } like ; inline
INSTANCE: chunking-seq sequence
MIXIN: subseq-chunking
INSTANCE: subseq-chunking sequence
M: subseq-chunking nth group@ subseq ; inline
MIXIN: slice-chunking
INSTANCE: slice-chunking sequence
M: slice-chunking nth group@ <slice> ; inline
M: slice-chunking nth-unsafe group@ slice boa ; inline

7
basis/hints/hints.factor
View File

@ -41,18 +41,13 @@ M: object specializer-declaration class ;
: specialize-quot ( quot specializer -- quot' )
[ drop ] [ specializer-cases ] 2bi alist>quot ;
! compiler.tree.propagation.inlining sets this to f
SYMBOL: specialize-method?
t specialize-method? set-global
: method-declaration ( method -- quot )
[ "method-generic" word-prop dispatch# object <array> ]
[ "method-class" word-prop ]
bi prefix [ declare ] curry [ ] like ;
: specialize-method ( quot method -- quot' )
[ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
[ method-declaration prepend ]
[ "method-generic" word-prop ] bi
specializer [ specialize-quot ] when* ;

2
basis/images/jpeg/jpeg.factor
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 ;

2
basis/macros/macros.factor
View File

@ -32,4 +32,4 @@ 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 ;
M: macro always-bump-effect-counter? drop t ;

25
basis/random/windows/windows.factor
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
[

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

@ -74,7 +74,7 @@ GENERIC: apply-object ( obj -- )
M: wrapper apply-object
wrapped>>
[ dup word? [ called-dependency depends-on ] [ drop ] if ]
[ dup word? [ depends-on-effect ] [ drop ] if ]
[ push-literal ]
bi ;

36
basis/stack-checker/dependencies/dependencies-tests.factor
View File

@ -1,37 +1 @@
IN: stack-checker.dependencies.tests
USING: tools.test stack-checker.dependencies words kernel namespaces
definitions ;
: computing-dependencies ( quot -- dependencies )
H{ } clone [ dependencies rot with-variable ] keep ;
inline
SYMBOL: a
SYMBOL: b
[ ] [ a called-dependency depends-on ] unit-test
[ H{ { a called-dependency } } ] [
[ a called-dependency depends-on ] computing-dependencies
] unit-test
[ H{ { a called-dependency } { b inlined-dependency } } ] [
[
a called-dependency depends-on b inlined-dependency depends-on
] computing-dependencies
] unit-test
[ H{ { a inlined-dependency } { b inlined-dependency } } ] [
[
a inlined-dependency depends-on
a called-dependency depends-on
b inlined-dependency depends-on
] computing-dependencies
] unit-test
[ flushed-dependency ] [ f flushed-dependency strongest-dependency ] unit-test
[ flushed-dependency ] [ flushed-dependency f strongest-dependency ] unit-test
[ inlined-dependency ] [ flushed-dependency inlined-dependency strongest-dependency ] unit-test
[ inlined-dependency ] [ called-dependency inlined-dependency strongest-dependency ] unit-test
[ flushed-dependency ] [ called-dependency flushed-dependency strongest-dependency ] unit-test
[ called-dependency ] [ called-dependency f strongest-dependency ] unit-test

105
basis/stack-checker/dependencies/dependencies.factor
View File

@ -1,23 +1,24 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes.algebra fry kernel math namespaces
sequences words ;
USING: assocs accessors classes.algebra fry generic kernel math
namespaces sequences words sets ;
FROM: classes.tuple.private => tuple-layout ;
IN: stack-checker.dependencies
! Words that the current quotation depends on
SYMBOL: dependencies
SYMBOLS: inlined-dependency flushed-dependency called-dependency ;
SYMBOLS: effect-dependency conditional-dependency definition-dependency ;
: index>= ( obj1 obj2 seq -- ? )
[ index ] curry bi@ >= ;
: dependency>= ( how1 how2 -- ? )
{ called-dependency flushed-dependency inlined-dependency }
{ effect-dependency conditional-dependency definition-dependency }
index>= ;
: strongest-dependency ( how1 how2 -- how )
[ called-dependency or ] bi@ [ dependency>= ] most ;
[ effect-dependency or ] bi@ [ dependency>= ] most ;
: depends-on ( word how -- )
over primitive? [ 2drop ] [
@ -26,12 +27,96 @@ SYMBOLS: inlined-dependency flushed-dependency called-dependency ;
] [ 3drop ] if
] if ;
: depends-on-effect ( word -- )
effect-dependency depends-on ;
: depends-on-conditionally ( word -- )
conditional-dependency depends-on ;
: depends-on-definition ( word -- )
definition-dependency depends-on ;
! Generic words that the current quotation depends on
SYMBOL: generic-dependencies
: ?class-or ( class/f class -- class' )
swap [ class-or ] when* ;
: ?class-or ( class class/f -- class' )
[ class-or ] when* ;
: depends-on-generic ( generic class -- )
: depends-on-generic ( class generic -- )
generic-dependencies get dup
[ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ;
[ [ ?class-or ] change-at ] [ 3drop ] if ;
! Conditional dependencies are re-evaluated when classes change;
! if any fail, the word is recompiled
SYMBOL: conditional-dependencies
GENERIC: satisfied? ( dependency -- ? )
: add-conditional-dependency ( ... class -- )
boa conditional-dependencies get
dup [ conjoin ] [ 2drop ] if ; inline
TUPLE: depends-on-class<= class1 class2 ;
: depends-on-class<= ( class1 class2 -- )
\ depends-on-class<= add-conditional-dependency ;
M: depends-on-class<= satisfied?
[ class1>> ] [ class2>> ] bi class<= ;
TUPLE: depends-on-classes-disjoint class1 class2 ;
: depends-on-classes-disjoint ( class1 class2 -- )
\ depends-on-classes-disjoint add-conditional-dependency ;
M: depends-on-classes-disjoint satisfied?
[ class1>> ] [ class2>> ] bi classes-intersect? not ;
TUPLE: depends-on-next-method class generic next-method ;
: depends-on-next-method ( class generic next-method -- )
over depends-on-conditionally
\ depends-on-next-method add-conditional-dependency ;
M: depends-on-next-method satisfied?
[ [ class>> ] [ generic>> ] bi next-method ] [ next-method>> ] bi eq? ;
TUPLE: depends-on-method class generic method ;
: depends-on-method ( class generic method -- )
over depends-on-conditionally
\ depends-on-method add-conditional-dependency ;
M: depends-on-method satisfied?
[ [ class>> ] [ generic>> ] bi method-for-class ] [ method>> ] bi eq? ;
TUPLE: depends-on-tuple-layout class layout ;
: depends-on-tuple-layout ( class layout -- )
[ drop depends-on-conditionally ]
[ \ depends-on-tuple-layout add-conditional-dependency ] 2bi ;
M: depends-on-tuple-layout satisfied?
[ class>> tuple-layout ] [ layout>> ] bi eq? ;
TUPLE: depends-on-flushable word ;
: depends-on-flushable ( word -- )
[ depends-on-conditionally ]
[ \ depends-on-flushable add-conditional-dependency ] bi ;
M: depends-on-flushable satisfied?
word>> flushable? ;
: init-dependencies ( -- )
H{ } clone dependencies set
H{ } clone generic-dependencies set
H{ } clone conditional-dependencies set ;
: without-dependencies ( quot -- )
[
dependencies off
generic-dependencies off
conditional-dependencies off
call
] with-scope ; inline

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

@ -140,7 +140,7 @@ SYMBOL: enter-out
: inline-word ( word -- )
commit-literals
[ inlined-dependency depends-on ]
[ depends-on-definition ]
[
dup inline-recursive-label [
call-recursive-inline-word

2
basis/stack-checker/known-words/known-words.factor
View File

@ -273,7 +273,7 @@ M: bad-executable summary
\ clear t "no-compile" set-word-prop
: non-inline-word ( word -- )
dup called-dependency depends-on
dup depends-on-effect
{
{ [ dup "shuffle" word-prop ] [ infer-shuffle-word ] }
{ [ dup "special" word-prop ] [ infer-special ] }

24
basis/stack-checker/transforms/transforms.factor
View File

@ -124,15 +124,15 @@ IN: stack-checker.transforms
\ 3|| t "no-compile" set-word-prop
: add-next-method-dependency ( method -- )
[ "method-class" word-prop ]
[ "method-generic" word-prop ] bi
2dup next-method
depends-on-next-method ;
\ (call-next-method) [
[
[ "method-class" word-prop ]
[ "method-generic" word-prop ] bi
[ inlined-dependency depends-on ] bi@
] [
[ next-method-quot ]
[ '[ _ no-next-method ] ] bi or
] bi
[ add-next-method-dependency ]
[ [ next-method-quot ] [ '[ _ no-next-method ] ] bi or ] bi
] 1 define-transform
\ (call-next-method) t "no-compile" set-word-prop
@ -140,10 +140,10 @@ IN: stack-checker.transforms
! Constructors
\ boa [
dup tuple-class? [
dup inlined-dependency depends-on
[ "boa-check" word-prop [ ] or ]
[ tuple-layout '[ _ <tuple-boa> ] ]
bi append
dup tuple-layout
[ depends-on-tuple-layout ]
[ [ "boa-check" word-prop [ ] or ] dip ] 2bi
'[ @ _ <tuple-boa> ]
] [ drop f ] if
] 1 define-transform

4
basis/tools/deploy/shaker/shaker.factor
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: arrays accessors io.backend io.streams.c init fry
namespaces math make assocs kernel parser parser.notes lexer
@ -128,6 +128,7 @@ IN: tools.deploy.shaker
"combination"
"compiled-generic-uses"
"compiled-uses"
"conditional-dependencies"
"constant"
"constraints"
"custom-inlining"
@ -159,7 +160,6 @@ IN: tools.deploy.shaker
"members"
"memo-quot"
"methods"
"mixin"
"method-class"
"method-generic"
"modular-arithmetic"

2
basis/tools/profiler/profiler.factor
View File

@ -40,7 +40,7 @@ IN: tools.profiler
: profiler-usage ( word -- words )
[ smart-usage [ word? ] filter ]
[ compiled-generic-usage keys ]
[ compiled-usage keys ]
[ effect-dependencies-of keys ]
tri 3append prune ;
: usage-counters ( word -- alist )

25
basis/typed/typed.factor
View File

@ -4,6 +4,7 @@ combinators.short-circuit definitions effects fry hints
math kernel kernel.private namespaces parser quotations
sequences slots words locals
locals.parser macros stack-checker.dependencies ;
FROM: classes.tuple.private => tuple-layout ;
IN: typed
ERROR: type-mismatch-error word expected-types ;
@ -31,6 +32,7 @@ PREDICATE: typed-word < word "typed-word" word-prop ;
: (unboxer) ( type -- quot )
dup unboxable-tuple-class? [
dup dup tuple-layout depends-on-tuple-layout
all-slots [
[ name>> reader-word 1quotation ]
[ class>> (unboxer) ] bi compose
@ -49,7 +51,10 @@ PREDICATE: typed-word < word "typed-word" word-prop ;
: (unboxed-types) ( type -- types )
dup unboxable-tuple-class?
[ all-slots [ class>> (unboxed-types) ] map concat ]
[
dup dup tuple-layout depends-on-tuple-layout
all-slots [ class>> (unboxed-types) ] map concat
]
[ 1array ] if ;
: unboxed-types ( types -- types' )
@ -75,7 +80,12 @@ DEFER: make-boxer
: boxer ( type -- quot )
dup unboxable-tuple-class?
[ [ all-slots [ class>> ] map make-boxer ] [ [ boa ] curry ] bi compose ]
[
dup dup tuple-layout depends-on-tuple-layout
[ all-slots [ class>> ] map make-boxer ]
[ [ boa ] curry ]
bi compose
]
[ drop [ ] ] if ;
: make-boxer ( types -- quot )
@ -84,18 +94,15 @@ DEFER: make-boxer
! defining typed words
: (depends-on) ( types -- types )
dup [ inlined-dependency depends-on ] each ; inline
MACRO: (typed) ( word def effect -- quot )
[ swap ] dip
[
nip effect-in-types (depends-on) swap
nip effect-in-types swap
[ [ unboxed-types ] [ make-boxer ] bi ] dip
'[ _ declare @ @ ]
]
[
effect-out-types (depends-on)
effect-out-types
dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if
] 2bi ;
@ -118,9 +125,9 @@ M: typed-gensym crossref?
[ 2nip ] 3tri define-declared ;
MACRO: typed ( quot word effect -- quot' )
[ effect-in-types (depends-on) dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ]
[ effect-in-types dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ]
[
nip effect-out-types (depends-on) dup typed-stack-effect?
nip effect-out-types dup typed-stack-effect?
[ [ unboxed-types ] [ make-boxer ] bi '[ @ _ declare @ ] ] [ drop ] if
] 2bi ;

3
core/bootstrap/primitives.factor
View File

@ -126,6 +126,9 @@ call( -- )
prepare-slots make-slots 1 finalize-slots
[ "slots" set-word-prop ] [ define-accessors ] 2bi ;
: define-builtin-predicate ( class -- )
dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
: define-builtin ( symbol slotspec -- )
[ [ define-builtin-predicate ] keep ] dip define-builtin-slots ;

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

@ -79,9 +79,9 @@ INSTANCE: union-with-one-member mixin-with-one-member
[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test
[ t ] [ growable tuple sequence class-and class<= ] unit-test
[ f ] [ growable tuple sequence class-and class<= ] unit-test
[ t ] [ growable assoc class-and tuple class<= ] unit-test
[ f ] [ growable assoc class-and tuple class<= ] unit-test
[ t ] [ object \ f \ f class-not class-or class<= ] unit-test
@ -130,6 +130,14 @@ INSTANCE: union-with-one-member mixin-with-one-member
[ t ] [ a union-with-one-member class<= ] unit-test
[ f ] [ union-with-one-member class-not integer class<= ] unit-test
MIXIN: empty-mixin
[ f ] [ empty-mixin class-not null class<= ] unit-test
[ f ] [ empty-mixin null class<= ] unit-test
[ t ] [ array sequence vector class-not class-and class<= ] unit-test
[ f ] [ vector sequence vector class-not class-and class<= ] unit-test
! class-and
: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;
@ -146,8 +154,6 @@ INSTANCE: union-with-one-member mixin-with-one-member
[ t ] [ slice reversed null class-and* ] unit-test
[ t ] [ \ f class-not \ f null class-and* ] unit-test
[ t ] [ vector virtual-sequence null class-and* ] unit-test
[ t ] [ vector array class-not vector class-and* ] unit-test
! class-or
@ -160,6 +166,7 @@ INSTANCE: union-with-one-member mixin-with-one-member
! classes-intersect?
[ t ] [ both tuple classes-intersect? ] unit-test
[ f ] [ vector virtual-sequence classes-intersect? ] unit-test
[ t ] [ number vector class-or sequence classes-intersect? ] unit-test

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

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes combinators accessors sequences arrays
vectors assocs namespaces words sorting layouts math hashtables
@ -34,22 +34,18 @@ DEFER: (class-or)
GENERIC: (flatten-class) ( class -- )
: normalize-class ( class -- class' )
{
{ [ dup members ] [ members <anonymous-union> normalize-class ] }
{ [ dup participants ] [ participants <anonymous-intersection> normalize-class ] }
[ ]
} cond ;
GENERIC: normalize-class ( class -- class' )
M: object normalize-class ;
PRIVATE>
GENERIC: valid-class? ( obj -- ? )
GENERIC: forgotten-class? ( obj -- ? )
M: class valid-class? drop t ;
M: anonymous-union valid-class? members>> [ valid-class? ] all? ;
M: anonymous-intersection valid-class? participants>> [ valid-class? ] all? ;
M: anonymous-complement valid-class? class>> valid-class? ;
M: word valid-class? drop f ;
M: word forgotten-class? "forgotten" word-prop ;
M: anonymous-union forgotten-class? members>> [ forgotten-class? ] any? ;
M: anonymous-intersection forgotten-class? participants>> [ forgotten-class? ] any? ;
M: anonymous-complement forgotten-class? class>> forgotten-class? ;
: class<= ( first second -- ? )
class<=-cache get [ (class<=) ] 2cache ;
@ -93,6 +89,9 @@ M: word valid-class? drop f ;
: left-anonymous-union<= ( first second -- ? )
[ members>> ] dip [ class<= ] curry all? ;
: right-union<= ( first second -- ? )
members [ class<= ] with any? ;
: right-anonymous-union<= ( first second -- ? )
members>> [ class<= ] with any? ;
@ -117,7 +116,7 @@ M: word valid-class? drop f ;
[ class-not normalize-class ] map
<anonymous-union>
] }
[ <anonymous-complement> ]
[ drop object ]
} cond ;
: left-anonymous-complement<= ( first second -- ? )
@ -147,6 +146,7 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
{ [ over anonymous-union? ] [ left-anonymous-union<= ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
{ [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
{ [ dup members ] [ right-union<= ] }
{ [ dup anonymous-union? ] [ right-anonymous-union<= ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }

7
core/classes/builtin/builtin.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes classes.algebra classes.algebra.private
words kernel kernel.private namespaces sequences math
@ -20,11 +20,6 @@ M: object class tag type>class ; inline
M: builtin-class rank-class drop 0 ;
GENERIC: define-builtin-predicate ( class -- )
M: builtin-class define-builtin-predicate
dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
M: builtin-class instance? [ tag ] [ class>type ] bi* eq? ;
M: builtin-class (flatten-class) dup set ;

49
core/classes/classes.factor
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: accessors arrays definitions assocs kernel kernel.private
slots.private namespaces make sequences strings words words.symbol
@ -37,11 +37,16 @@ PREDICATE: class < word "class" word-prop ;
: classes ( -- seq ) implementors-map get keys ;
: predicate-word ( word -- predicate )
: create-predicate-word ( word -- predicate )
[ name>> "?" append ] [ vocabulary>> ] bi create ;
: predicate-word ( word -- predicate )
"predicate" word-prop first ;
PREDICATE: predicate < word "predicating" word-prop >boolean ;
M: predicate flushable? drop t ;
M: predicate forget*
[ call-next-method ] [ f "predicating" set-word-prop ] bi ;
@ -49,8 +54,7 @@ M: predicate reset-word
[ call-next-method ] [ f "predicating" set-word-prop ] bi ;
: define-predicate ( class quot -- )
[ "predicate" word-prop first ] dip
(( object -- ? )) define-declared ;
[ predicate-word ] dip (( object -- ? )) define-declared ;
: superclass ( class -- super )
#! Output f for non-classes to work with algebra code
@ -133,19 +137,24 @@ M: sequence implementors [ implementors ] gather ;
dup deferred? [ define-symbol ] [ drop ] if ;
: (define-class) ( word props -- )
reset-caches
[ drop update-map- ]
[
{
[ dup class? [ drop ] [ [ implementors-map+ ] [ new-class ] bi ] if ]
[ reset-class ]
[ ?define-symbol ]
[ changed-definition ]
[ ]
} cleave
] dip [ assoc-union ] curry change-props
dup predicate-word
[ 1quotation "predicate" set-word-prop ]
[ swap "predicating" set-word-prop ]
[ drop t "class" set-word-prop ]
[
{
[ dup class? [ drop ] [ implementors-map+ ] if ]
[ reset-class ]
[ ?define-symbol ]
[ ]
} cleave
] dip [ assoc-union ] curry change-props
dup create-predicate-word
[ 1quotation "predicate" set-word-prop ]
[ swap "predicating" set-word-prop ]
[ drop t "class" set-word-prop ]
2tri
]
[ drop update-map+ ]
2tri ;
PRIVATE>
@ -161,13 +170,7 @@ GENERIC: update-methods ( class seq -- )
[ nip [ update-class ] each ] [ update-methods ] 2bi ;
: define-class ( word superclass members participants metaclass -- )
#! If it was already a class, update methods after.
reset-caches
make-class-props
[ drop update-map- ]
[ (define-class) ]
[ drop update-map+ ]
2tri ;
make-class-props [ (define-class) ] [ drop changed-definition ] 2bi ;
: forget-predicate ( class -- )
dup "predicate" word-prop

19
core/classes/intersection/intersection.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words accessors sequences kernel assocs combinators classes
classes.algebra classes.algebra.private classes.builtin
@ -8,6 +8,8 @@ IN: classes.intersection
PREDICATE: intersection-class < class
"metaclass" word-prop intersection-class eq? ;
<PRIVATE
: intersection-predicate-quot ( members -- quot )
[
[ drop t ]
@ -23,16 +25,14 @@ PREDICATE: intersection-class < class
M: intersection-class update-class define-intersection-predicate ;
: define-intersection-class ( class participants -- )
[ [ f f ] dip intersection-class define-class ]
[ drop update-classes ]
2bi ;
M: intersection-class rank-class drop 2 ;
M: intersection-class instance?
"participants" word-prop [ instance? ] with all? ;
M: intersection-class normalize-class
participants <anonymous-intersection> normalize-class ;
M: intersection-class (flatten-class)
participants <anonymous-intersection> (flatten-class) ;
@ -47,3 +47,10 @@ M: anonymous-intersection (flatten-class)
[ intersect-flattened-classes ] map-reduce
[ dup set ] each
] if-empty ;
PRIVATE>
: define-intersection-class ( class participants -- )
[ [ f f ] dip intersection-class define-class ]
[ drop update-classes ]
2bi ;

4
core/classes/mixin/mixin-tests.factor
View File

@ -38,8 +38,8 @@ MIXIN: mx1
INSTANCE: integer mx1
[ t ] [ integer mx1 class<= ] unit-test
[ t ] [ mx1 integer class<= ] unit-test
[ t ] [ mx1 number class<= ] unit-test
[ f ] [ mx1 integer class<= ] unit-test
[ f ] [ mx1 number class<= ] unit-test
"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval( -- )

129
core/classes/mixin/mixin.factor
View File

@ -1,20 +1,81 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes classes.union words kernel sequences
USING: classes classes.algebra classes.algebra.private
classes.union classes.union.private words kernel sequences
definitions combinators arrays assocs generic accessors ;
IN: classes.mixin
PREDICATE: mixin-class < union-class "mixin" word-prop ;
M: mixin-class normalize-class ;
M: mixin-class (classes-intersect?)
members [ classes-intersect? ] with any? ;
M: mixin-class reset-class
[ call-next-method ] [ { "mixin" } reset-props ] bi ;
M: mixin-class rank-class drop 3 ;
TUPLE: check-mixin-class class ;
: check-mixin-class ( mixin -- mixin )
dup mixin-class? [
\ check-mixin-class boa throw
] unless ;
<PRIVATE
: redefine-mixin-class ( class members -- )
[ (define-union-class) ]
[ drop changed-conditionally ]
[ drop t "mixin" set-word-prop ]
2bi ;
2tri ;
: if-mixin-member? ( class mixin true false -- )
[ check-mixin-class 2dup members member-eq? ] 2dip if ; inline
: change-mixin-class ( class mixin quot -- )
[ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
swap redefine-mixin-class ; inline
: (add-mixin-instance) ( class mixin -- )
#! Call update-methods before adding the member:
#! - Call sites of generics specializing on 'mixin'
#! where the inferred type is 'class' are updated,
#! - Call sites where the inferred type is a subtype
#! of 'mixin' disjoint from 'class' are not updated
dup class-usages {
[ nip update-methods ]
[ drop [ suffix ] change-mixin-class ]
[ drop [ f ] 2dip "instances" word-prop set-at ]
[ 2nip [ update-class ] each ]
} 3cleave ;
: (remove-mixin-instance) ( class mixin -- )
#! Call update-methods after removing the member:
#! - Call sites of generics specializing on 'mixin'
#! where the inferred type is 'class' are updated,
#! - Call sites where the inferred type is a subtype
#! of 'mixin' disjoint from 'class' are not updated
dup class-usages {
[ drop [ swap remove ] change-mixin-class ]
[ drop "instances" word-prop delete-at ]
[ 2nip [ update-class ] each ]
[ nip update-methods ]
} 3cleave ;
PRIVATE>
GENERIC# add-mixin-instance 1 ( class mixin -- )
M: class add-mixin-instance
[ 2drop ] [ (add-mixin-instance) ] if-mixin-member? ;
: remove-mixin-instance ( class mixin -- )
[ (remove-mixin-instance) ] [ 2drop ] if-mixin-member? ;
M: mixin-class class-forgotten remove-mixin-instance ;
: define-mixin-class ( class -- )
dup mixin-class? [
@ -26,73 +87,19 @@ M: mixin-class rank-class drop 3 ;
tri
] if ;
TUPLE: check-mixin-class class ;
: check-mixin-class ( mixin -- mixin )
dup mixin-class? [
\ check-mixin-class boa throw
] unless ;
: if-mixin-member? ( class mixin true false -- )
[ check-mixin-class 2dup members member-eq? ] 2dip if ; inline
: change-mixin-class ( class mixin quot -- )
[ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
swap redefine-mixin-class ; inline
: update-classes/new ( mixin -- )
class-usages
[ [ update-class ] each ]
[ implementors [ remake-generic ] each ] bi ;
: (add-mixin-instance) ( class mixin -- )
[ [ suffix ] change-mixin-class ]
[ [ f ] 2dip "instances" word-prop set-at ]
2bi ;
GENERIC# add-mixin-instance 1 ( class mixin -- )
M: class add-mixin-instance
#! Note: we call update-classes on the new member, not the
#! mixin. This ensures that we only have to update the
#! methods whose specializer intersects the new member, not
#! the entire mixin (since the other mixin members are not
#! affected at all). Also, all usages of the mixin will get
#! updated by transitivity; the mixins usages appear in
#! class-usages of the member, now that it's been added.
[ 2drop ] [
[ (add-mixin-instance) ] 2keep
[ nip ] [ [ new-class? ] either? ] 2bi
[ update-classes/new ] [ update-classes ] if
] if-mixin-member? ;
: (remove-mixin-instance) ( class mixin -- )
[ [ swap remove ] change-mixin-class ]
[ "instances" word-prop delete-at ]
2bi ;
: remove-mixin-instance ( class mixin -- )
#! The order of the three clauses is important here. The last
#! one must come after the other two so that the entries it
#! adds to changed-generics are not overwritten.
[
[ (remove-mixin-instance) ]
[ nip update-classes ]
[ class-usages update-methods ]
2tri
] [ 2drop ] if-mixin-member? ;
M: mixin-class class-forgotten remove-mixin-instance ;
! Definition protocol implementation ensures that removing an
! INSTANCE: declaration from a source file updates the mixin.
TUPLE: mixin-instance class mixin ;
C: <mixin-instance> mixin-instance
<PRIVATE
: >mixin-instance< ( mixin-instance -- class mixin )
[ class>> ] [ mixin>> ] bi ; inline
PRIVATE>
M: mixin-instance where >mixin-instance< "instances" word-prop at ;
M: mixin-instance set-where >mixin-instance< "instances" word-prop set-at ;

4
core/classes/parser/parser.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser vocabs.parser words kernel classes compiler.units lexer ;
IN: classes.parser
@ -9,7 +9,7 @@ IN: classes.parser
: create-class-in ( string -- word )
current-vocab create
dup save-class-location
dup predicate-word dup set-word save-location ;
dup create-predicate-word dup set-word save-location ;
: CREATE-CLASS ( -- word )
scan create-class-in ;

6
core/classes/predicate/predicate.factor
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: classes classes.algebra classes.algebra.private kernel
namespaces make words sequences quotations arrays kernel.private
@ -8,6 +8,8 @@ IN: classes.predicate
PREDICATE: predicate-class < class
"metaclass" word-prop predicate-class eq? ;
<PRIVATE
GENERIC: predicate-quot ( class -- quot )
M: predicate-class predicate-quot
@ -18,6 +20,8 @@ M: predicate-class predicate-quot
[ drop f ] , \ if ,
] [ ] make ;
PRIVATE>
: define-predicate-class ( class superclass definition -- )
[ drop f f predicate-class define-class ]
[ nip "predicate-definition" set-word-prop ]

9
core/classes/singleton/singleton.factor
View File

@ -1,11 +1,16 @@
! Copyright (C) 2008, 2009 Doug Coleman, Slava Pestov.
! Copyright (C) 2008, 2010 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes classes.algebra classes.algebra.private
classes.predicate kernel sequences words ;
classes.predicate classes.predicate.private kernel sequences
words ;
IN: classes.singleton
<PRIVATE
: singleton-predicate-quot ( class -- quot ) [ eq? ] curry ;
PRIVATE>
PREDICATE: singleton-class < predicate-class
[ "predicate-definition" word-prop ]
[ singleton-predicate-quot ]

5
core/classes/tuple/tuple-docs.factor
View File

@ -200,6 +200,8 @@ ARTICLE: "tuple-introspection" "Tuple introspection"
tuple>array
tuple-slots
}
"Tuples can be compared for slot equality even if the tuple class overrides " { $link equal? } ":"
{ $subsections tuple= }
"Tuple classes can also be defined at run time:"
{ $subsections define-tuple-class }
{ $see-also "slots" "mirrors" } ;
@ -348,8 +350,7 @@ HELP: tuple-class
HELP: tuple=
{ $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
{ $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
{ $description "Checks if two tuples have equal slot values. This is the default behavior of " { $link = } " on tuples, unless the tuple class subclasses " { $link identity-tuple } " or implements a method on " { $link equal? } ". In cases where equality has been redefined, this word can be used to get the default semantics if needed." } ;
HELP: tuple
{ $class-description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class."

2
core/classes/tuple/tuple.factor
View File

@ -223,7 +223,7 @@ M: tuple-class update-class
2drop
[
[ update-tuples-after ]
[ changed-definition ]
[ changed-conditionally ]
bi
] each-subclass
]

20
core/classes/union/union.factor
View File

@ -1,13 +1,15 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
classes.algebra classes.algebra.private namespaces arrays math
quotations ;
classes.private classes.algebra classes.algebra.private
namespaces arrays math quotations definitions ;
IN: classes.union
PREDICATE: union-class < class
"metaclass" word-prop union-class eq? ;
<PRIVATE
: union-predicate-quot ( members -- quot )
[
[ drop f ]
@ -24,15 +26,23 @@ PREDICATE: union-class < class
M: union-class update-class define-union-predicate ;
: (define-union-class) ( class members -- )
f swap f union-class define-class ;
f swap f union-class make-class-props (define-class) ;
PRIVATE>
: define-union-class ( class members -- )
[ (define-union-class) ] [ drop update-classes ] 2bi ;
[ (define-union-class) ]
[ drop changed-conditionally ]
[ drop update-classes ]
2tri ;
M: union-class rank-class drop 2 ;
M: union-class instance?
"members" word-prop [ instance? ] with any? ;
M: union-class normalize-class
members <anonymous-union> normalize-class ;
M: union-class (flatten-class)
members <anonymous-union> (flatten-class) ;

44
core/compiler/units/units.factor
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: accessors arrays kernel continuations assocs namespaces
sequences words vocabs definitions hashtables init sets
@ -43,6 +43,20 @@ PRIVATE>
SYMBOL: compiler-impl
HOOK: update-call-sites compiler-impl ( class generic -- words )
: changed-call-sites ( class generic -- )
update-call-sites [ changed-definition ] each ;
M: generic update-generic ( class generic -- )
[ changed-call-sites ]
[ remake-generic drop ]
[ changed-conditionally drop ]
2tri ;
M: sequence update-methods ( class seq -- )
implementors [ update-generic ] with each ;
HOOK: recompile compiler-impl ( words -- alist )
HOOK: to-recompile compiler-impl ( -- words )
@ -52,12 +66,14 @@ HOOK: process-forgotten-words compiler-impl ( words -- )
: compile ( words -- ) recompile modify-code-heap ;
! Non-optimizing compiler
M: f recompile
[ dup def>> ] { } map>assoc ;
M: f update-call-sites
2drop { } ;
M: f to-recompile
changed-definitions get [ drop word? ] assoc-filter
changed-generics get assoc-union keys ;
changed-definitions get [ drop word? ] assoc-filter keys ;
M: f recompile
[ dup def>> ] { } map>assoc ;
M: f process-forgotten-words drop ;
@ -92,9 +108,9 @@ GENERIC: definitions-changed ( assoc obj -- )
! inline caching
: effect-counter ( -- n ) 47 special-object ; inline
GENERIC: bump-effect-counter* ( defspec -- ? )
GENERIC: always-bump-effect-counter? ( defspec -- ? )
M: object bump-effect-counter* drop f ;
M: object always-bump-effect-counter? drop f ;
<PRIVATE
@ -108,6 +124,7 @@ M: object bump-effect-counter* drop f ;
dup new-definitions get first update
dup new-definitions get second update
dup changed-definitions get update
dup maybe-changed get update
dup dup changed-vocabs update ;
: process-forgotten-definitions ( -- )
@ -117,9 +134,10 @@ M: object bump-effect-counter* drop f ;
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 ;
changed-effects get
maybe-changed get
changed-definitions get [ drop always-bump-effect-counter? ] assoc-filter
3array assoc-combine new-words get assoc-diff assoc-empty? not ;
: bump-effect-counter ( -- )
bump-effect-counter? [
@ -148,25 +166,23 @@ PRIVATE>
: with-nested-compilation-unit ( quot -- )
[
H{ } clone changed-definitions set
H{ } clone changed-generics set
H{ } clone maybe-changed set
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
: with-compilation-unit ( quot -- )
[
H{ } clone changed-definitions set
H{ } clone changed-generics set
H{ } clone maybe-changed set
H{ } clone changed-effects set
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
[ finish-compilation-unit ] [ ] cleanup

17
core/definitions/definitions.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences namespaces assocs math accessors ;
IN: definitions
@ -15,28 +15,23 @@ SYMBOL: changed-definitions
: changed-definition ( defspec -- )
dup changed-definitions get set-in-unit ;
SYMBOL: changed-effects
SYMBOL: maybe-changed
SYMBOL: changed-generics
: changed-conditionally ( class -- )
dup maybe-changed get set-in-unit ;
SYMBOL: changed-effects
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 ;
: new-class? ( word -- ? )
new-classes get key? ;
GENERIC: where ( defspec -- loc )
M: object where drop f ;

19
core/generic/generic.factor
View File

@ -87,21 +87,16 @@ TUPLE: check-method class generic ;
\ check-method boa throw
] unless ; inline
: changed-generic ( class generic -- )
changed-generics get
[ [ [ class-or ] when* ] change-at ] [ no-compilation-unit ] if* ;
: remake-generic ( generic -- )
dup outdated-generics get set-in-unit ;
: remake-generics ( -- )
outdated-generics get keys [ generic? ] filter [ make-generic ] each ;
GENERIC: update-generic ( class generic -- )
: with-methods ( class generic quot -- )
[ drop changed-generic ]
[ [ "methods" word-prop ] dip call ]
[ drop remake-generic drop ]
3tri ; inline
[ "methods" word-prop ] prepose [ update-generic ] 2bi ; inline
: method-word-name ( class generic -- string )
[ name>> ] bi@ "=>" glue ;
@ -109,6 +104,9 @@ TUPLE: check-method class generic ;
PREDICATE: method-body < word
"method-generic" word-prop >boolean ;
M: method-body flushable?
"method-generic" word-prop flushable? ;
M: method-body stack-effect
"method-generic" word-prop stack-effect ;
@ -174,11 +172,6 @@ M: method-body forget*
[ call-next-method ] bi
] if ;
M: sequence update-methods ( class seq -- )
implementors [
[ changed-generic ] [ remake-generic drop ] 2bi
] with each ;
: define-generic ( word combination effect -- )
[ nip swap set-stack-effect ]
[

3
core/kernel/kernel-docs.factor
View File

@ -672,6 +672,9 @@ HELP: object
HELP: null
{ $class-description
"The canonical empty class with no instances."
}
{ $notes
"Unlike " { $snippet "null" } " in Java or " { $snippet "NULL" } " in C++, this is not a value signifying empty, or nothing. Use " { $link f } " for this purpose."
} ;
HELP: most

5
core/words/words.factor
View File

@ -110,9 +110,14 @@ M: word make-inline
: define-inline ( word def effect -- )
[ define-declared ] [ 2drop make-inline ] 3bi ;
GENERIC: flushable? ( word -- ? )
M: word flushable? "flushable" word-prop ;
GENERIC: reset-word ( word -- )
M: word reset-word
dup flushable? [ dup changed-conditionally ] when
{
"unannotated-def" "parsing" "inline" "recursive"
"foldable" "flushable" "reading" "writing" "reader"

32
extra/gpu/shaders/shaders.factor
View File

@ -128,6 +128,20 @@ TR: hyphens>underscores "-" "_" ;
[ gl-type vertex-attribute [ component-type>> ] [ dim>> ] bi feedback-type= ]
} 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ;
:: (bind-float-vertex-attribute) ( program-instance ptr name dim gl-type normalize? stride offset -- )
program-instance name attribute-index :> idx
idx 0 >= [
idx glEnableVertexAttribArray
idx dim gl-type normalize? stride offset ptr <displaced-alien> glVertexAttribPointer
] when ; inline
:: (bind-int-vertex-attribute) ( program-instance ptr name dim gl-type stride offset -- )
program-instance name attribute-index :> idx
idx 0 >= [
idx glEnableVertexAttribArray
idx dim gl-type stride offset ptr <displaced-alien> glVertexAttribIPointer
] when ; inline
:: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
vertex-attribute name>> hyphens>underscores :> name
vertex-attribute component-type>> :> type
@ -141,23 +155,9 @@ TR: hyphens>underscores "-" "_" ;
{ [ name not ] [ [ 2drop ] ] }
{
[ type unnormalized-integer-components? ]
[
{
name attribute-index [ glEnableVertexAttribArray ] keep
dim gl-type stride offset
} >quotation :> dip-block
{ dip-block dip <displaced-alien> glVertexAttribIPointer } >quotation
]
[ { name dim gl-type stride offset (bind-int-vertex-attribute) } >quotation ]
}
[
{
name attribute-index [ glEnableVertexAttribArray ] keep
dim gl-type normalize? stride offset
} >quotation :> dip-block
{ dip-block dip <displaced-alien> glVertexAttribPointer } >quotation
]
[ { name dim gl-type normalize? stride offset (bind-float-vertex-attribute) } >quotation ]
} cond ;
:: [bind-vertex-format] ( vertex-attributes -- quot )