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

stack-checker.dependencies: make conditional dependencies more robust

release
Slava Pestov 2010-01-31 01:55:35 +13:00
parent 9bc4e662c6
commit 2c63161c84
3 changed files with 26 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/compiler/compiler.factor
View File

@ -184,8 +184,8 @@ M: optimizing-compiler update-call-sites ( class generic -- words )
#! Words containing call sites with inferred type 'class' #! Words containing call sites with inferred type 'class'
#! which inlined a method on 'generic' #! which inlined a method on 'generic'
compiled-generic-usage swap '[ compiled-generic-usage swap '[
nip dup forgotten-class? nip dup classoid?
[ drop f ] [ _ classes-intersect? ] if [ _ classes-intersect? ] [ drop f ] if
] assoc-filter keys ; ] assoc-filter keys ;
M: optimizing-compiler recompile ( words -- alist ) M: optimizing-compiler recompile ( words -- alist )

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

@ -1,7 +1,7 @@
! Copyright (C) 2009, 2010 Slava Pestov. ! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors classes.algebra fry generic kernel math USING: assocs accessors classes.algebra fry generic kernel math
namespaces sequences words sets ; namespaces sequences words sets combinators.short-circuit ;
FROM: classes.tuple.private => tuple-layout ; FROM: classes.tuple.private => tuple-layout ;
IN: stack-checker.dependencies IN: stack-checker.dependencies
@ -62,7 +62,11 @@ TUPLE: depends-on-class<= class1 class2 ;
\ depends-on-class<= add-conditional-dependency ; \ depends-on-class<= add-conditional-dependency ;
M: depends-on-class<= satisfied? M: depends-on-class<= satisfied?
[ class1>> ] [ class2>> ] bi class<= ; {
[ class1>> classoid? ]
[ class2>> classoid? ]
[ [ class1>> ] [ class2>> ] bi class<= ]
} 1&& ;
TUPLE: depends-on-classes-disjoint class1 class2 ; TUPLE: depends-on-classes-disjoint class1 class2 ;
@ -70,7 +74,11 @@ TUPLE: depends-on-classes-disjoint class1 class2 ;
\ depends-on-classes-disjoint add-conditional-dependency ; \ depends-on-classes-disjoint add-conditional-dependency ;
M: depends-on-classes-disjoint satisfied? M: depends-on-classes-disjoint satisfied?
[ class1>> ] [ class2>> ] bi classes-intersect? not ; {
[ class1>> classoid? ]
[ class2>> classoid? ]
[ [ class1>> ] [ class2>> ] bi classes-intersect? not ]
} 1&& ;
TUPLE: depends-on-next-method class generic next-method ; TUPLE: depends-on-next-method class generic next-method ;
@ -79,7 +87,10 @@ TUPLE: depends-on-next-method class generic next-method ;
\ depends-on-next-method add-conditional-dependency ; \ depends-on-next-method add-conditional-dependency ;
M: depends-on-next-method satisfied? M: depends-on-next-method satisfied?
[ [ class>> ] [ generic>> ] bi next-method ] [ next-method>> ] bi eq? ; {
[ class>> classoid? ]
[ [ [ class>> ] [ generic>> ] bi next-method ] [ next-method>> ] bi eq? ]
} 1&& ;
TUPLE: depends-on-method class generic method ; TUPLE: depends-on-method class generic method ;
@ -88,7 +99,10 @@ TUPLE: depends-on-method class generic method ;
\ depends-on-method add-conditional-dependency ; \ depends-on-method add-conditional-dependency ;
M: depends-on-method satisfied? M: depends-on-method satisfied?
[ [ class>> ] [ generic>> ] bi method-for-class ] [ method>> ] bi eq? ; {
[ class>> classoid? ]
[ [ [ class>> ] [ generic>> ] bi method-for-class ] [ method>> ] bi eq? ]
} 1&& ;
TUPLE: depends-on-tuple-layout class layout ; TUPLE: depends-on-tuple-layout class layout ;

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

@ -40,12 +40,12 @@ M: object normalize-class ;
PRIVATE> PRIVATE>
GENERIC: forgotten-class? ( obj -- ? ) GENERIC: classoid? ( obj -- ? )
M: word forgotten-class? "forgotten" word-prop ; M: word classoid? class? ;
M: anonymous-union forgotten-class? members>> [ forgotten-class? ] any? ; M: anonymous-union classoid? members>> [ classoid? ] all? ;
M: anonymous-intersection forgotten-class? participants>> [ forgotten-class? ] any? ; M: anonymous-intersection classoid? participants>> [ classoid? ] all? ;
M: anonymous-complement forgotten-class? class>> forgotten-class? ; M: anonymous-complement classoid? class>> classoid? ;
: class<= ( first second -- ? ) : class<= ( first second -- ? )
class<=-cache get [ (class<=) ] 2cache ; class<=-cache get [ (class<=) ] 2cache ;