Fix some compiled-usage issues

db4
Slava Pestov 2008-01-12 04:25:16 -05:00
parent 84891e2591
commit c8d4846a03
8 changed files with 123 additions and 34 deletions

View File

@ -13,33 +13,22 @@ compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies -- )
2dup "compiled-uses" set-word-prop
compiled-crossref get add-vertex ;
compiled-crossref get add-vertex* ;
: compiled-unxref ( word -- )
dup "compiled-uses" word-prop
compiled-crossref get remove-vertex ;
compiled-crossref get remove-vertex* ;
: compiled-usage ( word -- seq )
compiled-crossref get at keys ;
: sensitive? ( word -- ? )
dup "inline" word-prop
over "infer" word-prop
pick "specializer" word-prop
roll generic?
or or or ;
: compiled-usage ( word -- assoc )
compiled-crossref get at ;
: compiled-usages ( words -- seq )
compiled-crossref get [
[
over dup set
over sensitive?
[ at namespace swap update ] [ 2drop ] if
] curry each
] H{ } make-assoc keys ;
[ [ dup ] H{ } map>assoc dup ] keep [
compiled-usage [ nip +inlined+ eq? ] assoc-subset update
] with each keys ;
: ripple-up ( word -- )
compiled-usage [ queue-compile ] each ;
compiled-usage [ drop queue-compile ] assoc-each ;
: save-effect ( word effect -- )
over "compiled-uses" word-prop [
@ -60,7 +49,6 @@ compiled-crossref global [ H{ } assoc-like ] change-at
] computing-dependencies ;
: compile-failed ( word error -- )
! dup inference-error? [ rethrow ] unless
f pick compiled get set-at
swap compiler-error ;

View File

@ -92,7 +92,7 @@ DEFER: x-4
[ t ] [ \ x-3 "compiled-uses" word-prop >boolean ] unit-test
[ t ] [ \ x-3 "compiled-uses" word-prop [ interned? ] all? ] unit-test
[ t ] [ \ x-3 "compiled-uses" word-prop [ drop interned? ] assoc-all? ] unit-test
DEFER: g-test-1
@ -190,3 +190,18 @@ DEFER: inline-then-not-inline-test-2
[ f ] [ \ inline-then-not-inline-test-2 word-xt "a" get = ] unit-test
[ 6 6 9 ] [ inline-then-not-inline-test-2 ] unit-test
DEFER: generic-then-not-generic-test-1
DEFER: generic-then-not-generic-test-2
[ ] [ "IN: temporary GENERIC: generic-then-not-generic-test-1 ( a -- b )" eval ] unit-test
[ ] [ "IN: temporary USE: math M: integer generic-then-not-generic-test-1 sq ;" eval ] unit-test
[ ] [ "IN: temporary : generic-then-not-generic-test-2 3 generic-then-not-generic-test-1 ;" eval ] unit-test
[ 9 ] [ generic-then-not-generic-test-2 ] unit-test
[ ] [ "IN: temporary USE: math : generic-then-not-generic-test-1 1 + ;" eval ] unit-test
[ 4 ] [ generic-then-not-generic-test-2 ] unit-test

View File

@ -16,3 +16,35 @@ H{
[ { 2 3 4 5 } ] [
2 [ "g" get at ] closure keys natural-sort
] unit-test
H{ } "g" set
[ ] [
"mary"
H{ { "billy" "one" } { "joey" "two" } }
"g" get add-vertex*
] unit-test
[ H{ { "mary" "one" } } ] [
"billy" "g" get at
] unit-test
[ ] [
"liz"
H{ { "billy" "four" } { "fred" "three" } }
"g" get add-vertex*
] unit-test
[ H{ { "mary" "one" } { "liz" "four" } } ] [
"billy" "g" get at
] unit-test
[ ] [
"mary"
H{ { "billy" "one" } { "joey" "two" } }
"g" get remove-vertex*
] unit-test
[ H{ { "liz" "four" } } ] [
"billy" "g" get at
] unit-test

View File

@ -16,9 +16,25 @@ SYMBOL: graph
: add-vertex ( vertex edges graph -- )
[ [ dupd nest set-at ] with each ] if-graph ; inline
: (add-vertex) ( key value vertex -- )
rot nest set-at ;
: add-vertex* ( vertex edges graph -- )
[
swap [ (add-vertex) ] curry assoc-each
] if-graph ; inline
: remove-vertex ( vertex edges graph -- )
[ [ graph get at delete-at ] with each ] if-graph ; inline
: (remove-vertex) ( key value vertex -- )
rot graph get at delete-at drop ;
: remove-vertex* ( vertex edges graph -- )
[
swap [ (remove-vertex) ] curry assoc-each
] if-graph ; inline
SYMBOL: previous
: (closure) ( obj quot -- )

View File

@ -76,7 +76,8 @@ GENERIC: apply-object ( obj -- )
M: object apply-object apply-literal ;
M: wrapper apply-object wrapped dup depends-on apply-literal ;
M: wrapper apply-object
wrapped dup +called+ depends-on apply-literal ;
: terminate ( -- )
terminated? on #terminate node, ;
@ -372,6 +373,7 @@ TUPLE: effect-error word effect ;
: custom-infer ( word -- )
#! Customized inference behavior
dup +inlined+ depends-on
"infer" word-prop call ;
: cached-infer ( word -- )
@ -449,10 +451,12 @@ M: #call-label collect-recursion*
] if ;
M: word apply-object
dup depends-on [
[
dup +inlined+ depends-on
dup inline-recursive-label
[ declared-infer ] [ inline-word ] if
] [
dup +called+ depends-on
dup recursive-label
[ declared-infer ] [ apply-word ] if
] if-inline ;

View File

@ -0,0 +1,25 @@
IN: temporary
USING: tools.test inference.state ;
SYMBOL: a
SYMBOL: b
[ ] [ a +called+ depends-on ] unit-test
[ H{ { a +called+ } } ] [
[ a +called+ depends-on ] computing-dependencies
] unit-test
[ H{ { a +called+ } { b +inlined+ } } ] [
[
a +called+ depends-on b +inlined+ depends-on
] computing-dependencies
] unit-test
[ H{ { a +inlined+ } { b +inlined+ } } ] [
[
a +inlined+ depends-on
a +called+ depends-on
b +inlined+ depends-on
] computing-dependencies
] unit-test

View File

@ -31,11 +31,16 @@ SYMBOL: current-node
! Words that the current dataflow IR depends on
SYMBOL: dependencies
: depends-on ( word -- )
dup dependencies get dup [ set-at ] [ 3drop ] if ;
SYMBOL: +inlined+
SYMBOL: +called+
: depends-on ( word how -- )
swap dependencies get dup [
2dup at +inlined+ eq? [ 3drop ] [ set-at ] if
] [ 3drop ] if ;
: computing-dependencies ( quot -- dependencies )
H{ } clone [ dependencies rot with-variable ] keep keys ;
H{ } clone [ dependencies rot with-variable ] keep ;
inline
! Did the current control-flow path throw an error?

View File

@ -1,9 +1,9 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend io kernel math namespaces
sequences vectors words quotations hashtables combinators
classes generic.math continuations optimizer.def-use
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
combinators classes generic.math continuations optimizer.def-use
optimizer.pattern-match generic.standard ;
IN: optimizer.backend
@ -173,8 +173,8 @@ M: node remember-method*
2drop ;
: remember-method ( method-spec node -- )
swap dup
[ [ swap remember-method* ] curry each-node ] [ 2drop ] if ;
swap dup second +inlined+ depends-on
[ swap remember-method* ] curry each-node ;
: (splice-method) ( #call method-spec quot -- node )
#! Must remember the method before splicing in, otherwise
@ -184,7 +184,10 @@ M: node remember-method*
[ swap infer-classes/node ] 2keep
[ substitute-node ] keep ;
: splice-quot ( #call quot -- node ) f swap (splice-method) ;
: splice-quot ( #call quot -- node )
over node-in-d dataflow-with
[ swap infer-classes/node ] 2keep
[ substitute-node ] keep ;
: drop-inputs ( node -- #shuffle )
node-in-d clone \ #shuffle in-node ;
@ -358,7 +361,8 @@ M: #dispatch optimize-node*
] if ;
: optimistic-inline ( #call -- node )
dup node-param word-def splice-quot ;
dup node-param dup +inlined+ depends-on
word-def splice-quot ;
M: #call optimize-node*
{