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

Fix inference bug erg found a while ago

db4
Slava Pestov 2008-06-07 04:19:23 -05:00
parent 014d2ea31c
commit 1ccab34cfa
4 changed files with 98 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/inference/backend/backend-docs.factor
View File

@ -61,7 +61,7 @@ HELP: effect-error
{ $description "Throws an " { $link effect-error } "." } { $description "Throws an " { $link effect-error } "." }
{ $error-description "Thrown when a word's inferred stack effect does not match its declared stack effect." } ; { $error-description "Thrown when a word's inferred stack effect does not match its declared stack effect." } ;
HELP: recursive-declare-error HELP: no-recursive-declaration
{ $error-description "Thrown when inference encounters a recursive call to a word lacking a stack effect declaration. Recursive words must declare a stack effect in order to compile. Due to implementation detail, generic words are recursive, and thus the same restriction applies." } ; { $error-description "Thrown when inference encounters a recursive call to a word lacking a stack effect declaration. Recursive words must declare a stack effect in order to compile. Due to implementation detail, generic words are recursive, and thus the same restriction applies." } ;
HELP: recursive-quotation-error HELP: recursive-quotation-error

151
core/inference/backend/backend.factor
View File

@ -90,8 +90,9 @@ M: object value-literal \ literal-expected inference-warning ;
meta-d [ add-inputs ] change d-in [ + ] change ; meta-d [ add-inputs ] change d-in [ + ] change ;
: current-effect ( -- effect ) : current-effect ( -- effect )
d-in get meta-d get length <effect> d-in get
terminated? get over set-effect-terminated? ; meta-d get length <effect>
terminated? get >>terminated? ;
: init-inference ( -- ) : init-inference ( -- )
terminated? off terminated? off
@ -115,13 +116,13 @@ M: wrapper apply-object
terminated? on #terminate node, ; terminated? on #terminate node, ;
: infer-quot ( quot rstate -- ) : infer-quot ( quot rstate -- )
recursive-state get >r recursive-state get [
recursive-state set recursive-state set
[ apply-object terminated? get not ] all? drop [ apply-object terminated? get not ] all? drop
r> recursive-state set ; ] dip recursive-state set ;
: infer-quot-recursive ( quot word label -- ) : infer-quot-recursive ( quot word label -- )
recursive-state get -rot 2array prefix infer-quot ; 2array recursive-state get swap prefix infer-quot ;
: time-bomb ( error -- ) : time-bomb ( error -- )
[ throw ] curry recursive-state get infer-quot ; [ throw ] curry recursive-state get infer-quot ;
@ -136,9 +137,9 @@ TUPLE: recursive-quotation-error quot ;
value-literal recursive-quotation-error inference-error value-literal recursive-quotation-error inference-error
] [ ] [
dup value-literal callable? [ dup value-literal callable? [
dup value-literal [ value-literal ]
over value-recursion [ [ value-recursion ] keep f 2array prefix ]
rot f 2array prefix infer-quot bi infer-quot
] [ ] [
drop bad-call drop bad-call
] if ] if
@ -191,26 +192,26 @@ TUPLE: too-many-r> ;
meta-d get push-all ; meta-d get push-all ;
: if-inline ( word true false -- ) : if-inline ( word true false -- )
>r >r dup inline? r> r> if ; inline [ dup inline? ] 2dip if ; inline
: consume/produce ( effect node -- ) : consume/produce ( effect node -- )
over effect-in over consume-values [ [ in>> ] dip consume-values ]
over effect-out over produce-values [ [ out>> ] dip produce-values ]
node, [ node, terminated?>> [ terminate ] when ]
effect-terminated? [ terminate ] when ; 2tri ;
GENERIC: constructor ( value -- word/f ) GENERIC: constructor ( value -- word/f )
GENERIC: infer-uncurry ( value -- ) GENERIC: infer-uncurry ( value -- )
M: curried infer-uncurry M: curried infer-uncurry
drop pop-d dup curried-obj push-d curried-quot push-d ; drop pop-d [ obj>> push-d ] [ quot>> push-d ] bi ;
M: curried constructor M: curried constructor
drop \ curry ; drop \ curry ;
M: composed infer-uncurry M: composed infer-uncurry
drop pop-d dup composed-quot1 push-d composed-quot2 push-d ; drop pop-d [ quot1>> push-d ] [ quot2>> push-d ] bi ;
M: composed constructor M: composed constructor
drop \ compose ; drop \ compose ;
@ -255,13 +256,13 @@ M: object constructor drop f ;
DEFER: unify-values DEFER: unify-values
: unify-curries ( seq -- value ) : unify-curries ( seq -- value )
dup [ curried-obj ] map unify-values [ [ obj>> ] map unify-values ]
swap [ curried-quot ] map unify-values [ [ quot>> ] map unify-values ] bi
<curried> ; <curried> ;
: unify-composed ( seq -- value ) : unify-composed ( seq -- value )
dup [ composed-quot1 ] map unify-values [ [ quot1>> ] map unify-values ]
swap [ composed-quot2 ] map unify-values [ [ quot2>> ] map unify-values ] bi
<composed> ; <composed> ;
TUPLE: cannot-unify-specials ; TUPLE: cannot-unify-specials ;
@ -292,7 +293,7 @@ TUPLE: unbalanced-branches-error quots in out ;
: unify-inputs ( max-d-in d-in meta-d -- meta-d ) : unify-inputs ( max-d-in d-in meta-d -- meta-d )
dup [ dup [
[ >r - r> length + ] keep add-inputs nip [ [ - ] dip length + ] keep add-inputs nip
] [ ] [
2nip 2nip
] if ; ] if ;
@ -318,21 +319,24 @@ TUPLE: unbalanced-branches-error quots in out ;
[ swap at ] curry map ; [ swap at ] curry map ;
: datastack-effect ( seq -- ) : datastack-effect ( seq -- )
dup quotation branch-variable [ quotation branch-variable ]
over d-in branch-variable [ d-in branch-variable ]
rot meta-d active-variable [ meta-d active-variable ] tri
unify-effect meta-d set d-in set ; unify-effect
[ d-in set ] [ meta-d set ] bi* ;
: retainstack-effect ( seq -- ) : retainstack-effect ( seq -- )
dup quotation branch-variable [ quotation branch-variable ]
over length 0 <repetition> [ length 0 <repetition> ]
rot meta-r active-variable [ meta-r active-variable ] tri
unify-effect meta-r set drop ; unify-effect
[ drop ] [ meta-r set ] bi* ;
: unify-effects ( seq -- ) : unify-effects ( seq -- )
dup datastack-effect [ datastack-effect ]
dup retainstack-effect [ retainstack-effect ]
[ terminated? swap at ] all? terminated? set ; [ [ terminated? swap at ] all? terminated? set ]
tri ;
: unify-dataflow ( effects -- nodes ) : unify-dataflow ( effects -- nodes )
dataflow-graph branch-variable ; dataflow-graph branch-variable ;
@ -347,14 +351,17 @@ TUPLE: unbalanced-branches-error quots in out ;
: infer-branch ( last value -- namespace ) : infer-branch ( last value -- namespace )
[ [
copy-inference copy-inference
dup value-literal quotation set
infer-quot-value [ value-literal quotation set ]
[ infer-quot-value ]
bi
terminated? get [ drop ] [ call node, ] if terminated? get [ drop ] [ call node, ] if
] H{ } make-assoc ; inline ] H{ } make-assoc ; inline
: (infer-branches) ( last branches -- list ) : (infer-branches) ( last branches -- list )
[ infer-branch ] with map [ infer-branch ] with map
dup unify-effects unify-dataflow ; inline [ unify-effects ] [ unify-dataflow ] bi ; inline
: infer-branches ( last branches node -- ) : infer-branches ( last branches node -- )
#! last is a quotation which provides a #return or a #values #! last is a quotation which provides a #return or a #values
@ -390,9 +397,10 @@ TUPLE: effect-error word effect ;
: finish-word ( word -- ) : finish-word ( word -- )
current-effect current-effect
2dup check-effect [ check-effect ]
over recorded get push [ drop recorded get push ]
"inferred-effect" set-word-prop ; [ "inferred-effect" set-word-prop ]
2tri ;
: infer-word ( word -- effect ) : infer-word ( word -- effect )
[ [
@ -408,8 +416,7 @@ TUPLE: effect-error word effect ;
: custom-infer ( word -- ) : custom-infer ( word -- )
#! Customized inference behavior #! Customized inference behavior
dup +inlined+ depends-on [ +inlined+ depends-on ] [ "infer" word-prop call ] bi ;
"infer" word-prop call ;
: cached-infer ( word -- ) : cached-infer ( word -- )
dup "inferred-effect" word-prop make-call-node ; dup "inferred-effect" word-prop make-call-node ;
@ -422,13 +429,13 @@ TUPLE: effect-error word effect ;
[ dup infer-word make-call-node ] [ dup infer-word make-call-node ]
} cond ; } cond ;
TUPLE: recursive-declare-error word ; TUPLE: no-recursive-declaration word ;
: declared-infer ( word -- ) : declared-infer ( word -- )
dup stack-effect [ dup stack-effect [
make-call-node make-call-node
] [ ] [
\ recursive-declare-error inference-error \ no-recursive-declaration inference-error
] if* ; ] if* ;
GENERIC: collect-label-info* ( label node -- ) GENERIC: collect-label-info* ( label node -- )
@ -463,40 +470,56 @@ M: #return collect-label-info*
: inline-block ( word -- #label data ) : inline-block ( word -- #label data )
[ [
copy-inference nest-node copy-inference nest-node
dup word-def swap <inlined-block> [ word-def ] [ <inlined-block> ] bi
[ infer-quot-recursive ] 2keep [ infer-quot-recursive ] 2keep
#label unnest-node #label unnest-node
dup collect-label-info dup collect-label-info
] H{ } make-assoc ; ] H{ } make-assoc ;
: join-values ( #label -- ) : join-values ( #label -- )
calls>> [ node-in-d ] map meta-d get suffix calls>> [ in-d>> ] map meta-d get suffix
unify-lengths unify-stacks unify-lengths unify-stacks
meta-d [ length tail* ] change ; meta-d [ length tail* ] change ;
: splice-node ( node -- ) : splice-node ( node -- )
dup node-successor [ dup successor>> [
dup node, penultimate-node f over set-node-successor [ node, ] [ penultimate-node ] bi
dup current-node set f >>successor
] when drop ; current-node set
] [ drop ] if ;
: apply-infer ( hash -- ) : apply-infer ( data -- )
{ meta-d meta-r d-in terminated? } { meta-d meta-r d-in terminated? } swap extract-keys
[ swap [ at ] curry map ] keep namespace swap update ;
[ set ] 2each ;
: current-stack-height ( -- n )
meta-d get length d-in get - ;
: word-stack-height ( word -- n )
stack-effect [ in>> length ] [ out>> length ] bi - ;
: bad-recursive-declaration ( word inferred -- )
dup 0 < [ 0 ] [ 0 swap ] if <effect> effect-error ;
: check-stack-height ( word height -- )
over word-stack-height over =
[ 2drop ] [ bad-recursive-declaration ] if ;
: inline-recursive-word ( word #label -- )
current-stack-height [
flatten-meta-d [ join-values inline-block apply-infer ] dip >>in-d
[ node, ]
[ calls>> [ [ flatten-curries ] modify-values ] each ]
[ word>> ]
tri
] dip
current-stack-height -
check-stack-height ;
: inline-word ( word -- ) : inline-word ( word -- )
dup inline-block over recursive-label? [ dup inline-block over recursive-label?
flatten-meta-d >r [ drop inline-recursive-word ]
drop join-values inline-block apply-infer [ apply-infer node-child successor>> splice-node drop ] if ;
r> over set-node-in-d
dup node,
calls>> [
[ flatten-curries ] modify-values
] each
] [
apply-infer node-child node-successor splice-node drop
] if ;
M: word apply-object M: word apply-object
[ [

20
core/inference/errors/errors.factor
View File

@ -15,10 +15,8 @@ M: inference-error error-help drop f ;
M: unbalanced-branches-error error. M: unbalanced-branches-error error.
"Unbalanced branches:" print "Unbalanced branches:" print
dup unbalanced-branches-error-quots [ quots>> ] [ in>> ] [ out>> [ length ] map ] tri 3array flip
over unbalanced-branches-error-in [ [ bl ] [ pprint ] interleave nl ] each ;
rot unbalanced-branches-error-out [ length ] map
3array flip [ [ bl ] [ pprint ] interleave nl ] each ;
M: literal-expected summary M: literal-expected summary
drop "Literal value expected" ; drop "Literal value expected" ;
@ -32,24 +30,24 @@ M: too-many-r> summary
"Quotation pops retain stack elements which it did not push" ; "Quotation pops retain stack elements which it did not push" ;
M: no-effect error. M: no-effect error.
"Unable to infer stack effect of " write no-effect-word . ; "Unable to infer stack effect of " write word>> . ;
M: recursive-declare-error error. M: no-recursive-declaration error.
"The recursive word " write "The recursive word " write
recursive-declare-error-word pprint word>> pprint
" must declare a stack effect" print ; " must declare a stack effect" print ;
M: effect-error error. M: effect-error error.
"Stack effects of the word " write "Stack effects of the word " write
dup effect-error-word pprint dup word>> pprint
" do not match." print " do not match." print
"Declared: " write "Declared: " write
dup effect-error-word stack-effect effect>string . dup word>> stack-effect effect>string .
"Inferred: " write effect-error-effect effect>string . ; "Inferred: " write effect>> effect>string . ;
M: recursive-quotation-error error. M: recursive-quotation-error error.
"The quotation " write "The quotation " write
recursive-quotation-error-quot pprint quot>> pprint
" calls itself." print " calls itself." print
"Stack effect inference is undecidable when quotation-level recursion is permitted." print ; "Stack effect inference is undecidable when quotation-level recursion is permitted." print ;

2
core/inference/inference-docs.factor
View File

@ -89,7 +89,7 @@ ARTICLE: "inference-errors" "Inference errors"
{ $subsection too-many-r> } { $subsection too-many-r> }
{ $subsection unbalanced-branches-error } { $subsection unbalanced-branches-error }
{ $subsection effect-error } { $subsection effect-error }
{ $subsection recursive-declare-error } ; { $subsection no-recursive-declaration } ;
ARTICLE: "inference" "Stack effect inference" ARTICLE: "inference" "Stack effect inference"
"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile." "The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile."