\r
+ listener/plugin:\r
\r
+- console: wrong history\r
- listener: if too many things popped off the stack, complain\r
- gracefully handle non-working cfactor\r
- NPE in ErrorHighlight\r
"/library/tools/heap-stats.factor"
"/library/gensym.factor"
"/library/tools/interpreter.factor"
+ "/library/inference/dataflow.factor"
"/library/inference/inference.factor"
"/library/inference/words.factor"
"/library/inference/branches.factor"
: keep ( a quot -- a )
#! Execute the quotation with a on the stack, and restore a
#! after the quotation returns.
- over >r call r> ;
+ over >r call r> ; inline
: 2keep ( a b quot -- a b )
#! Execute the quotation with a and b on the stack, and
#! restore a and b after the quotation returns.
- over >r pick >r call r> r> ;
+ over >r pick >r call r> r> ; inline
: apply ( code input -- code output )
#! Apply code to input.
- swap dup >r call r> swap ;
+ swap dup >r call r> swap ; inline
: cond ( x list -- )
#! The list is of this form:
#! If the condition is not f, execute the 'true' quotation,
#! with the condition on the stack. Otherwise, pop the
#! condition and execute the 'false' quotation.
- pick [ drop call ] [ nip nip call ] ifte ;
- inline
+ pick [ drop call ] [ nip nip call ] ifte ; inline
: unless ( cond quot -- )
#! Execute a quotation only when the condition is f. The
DEFER: (infer)
-: (effect) ( -- [ in | stack ] )
- d-in get meta-d get cons ;
-
-: infer-branch ( quot -- [ in-d | datastack ] )
+: infer-branch ( quot -- [ in-d | datastack ] dataflow )
#! Infer the quotation's effect, restoring the meta
#! interpreter state afterwards.
- [ copy-interpreter (infer) (effect) ] with-scope ;
+ [
+ copy-interpreter
+ dataflow-graph off
+ (infer)
+ d-in get meta-d get cons
+ get-dataflow
+ ] with-scope ;
: difference ( [ in | stack ] -- diff )
#! Stack height difference of infer-branch return value.
"Unbalanced branches" throw
] ifte ;
-: recursive-branch ( quot -- )
- #! Set base case if inference didn't fail
+: recursive-branch ( quot -- ? )
+ #! Set base case if inference didn't fail.
[
- car infer-branch recursive-state get set-base
+ car infer-branch drop recursive-state get set-base t
] [
- [ drop ] when
+ [ drop f ] when
] catch ;
-: infer-branches ( brachlist -- )
+: infer-branches ( consume instruction brachlist -- )
#! Recursive stack effect inference is done here. If one of
#! the branches has an undecidable stack effect, we set the
#! base case to this stack effect and try again.
- dup [ recursive-branch ] each
- [ car infer-branch ] map unify ;
+ f over [ recursive-branch or ] each [
+ [ [ car infer-branch , ] map ] make-list swap
+ >r dataflow, r> unify
+ ] [
+ "Foo!" throw
+ ] ifte ;
: infer-ifte ( -- )
#! Infer effects for both branches, unify.
+ 3 IFTE
pop-d pop-d 2list
pop-d drop ( condition )
infer-branches ;
: infer-generic ( -- )
#! Infer effects for all branches, unify.
+ 2 GENERIC
pop-d vtable>list
peek-d drop ( dispatch )
infer-branches ;
: infer-2generic ( -- )
#! Infer effects for all branches, unify.
+ 3 2GENERIC
pop-d vtable>list
peek-d drop ( dispatch )
peek-d drop ( dispatch )
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: inference
+USE: lists
+USE: namespaces
+USE: stack
+
+! We build a dataflow graph for the compiler.
+SYMBOL: dataflow-graph
+
+SYMBOL: CALL ( non-tail call )
+SYMBOL: JUMP ( tail-call )
+SYMBOL: PUSH ( literal )
+
+SYMBOL: IFTE
+SYMBOL: GENERIC
+SYMBOL: 2GENERIC
+
+: get-dataflow ( -- IR )
+ dataflow-graph get reverse ;
+
+: dataflow, ( consume instruction parameters -- )
+ #! Add a node to the dataflow IR. Each node is a list of
+ #! three elements:
+ #! - list of elements consumed from stack
+ #! - a symbol CALL, JUMP or PUSH
+ #! - parameter(s) to insn
+ unit cons cons dataflow-graph cons@ ;
+
+: dataflow-literal, ( lit -- )
+ >r 0 PUSH r> dataflow, ;
+
+: dataflow-word, ( in word -- )
+ >r count CALL r> dataflow, ;
SYMBOL: base-case
SYMBOL: entry-effect
-! We build a dataflow graph for the compiler.
-SYMBOL: dataflow-graph
-
-: dataflow, ( obj -- )
- #! Add a node to the dataflow IR.
- dataflow-graph cons@ ;
-
: gensym-vector ( n -- vector )
dup <vector> swap [ gensym over vector-push ] times ;
DEFER: apply-word
+: apply-literal ( obj -- )
+ #! Literals are annotated with the current recursive
+ #! state.
+ dup dataflow-literal, recursive-state get cons push-d ;
+
: apply-object ( obj -- )
#! Apply the object's stack effect to the inferencer state.
- #! There are three options: recursive-infer words always
- #! cause a recursive call of the inferencer, regardless.
- #! Be careful, you might hang the inferencer. Other words
- #! solve a fixed-point equation if a recursive call is made,
- #! otherwise the inferencer is invoked recursively if its
- #! not a recursive call.
- dup word? [
- apply-word
- ] [
- #! Literals are annotated with the current recursive
- #! state.
- dup dataflow, recursive-state get cons push-d
- ] ifte ;
+ dup word? [ apply-word ] [ apply-literal ] ifte ;
: (infer) ( quot -- )
#! Recursive calls to this word are made for nested
: infer ( quot -- [ in | out ] )
#! Stack effect of a quotation.
- [
- f init-inference (infer) effect
- ( dataflow-graph get USE: prettyprint . )
- ] with-scope ;
+ [ f init-inference (infer) effect ] with-scope ;
+
+: dataflow ( quot -- dataflow )
+ #! Data flow of a quotation.
+ [ f init-inference (infer) get-dataflow ] with-scope ;
: try-infer ( quot -- effect/f )
#! Push f if inference fails.
#! either execute the word in the meta interpreter (if it is
#! side-effect-free and all parameters are literal), or
#! simply apply its stack effect to the meta-interpreter.
+ dup car pick dataflow-word,
swap "infer" word-property dup [
swap car ensure-d call
] [
: apply-compound ( word -- )
#! Infer a compound word's stack effect.
- dup "inline-infer" word-property [
+ dup "inline" word-property [
inline-compound
] [
- [
- dup dataflow, infer-compound consume/produce
- ] [
- [
- dup t "inline-infer" set-word-property
- inline-compound
- ] when
- ] catch
+ dup infer-compound dup car rot dataflow-word,
+ consume/produce
] ifte ;
: current-word ( -- word )
check-recursion recursive-word
] [
drop dup "infer-effect" word-property dup [
- over dataflow,
apply-effect
] [
- drop dup compound? [ apply-compound ] [ no-effect ] ifte
+ drop
+ [
+ [ compound? ] [ apply-compound ]
+ [ symbol? ] [ apply-literal ]
+ [ drop t ] [ no-effect ]
+ ] cond
] ifte
] ifte ;
: infer-call ( [ rstate | quot ] -- )
+ 1 \ drop dataflow-word,
[
+ dataflow-graph off
pop-d uncons recursive-state set (infer)
- d-in get meta-d get
- ] with-scope meta-d set d-in set ;
+ d-in get meta-d get get-dataflow
+ ] with-scope
+ [ dataflow-graph cons@ ] each meta-d set d-in set ;
\ call [ infer-call ] "infer" set-word-property
#! objects to the list that is returned when the quotation
#! is done.
[ "list-buffer" off call "list-buffer" get ] with-scope ;
+ inline
: make-list ( quot -- list )
#! Return a list whose entries are in the same order that ,
#! was called.
- make-rlist reverse ;
+ make-rlist reverse ; inline
: , ( obj -- )
#! Append an object to the currently constructing list.
dup cons? [ tail ] when not ;
: partition-add ( obj ? ret1 ret2 -- ret1 ret2 )
- rot [ swapd cons ] [ >r cons r> ] ifte ; inline
+ rot [ swapd cons ] [ >r cons r> ] ifte ;
: partition-step ( ref list combinator -- ref cdr combinator car ? )
pick pick car pick call >r >r unswons r> swap r> ; inline
: each ( list quot -- )
#! Push each element of a proper list in turn, and apply a
#! quotation with effect ( X -- ) to each element.
- over [ (each) each ] [ 2drop ] ifte ;
- inline
+ over [ (each) each ] [ 2drop ] ifte ; inline
: reverse ( list -- list )
[ ] swap [ swons ] each ;
#! Push each element of a proper list in turn, and collect
#! return values of applying a quotation with effect
#! ( X -- Y ) to each element into a new list.
- over [ (each) rot >r map r> swons ] [ drop ] ifte ;
- inline
+ over [ (each) rot >r map r> swons ] [ drop ] ifte ; inline
: subset ( list quot -- list )
#! Applies a quotation with effect ( X -- ? ) to each
#! Call a quotation. The quotation can call , to prepend
#! objects to the list that is returned when the quotation
#! is done.
- make-list cat ;
+ make-list cat ; inline
: make-rstring ( quot -- string )
#! Return a string whose entries are in the same order that ,
#! was called.
- make-rlist cat ;
+ make-rlist cat ; inline
: fill ( count char -- string )
#! Push a string that consists of the same character
#! The quotation must have stack effect ( X -- X ).
over str-length <sbuf> rot [
swap >r apply r> tuck sbuf-append
- ] str-each nip sbuf>str ;
+ ] str-each nip sbuf>str ; inline
: split-next ( index string split -- next )
3dup index-of* dup -1 = [
#! pushed onto the stack.
over str-length [
-rot 2dup >r >r >r str-nth r> call r> r>
- ] times* 2drop ;
+ ] times* 2drop ; inline
: str-sort ( list -- sorted )
#! Sorts the list into ascending lexicographical string
[ [ 1 | 0 ] ] [ [ nested-when* ] infer ] unit-test
+SYMBOL: sym-test
+
+[ [ 0 | 1 ] ] [ [ sym-test ] infer ] unit-test
+
[ [ 2 | 1 ] ] [ [ fie ] infer ] unit-test
[ [ 2 | 1 ] ] [ [ foe ] infer ] unit-test
#! pushed onto the stack.
over vector-length [
-rot 2dup >r >r >r vector-nth r> call r> r>
- ] times* 2drop ;
+ ] times* 2drop ; inline
: vector-map ( vector code -- vector )
#! Applies code to each element of the vector, return a new
#! ( obj -- obj ).
over vector-length <vector> rot [
swap >r apply r> tuck vector-push
- ] vector-each nip ;
+ ] vector-each nip ; inline
: vector-and ( vector -- ? )
#! Logical and of all elements in the vector.
t swap [ and ] vector-each ;
: vector-all? ( vector pred -- ? )
- vector-map vector-and ;
+ vector-map vector-and ; inline
: vector-append ( v1 v2 -- )
#! Destructively append v2 to v1.
#! in a new vector.
over <vector> rot [
-rot 2dup >r >r slip vector-push r> r>
- ] times* nip ;
+ ] times* nip ; inline
: vector-zip ( v1 v2 -- v )
#! Make a new vector with each pair of elements from the
#! differ.
-rot vector-zip [
swap dup >r >r uncons r> call r> swap
- ] vector-map nip ;
+ ] vector-map nip ; inline
: ?vector= ( n vec vec -- ? )
#! Reached end?
- drop vector-length = ;
+ drop vector-length number= ;
: (vector=) ( n vec vec -- ? )
3dup ?vector= [
projects / factor.git / commitdiff