diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 3e00783409..33ac362c76 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,6 +1,5 @@ + 0.87: -- cocoa: move window while factor is busy: mouse gets messed up! - live search: timer delay would be nice - menu should stay up if mouse button released - roundoff is still not quite right with tracks @@ -19,7 +18,6 @@ - intrinsic fixnum>float float>fixnum - mac intel: struct returns from objc methods - faster apropos -- infer which variables are read, written in a quotation - compiled call traces + ui: diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 08148a6afa..42d4e4ea04 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -7,72 +7,70 @@ optimizer parser sequences sequences-internals words ; [ print-warnings off + ! Wrap everything in a catch which starts a listener so + ! you can see what went wrong, instead of dealing with a + ! fep [ - ! Wrap everything in a catch which starts a listener so - ! you can see what went wrong, instead of dealing with a - ! fep - [ - "Cross-referencing..." print flush - H{ } clone changed-words set-global - H{ } clone crossref set-global xref-words + "Cross-referencing..." print flush + H{ } clone changed-words set-global + H{ } clone crossref set-global xref-words - cpu "x86" = [ - macosx? - "resource:/library/compiler/x86/alien-macosx.factor" - "resource:/library/compiler/x86/alien.factor" - ? run-file + cpu "x86" = [ + macosx? + "resource:/library/compiler/x86/alien-macosx.factor" + "resource:/library/compiler/x86/alien.factor" + ? run-file + ] when + + "compile" get [ + windows? [ + "resource:/library/windows/dlls.factor" + run-file ] when - "compile" get [ - windows? [ - "resource:/library/windows/dlls.factor" - run-file - ] when + \ number= compile + \ + compile + \ nth compile + \ set-nth compile + \ = compile - \ number= compile - \ + compile - \ nth compile - \ set-nth compile - \ = compile - - ! Load UI backend - "cocoa" get [ - "library/ui/cocoa" require - ] when - - "x11" get [ - "library/ui/x11" require - ] when - - windows? [ - "library/ui/windows" require - ] when - - ! Load native I/O code - "native-io" get [ - unix? [ - "library/io/unix" require - ] when - windows? [ - "library/io/windows" require - ] when - ] when - - parse-command-line - - compile-all - - "Initializing native I/O..." print flush - "native-io" get [ init-io ] when - - ! We only do this if we are compiled, otherwise - ! it takes too long. - "Building online help search index..." print - flush - H{ } clone parent-graph set-global xref-help - H{ } clone term-index set-global index-help + ! Load UI backend + "cocoa" get [ + "library/ui/cocoa" require ] when - ] no-parse-hook + + "x11" get [ + "library/ui/x11" require + ] when + + windows? [ + "library/ui/windows" require + ] when + + ! Load native I/O code + "native-io" get [ + unix? [ + "library/io/unix" require + ] when + windows? [ + "library/io/windows" require + ] when + ] when + + parse-command-line + + compile-all + + "Initializing native I/O..." print flush + "native-io" get [ init-io ] when + + ! We only do this if we are compiled, otherwise + ! it takes too long. + "Building online help search index..." print + flush + H{ } clone parent-graph set-global xref-help + H{ } clone term-index set-global index-help + ] when run-bootstrap-init @@ -83,6 +81,10 @@ optimizer parser sequences sequences-internals words ; 0 exit ] set-boot + "compile" get [ + [ recompile ] parse-hook set-global + ] when + f error set-global f error-continuation set-global diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 4d19bbcbb7..17225e8fbb 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -69,6 +69,7 @@ SYMBOL: architecture : emit-object ( header tag quot -- addr ) swap here-as >r swap tag-header emit call align-here r> ; + inline ! Image header @@ -224,7 +225,7 @@ M: string ' : emit-array ( list type -- pointer ) >r [ ' ] map r> object-tag [ dup length emit-fixnum - ( elements -- ) emit-seq + emit-seq ] emit-object ; : transfer-tuple ( tuple -- tuple ) diff --git a/library/compiler/alien/alien-callback.factor b/library/compiler/alien/alien-callback.factor index ef420050c5..c7ab5d4be6 100644 --- a/library/compiler/alien/alien-callback.factor +++ b/library/compiler/alien/alien-callback.factor @@ -27,7 +27,7 @@ M: alien-callback-error summary alien-callback-xt [ word-xt ] curry infer-quot ; \ alien-callback [ string object quotation ] [ alien ] -"infer-effect" set-word-prop +"inferred-effect" set-word-prop \ alien-callback [ empty-node dup node, diff --git a/library/compiler/alien/alien-indirect.factor b/library/compiler/alien/alien-indirect.factor index 3fed61c16b..72590c5043 100644 --- a/library/compiler/alien/alien-indirect.factor +++ b/library/compiler/alien/alien-indirect.factor @@ -16,7 +16,7 @@ M: alien-indirect-error summary drop "Words calling ``alien-indirect'' cannot run in the interpreter. Compile the caller word and try again." ; \ alien-indirect [ string object string ] [ ] -"infer-effect" set-word-prop +"inferred-effect" set-word-prop \ alien-indirect [ empty-node diff --git a/library/compiler/alien/alien-invoke.factor b/library/compiler/alien/alien-invoke.factor index 165e29891b..26bd931677 100644 --- a/library/compiler/alien/alien-invoke.factor +++ b/library/compiler/alien/alien-invoke.factor @@ -9,7 +9,7 @@ TUPLE: alien-invoke library function return parameters ; C: alien-invoke make-node ; : alien-invoke-stack ( node -- ) - dup alien-invoke-parameters length over consume-values + dup alien-invoke-parameters over consume-values dup alien-invoke-return "void" = 0 1 ? swap produce-values ; : alien-invoke-dlsym ( node -- symbol dll ) @@ -29,7 +29,7 @@ M: alien-invoke-error summary [ inference-warning ] recover ; \ alien-invoke [ string object string object ] [ ] -"infer-effect" set-word-prop +"inferred-effect" set-word-prop \ alien-invoke [ empty-node diff --git a/library/compiler/alien/objc/utilities.factor b/library/compiler/alien/objc/utilities.factor index 2e6f6d0e38..3d53ec05a4 100644 --- a/library/compiler/alien/objc/utilities.factor +++ b/library/compiler/alien/objc/utilities.factor @@ -121,7 +121,7 @@ H{ } clone objc-methods set-global \ (send) [ pop-literal nip infer-send ] "infer" set-word-prop \ (send) [ object object ] [ ] -"infer-effect" set-word-prop +"inferred-effect" set-word-prop : send ( ... selector -- ... ) f (send) ; inline diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor index 9aade068eb..59930220f0 100644 --- a/library/compiler/compiler.factor +++ b/library/compiler/compiler.factor @@ -32,10 +32,10 @@ M: f batch-ends drop ; : word-dataflow ( word -- dataflow ) [ - dup ?no-effect + dup "no-effect" word-prop [ no-effect ] when dup dup add-recursive-state - dup specialized-def (dataflow) - swap current-effect check-effect + [ specialized-def (dataflow) ] keep + finish-word 2drop ] with-infer ; : (compile) ( word -- ) @@ -50,11 +50,8 @@ M: f batch-ends drop ; [ (compile) ] with-compiler ; : try-compile ( word -- ) - [ - compile - ] [ - batch-errors get compile-error update-xt - ] recover ; + [ compile ] + [ batch-errors get compile-error update-xt ] recover ; : compile-batch ( seq -- ) batch-errors get batch-begins @@ -78,5 +75,3 @@ M: f batch-ends drop ; changed-words get [ dup hash-keys compile-batch clear-hash ] when* ; - -[ recompile ] parse-hook set diff --git a/library/compiler/inference/branches.factor b/library/compiler/inference/branches.factor index f9563e5e2c..7a39e8cc10 100644 --- a/library/compiler/inference/branches.factor +++ b/library/compiler/inference/branches.factor @@ -55,16 +55,41 @@ TUPLE: unbalanced-branches-error in out ; swap meta-r active-variable unify-effect meta-r set drop ; +TUPLE: unbalanced-namestacks ; + +: unify-namestacks ( seq -- ) + flip + [ H{ } clone [ dupd hash-update ] reduce ] map + meta-n set ; + +: namestack-effect ( seq -- ) + #! If the namestack is unbalanced, we don't throw an error + meta-n active-variable + dup [ length ] map all-equal? [ + inference-error + ] unless + unify-namestacks ; + +: unify-vars ( seq -- ) + #! Don't use active-variable here, because we want to + #! consider variables set right before a throw too + [ inferred-vars swap hash ] map apply-var-seq ; + : unify-effects ( seq -- ) - dup datastack-effect dup callstack-effect + dup datastack-effect + dup callstack-effect + dup namestack-effect + dup unify-vars [ terminated? swap hash ] all? terminated? set ; : unify-dataflow ( effects -- nodes ) [ dataflow-graph swap hash ] map ; : copy-inference ( -- ) - meta-r [ clone ] change meta-d [ clone ] change + meta-r [ clone ] change + meta-n [ [ clone ] map ] change + inferred-vars [ clone ] change d-in [ ] change dataflow-graph off current-node off ; diff --git a/library/compiler/inference/dataflow.factor b/library/compiler/inference/dataflow.factor index fd4212da29..2391760217 100644 --- a/library/compiler/inference/dataflow.factor +++ b/library/compiler/inference/dataflow.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: inference USING: arrays generic hashtables kernel math -namespaces parser sequences words ; +namespaces parser sequences words vectors ; SYMBOL: d-in SYMBOL: meta-d diff --git a/library/compiler/inference/errors.factor b/library/compiler/inference/errors.factor index 0c6a4e78b4..c45044750e 100644 --- a/library/compiler/inference/errors.factor +++ b/library/compiler/inference/errors.factor @@ -28,6 +28,10 @@ M: too-many-r> summary drop "Quotation pops retain stack elements which it did not push" ; +M: too-many-n> summary + drop + "Quotation pops name stack elements which it did not push" ; + M: no-effect error. "The word " write no-effect-word pprint diff --git a/library/compiler/inference/inference.factor b/library/compiler/inference/inference.factor index 0e7cb7fb16..c6956cb233 100644 --- a/library/compiler/inference/inference.factor +++ b/library/compiler/inference/inference.factor @@ -3,7 +3,7 @@ IN: inference USING: arrays errors generic io kernel math namespaces parser prettyprint sequences strings -vectors words ; +vectors words tools ; TUPLE: inference-error rstate major? ; @@ -29,17 +29,14 @@ M: object value-literal : value-vector ( n -- vector ) [ drop ] map >vector ; -: add-inputs ( n stack -- n stack ) - tuck length - dup 0 > +: add-inputs ( seq stack -- n stack ) + tuck [ length ] 2apply - dup 0 > [ dup value-vector [ rot nappend ] keep ] [ drop 0 swap ] if ; -: ensure-values ( n -- ) +: ensure-values ( seq -- ) meta-d [ add-inputs ] change d-in [ + ] change ; -: short-effect ( -- pair ) - d-in get meta-d get length 2array ; - SYMBOL: terminated? : current-effect ( -- effect ) @@ -50,8 +47,10 @@ SYMBOL: recorded : init-inference ( recursive-state -- ) terminated? off - V{ } clone meta-r set V{ } clone meta-d set + V{ } clone meta-r set + V{ } clone meta-n set + empty-vars inferred-vars set 0 d-in set recursive-state set dataflow-graph off @@ -97,9 +96,11 @@ TUPLE: too-many-r> ; ] when ; : undo-infer ( -- ) - recorded get - [ "infer" word-prop not ] subset - [ f "infer-effect" set-word-prop ] each ; + recorded get [ "infer" word-prop not ] subset [ + dup + f "inferred-vars" set-word-prop + f "inferred-effect" set-word-prop + ] each ; : with-infer ( quot -- ) [ @@ -115,8 +116,19 @@ TUPLE: too-many-r> ; ] recover ] with-scope ; -: infer ( quot -- effect ) - [ infer-quot short-effect ] with-infer ; +: infer ( quot -- effect infer-vars ) + [ infer-quot inferred-vars get current-effect ] with-infer ; + +: vars. ( seq str -- ) + over empty? [ 2drop ] [ print [ . ] each ] if ; + +: infer. ( quot -- ) + infer + "* Stack effect:" print effect>string print + dup inferred-vars-reads "* Reads free variables:" vars. + dup inferred-vars-writes "* Writes free variables:" vars. + dup inferred-vars-reads-globals "* Reads global variables:" vars. + inferred-vars-writes-globals "* Writes global variables:" vars. ; : (dataflow) ( quot -- dataflow ) infer-quot f #return node, dataflow-graph get ; diff --git a/library/compiler/inference/known-words.factor b/library/compiler/inference/known-words.factor index c41bcb9415..bba878d2bb 100644 --- a/library/compiler/inference/known-words.factor +++ b/library/compiler/inference/known-words.factor @@ -1,60 +1,62 @@ +! Copyright (C) 2004, 2006 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. IN: inference USING: arrays alien assembler errors generic hashtables hashtables-internals io io-internals kernel kernel-internals math math-internals memory parser -sequences strings vectors words prettyprint ; +sequences strings vectors words prettyprint namespaces ; \ declare [ pop-literal nip - dup length ensure-values + dup ensure-values dup length d-tail swap #declare [ 2dup set-node-in-d set-node-out-d ] keep node, ] "infer" set-word-prop -\ declare { object } { } "infer-effect" set-word-prop +\ declare { object } { } "inferred-effect" set-word-prop -\ fixnum< { fixnum fixnum } { object } "infer-effect" set-word-prop +\ fixnum< { fixnum fixnum } { object } "inferred-effect" set-word-prop \ fixnum< t "foldable" set-word-prop -\ fixnum<= { fixnum fixnum } { object } "infer-effect" set-word-prop +\ fixnum<= { fixnum fixnum } { object } "inferred-effect" set-word-prop \ fixnum<= t "foldable" set-word-prop -\ fixnum> { fixnum fixnum } { object } "infer-effect" set-word-prop +\ fixnum> { fixnum fixnum } { object } "inferred-effect" set-word-prop \ fixnum> t "foldable" set-word-prop -\ fixnum>= { fixnum fixnum } { object } "infer-effect" set-word-prop +\ fixnum>= { fixnum fixnum } { object } "inferred-effect" set-word-prop \ fixnum>= t "foldable" set-word-prop -\ eq? { object object } { object } "infer-effect" set-word-prop +\ eq? { object object } { object } "inferred-effect" set-word-prop \ eq? t "foldable" set-word-prop ! Primitive combinators -\ call { object } { } "infer-effect" set-word-prop +\ call { object } { } "inferred-effect" set-word-prop \ call [ pop-literal infer-quot-value ] "infer" set-word-prop -\ execute { word } { } "infer-effect" set-word-prop +\ execute { word } { } "inferred-effect" set-word-prop \ execute [ pop-literal unit infer-quot-value ] "infer" set-word-prop -\ if { object object object } { } "infer-effect" set-word-prop +\ if { object object object } { } "inferred-effect" set-word-prop \ if [ 2 #drop node, pop-d pop-d swap 2array #if pop-d drop infer-branches ] "infer" set-word-prop -\ cond { object } { } "infer-effect" set-word-prop +\ cond { object } { } "inferred-effect" set-word-prop \ cond [ pop-literal [ no-cond ] swap alist>quot infer-quot-value ] "infer" set-word-prop -\ dispatch { fixnum array } { } "infer-effect" set-word-prop +\ dispatch { fixnum array } { } "inferred-effect" set-word-prop \ dispatch [ pop-literal nip [ ] map @@ -64,300 +66,352 @@ sequences strings vectors words prettyprint ; ! Non-standard control flow \ throw { object } { } t over set-effect-terminated? -"infer-effect" set-word-prop +"inferred-effect" set-word-prop ! Stack effects for all primitives -\ rehash-string { string } { } "infer-effect" set-word-prop +\ rehash-string { string } { } "inferred-effect" set-word-prop -\ string>sbuf { string } { sbuf } "infer-effect" set-word-prop +\ string>sbuf { string } { sbuf } "inferred-effect" set-word-prop -\ bignum>fixnum { bignum } { fixnum } "infer-effect" set-word-prop +\ bignum>fixnum { bignum } { fixnum } "inferred-effect" set-word-prop \ bignum>fixnum t "foldable" set-word-prop -\ float>fixnum { float } { fixnum } "infer-effect" set-word-prop +\ float>fixnum { float } { fixnum } "inferred-effect" set-word-prop \ bignum>fixnum t "foldable" set-word-prop -\ fixnum>bignum { fixnum } { bignum } "infer-effect" set-word-prop +\ fixnum>bignum { fixnum } { bignum } "inferred-effect" set-word-prop \ fixnum>bignum t "foldable" set-word-prop -\ float>bignum { float } { bignum } "infer-effect" set-word-prop +\ float>bignum { float } { bignum } "inferred-effect" set-word-prop \ float>bignum t "foldable" set-word-prop -\ fixnum>float { fixnum } { float } "infer-effect" set-word-prop +\ fixnum>float { fixnum } { float } "inferred-effect" set-word-prop \ fixnum>float t "foldable" set-word-prop -\ bignum>float { bignum } { float } "infer-effect" set-word-prop +\ bignum>float { bignum } { float } "inferred-effect" set-word-prop \ bignum>float t "foldable" set-word-prop -\ (fraction>) { integer integer } { rational } "infer-effect" set-word-prop +\ (fraction>) { integer integer } { rational } "inferred-effect" set-word-prop \ (fraction>) t "foldable" set-word-prop -\ string>float { string } { float } "infer-effect" set-word-prop +\ string>float { string } { float } "inferred-effect" set-word-prop \ string>float t "foldable" set-word-prop -\ float>string { float } { string } "infer-effect" set-word-prop +\ float>string { float } { string } "inferred-effect" set-word-prop \ float>string t "foldable" set-word-prop -\ float>bits { real } { integer } "infer-effect" set-word-prop +\ float>bits { real } { integer } "inferred-effect" set-word-prop \ float>bits t "foldable" set-word-prop -\ double>bits { real } { integer } "infer-effect" set-word-prop +\ double>bits { real } { integer } "inferred-effect" set-word-prop \ double>bits t "foldable" set-word-prop -\ bits>float { integer } { float } "infer-effect" set-word-prop +\ bits>float { integer } { float } "inferred-effect" set-word-prop \ bits>float t "foldable" set-word-prop -\ bits>double { integer } { float } "infer-effect" set-word-prop +\ bits>double { integer } { float } "inferred-effect" set-word-prop \ bits>double t "foldable" set-word-prop -\ { real real } { number } "infer-effect" set-word-prop +\ { real real } { number } "inferred-effect" set-word-prop \ t "foldable" set-word-prop -\ fixnum+ { fixnum fixnum } { integer } "infer-effect" set-word-prop +\ fixnum+ { fixnum fixnum } { integer } "inferred-effect" set-word-prop \ fixnum+ t "foldable" set-word-prop -\ fixnum+fast { fixnum fixnum } { fixnum } "infer-effect" set-word-prop +\ fixnum+fast { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop \ fixnum+fast t "foldable" set-word-prop -\ fixnum- { fixnum fixnum } { integer } "infer-effect" set-word-prop +\ fixnum- { fixnum fixnum } { integer } "inferred-effect" set-word-prop \ fixnum- t "foldable" set-word-prop -\ fixnum-fast { fixnum fixnum } { fixnum } "infer-effect" set-word-prop +\ fixnum-fast { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop \ fixnum-fast t "foldable" set-word-prop -\ fixnum* { fixnum fixnum } { integer } "infer-effect" set-word-prop +\ fixnum* { fixnum fixnum } { integer } "inferred-effect" set-word-prop \ fixnum* t "foldable" set-word-prop -\ fixnum/i { fixnum fixnum } { integer } "infer-effect" set-word-prop +\ fixnum/i { fixnum fixnum } { integer } "inferred-effect" set-word-prop \ fixnum/i t "foldable" set-word-prop -\ fixnum-mod { fixnum fixnum } { fixnum } "infer-effect" set-word-prop +\ fixnum-mod { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop \ fixnum-mod t "foldable" set-word-prop -\ fixnum/mod { fixnum fixnum } { integer fixnum } "infer-effect" set-word-prop +\ fixnum/mod { fixnum fixnum } { integer fixnum } "inferred-effect" set-word-prop \ fixnum/mod t "foldable" set-word-prop -\ fixnum-bitand { fixnum fixnum } { fixnum } "infer-effect" set-word-prop +\ fixnum-bitand { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop \ fixnum-bitand t "foldable" set-word-prop -\ fixnum-bitor { fixnum fixnum } { fixnum } "infer-effect" set-word-prop +\ fixnum-bitor { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop \ fixnum-bitor t "foldable" set-word-prop -\ fixnum-bitxor { fixnum fixnum } { fixnum } "infer-effect" set-word-prop +\ fixnum-bitxor { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop \ fixnum-bitxor t "foldable" set-word-prop -\ fixnum-bitnot { fixnum } { fixnum } "infer-effect" set-word-prop +\ fixnum-bitnot { fixnum } { fixnum } "inferred-effect" set-word-prop \ fixnum-bitnot t "foldable" set-word-prop -\ fixnum-shift { fixnum fixnum } { integer } "infer-effect" set-word-prop +\ fixnum-shift { fixnum fixnum } { integer } "inferred-effect" set-word-prop \ fixnum-shift t "foldable" set-word-prop -\ bignum= { bignum bignum } { object } "infer-effect" set-word-prop +\ bignum= { bignum bignum } { object } "inferred-effect" set-word-prop \ bignum= t "foldable" set-word-prop -\ bignum+ { bignum bignum } { bignum } "infer-effect" set-word-prop +\ bignum+ { bignum bignum } { bignum } "inferred-effect" set-word-prop \ bignum+ t "foldable" set-word-prop -\ bignum- { bignum bignum } { bignum } "infer-effect" set-word-prop +\ bignum- { bignum bignum } { bignum } "inferred-effect" set-word-prop \ bignum- t "foldable" set-word-prop -\ bignum* { bignum bignum } { bignum } "infer-effect" set-word-prop +\ bignum* { bignum bignum } { bignum } "inferred-effect" set-word-prop \ bignum* t "foldable" set-word-prop -\ bignum/i { bignum bignum } { bignum } "infer-effect" set-word-prop +\ bignum/i { bignum bignum } { bignum } "inferred-effect" set-word-prop \ bignum/i t "foldable" set-word-prop -\ bignum-mod { bignum bignum } { bignum } "infer-effect" set-word-prop +\ bignum-mod { bignum bignum } { bignum } "inferred-effect" set-word-prop \ bignum-mod t "foldable" set-word-prop -\ bignum/mod { bignum bignum } { bignum bignum } "infer-effect" set-word-prop +\ bignum/mod { bignum bignum } { bignum bignum } "inferred-effect" set-word-prop \ bignum/mod t "foldable" set-word-prop -\ bignum-bitand { bignum bignum } { bignum } "infer-effect" set-word-prop +\ bignum-bitand { bignum bignum } { bignum } "inferred-effect" set-word-prop \ bignum-bitand t "foldable" set-word-prop -\ bignum-bitor { bignum bignum } { bignum } "infer-effect" set-word-prop +\ bignum-bitor { bignum bignum } { bignum } "inferred-effect" set-word-prop \ bignum-bitor t "foldable" set-word-prop -\ bignum-bitxor { bignum bignum } { bignum } "infer-effect" set-word-prop +\ bignum-bitxor { bignum bignum } { bignum } "inferred-effect" set-word-prop \ bignum-bitxor t "foldable" set-word-prop -\ bignum-bitnot { bignum } { bignum } "infer-effect" set-word-prop +\ bignum-bitnot { bignum } { bignum } "inferred-effect" set-word-prop \ bignum-bitnot t "foldable" set-word-prop -\ bignum-shift { bignum bignum } { bignum } "infer-effect" set-word-prop +\ bignum-shift { bignum bignum } { bignum } "inferred-effect" set-word-prop \ bignum-shift t "foldable" set-word-prop -\ bignum< { bignum bignum } { object } "infer-effect" set-word-prop +\ bignum< { bignum bignum } { object } "inferred-effect" set-word-prop \ bignum< t "foldable" set-word-prop -\ bignum<= { bignum bignum } { object } "infer-effect" set-word-prop +\ bignum<= { bignum bignum } { object } "inferred-effect" set-word-prop \ bignum<= t "foldable" set-word-prop -\ bignum> { bignum bignum } { object } "infer-effect" set-word-prop +\ bignum> { bignum bignum } { object } "inferred-effect" set-word-prop \ bignum> t "foldable" set-word-prop -\ bignum>= { bignum bignum } { object } "infer-effect" set-word-prop +\ bignum>= { bignum bignum } { object } "inferred-effect" set-word-prop \ bignum>= t "foldable" set-word-prop -\ float+ { float float } { float } "infer-effect" set-word-prop +\ float+ { float float } { float } "inferred-effect" set-word-prop \ float+ t "foldable" set-word-prop -\ float- { float float } { float } "infer-effect" set-word-prop +\ float- { float float } { float } "inferred-effect" set-word-prop \ float- t "foldable" set-word-prop -\ float* { float float } { float } "infer-effect" set-word-prop +\ float* { float float } { float } "inferred-effect" set-word-prop \ float* t "foldable" set-word-prop -\ float/f { float float } { float } "infer-effect" set-word-prop +\ float/f { float float } { float } "inferred-effect" set-word-prop \ float/f t "foldable" set-word-prop -\ float< { float float } { object } "infer-effect" set-word-prop +\ float< { float float } { object } "inferred-effect" set-word-prop \ float< t "foldable" set-word-prop -\ float-mod { float float } { float } "infer-effect" set-word-prop +\ float-mod { float float } { float } "inferred-effect" set-word-prop \ float-mod t "foldable" set-word-prop -\ float<= { float float } { object } "infer-effect" set-word-prop +\ float<= { float float } { object } "inferred-effect" set-word-prop \ float<= t "foldable" set-word-prop -\ float> { float float } { object } "infer-effect" set-word-prop +\ float> { float float } { object } "inferred-effect" set-word-prop \ float> t "foldable" set-word-prop -\ float>= { float float } { object } "infer-effect" set-word-prop +\ float>= { float float } { object } "inferred-effect" set-word-prop \ float>= t "foldable" set-word-prop -\ (word) { object object } { word } "infer-effect" set-word-prop +\ (word) { object object } { word } "inferred-effect" set-word-prop -\ update-xt { word } { } "infer-effect" set-word-prop +\ update-xt { word } { } "inferred-effect" set-word-prop -\ word-xt { word } { integer } "infer-effect" set-word-prop +\ word-xt { word } { integer } "inferred-effect" set-word-prop -\ getenv { fixnum } { object } "infer-effect" set-word-prop -\ setenv { object fixnum } { } "infer-effect" set-word-prop -\ stat { string } { object object object object } "infer-effect" set-word-prop -\ (directory) { string } { array } "infer-effect" set-word-prop -\ data-gc { integer } { } "infer-effect" set-word-prop +\ getenv { fixnum } { object } "inferred-effect" set-word-prop +\ setenv { object fixnum } { } "inferred-effect" set-word-prop +\ stat { string } { object object object object } "inferred-effect" set-word-prop +\ (directory) { string } { array } "inferred-effect" set-word-prop +\ data-gc { integer } { } "inferred-effect" set-word-prop ! code-gc does not declare a stack effect since it might be ! called from a compiled word which becomes unreachable during ! the course of its execution, resulting in a crash -\ gc-time { } { integer } "infer-effect" set-word-prop -\ save-image { string } { } "infer-effect" set-word-prop -\ exit { integer } { } "infer-effect" set-word-prop -\ data-room { } { integer integer array } "infer-effect" set-word-prop -\ code-room { } { integer integer } "infer-effect" set-word-prop -\ os-env { string } { object } "infer-effect" set-word-prop -\ millis { } { integer } "infer-effect" set-word-prop +\ gc-time { } { integer } "inferred-effect" set-word-prop +\ save-image { string } { } "inferred-effect" set-word-prop +\ exit { integer } { } "inferred-effect" set-word-prop +\ data-room { } { integer integer array } "inferred-effect" set-word-prop +\ code-room { } { integer integer } "inferred-effect" set-word-prop +\ os-env { string } { object } "inferred-effect" set-word-prop +\ millis { } { integer } "inferred-effect" set-word-prop -\ type { object } { fixnum } "infer-effect" set-word-prop +\ type { object } { fixnum } "inferred-effect" set-word-prop \ type t "foldable" set-word-prop -\ tag { object } { fixnum } "infer-effect" set-word-prop +\ tag { object } { fixnum } "inferred-effect" set-word-prop \ tag t "foldable" set-word-prop -\ cwd { } { string } "infer-effect" set-word-prop -\ cd { string } { } "infer-effect" set-word-prop +\ cwd { } { string } "inferred-effect" set-word-prop +\ cd { string } { } "inferred-effect" set-word-prop -\ dlopen { string } { dll } "infer-effect" set-word-prop -\ dlsym { string object } { integer } "infer-effect" set-word-prop -\ dlclose { dll } { } "infer-effect" set-word-prop +\ dlopen { string } { dll } "inferred-effect" set-word-prop +\ dlsym { string object } { integer } "inferred-effect" set-word-prop +\ dlclose { dll } { } "inferred-effect" set-word-prop -\ { integer } { byte-array } "infer-effect" set-word-prop +\ { integer } { byte-array } "inferred-effect" set-word-prop -\ { integer c-ptr } { c-ptr } "infer-effect" set-word-prop +\ { integer c-ptr } { c-ptr } "inferred-effect" set-word-prop -\ alien-signed-cell { c-ptr integer } { integer } "infer-effect" set-word-prop +\ alien-signed-cell { c-ptr integer } { integer } "inferred-effect" set-word-prop -\ set-alien-signed-cell { integer c-ptr integer } { } "infer-effect" set-word-prop -\ alien-unsigned-cell { c-ptr integer } { integer } "infer-effect" set-word-prop +\ set-alien-signed-cell { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ alien-unsigned-cell { c-ptr integer } { integer } "inferred-effect" set-word-prop -\ set-alien-unsigned-cell { integer c-ptr integer } { } "infer-effect" set-word-prop -\ alien-signed-8 { c-ptr integer } { integer } "infer-effect" set-word-prop +\ set-alien-unsigned-cell { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ alien-signed-8 { c-ptr integer } { integer } "inferred-effect" set-word-prop -\ set-alien-signed-8 { integer c-ptr integer } { } "infer-effect" set-word-prop -\ alien-unsigned-8 { c-ptr integer } { integer } "infer-effect" set-word-prop +\ set-alien-signed-8 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ alien-unsigned-8 { c-ptr integer } { integer } "inferred-effect" set-word-prop -\ set-alien-unsigned-8 { integer c-ptr integer } { } "infer-effect" set-word-prop -\ alien-signed-4 { c-ptr integer } { integer } "infer-effect" set-word-prop +\ set-alien-unsigned-8 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ alien-signed-4 { c-ptr integer } { integer } "inferred-effect" set-word-prop -\ set-alien-signed-4 { integer c-ptr integer } { } "infer-effect" set-word-prop -\ alien-unsigned-4 { c-ptr integer } { integer } "infer-effect" set-word-prop +\ set-alien-signed-4 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ alien-unsigned-4 { c-ptr integer } { integer } "inferred-effect" set-word-prop -\ set-alien-unsigned-4 { integer c-ptr integer } { } "infer-effect" set-word-prop -\ alien-signed-2 { c-ptr integer } { integer } "infer-effect" set-word-prop +\ set-alien-unsigned-4 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ alien-signed-2 { c-ptr integer } { integer } "inferred-effect" set-word-prop -\ set-alien-signed-2 { integer c-ptr integer } { } "infer-effect" set-word-prop -\ alien-unsigned-2 { c-ptr integer } { integer } "infer-effect" set-word-prop +\ set-alien-signed-2 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ alien-unsigned-2 { c-ptr integer } { integer } "inferred-effect" set-word-prop -\ set-alien-unsigned-2 { integer c-ptr integer } { } "infer-effect" set-word-prop -\ alien-signed-1 { c-ptr integer } { integer } "infer-effect" set-word-prop +\ set-alien-unsigned-2 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ alien-signed-1 { c-ptr integer } { integer } "inferred-effect" set-word-prop -\ set-alien-signed-1 { integer c-ptr integer } { } "infer-effect" set-word-prop -\ alien-unsigned-1 { c-ptr integer } { integer } "infer-effect" set-word-prop +\ set-alien-signed-1 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ alien-unsigned-1 { c-ptr integer } { integer } "inferred-effect" set-word-prop -\ set-alien-unsigned-1 { integer c-ptr integer } { } "infer-effect" set-word-prop -\ alien-float { c-ptr integer } { float } "infer-effect" set-word-prop +\ set-alien-unsigned-1 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ alien-float { c-ptr integer } { float } "inferred-effect" set-word-prop -\ set-alien-float { float c-ptr integer } { } "infer-effect" set-word-prop -\ alien-float { c-ptr integer } { float } "infer-effect" set-word-prop +\ set-alien-float { float c-ptr integer } { } "inferred-effect" set-word-prop +\ alien-float { c-ptr integer } { float } "inferred-effect" set-word-prop -\ set-alien-double { float c-ptr integer } { } "infer-effect" set-word-prop -\ alien-double { c-ptr integer } { float } "infer-effect" set-word-prop +\ set-alien-double { float c-ptr integer } { } "inferred-effect" set-word-prop +\ alien-double { c-ptr integer } { float } "inferred-effect" set-word-prop -\ alien>char-string { c-ptr } { string } "infer-effect" set-word-prop +\ alien>char-string { c-ptr } { string } "inferred-effect" set-word-prop -\ string>char-alien { string } { byte-array } "infer-effect" set-word-prop +\ string>char-alien { string } { byte-array } "inferred-effect" set-word-prop -\ alien>u16-string { c-ptr } { string } "infer-effect" set-word-prop +\ alien>u16-string { c-ptr } { string } "inferred-effect" set-word-prop -\ string>u16-alien { string } { byte-array } "infer-effect" set-word-prop +\ string>u16-alien { string } { byte-array } "inferred-effect" set-word-prop -\ string>memory { string integer } { } "infer-effect" set-word-prop -\ memory>string { integer integer } { string } "infer-effect" set-word-prop +\ string>memory { string integer } { } "inferred-effect" set-word-prop +\ memory>string { integer integer } { string } "inferred-effect" set-word-prop -\ alien-address { alien } { integer } "infer-effect" set-word-prop +\ alien-address { alien } { integer } "inferred-effect" set-word-prop -\ slot { object fixnum } { object } "infer-effect" set-word-prop +\ slot { object fixnum } { object } "inferred-effect" set-word-prop -\ set-slot { object object fixnum } { } "infer-effect" set-word-prop +\ set-slot { object object fixnum } { } "inferred-effect" set-word-prop -\ char-slot { fixnum object } { fixnum } "infer-effect" set-word-prop +\ char-slot { fixnum object } { fixnum } "inferred-effect" set-word-prop -\ set-char-slot { fixnum fixnum object } { } "infer-effect" set-word-prop -\ resize-array { integer array } { array } "infer-effect" set-word-prop -\ resize-string { integer string } { string } "infer-effect" set-word-prop +\ set-char-slot { fixnum fixnum object } { } "inferred-effect" set-word-prop +\ resize-array { integer array } { array } "inferred-effect" set-word-prop +\ resize-string { integer string } { string } "inferred-effect" set-word-prop -\ (hashtable) { } { hashtable } "infer-effect" set-word-prop +\ (hashtable) { } { hashtable } "inferred-effect" set-word-prop -\ { integer object } { array } "infer-effect" set-word-prop +\ { integer object } { array } "inferred-effect" set-word-prop -\ begin-scan { } { } "infer-effect" set-word-prop -\ next-object { } { object } "infer-effect" set-word-prop -\ end-scan { } { } "infer-effect" set-word-prop +\ begin-scan { } { } "inferred-effect" set-word-prop +\ next-object { } { object } "inferred-effect" set-word-prop +\ end-scan { } { } "inferred-effect" set-word-prop -\ size { object } { fixnum } "infer-effect" set-word-prop +\ size { object } { fixnum } "inferred-effect" set-word-prop -\ die { } { } "infer-effect" set-word-prop -\ fopen { string string } { alien } "infer-effect" set-word-prop -\ fgetc { alien } { object } "infer-effect" set-word-prop -\ fwrite { string alien } { } "infer-effect" set-word-prop -\ fflush { alien } { } "infer-effect" set-word-prop -\ fclose { alien } { } "infer-effect" set-word-prop -\ expired? { object } { object } "infer-effect" set-word-prop +\ die { } { } "inferred-effect" set-word-prop +\ fopen { string string } { alien } "inferred-effect" set-word-prop +\ fgetc { alien } { object } "inferred-effect" set-word-prop +\ fwrite { string alien } { } "inferred-effect" set-word-prop +\ fflush { alien } { } "inferred-effect" set-word-prop +\ fclose { alien } { } "inferred-effect" set-word-prop +\ expired? { object } { object } "inferred-effect" set-word-prop -\ { object } { wrapper } "infer-effect" set-word-prop +\ { object } { wrapper } "inferred-effect" set-word-prop \ t "foldable" set-word-prop -\ (clone) { object } { object } "infer-effect" set-word-prop +\ (clone) { object } { object } "inferred-effect" set-word-prop -\ become { object fixnum } { object } "infer-effect" set-word-prop +\ become { object fixnum } { object } "inferred-effect" set-word-prop -\ array>vector { array } { vector } "infer-effect" set-word-prop +\ array>vector { array } { vector } "inferred-effect" set-word-prop -\ finalize-compile { array } { } "infer-effect" set-word-prop +\ finalize-compile { array } { } "inferred-effect" set-word-prop -\ { integer integer } { string } "infer-effect" set-word-prop +\ { integer integer } { string } "inferred-effect" set-word-prop -\ { integer } { quotation } "infer-effect" set-word-prop +\ { integer } { quotation } "inferred-effect" set-word-prop + +! Dynamic scope inference +: if-tos-literal ( quot -- ) + peek-d dup value? [ value-literal swap call ] [ 2drop ] if ; + inline + +\ >n [ H{ } clone push-n ] "infer-vars" set-word-prop + +\ >n { object } { } "inferred-effect" set-word-prop + +TUPLE: too-many-n> ; + +: apply-n> ( -- ) + meta-n get empty? [ + > inference-error + ] [ + pop-n drop + ] if ; + +\ n> [ apply-n> ] "infer-vars" set-word-prop + +\ n> { } { object } "inferred-effect" set-word-prop + +\ ndrop [ apply-n> ] "infer-vars" set-word-prop + +\ ndrop { } { } "inferred-effect" set-word-prop + +\ get [ + [ apply-var-read ] if-tos-literal +] "infer-vars" set-word-prop + +\ get { object } { object } "inferred-effect" set-word-prop + +\ set [ + [ apply-var-write ] if-tos-literal +] "infer-vars" set-word-prop + +\ set { object object } { } "inferred-effect" set-word-prop + +\ get-global [ + [ apply-global-read ] + if-tos-literal +] "infer-vars" set-word-prop + +\ get-global { object } { object } "inferred-effect" set-word-prop + +\ set-global [ + [ apply-global-write ] + if-tos-literal +] "infer-vars" set-word-prop + +\ set-global { object object } { } "inferred-effect" set-word-prop diff --git a/library/compiler/inference/stack.factor b/library/compiler/inference/stack.factor index d0958ac9f9..574ee104b4 100644 --- a/library/compiler/inference/stack.factor +++ b/library/compiler/inference/stack.factor @@ -18,7 +18,7 @@ sequences words parser words ; infer-shuffle-outputs ; : define-shuffle ( word shuffle -- ) - [ "infer-effect" set-word-prop ] 2keep + [ "inferred-effect" set-word-prop ] 2keep [ infer-shuffle ] curry "infer" set-word-prop ; { @@ -47,7 +47,7 @@ sequences words parser words ; 0 1 rot node-outputs ] "infer" set-word-prop -\ >r { object } { } "infer-effect" set-word-prop +\ >r { object } { } "inferred-effect" set-word-prop \ r> [ check-r> @@ -57,4 +57,4 @@ sequences words parser words ; 1 0 rot node-outputs ] "infer" set-word-prop -\ r> { } { object } "infer-effect" set-word-prop +\ r> { } { object } "inferred-effect" set-word-prop diff --git a/library/compiler/inference/variables.factor b/library/compiler/inference/variables.factor new file mode 100644 index 0000000000..313e799630 --- /dev/null +++ b/library/compiler/inference/variables.factor @@ -0,0 +1,54 @@ +! Copyright (C) 2004, 2006 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: inference +USING: kernel sequences hashtables kernel-internals words +namespaces generic vectors namespaces ; + +! Name stack and variable binding simulation +SYMBOL: meta-n + +: push-n meta-n get push ; +: pop-n meta-n get pop ; +: peek-n meta-n get peek ; + +TUPLE: inferred-vars reads writes reads-globals writes-globals ; + +: vars-trivial? ( vars -- ? ) tuple-slots [ empty? ] all? ; + +: empty-vars ( -- vars ) + V{ } clone V{ } clone V{ } clone V{ } clone + ; + +: apply-var-seq ( seq -- ) + inferred-vars [ + >r [ tuple-slots ] map r> tuple-slots add flip + [ concat prune >vector ] map first4 + ] change ; + +: apply-var-read ( symbol -- ) + dup meta-n get [ hash-member? ] contains-with? [ + drop + ] [ + inferred-vars get inferred-vars-reads push-new + ] if ; + +: apply-var-write ( symbol -- ) + meta-n get empty? [ + inferred-vars get inferred-vars-writes push-new + ] [ + dup peek-n set-hash + ] if ; + +: apply-global-read ( symbol -- ) + inferred-vars get inferred-vars-reads-globals push-new ; + +: apply-global-write ( symbol -- ) + inferred-vars get inferred-vars-writes-globals push-new ; + +: apply-vars ( vars -- ) + [ + dup inferred-vars-reads [ apply-var-read ] each + dup inferred-vars-writes [ apply-var-write ] each + dup inferred-vars-reads-globals [ apply-global-read ] each + inferred-vars-writes-globals [ apply-global-write ] each + ] when* ; diff --git a/library/compiler/inference/words.factor b/library/compiler/inference/words.factor index 667b9e7439..4cf0a69fe3 100644 --- a/library/compiler/inference/words.factor +++ b/library/compiler/inference/words.factor @@ -5,29 +5,32 @@ math math-internals namespaces parser prettyprint sequences strings vectors words ; IN: inference -: consume-values ( n node -- ) +: consume-values ( seq node -- ) + >r length r> over ensure-values over 0 rot node-inputs meta-d get [ length swap - ] keep set-length ; -: produce-values ( n node -- ) +: produce-values ( seq node -- ) >r [ drop ] map dup r> set-node-out-d meta-d get swap nappend ; : recursing? ( word -- label/f ) recursive-state get assoc ; +: if-inline ( word true false -- ) + >r >r dup "inline" word-prop r> r> if ; inline + : make-call-node ( word -- node ) - dup "inline" word-prop [ dup recursing? [ #call-label ] [ #call ] ?if ] [ #call ] - if ; + if-inline ; -: consume/produce ( word effect -- ) +: consume/produce ( effect word -- ) meta-d get clone >r swap make-call-node dup node, - over effect-in length over consume-values - over effect-out length over produce-values + over effect-in over consume-values + over effect-out over produce-values r> over #call-label? [ swap set-node-in-d ] [ 2drop ] if effect-terminated? [ terminate ] when ; @@ -45,7 +48,7 @@ TUPLE: no-effect word ; : add-recursive-state ( word label -- ) 2array recursive-state [ swap add ] change ; -: inline-block ( word -- node-block variables ) +: inline-block ( word -- node-block data ) [ copy-inference nest-node gensym 2dup add-recursive-state @@ -87,15 +90,14 @@ M: #call-label collect-recursion* apply-infer node-child node-successor splice-node drop ] if ; -: infer-compound ( word -- effect ) +: infer-compound ( word -- hash ) [ - recursive-state get init-inference - [ inline-block nip [ current-effect ] bind ] keep - ] with-scope over consume/produce ; + recursive-state get init-inference inline-block nip + ] with-scope ; -GENERIC: apply-word +GENERIC: infer-word ( word -- effect data ) -M: object apply-word no-effect ; +M: word infer-word no-effect ; TUPLE: effect-error word effect ; @@ -104,57 +106,76 @@ TUPLE: effect-error word effect ; : check-effect ( word effect -- ) over "infer" word-prop [ - 2drop - ] [ over recorded get push - dup pick "declared-effect" word-prop dup - [ effect<= [ effect-error ] unless ] [ 2drop ] if - "infer-effect" set-word-prop - ] if ; + over "declared-effect" word-prop 2dup + [ swap effect<= [ effect-error ] unless ] [ 2drop ] if + ] unless 2drop ; -M: compound apply-word - [ - dup infer-compound check-effect - ] [ - swap t "no-effect" set-word-prop rethrow - ] recover ; +: save-inferred-data ( word effect vars -- ) + >r over r> + dup vars-trivial? [ drop f ] when + "inferred-vars" set-word-prop + "inferred-effect" set-word-prop ; -: ?no-effect ( word -- ) - dup "no-effect" word-prop [ no-effect ] [ drop ] if ; +: finish-word ( word -- effect vars ) + current-effect 2dup check-effect + inferred-vars get + [ save-inferred-data ] 2keep ; -: apply-default ( word -- ) - dup ?no-effect - dup "infer-effect" word-prop [ - over "infer" word-prop [ - swap effect-in length ensure-values call drop - ] [ - consume/produce - ] if* - ] [ - apply-word - ] if* ; +M: compound infer-word + [ dup infer-compound [ finish-word ] bind ] + [ swap t "no-effect" set-word-prop rethrow ] recover ; -M: word apply-object apply-default ; +: custom-infer ( word -- ) + #! Customized inference behavior + dup "inferred-vars" word-prop apply-vars + dup "inferred-effect" word-prop effect-in ensure-values + "infer" word-prop call ; + +: apply-effect/vars ( word effect vars -- ) + apply-vars consume/produce ; + +: cached-infer ( word -- ) + dup "inferred-effect" word-prop + over "inferred-vars" word-prop + apply-effect/vars ; + +: apply-word ( word -- ) + { + { [ dup "no-effect" word-prop ] [ no-effect ] } + { [ dup "infer" word-prop ] [ custom-infer ] } + { [ dup "inferred-effect" word-prop ] [ cached-infer ] } + { [ t ] [ dup infer-word apply-effect/vars ] } + } cond ; + +M: word apply-object apply-word ; M: symbol apply-object apply-literal ; TUPLE: recursive-declare-error word ; -: recursive-effect ( word -- effect ) - dup stack-effect - [ ] [ inference-error ] ?if ; +: declared-infer ( word -- ) + dup stack-effect [ + consume/produce + ] [ + inference-error + ] if* ; + +: apply-inline ( word -- ) + dup recursive-state get peek first eq? + [ declared-infer ] [ inline-closure ] if ; + +: apply-compound ( word -- ) + dup recursing? [ declared-infer ] [ apply-word ] if ; + +: custom-infer-vars ( word -- ) + dup "infer-vars" word-prop dup [ + swap "inferred-effect" word-prop effect-in ensure-values + call + ] [ + 2drop + ] if ; M: compound apply-object - dup "inline" word-prop [ - dup recursive-state get peek first eq? [ - dup recursive-effect consume/produce - ] [ - inline-closure - ] if - ] [ - dup recursing? [ - dup recursive-effect consume/produce - ] [ - apply-default - ] if - ] if ; + dup custom-infer-vars + [ apply-inline ] [ apply-compound ] if-inline ; diff --git a/library/compiler/load.factor b/library/compiler/load.factor index 07d555d00e..57392a0e0c 100644 --- a/library/compiler/load.factor +++ b/library/compiler/load.factor @@ -2,6 +2,7 @@ PROVIDE: library/compiler { +files+ { "inference/shuffle.factor" "inference/dataflow.factor" + "inference/variables.factor" "inference/inference.factor" "inference/branches.factor" "inference/words.factor" diff --git a/library/compiler/optimizer/class-infer.factor b/library/compiler/optimizer/class-infer.factor index 900621ff60..37f81282bd 100644 --- a/library/compiler/optimizer/class-infer.factor +++ b/library/compiler/optimizer/class-infer.factor @@ -119,7 +119,7 @@ M: node child-ties dup node-param "output-classes" word-prop [ call ] [ - node-param "infer-effect" word-prop effect-out + node-param "inferred-effect" word-prop effect-out dup [ word? ] all? [ drop f ] unless ] if* ; diff --git a/library/compiler/test/inference.factor b/library/compiler/test/inference.factor index 9391b7eee4..29b127a1a3 100644 --- a/library/compiler/test/inference.factor +++ b/library/compiler/test/inference.factor @@ -3,6 +3,9 @@ math math-internals namespaces parser sequences strings test vectors words ; IN: temporary +: short-effect + dup effect-in length swap effect-out length 2array nip ; + [ f ] [ f [ [ ] map-nodes ] with-node-iterator ] unit-test [ t ] [ [ ] dataflow dup [ [ ] map-nodes ] with-node-iterator = ] unit-test @@ -11,20 +14,20 @@ IN: temporary [ t ] [ [ [ ] [ ] if ] dataflow dup [ [ ] map-nodes ] with-node-iterator = ] unit-test -[ { 0 0 } ] [ f infer ] unit-test -[ { 0 2 } ] [ [ 2 "Hello" ] infer ] unit-test -[ { 1 2 } ] [ [ dup ] infer ] unit-test +[ { 0 0 } ] [ f infer short-effect ] unit-test +[ { 0 2 } ] [ [ 2 "Hello" ] infer short-effect ] unit-test +[ { 1 2 } ] [ [ dup ] infer short-effect ] unit-test -[ { 1 2 } ] [ [ [ dup ] call ] infer ] unit-test -[ [ call ] infer ] unit-test-fails +[ { 1 2 } ] [ [ [ dup ] call ] infer short-effect ] unit-test +[ [ call ] infer short-effect ] unit-test-fails -[ { 2 4 } ] [ [ 2dup ] infer ] unit-test +[ { 2 4 } ] [ [ 2dup ] infer short-effect ] unit-test -[ { 1 0 } ] [ [ [ ] [ ] if ] infer ] unit-test -[ [ if ] infer ] unit-test-fails -[ [ [ ] if ] infer ] unit-test-fails -[ [ [ 2 ] [ ] if ] infer ] unit-test-fails -[ { 4 3 } ] [ [ [ rot ] [ -rot ] if ] infer ] unit-test +[ { 1 0 } ] [ [ [ ] [ ] if ] infer short-effect ] unit-test +[ [ if ] infer short-effect ] unit-test-fails +[ [ [ ] if ] infer short-effect ] unit-test-fails +[ [ [ 2 ] [ ] if ] infer short-effect ] unit-test-fails +[ { 4 3 } ] [ [ [ rot ] [ -rot ] if ] infer short-effect ] unit-test [ { 4 3 } ] [ [ @@ -33,18 +36,18 @@ IN: temporary ] [ -rot ] if - ] infer + ] infer short-effect ] unit-test -[ { 1 1 } ] [ [ dup [ ] when ] infer ] unit-test -[ { 1 1 } ] [ [ dup [ dup fixnum* ] when ] infer ] unit-test -[ { 2 1 } ] [ [ [ dup fixnum* ] when ] infer ] unit-test +[ { 1 1 } ] [ [ dup [ ] when ] infer short-effect ] unit-test +[ { 1 1 } ] [ [ dup [ dup fixnum* ] when ] infer short-effect ] unit-test +[ { 2 1 } ] [ [ [ dup fixnum* ] when ] infer short-effect ] unit-test -[ { 1 0 } ] [ [ [ drop ] when* ] infer ] unit-test -[ { 1 1 } ] [ [ [ { { [ ] } } ] unless* ] infer ] unit-test +[ { 1 0 } ] [ [ [ drop ] when* ] infer short-effect ] unit-test +[ { 1 1 } ] [ [ [ { { [ ] } } ] unless* ] infer short-effect ] unit-test [ { 0 1 } ] [ - [ [ 2 2 fixnum+ ] dup [ ] when call ] infer + [ [ 2 2 fixnum+ ] dup [ ] when call ] infer short-effect ] unit-test [ @@ -57,37 +60,37 @@ IN: temporary : termination-test-2 [ termination-test-1 ] [ 3 ] if ; -[ { 1 1 } ] [ [ termination-test-2 ] infer ] unit-test +[ { 1 1 } ] [ [ termination-test-2 ] infer short-effect ] unit-test : infinite-loop infinite-loop ; -[ [ infinite-loop ] infer ] unit-test-fails +[ [ infinite-loop ] infer short-effect ] unit-test-fails : no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] if ; -[ [ no-base-case-1 ] infer ] unit-test-fails +[ [ no-base-case-1 ] infer short-effect ] unit-test-fails : simple-recursion-1 ( obj -- obj ) dup [ simple-recursion-1 ] [ ] if ; -[ { 1 1 } ] [ [ simple-recursion-1 ] infer ] unit-test +[ { 1 1 } ] [ [ simple-recursion-1 ] infer short-effect ] unit-test : simple-recursion-2 ( obj -- obj ) dup [ ] [ simple-recursion-2 ] if ; -[ { 1 1 } ] [ [ simple-recursion-2 ] infer ] unit-test +[ { 1 1 } ] [ [ simple-recursion-2 ] infer short-effect ] unit-test : bad-recursion-2 ( obj -- obj ) dup [ dup first swap second bad-recursion-2 ] [ ] if ; -[ [ bad-recursion-2 ] infer ] unit-test-fails +[ [ bad-recursion-2 ] infer short-effect ] unit-test-fails : funny-recursion ( obj -- obj ) dup [ funny-recursion 1 ] [ 2 ] if drop ; -[ { 1 1 } ] [ [ funny-recursion ] infer ] unit-test +[ { 1 1 } ] [ [ funny-recursion ] infer short-effect ] unit-test ! Simple combinators -[ { 1 2 } ] [ [ [ first ] keep second ] infer ] unit-test +[ { 1 2 } ] [ [ [ first ] keep second ] infer short-effect ] unit-test ! Mutual recursion DEFER: foe @@ -110,8 +113,8 @@ DEFER: foe 2drop f ] if ; -[ { 2 1 } ] [ [ fie ] infer ] unit-test -[ { 2 1 } ] [ [ foe ] infer ] unit-test +[ { 2 1 } ] [ [ fie ] infer short-effect ] unit-test +[ { 2 1 } ] [ [ foe ] infer short-effect ] unit-test : nested-when ( -- ) t [ @@ -120,7 +123,7 @@ DEFER: foe ] when ] when ; -[ { 0 0 } ] [ [ nested-when ] infer ] unit-test +[ { 0 0 } ] [ [ nested-when ] infer short-effect ] unit-test : nested-when* ( obj -- ) [ @@ -129,11 +132,11 @@ DEFER: foe ] when* ] when* ; -[ { 1 0 } ] [ [ nested-when* ] infer ] unit-test +[ { 1 0 } ] [ [ nested-when* ] infer short-effect ] unit-test SYMBOL: sym-test -[ { 0 1 } ] [ [ sym-test ] infer ] unit-test +[ { 0 1 } ] [ [ sym-test ] infer short-effect ] unit-test : terminator-branch dup [ @@ -142,7 +145,7 @@ SYMBOL: sym-test "foo" throw ] if ; -[ { 1 1 } ] [ [ terminator-branch ] infer ] unit-test +[ { 1 1 } ] [ [ terminator-branch ] infer short-effect ] unit-test : recursive-terminator ( obj -- ) dup [ @@ -151,12 +154,12 @@ SYMBOL: sym-test "Hi" throw ] if ; -[ { 1 0 } ] [ [ recursive-terminator ] infer ] unit-test +[ { 1 0 } ] [ [ recursive-terminator ] infer short-effect ] unit-test GENERIC: potential-hang ( obj -- obj ) M: fixnum potential-hang dup [ potential-hang ] when ; -[ ] [ [ 5 potential-hang ] infer drop ] unit-test +[ ] [ [ 5 potential-hang ] infer short-effect drop ] unit-test TUPLE: funny-cons car cdr ; GENERIC: iterate ( obj -- ) @@ -164,24 +167,24 @@ M: funny-cons iterate funny-cons-cdr iterate ; M: f iterate drop ; M: real iterate drop ; -[ { 1 0 } ] [ [ iterate ] infer ] unit-test +[ { 1 0 } ] [ [ iterate ] infer short-effect ] unit-test ! Regression : cat ( obj -- * ) dup [ throw ] [ throw ] if ; : dog ( a b c -- ) dup [ cat ] [ 3drop ] if ; -[ { 3 0 } ] [ [ dog ] infer ] unit-test +[ { 3 0 } ] [ [ dog ] infer short-effect ] unit-test ! Regression DEFER: monkey : friend ( a b c -- ) dup [ friend ] [ monkey ] if ; : monkey ( a b c -- ) dup [ 3drop ] [ friend ] if ; -[ { 3 0 } ] [ [ friend ] infer ] unit-test +[ { 3 0 } ] [ [ friend ] infer short-effect ] unit-test -! Regression -- same as above but we infer the second word first +! Regression -- same as above but we infer short-effect the second word first DEFER: blah2 : blah ( a b c -- ) dup [ blah ] [ blah2 ] if ; : blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ; -[ { 3 0 } ] [ [ blah2 ] infer ] unit-test +[ { 3 0 } ] [ [ blah2 ] infer short-effect ] unit-test ! Regression DEFER: blah4 @@ -189,7 +192,7 @@ DEFER: blah4 dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ; : blah4 ( a b c -- ) dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ; -[ { 3 0 } ] [ [ blah4 ] infer ] unit-test +[ { 3 0 } ] [ [ blah4 ] infer short-effect ] unit-test ! Regression : bad-combinator ( obj quot -- ) @@ -199,14 +202,14 @@ DEFER: blah4 [ swap slip ] keep swap bad-combinator ] if ; inline -[ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails +[ [ [ 1 ] [ ] bad-combinator ] infer short-effect ] unit-test-fails ! Regression : bad-input# dup string? [ 2array throw ] unless over string? [ 2array throw ] unless ; -[ { 2 2 } ] [ [ bad-input# ] infer ] unit-test +[ { 2 2 } ] [ [ bad-input# ] infer short-effect ] unit-test ! Regression @@ -214,18 +217,18 @@ DEFER: blah4 DEFER: do-crap : more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ; : do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ; -[ [ do-crap ] infer ] unit-test-fails +[ [ do-crap ] infer short-effect ] unit-test-fails ! This one does not DEFER: do-crap* : more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ; : do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ; -[ [ do-crap* ] infer ] unit-test-fails +[ [ do-crap* ] infer short-effect ] unit-test-fails ! Regression : too-deep ( a b -- c ) dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline -[ { 2 1 } ] [ [ too-deep ] infer ] unit-test +[ { 2 1 } ] [ [ too-deep ] infer short-effect ] unit-test ! Error reporting is wrong G: xyz math-combination ; @@ -233,7 +236,7 @@ M: fixnum xyz 2array ; M: ratio xyz [ >fraction ] 2apply swapd >r 2array swap r> 2array swap ; -[ t ] [ [ [ xyz ] infer ] catch inference-error? ] unit-test +[ t ] [ [ [ xyz ] infer short-effect ] catch inference-error? ] unit-test ! Doug Coleman discovered this one while working on the ! calendar library @@ -265,17 +268,17 @@ DEFER: C [ dup B C ] } dispatch ; -[ { 1 0 } ] [ [ A ] infer ] unit-test -[ { 1 0 } ] [ [ B ] infer ] unit-test -[ { 1 0 } ] [ [ C ] infer ] unit-test +[ { 1 0 } ] [ [ A ] infer short-effect ] unit-test +[ { 1 0 } ] [ [ B ] infer short-effect ] unit-test +[ { 1 0 } ] [ [ C ] infer short-effect ] unit-test ! I found this bug by thinking hard about the previous one DEFER: Y : X ( a b -- c d ) dup [ swap Y ] [ ] if ; : Y ( a b -- c d ) X ; -[ { 2 2 } ] [ [ X ] infer ] unit-test -[ { 2 2 } ] [ [ Y ] infer ] unit-test +[ { 2 2 } ] [ [ X ] infer short-effect ] unit-test +[ { 2 2 } ] [ [ Y ] infer short-effect ] unit-test ! This one comes from UI code DEFER: #1 @@ -284,68 +287,92 @@ DEFER: #1 : #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ; : #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ; -[ \ #4 word-def infer ] unit-test-fails -[ [ #1 ] infer ] unit-test-fails +[ \ #4 word-def infer short-effect ] unit-test-fails +[ [ #1 ] infer short-effect ] unit-test-fails ! Similar DEFER: bar : foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ; : bar ( a b -- ) [ 2 2 + ] t foo drop call drop ; -[ [ foo ] infer ] unit-test-fails +[ [ foo ] infer short-effect ] unit-test-fails -[ 1234 infer ] unit-test-fails +[ 1234 infer short-effect ] unit-test-fails ! This used to hang -[ [ [ dup call ] dup call ] infer ] unit-test-fails +[ [ [ dup call ] dup call ] infer short-effect ] unit-test-fails ! This form should not have a stack effect : bad-recursion-1 ( a -- b ) dup [ drop bad-recursion-1 5 ] [ ] if ; -[ [ bad-recursion-1 ] infer ] unit-test-fails +[ [ bad-recursion-1 ] infer short-effect ] unit-test-fails : bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ; -[ [ bad-bin ] infer ] unit-test-fails +[ [ bad-bin ] infer short-effect ] unit-test-fails -[ t ] [ [ [ r> ] infer ] catch inference-error? ] unit-test +[ t ] [ [ [ r> ] infer short-effect ] catch inference-error? ] unit-test ! Test some random library words -[ { 1 1 } ] [ [ unit ] infer ] unit-test +[ { 1 1 } ] [ [ unit ] infer short-effect ] unit-test -[ { 1 0 } ] [ [ >n ] infer ] unit-test -[ { 0 1 } ] [ [ n> ] infer ] unit-test +! Unbalanced >n/n> is an error now! +! [ { 1 0 } ] [ [ >n ] infer short-effect ] unit-test +! [ { 0 1 } ] [ [ n> ] infer short-effect ] unit-test -[ { 2 1 } ] [ [ bitor ] infer ] unit-test -[ { 2 1 } ] [ [ bitand ] infer ] unit-test -[ { 2 1 } ] [ [ bitxor ] infer ] unit-test -[ { 2 1 } ] [ [ mod ] infer ] unit-test -[ { 2 1 } ] [ [ /i ] infer ] unit-test -[ { 2 1 } ] [ [ /f ] infer ] unit-test -[ { 2 2 } ] [ [ /mod ] infer ] unit-test -[ { 2 1 } ] [ [ + ] infer ] unit-test -[ { 2 1 } ] [ [ - ] infer ] unit-test -[ { 2 1 } ] [ [ * ] infer ] unit-test -[ { 2 1 } ] [ [ / ] infer ] unit-test -[ { 2 1 } ] [ [ < ] infer ] unit-test -[ { 2 1 } ] [ [ <= ] infer ] unit-test -[ { 2 1 } ] [ [ > ] infer ] unit-test -[ { 2 1 } ] [ [ >= ] infer ] unit-test -[ { 2 1 } ] [ [ number= ] infer ] unit-test +[ { 2 1 } ] [ [ bitor ] infer short-effect ] unit-test +[ { 2 1 } ] [ [ bitand ] infer short-effect ] unit-test +[ { 2 1 } ] [ [ bitxor ] infer short-effect ] unit-test +[ { 2 1 } ] [ [ mod ] infer short-effect ] unit-test +[ { 2 1 } ] [ [ /i ] infer short-effect ] unit-test +[ { 2 1 } ] [ [ /f ] infer short-effect ] unit-test +[ { 2 2 } ] [ [ /mod ] infer short-effect ] unit-test +[ { 2 1 } ] [ [ + ] infer short-effect ] unit-test +[ { 2 1 } ] [ [ - ] infer short-effect ] unit-test +[ { 2 1 } ] [ [ * ] infer short-effect ] unit-test +[ { 2 1 } ] [ [ / ] infer short-effect ] unit-test +[ { 2 1 } ] [ [ < ] infer short-effect ] unit-test +[ { 2 1 } ] [ [ <= ] infer short-effect ] unit-test +[ { 2 1 } ] [ [ > ] infer short-effect ] unit-test +[ { 2 1 } ] [ [ >= ] infer short-effect ] unit-test +[ { 2 1 } ] [ [ number= ] infer short-effect ] unit-test -[ { 1 1 } ] [ [ string>number ] infer ] unit-test -[ { 2 1 } ] [ [ = ] infer ] unit-test -[ { 1 1 } ] [ [ get ] infer ] unit-test +[ { 1 1 } ] [ [ string>number ] infer short-effect ] unit-test +[ { 2 1 } ] [ [ = ] infer short-effect ] unit-test +[ { 1 1 } ] [ [ get ] infer short-effect ] unit-test -[ { 2 0 } ] [ [ push ] infer ] unit-test -[ { 2 0 } ] [ [ set-length ] infer ] unit-test -[ { 2 1 } ] [ [ append ] infer ] unit-test -[ { 1 1 } ] [ [ peek ] infer ] unit-test +[ { 2 0 } ] [ [ push ] infer short-effect ] unit-test +[ { 2 0 } ] [ [ set-length ] infer short-effect ] unit-test +[ { 2 1 } ] [ [ append ] infer short-effect ] unit-test +[ { 1 1 } ] [ [ peek ] infer short-effect ] unit-test -[ { 1 1 } ] [ [ length ] infer ] unit-test -[ { 1 1 } ] [ [ reverse ] infer ] unit-test -[ { 2 1 } ] [ [ member? ] infer ] unit-test -[ { 2 1 } ] [ [ remove ] infer ] unit-test -[ { 1 1 } ] [ [ natural-sort ] infer ] unit-test +[ { 1 1 } ] [ [ length ] infer short-effect ] unit-test +[ { 1 1 } ] [ [ reverse ] infer short-effect ] unit-test +[ { 2 1 } ] [ [ member? ] infer short-effect ] unit-test +[ { 2 1 } ] [ [ remove ] infer short-effect ] unit-test +[ { 1 1 } ] [ [ natural-sort ] infer short-effect ] unit-test + +! Test scope inference +SYMBOL: x + +[ [ n> ] infer ] unit-test-fails +[ [ ndrop ] infer ] unit-test-fails +[ V{ x } ] [ [ x get ] infer drop inferred-vars-reads ] unit-test +[ V{ x } ] [ [ x set ] infer drop inferred-vars-writes ] unit-test +[ V{ x } ] [ [ [ x get ] with-scope ] infer drop inferred-vars-reads ] unit-test +[ V{ } ] [ [ [ x set ] with-scope ] infer drop inferred-vars-writes ] unit-test +[ V{ x } ] [ [ [ x get ] bind ] infer drop inferred-vars-reads ] unit-test +[ V{ } ] [ [ [ x set ] bind ] infer drop inferred-vars-writes ] unit-test +[ V{ x } ] [ [ [ x get ] make-hash ] infer drop inferred-vars-reads ] unit-test +[ V{ } ] [ [ [ x set ] make-hash ] infer drop inferred-vars-writes ] unit-test +[ V{ building } ] [ [ , ] infer drop inferred-vars-reads ] unit-test +[ V{ } ] [ [ [ 3 , ] { } make ] infer drop inferred-vars-reads ] unit-test +[ V{ x } ] [ [ [ x get ] [ 5 ] if ] infer drop inferred-vars-reads ] unit-test +[ V{ x } ] [ [ >n [ x get ] [ 5 ] if n> ] infer drop inferred-vars-reads ] unit-test +[ V{ } ] [ [ >n [ x set ] [ drop ] if x get n> ] infer drop inferred-vars-reads ] unit-test +[ V{ x } ] [ [ >n x get ndrop ] infer drop inferred-vars-reads ] unit-test +[ V{ } ] [ [ >n x set ndrop ] infer drop inferred-vars-writes ] unit-test + +[ [ >n ] [ ] if ] unit-test-fails diff --git a/library/effects.factor b/library/effects.factor index 2e3741b32e..da7cbd01ff 100644 --- a/library/effects.factor +++ b/library/effects.factor @@ -44,7 +44,7 @@ C: effect : stack-effect ( word -- effect/f ) dup "declared-effect" word-prop [ ] [ - dup "infer-effect" word-prop [ ] [ drop f ] ?if + dup "inferred-effect" word-prop [ ] [ drop f ] ?if ] ?if ; M: effect clone diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index 68506088fc..dcca8a251f 100644 --- a/library/tools/debugger.factor +++ b/library/tools/debugger.factor @@ -34,7 +34,9 @@ SYMBOL: restarts error-continuation get continuation-name hash-stack ; : :res ( n -- ) - restarts get nth first3 continue-with ; + restarts get-global nth + f restarts set-global + first3 continue-with ; : :edit ( -- ) error get diff --git a/library/ui/hierarchy.factor b/library/ui/hierarchy.factor index e6d49b2084..4291ea2556 100644 --- a/library/ui/hierarchy.factor +++ b/library/ui/hierarchy.factor @@ -75,7 +75,7 @@ M: gadget ungraft* drop ; : build-spec ( spec quot -- ) swap (build-spec) call ; -\ build-spec 2 0 "infer-effect" set-word-prop +\ build-spec 2 0 "inferred-effect" set-word-prop \ build-spec [ pop-literal pop-literal nip (build-spec) infer-quot-value diff --git a/library/words.factor b/library/words.factor index e9f823c39c..82c2b4cce6 100644 --- a/library/words.factor +++ b/library/words.factor @@ -85,8 +85,10 @@ SYMBOL: crossref { [ dup "infer" word-prop ] [ drop ] } { [ t ] [ dup changed-word - { "infer-effect" "base-case" "no-effect" } - reset-props + { + "inferred-effect" "inferred-vars" + "base-case" "no-effect" + } reset-props ] } } cond ;