Stack checker and propagation now themselves infer, improve propagation pass

unfinished/compiler/frontend/frontend-tests.factor

@@ -1,17 +1,6 @@
+IN: compiler.frontend.tests
+USING: compiler.frontend tools.test ;
 
-
+\ dataflow must-infer
-[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test
+\ dataflow-with must-infer
-[ ] [ [ 1 2 3 ] dataflow [ ] transform-nodes drop ] unit-test
+\ word-dataflow must-infer
-
-USE: inference.dataflow
-
-{ 1 0 } [ [ iterate-next ] iterate-nodes ] must-infer-as
-
-{ 1 0 }
-[
-    [ [ iterate-next ] iterate-nodes ] with-node-iterator
-] must-infer-as
-
-{ 1 0 } [ [ drop ] each-node ] must-infer-as
-
-{ 1 0 } [ [ ] map-children ] must-infer-as

unfinished/compiler/tree/combinators/combinators-tests.factor

@@ -0,0 +1,17 @@
+IN: compiler.tree.combinators.tests
+USING: compiler.tree.combinators compiler.frontend tools.test
+kernel ;
+
+[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test
+[ ] [ [ 1 2 3 ] dataflow [ ] transform-nodes drop ] unit-test
+
+{ 1 0 } [ [ iterate-next ] iterate-nodes ] must-infer-as
+
+{ 1 0 }
+[
+    [ [ iterate-next ] iterate-nodes ] with-node-iterator
+] must-infer-as
+
+{ 1 0 } [ [ drop ] each-node ] must-infer-as
+
+{ 1 0 } [ [ ] map-children ] must-infer-as

unfinished/compiler/tree/propagation/constraints/constraints.factor

@@ -38,7 +38,7 @@ M: false-constraint assume
     bi ;
 
 M: false-constraint satisfied?
-    value>> value-info class>> \ f class-not class<= ;
+    value>> value-info class>> \ f class<= ;
 
 ! Class constraints
 TUPLE: class-constraint value class ;

unfinished/compiler/tree/propagation/info/info-tests.factor

@@ -48,3 +48,9 @@ IN: compiler.tree.propagation.info.tests
     2 3 (a,b] <interval-info> fixnum <class-info>
     value-info-intersect >literal<
 ] unit-test
+
+[ T{ value-info f fixnum empty-interval f f } ] [
+    fixnum -10 0 [a,b] <class/interval-info>
+    fixnum 19 29 [a,b] <class/interval-info>
+    value-info-intersect
+] unit-test

unfinished/compiler/tree/propagation/info/info.factor

@@ -27,7 +27,7 @@ SYMBOL: copies
 ! slots read-only to allow cloning followed by writing.
 TUPLE: value-info
 { class initial: null }
-interval
+{ interval initial: empty-interval }
 literal
 literal? ;
 
@@ -36,15 +36,19 @@ literal? ;
     [ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ;
 
 : interval>literal ( class interval -- literal literal? )
-    dup from>> first {
+    dup empty-interval eq? [
-        { [ over interval-length 0 > ] [ 3drop f f ] }
+        2drop f f
-        { [ over from>> second not ] [ 3drop f f ] }
+    ] [
-        { [ over to>> second not ] [ 3drop f f ] }
+        dup from>> first {
-        { [ pick fixnum class<= ] [ 2nip >fixnum t ] }
+            { [ over interval-length 0 > ] [ 3drop f f ] }
-        { [ pick bignum class<= ] [ 2nip >bignum t ] }
+            { [ over from>> second not ] [ 3drop f f ] }
-        { [ pick float class<= ] [ 2nip >float t ] }
+            { [ over to>> second not ] [ 3drop f f ] }
-        [ 3drop f f ]
+            { [ pick fixnum class<= ] [ 2nip >fixnum t ] }
-    } cond ;
+            { [ pick bignum class<= ] [ 2nip >bignum t ] }
+            { [ pick float class<= ] [ 2nip >float t ] }
+            [ 3drop f f ]
+        } cond
+    ] if ;
 
 : <value-info> ( class interval literal literal? -- info )
     [
@@ -55,18 +59,21 @@ literal? ;
         tri t
     ] [
         drop
-        over null class<= [ drop f f f ] [
+        over null class<= [ drop empty-interval f f ] [
             over integer class<= [ integral-closure ] when
             2dup interval>literal
         ] if
     ] if
     \ value-info boa ; foldable
 
+: <class/interval-info> ( class interval -- info )
+    f f <value-info> ; foldable
+
 : <class-info> ( class -- info )
-    [-inf,inf] f f <value-info> ; foldable
+    [-inf,inf] <class/interval-info> ; foldable
 
 : <interval-info> ( interval -- info )
-    real swap f f <value-info> ; foldable
+    real swap <class/interval-info> ; foldable
 
 : <literal-info> ( literal -- info )
     f [-inf,inf] rot t <value-info> ; foldable
@@ -81,23 +88,12 @@ literal? ;
         [ drop >literal< ]
     } cond ;
 
-: interval-intersect' ( i1 i2 -- i3 )
-    #! Change core later.
-    2dup and [ interval-intersect ] [ 2drop f ] if ;
-
 : value-info-intersect ( info1 info2 -- info )
     [ [ class>> ] bi@ class-and ]
-    [ [ interval>> ] bi@ interval-intersect' ]
+    [ [ interval>> ] bi@ interval-intersect ]
     [ intersect-literals ]
     2tri <value-info> ;
 
-: interval-union' ( i1 i2 -- i3 )
-    {
-        { [ dup not ] [ drop ] }
-        { [ over not ] [ nip ] }
-        [ interval-union ]
-    } cond ;
-
 : union-literals ( info1 info2 -- literal literal? )
     2dup [ literal?>> ] both? [
         [ literal>> ] bi@ 2dup eql? [ drop t ] [ 2drop f f ] if
@@ -105,7 +101,7 @@ literal? ;
 
 : value-info-union ( info1 info2 -- info )
     [ [ class>> ] bi@ class-or ]
-    [ [ interval>> ] bi@ interval-union' ]
+    [ [ interval>> ] bi@ interval-union ]
     [ union-literals ]
     2tri <value-info> ;
 

unfinished/compiler/tree/propagation/known-words/known-words.factor

@@ -1,14 +1,23 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel effects accessors math math.private math.libm
-math.partial-dispatch math.intervals layouts words sequences
+math.partial-dispatch math.intervals math.parser layouts words
-sequences.private arrays assocs classes classes.algebra
+sequences sequences.private arrays assocs classes
-combinators generic.math fry locals
+classes.algebra combinators generic.math splitting fry locals
-compiler.tree.propagation.info
+classes.tuple alien.accessors classes.tuple.private
-compiler.tree.propagation.nodes
+compiler.tree.propagation.info compiler.tree.propagation.nodes
 compiler.tree.propagation.constraints ;
 IN: compiler.tree.propagation.known-words
 
+\ and [
+    [ [ <true-constraint> ] bi@ <conjunction> ] dip if-true
+] +constraints+ set-word-prop
+
+\ not [
+    [ [ <false-constraint> ] [ <true-constraint> ] bi ] dip
+    <conditional>
+] +constraints+ set-word-prop
+
 \ fixnum
 most-negative-fixnum most-positive-fixnum [a,b]
 +interval+ set-word-prop
@@ -66,40 +75,38 @@ most-negative-fixnum most-positive-fixnum [a,b]
 \ abs [ [ interval-abs ] ?change-interval ] +outputs+ set-word-prop
 
 : math-closure ( class -- newclass )
-    { null fixnum bignum integer rational float real number }
+    { fixnum bignum integer rational float real number object }
-    [ class<= ] with find nip number or ;
+    [ class<= ] with find nip ;
-
-: interval-subset?' ( i1 i2 -- ? )
-    {
-        { [ over not ] [ 2drop t ] }
-        { [ dup not ] [ 2drop f ] }
-        [ interval-subset? ]
-    } cond ;
 
 : fits? ( interval class -- ? )
-    +interval+ word-prop interval-subset?' ;
+    +interval+ word-prop interval-subset? ;
 
 : binary-op-class ( info1 info2 -- newclass )
-    [ class>> math-closure ] bi@ math-class-max ;
+    [ class>> ] bi@
+    2dup [ null class<= ] either? [ 2drop null ] [
+        [ math-closure ] bi@ math-class-max
+    ] if ;
 
 : binary-op-interval ( info1 info2 quot -- newinterval )
     [ [ interval>> ] bi@ 2dup and ] dip [ 2drop f ] if ; inline
 
-: <class/interval-info> ( class interval -- info )
-    [ f f <value-info> ] [ <class-info> ] if* ;
-
 : won't-overflow? ( class interval -- ? )
     [ fixnum class<= ] [ fixnum fits? ] bi* and ;
 
 : may-overflow ( class interval -- class' interval' )
-    2dup won't-overflow?
+    over null class<= [
-    [ [ integer math-class-max ] dip ] unless ;
+        2dup won't-overflow?
+        [ [ integer math-class-max ] dip ] unless
+    ] unless ;
 
 : may-be-rational ( class interval -- class' interval' )
     over null class<= [
         [ rational math-class-max ] dip
     ] unless ;
 
+: number-valued ( class interval -- class' interval' )
+    [ number math-class-min ] dip ;
+
 : integer-valued ( class interval -- class' interval' )
     [ integer math-class-min ] dip ;
 
@@ -118,25 +125,25 @@ most-negative-fixnum most-positive-fixnum [a,b]
         <class/interval-info>
     ] +outputs+ set-word-prop ;
 
-\ + [ [ interval+ ] [ may-overflow ] binary-op ] each-derived-op
+\ + [ [ interval+ ] [ may-overflow number-valued ] binary-op ] each-derived-op
-\ + [ [ interval+ ] [ ] binary-op ] each-fast-derived-op
+\ + [ [ interval+ ] [ number-valued ] binary-op ] each-fast-derived-op
 
-\ - [ [ interval+ ] [ may-overflow ] binary-op ] each-derived-op
+\ - [ [ interval- ] [ may-overflow number-valued ] binary-op ] each-derived-op
-\ - [ [ interval+ ] [ ] binary-op ] each-fast-derived-op
+\ - [ [ interval- ] [ number-valued ] binary-op ] each-fast-derived-op
 
-\ * [ [ interval* ] [ may-overflow ] binary-op ] each-derived-op
+\ * [ [ interval* ] [ may-overflow number-valued ] binary-op ] each-derived-op
-\ * [ [ interval* ] [ ] binary-op ] each-fast-derived-op
+\ * [ [ interval* ] [ number-valued ] binary-op ] each-fast-derived-op
 
-\ shift [ [ interval-shift-safe ] [ may-overflow ] binary-op ] each-derived-op
+\ / [ [ interval/-safe ] [ may-be-rational number-valued ] binary-op ] each-derived-op
-\ shift [ [ interval-shift-safe ] [ ] binary-op ] each-fast-derived-op
-
-\ / [ [ interval/-safe ] [ may-be-rational ] binary-op ] each-derived-op
 \ /i [ [ interval/i ] [ may-overflow integer-valued ] binary-op ] each-derived-op
 \ /f [ [ interval/f ] [ float-valued ] binary-op ] each-derived-op
 
 \ mod [ [ interval-mod ] [ real-valued ] binary-op ] each-derived-op
 \ rem [ [ interval-rem ] [ may-overflow real-valued ] binary-op ] each-derived-op
 
+\ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] binary-op ] each-derived-op
+\ shift [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op
+
 \ bitand [ [ interval-bitand ] [ integer-valued ] binary-op ] each-derived-op
 \ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op
 \ bitxor [ [ interval-bitxor ] [ integer-valued ] binary-op ] each-derived-op
@@ -168,13 +175,9 @@ most-negative-fixnum most-positive-fixnum [a,b]
 :: (comparison-constraints) ( in1 in2 op -- constraint )
     [let | i1 [ in1 value-info interval>> ]
            i2 [ in2 value-info interval>> ] |
-       i1 i2 and [
+       in1 i1 i2 op assume-interval <interval-constraint>
-           in1 i1 i2 op assume-interval <interval-constraint>
+       in2 i2 i1 op swap-comparison assume-interval <interval-constraint>
-           in2 i2 i1 op swap-comparison assume-interval <interval-constraint>
+       <conjunction>
-           <conjunction>
-       ] [
-           f
-       ] if
     ] ;
 
 : comparison-constraints ( in1 in2 out op -- constraint )
@@ -185,10 +188,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
     ] dip <conditional> ;
 
 : comparison-op ( word op -- )
-    '[
+    '[ , comparison-constraints ] +constraints+ set-word-prop ;
-        [ in-d>> first2 ] [ out-d>> first ] bi
-        , comparison-constraints
-    ] +constraints+ set-word-prop ;
 
 { < > <= >= } [ dup [ comparison-op ] curry each-derived-op ] each
 
@@ -201,71 +201,46 @@ most-negative-fixnum most-positive-fixnum [a,b]
         ,
         [ nip ] [
             [ interval>> ] [ class-interval ] bi*
-            interval-intersect'
+            interval-intersect
         ] 2bi
         <class/interval-info>
     ] +outputs+ set-word-prop
 ] assoc-each
 
-! 
+{
-! {
+    alien-signed-1
-!     alien-signed-1
+    alien-unsigned-1
-!     alien-unsigned-1
+    alien-signed-2
-!     alien-signed-2
+    alien-unsigned-2
-!     alien-unsigned-2
+    alien-signed-4
-!     alien-signed-4
+    alien-unsigned-4
-!     alien-unsigned-4
+    alien-signed-8
-!     alien-signed-8
+    alien-unsigned-8
-!     alien-unsigned-8
+} [
-! } [
+    dup name>> {
-!     dup name>> {
+        {
-!         {
+            [ "alien-signed-" ?head ]
-!             [ "alien-signed-" ?head ]
+            [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ]
-!             [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ]
+        }
-!         }
+        {
-!         {
+            [ "alien-unsigned-" ?head ]
-!             [ "alien-unsigned-" ?head ]
+            [ string>number 8 * 2^ 1- 0 swap [a,b] ]
-!             [ string>number 8 * 2^ 1- 0 swap [a,b] ]
+        }
-!         }
+    } cond
-!     } cond 1array
+    [ fixnum fits? fixnum bignum ? ] keep <class/interval-info>
-!     [ nip f swap ] curry "output-classes" set-word-prop
+    [ 2nip ] curry +outputs+ set-word-prop
-! ] each
+] each
-! 
-! 
-! { <tuple> <tuple-boa> (tuple) } [
-!     [
-!         dup node-in-d peek node-literal
-!         dup tuple-layout? [ class>> ] [ drop tuple ] if
-!         1array f
-!     ] "output-classes" set-word-prop
-! ] each
-! 
-! \ new [
-!     dup node-in-d peek node-literal
-!     dup class? [ drop tuple ] unless 1array f
-! ] "output-classes" set-word-prop
-! 
-! ! the output of clone has the same type as the input
-! { clone (clone) } [
-!     [
-!         node-in-d [ value-class* ] map f
-!     ] "output-classes" set-word-prop
-! ] each
-! 
-! ! if the result of eq? is t and the second input is a literal,
-! ! the first input is equal to the second
-! \ eq? [
-!     dup node-in-d second dup value? [
-!         swap [
-!             value-literal 0 `input literal,
-!             \ f class-not 0 `output class,
-!         ] set-constraints
-!     ] [
-!         2drop
-!     ] if
-! ] "constraints" set-word-prop
 
-: and-constraints ( in1 in2 out -- constraint )
+{ <tuple> <tuple-boa> } [
-    [ [ <true-constraint> ] bi@ ] dip <conditional> ;
+    [
+        literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if
+        [ clear ] dip
+    ] +outputs+ set-word-prop
+] each
 
-! XXX...
+\ new [
+    literal>> dup tuple-class? [ drop tuple ] unless <class-info>
+] +outputs+ set-word-prop
+
+! the output of clone has the same type as the input
+{ clone (clone) } [ [ ] +outputs+ set-word-prop ] each

unfinished/compiler/tree/propagation/propagation-tests.factor

@@ -1,8 +1,12 @@
 USING: kernel compiler.frontend compiler.tree
-compiler.tree.propagation tools.test math accessors
+compiler.tree.propagation tools.test math math.order
-sequences arrays kernel.private ;
+accessors sequences arrays kernel.private vectors
+alien.accessors alien.c-types ;
 IN: compiler.tree.propagation.tests
 
+\ propagate must-infer
+\ propagate/node must-infer
+
 : final-info ( quot -- seq )
     dataflow propagate last-node node-input-infos ;
 
@@ -64,7 +68,7 @@ IN: compiler.tree.propagation.tests
     [ { null null } declare + ] final-classes
 ] unit-test
 
-[ V{ fixnum } ] [
+[ V{ null } ] [
     [ { null fixnum } declare + ] final-classes
 ] unit-test
 
@@ -87,3 +91,55 @@ IN: compiler.tree.propagation.tests
 [ V{ fixnum } ] [
     [ >fixnum dup 10 > [ 1 - ] when ] final-classes
 ] unit-test
+
+[ V{ integer } ] [ [ >fixnum 2 * ] final-classes ] unit-test
+
+[ V{ integer } ] [
+    [ >fixnum dup 10 < drop 2 * ] final-classes
+] unit-test
+
+[ V{ integer } ] [
+    [ >fixnum dup 10 < [ 2 * ] when ] final-classes
+] unit-test
+
+[ V{ integer } ] [
+    [ >fixnum dup 10 < [ 2 * ] [ 2 * ] if ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ >fixnum dup 10 < [ dup -10 > [ 2 * ] when ] when ] final-classes
+] unit-test
+
+[ V{ f } ] [
+    [ dup 10 < [ dup 8 > [ drop 9 ] unless ] [ drop 9 ] if ] final-literals
+] unit-test
+
+[ V{ 9 } ] [
+    [
+        >fixnum
+        dup 10 < [ dup 8 > [ drop 9 ] unless ] [ drop 9 ] if
+    ] final-literals
+] unit-test
+
+[ V{ fixnum } ] [
+    [
+        >fixnum
+        dup [ 10 < ] [ -10 > ] bi and not [ 2 * ] unless
+    ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ { fixnum } declare (clone) ] final-classes
+] unit-test
+
+[ V{ vector } ] [
+    [ vector new ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [
+        [ uchar-nth ] 2keep [ uchar-nth ] 2keep uchar-nth
+        >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift
+        255 min 0 max
+    ] final-classes
+] unit-test

unfinished/compiler/tree/propagation/simple/simple.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors kernel sequences assocs words namespaces
-classes.algebra combinators classes
+classes.algebra combinators classes continuations
 compiler.tree
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
@@ -49,10 +49,13 @@ M: #copy propagate-before
     [ [ class-not <class-constraint> ] dip if-false ]
     3bi <conjunction> ;
 
-: compute-constraints ( #call -- constraint )
+: custom-constraints ( #call quot -- )
-    dup word>> +constraints+ word-prop [ call assume ] [
+    [ [ in-d>> ] [ out-d>> ] bi append ] dip
-        dup word>> predicate?
+    with-datastack first assume ;
-        [
+
+: compute-constraints ( #call -- )
+    dup word>> +constraints+ word-prop [ custom-constraints ] [
+        dup word>> predicate? [
             [ in-d>> first ]
             [ word>> "predicating" word-prop ]
             [ out-d>> first ]
@@ -70,13 +73,14 @@ M: #copy propagate-before
 : call-outputs-quot ( node quot -- infos )
     [ in-d>> [ value-info ] map ] dip with-datastack ;
 
-: output-value-infos ( node word -- infos )
+: output-value-infos ( node -- infos )
     dup word>> +outputs+ word-prop
     [ call-outputs-quot ] [ default-output-value-infos ] if* ;
 
 M: #call propagate-before
+    [ [ output-value-infos ] [ out-d>> ] bi set-value-infos ]
     [ compute-constraints ]
-    [ [ output-value-infos ] [ out-d>> ] bi set-value-infos ] bi ;
+    bi ;
 
 M: node propagate-before drop ;
 

unfinished/stack-checker/backend/backend.factor

@@ -11,6 +11,8 @@ IN: stack-checker.backend
 ! Word properties we use
 SYMBOL: +inferred-effect+
 SYMBOL: +cannot-infer+
+SYMBOL: +special+
+SYMBOL: +shuffle+
 SYMBOL: +infer+
 
 SYMBOL: visited
@@ -191,22 +193,9 @@ M: object apply-object push-literal ;
 : call-recursive-word ( word -- )
     dup required-stack-effect apply-word/effect ;
 
-: custom-infer ( word -- )
-    [ +inlined+ depends-on ] [ +infer+ word-prop call ] bi ;
-
 : cached-infer ( word -- )
     dup +inferred-effect+ word-prop apply-word/effect ;
 
-: non-inline-word ( word -- )
-    dup +called+ depends-on
-    {
-        { [ dup recursive-label ] [ call-recursive-word ] }
-        { [ dup +infer+ word-prop ] [ custom-infer ] }
-        { [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
-        { [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
-        [ dup infer-word apply-word/effect ]
-    } cond ;
-
 : with-infer ( quot -- effect visitor )
     [
         [
@@ -219,4 +208,4 @@ M: object apply-object push-literal ;
             current-effect
             dataflow-visitor get
         ] [ ] [ undo-infer ] cleanup
-    ] with-scope ;
+    ] with-scope ; inline

unfinished/stack-checker/branches/branches.factor

@@ -67,8 +67,19 @@ SYMBOL: quotations
     [ infer-branch ] map
     [ dataflow-visitor branch-variable ] keep ;
 
-: infer-if ( branches -- )
+: (infer-if) ( branches -- )
     infer-branches [ first2 #if, ] dip compute-phi-function ;
 
-: infer-dispatch ( branches -- )
+: infer-if ( -- )
+    2 consume-d
+    dup [ known [ curry? ] [ composed? ] bi or ] contains? [
+        output-d
+        [ rot [ drop call ] [ nip call ] if ]
+        recursive-state get infer-quot
+    ] [
+        [ #drop, ] [ [ literal ] map (infer-if) ] bi
+    ] if ;
+
+: infer-dispatch ( -- )
+    pop-literal nip [ <literal> ] map
     infer-branches [ #dispatch, ] dip compute-phi-function ;

unfinished/stack-checker/inlining/inlining.factor

@@ -6,7 +6,8 @@ stack-checker.state
 stack-checker.visitor
 stack-checker.backend
 stack-checker.branches
-stack-checker.errors ;
+stack-checker.errors
+stack-checker.known-words ;
 IN: stack-checker.inlining
 
 ! Code to handle inline words. Much of the complexity stems from

unfinished/stack-checker/known-words/known-words.factor

@@ -2,26 +2,25 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors alien alien.accessors arrays byte-arrays
 classes sequences.private continuations.private effects generic
-hashtables hashtables.private io io.backend io.files io.files.private
+hashtables hashtables.private io io.backend io.files
-io.streams.c kernel kernel.private math math.private memory
+io.files.private io.streams.c kernel kernel.private math
-namespaces namespaces.private parser prettyprint quotations
+math.private memory namespaces namespaces.private parser
-quotations.private sbufs sbufs.private sequences
+prettyprint quotations quotations.private sbufs sbufs.private
-sequences.private slots.private strings strings.private system
+sequences sequences.private slots.private strings
-threads.private classes.tuple classes.tuple.private vectors
+strings.private system threads.private classes.tuple
-vectors.private words words.private assocs summary
+classes.tuple.private vectors vectors.private words definitions
-compiler.units system.private
+words.private assocs summary compiler.units system.private
-stack-checker.state stack-checker.backend stack-checker.branches
+combinators locals.backend stack-checker.state
-stack-checker.errors stack-checker.visitor ;
+stack-checker.backend stack-checker.branches
+stack-checker.errors stack-checker.transforms
+stack-checker.visitor ;
 IN: stack-checker.known-words
 
-: infer-shuffle ( shuffle -- )
+: infer-primitive ( word -- )
-    [ in>> length consume-d ] keep ! inputs shuffle
+    dup
-    [ drop ] [ shuffle* dup copy-values dup output-d ] 2bi ! inputs outputs copies
+    [ "input-classes" word-prop ]
-    [ nip ] [ swap zip ] 2bi ! inputs copies mapping
+    [ "default-output-classes" word-prop ] bi <effect>
-    #shuffle, ;
+    apply-word/effect ;
-
-: define-shuffle ( word shuffle -- )
-    '[ , infer-shuffle ] +infer+ set-word-prop ;
 
 {
     { drop  (( x     --             )) }
@@ -40,19 +39,22 @@ IN: stack-checker.known-words
     { over  (( x y   -- x y x       )) }
     { pick  (( x y z -- x y z x     )) }
     { swap  (( x y   -- y x         )) }
-} [ define-shuffle ] assoc-each
+} [ +shuffle+ set-word-prop ] assoc-each
 
-\ >r [ 1 infer->r ] +infer+ set-word-prop
+: infer-shuffle ( shuffle -- )
-\ r> [ 1 infer-r> ] +infer+ set-word-prop
+    [ in>> length consume-d ] keep ! inputs shuffle
+    [ drop ] [ shuffle* dup copy-values dup output-d ] 2bi ! inputs outputs copies
+    [ nip ] [ swap zip ] 2bi ! inputs copies mapping
+    #shuffle, ;
 
+: infer-shuffle-word ( word -- )
+    +shuffle+ word-prop infer-shuffle ;
 
-\ declare [
+: infer-declare ( -- )
     pop-literal nip
     [ length consume-d dup copy-values dup output-d ] keep
-    #declare,
+    #declare, ;
-] +infer+ set-word-prop
 
-! Primitive combinators
 GENERIC: infer-call* ( value known -- )
 
 : infer-call ( value -- ) dup known infer-call* ;
@@ -73,495 +75,524 @@ M: composed infer-call*
     [ quot2>> known pop-d [ set-known ] keep ]
     [ quot1>> known pop-d [ set-known ] keep ] bi
     push-d push-d
-    [ slip call ] recursive-state get infer-quot ;
+    1 infer->r pop-d infer-call
+    terminated? get [ 1 infer-r> pop-d infer-call ] unless ;
 
 M: object infer-call*
     \ literal-expected inference-warning ;
 
-\ call [ pop-d infer-call ] +infer+ set-word-prop
+: infer-curry ( -- )
-
-\ call t "no-compile" set-word-prop
-
-\ curry [
     2 consume-d
     dup first2 <curried> make-known
     [ push-d ] [ 1array ] bi
-    \ curry #call,
+    \ curry #call, ;
-] +infer+ set-word-prop
 
-\ compose [
+: infer-compose ( -- )
     2 consume-d
     dup first2 <composed> make-known
     [ push-d ] [ 1array ] bi
-    \ compose #call,
+    \ compose #call, ;
-] +infer+ set-word-prop
 
-\ execute [
+: infer-execute ( -- )
     pop-literal nip
     dup word? [
         apply-object
     ] [
         drop
         "execute must be given a word" time-bomb
-    ] if
+    ] if ;
-] +infer+ set-word-prop
 
-\ execute t "no-compile" set-word-prop
+: infer-<tuple-boa> ( -- )
-
-\ if [
-    2 consume-d
-    dup [ known [ curry? ] [ composed? ] bi or ] contains? [
-        output-d
-        [ rot [ drop call ] [ nip call ] if ]
-        recursive-state get infer-quot
-    ] [
-        [ #drop, ] [ [ literal ] map infer-if ] bi
-    ] if
-] +infer+ set-word-prop
-
-\ dispatch [
-    pop-literal nip [ <literal> ] map infer-dispatch
-] +infer+ set-word-prop
-
-\ dispatch t "no-compile" set-word-prop
-
-! Variadic tuple constructor
-\ <tuple-boa> [
     \ <tuple-boa>
     peek-d literal value>> size>> { tuple } <effect>
-    apply-word/effect
+    apply-word/effect ;
-] +infer+ set-word-prop
 
-! Non-standard control flow
+: infer-(throw) ( -- )
-\ (throw) [
     \ (throw)
     peek-d literal value>> 2 + f <effect> t >>terminated?
-    apply-word/effect
+    apply-word/effect ;
-] +infer+ set-word-prop
 
-:  set-primitive-effect ( word effect -- )
+: infer-exit ( -- )
-    [ in>> "input-classes" set-word-prop ]
+    \ exit
-    [ out>> "default-output-classes" set-word-prop ]
+    { integer } { } t >>terminated? <effect>
-    [ dupd '[ , , apply-word/effect ] +infer+ set-word-prop ]
+    apply-word/effect ;
-    2tri ;
+
+: infer-load-locals ( -- )
+    pop-literal nip
+    [ dup reverse <effect> infer-shuffle ]
+    [ infer->r ]
+    bi ;
+
+: infer-get-local ( -- )
+    pop-literal nip
+    [ infer-r> ]
+    [ dup 0 prefix <effect> infer-shuffle ]
+    [ infer->r ]
+    tri ;
+
+: infer-drop-locals ( -- )
+    pop-literal nip
+    [ infer-r> ]
+    [ { } <effect> infer-shuffle ] bi ;
+
+: infer-special ( word -- )
+    {
+        { \ >r [ 1 infer->r ] }
+        { \ r> [ 1 infer-r> ] }
+        { \ declare [ infer-declare ] }
+        { \ call [ pop-d infer-call ] }
+        { \ curry [ infer-curry ] }
+        { \ compose [ infer-compose ] }
+        { \ execute [ infer-execute ] }
+        { \ if [ infer-if ] }
+        { \ dispatch [ infer-dispatch ] }
+        { \ <tuple-boa> [ infer-<tuple-boa> ] }
+        { \ (throw) [ infer-(throw) ] }
+        { \ exit [ infer-exit ] }
+        { \ load-locals [ infer-load-locals ] }
+        { \ get-local [ infer-get-local ] }
+        { \ drop-locals [ infer-drop-locals ] }
+        { \ do-primitive [ \ do-primitive cannot-infer-effect ] }
+    } case ;
+
+{
+    >r r> declare call curry compose
+    execute if dispatch <tuple-boa>
+    (throw) load-locals get-local drop-locals
+    do-primitive
+} [ t +special+ set-word-prop ] each
+
+{ call execute dispatch load-locals get-local drop-locals }
+[ t "no-compile" set-word-prop ] each
+
+: non-inline-word ( word -- )
+    dup +called+ depends-on
+    {
+        { [ dup +shuffle+ word-prop ] [ infer-shuffle-word ] }
+        { [ dup +special+ word-prop ] [ infer-special ] }
+        { [ dup primitive? ] [ infer-primitive ] }
+        { [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
+        { [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
+        { [ dup +transform-quot+ word-prop ] [ apply-transform ] }
+        { [ dup "macro" word-prop ] [ apply-macro ] }
+        { [ dup recursive-label ] [ call-recursive-word ] }
+        [ dup infer-word apply-word/effect ]
+    } cond ;
+
+: define-primitive ( word inputs outputs -- )
+    [ drop "input-classes" set-word-prop ]
+    [ nip "default-output-classes" set-word-prop ]
+    3bi ;
 
 ! Stack effects for all primitives
-\ fixnum< { fixnum fixnum } { object } <effect> set-primitive-effect
+\ fixnum< { fixnum fixnum } { object } define-primitive
 \ fixnum< make-foldable
 
-\ fixnum<= { fixnum fixnum } { object } <effect> set-primitive-effect
+\ fixnum<= { fixnum fixnum } { object } define-primitive
 \ fixnum<= make-foldable
 
-\ fixnum> { fixnum fixnum } { object } <effect> set-primitive-effect
+\ fixnum> { fixnum fixnum } { object } define-primitive
 \ fixnum> make-foldable
 
-\ fixnum>= { fixnum fixnum } { object } <effect> set-primitive-effect
+\ fixnum>= { fixnum fixnum } { object } define-primitive
 \ fixnum>= make-foldable
 
-\ eq? { object object } { object } <effect> set-primitive-effect
+\ eq? { object object } { object } define-primitive
 \ eq? make-foldable
 
-\ rehash-string { string } { } <effect> set-primitive-effect
+\ bignum>fixnum { bignum } { fixnum } define-primitive
-
-\ bignum>fixnum { bignum } { fixnum } <effect> set-primitive-effect
 \ bignum>fixnum make-foldable
 
-\ float>fixnum { float } { fixnum } <effect> set-primitive-effect
+\ float>fixnum { float } { fixnum } define-primitive
 \ bignum>fixnum make-foldable
 
-\ fixnum>bignum { fixnum } { bignum } <effect> set-primitive-effect
+\ fixnum>bignum { fixnum } { bignum } define-primitive
 \ fixnum>bignum make-foldable
 
-\ float>bignum { float } { bignum } <effect> set-primitive-effect
+\ float>bignum { float } { bignum } define-primitive
 \ float>bignum make-foldable
 
-\ fixnum>float { fixnum } { float } <effect> set-primitive-effect
+\ fixnum>float { fixnum } { float } define-primitive
 \ fixnum>float make-foldable
 
-\ bignum>float { bignum } { float } <effect> set-primitive-effect
+\ bignum>float { bignum } { float } define-primitive
 \ bignum>float make-foldable
 
-\ <ratio> { integer integer } { ratio } <effect> set-primitive-effect
+\ <ratio> { integer integer } { ratio } define-primitive
 \ <ratio> make-foldable
 
-\ string>float { string } { float } <effect> set-primitive-effect
+\ string>float { string } { float } define-primitive
 \ string>float make-foldable
 
-\ float>string { float } { string } <effect> set-primitive-effect
+\ float>string { float } { string } define-primitive
 \ float>string make-foldable
 
-\ float>bits { real } { integer } <effect> set-primitive-effect
+\ float>bits { real } { integer } define-primitive
 \ float>bits make-foldable
 
-\ double>bits { real } { integer } <effect> set-primitive-effect
+\ double>bits { real } { integer } define-primitive
 \ double>bits make-foldable
 
-\ bits>float { integer } { float } <effect> set-primitive-effect
+\ bits>float { integer } { float } define-primitive
 \ bits>float make-foldable
 
-\ bits>double { integer } { float } <effect> set-primitive-effect
+\ bits>double { integer } { float } define-primitive
 \ bits>double make-foldable
 
-\ <complex> { real real } { complex } <effect> set-primitive-effect
+\ <complex> { real real } { complex } define-primitive
 \ <complex> make-foldable
 
-\ fixnum+ { fixnum fixnum } { integer } <effect> set-primitive-effect
+\ fixnum+ { fixnum fixnum } { integer } define-primitive
 \ fixnum+ make-foldable
 
-\ fixnum+fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum+fast { fixnum fixnum } { fixnum } define-primitive
 \ fixnum+fast make-foldable
 
-\ fixnum- { fixnum fixnum } { integer } <effect> set-primitive-effect
+\ fixnum- { fixnum fixnum } { integer } define-primitive
 \ fixnum- make-foldable
 
-\ fixnum-fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-fast { fixnum fixnum } { fixnum } define-primitive
 \ fixnum-fast make-foldable
 
-\ fixnum* { fixnum fixnum } { integer } <effect> set-primitive-effect
+\ fixnum* { fixnum fixnum } { integer } define-primitive
 \ fixnum* make-foldable
 
-\ fixnum*fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum*fast { fixnum fixnum } { fixnum } define-primitive
 \ fixnum*fast make-foldable
 
-\ fixnum/i { fixnum fixnum } { integer } <effect> set-primitive-effect
+\ fixnum/i { fixnum fixnum } { integer } define-primitive
 \ fixnum/i make-foldable
 
-\ fixnum-mod { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-mod { fixnum fixnum } { fixnum } define-primitive
 \ fixnum-mod make-foldable
 
-\ fixnum/mod { fixnum fixnum } { integer fixnum } <effect> set-primitive-effect
+\ fixnum/mod { fixnum fixnum } { integer fixnum } define-primitive
 \ fixnum/mod make-foldable
 
-\ fixnum-bitand { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-bitand { fixnum fixnum } { fixnum } define-primitive
 \ fixnum-bitand make-foldable
 
-\ fixnum-bitor { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-bitor { fixnum fixnum } { fixnum } define-primitive
 \ fixnum-bitor make-foldable
 
-\ fixnum-bitxor { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-bitxor { fixnum fixnum } { fixnum } define-primitive
 \ fixnum-bitxor make-foldable
 
-\ fixnum-bitnot { fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-bitnot { fixnum } { fixnum } define-primitive
 \ fixnum-bitnot make-foldable
 
-\ fixnum-shift { fixnum fixnum } { integer } <effect> set-primitive-effect
+\ fixnum-shift { fixnum fixnum } { integer } define-primitive
 \ fixnum-shift make-foldable
 
-\ fixnum-shift-fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-shift-fast { fixnum fixnum } { fixnum } define-primitive
 \ fixnum-shift-fast make-foldable
 
-\ bignum= { bignum bignum } { object } <effect> set-primitive-effect
+\ bignum= { bignum bignum } { object } define-primitive
 \ bignum= make-foldable
 
-\ bignum+ { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum+ { bignum bignum } { bignum } define-primitive
 \ bignum+ make-foldable
 
-\ bignum- { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum- { bignum bignum } { bignum } define-primitive
 \ bignum- make-foldable
 
-\ bignum* { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum* { bignum bignum } { bignum } define-primitive
 \ bignum* make-foldable
 
-\ bignum/i { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum/i { bignum bignum } { bignum } define-primitive
 \ bignum/i make-foldable
 
-\ bignum-mod { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum-mod { bignum bignum } { bignum } define-primitive
 \ bignum-mod make-foldable
 
-\ bignum/mod { bignum bignum } { bignum bignum } <effect> set-primitive-effect
+\ bignum/mod { bignum bignum } { bignum bignum } define-primitive
 \ bignum/mod make-foldable
 
-\ bignum-bitand { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum-bitand { bignum bignum } { bignum } define-primitive
 \ bignum-bitand make-foldable
 
-\ bignum-bitor { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum-bitor { bignum bignum } { bignum } define-primitive
 \ bignum-bitor make-foldable
 
-\ bignum-bitxor { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum-bitxor { bignum bignum } { bignum } define-primitive
 \ bignum-bitxor make-foldable
 
-\ bignum-bitnot { bignum } { bignum } <effect> set-primitive-effect
+\ bignum-bitnot { bignum } { bignum } define-primitive
 \ bignum-bitnot make-foldable
 
-\ bignum-shift { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum-shift { bignum bignum } { bignum } define-primitive
 \ bignum-shift make-foldable
 
-\ bignum< { bignum bignum } { object } <effect> set-primitive-effect
+\ bignum< { bignum bignum } { object } define-primitive
 \ bignum< make-foldable
 
-\ bignum<= { bignum bignum } { object } <effect> set-primitive-effect
+\ bignum<= { bignum bignum } { object } define-primitive
 \ bignum<= make-foldable
 
-\ bignum> { bignum bignum } { object } <effect> set-primitive-effect
+\ bignum> { bignum bignum } { object } define-primitive
 \ bignum> make-foldable
 
-\ bignum>= { bignum bignum } { object } <effect> set-primitive-effect
+\ bignum>= { bignum bignum } { object } define-primitive
 \ bignum>= make-foldable
 
-\ bignum-bit? { bignum integer } { object } <effect> set-primitive-effect
+\ bignum-bit? { bignum integer } { object } define-primitive
 \ bignum-bit? make-foldable
 
-\ bignum-log2 { bignum } { bignum } <effect> set-primitive-effect
+\ bignum-log2 { bignum } { bignum } define-primitive
 \ bignum-log2 make-foldable
 
-\ byte-array>bignum { byte-array } { bignum } <effect> set-primitive-effect
+\ byte-array>bignum { byte-array } { bignum } define-primitive
 \ byte-array>bignum make-foldable
 
-\ float= { float float } { object } <effect> set-primitive-effect
+\ float= { float float } { object } define-primitive
 \ float= make-foldable
 
-\ float+ { float float } { float } <effect> set-primitive-effect
+\ float+ { float float } { float } define-primitive
 \ float+ make-foldable
 
-\ float- { float float } { float } <effect> set-primitive-effect
+\ float- { float float } { float } define-primitive
 \ float- make-foldable
 
-\ float* { float float } { float } <effect> set-primitive-effect
+\ float* { float float } { float } define-primitive
 \ float* make-foldable
 
-\ float/f { float float } { float } <effect> set-primitive-effect
+\ float/f { float float } { float } define-primitive
 \ float/f make-foldable
 
-\ float< { float float } { object } <effect> set-primitive-effect
+\ float< { float float } { object } define-primitive
 \ float< make-foldable
 
-\ float-mod { float float } { float } <effect> set-primitive-effect
+\ float-mod { float float } { float } define-primitive
 \ float-mod make-foldable
 
-\ float<= { float float } { object } <effect> set-primitive-effect
+\ float<= { float float } { object } define-primitive
 \ float<= make-foldable
 
-\ float> { float float } { object } <effect> set-primitive-effect
+\ float> { float float } { object } define-primitive
 \ float> make-foldable
 
-\ float>= { float float } { object } <effect> set-primitive-effect
+\ float>= { float float } { object } define-primitive
 \ float>= make-foldable
 
-\ <word> { object object } { word } <effect> set-primitive-effect
+\ <word> { object object } { word } define-primitive
 \ <word> make-flushable
 
-\ word-xt { word } { integer integer } <effect> set-primitive-effect
+\ word-xt { word } { integer integer } define-primitive
 \ word-xt make-flushable
 
-\ getenv { fixnum } { object } <effect> set-primitive-effect
+\ getenv { fixnum } { object } define-primitive
 \ getenv make-flushable
 
-\ setenv { object fixnum } { } <effect> set-primitive-effect
+\ setenv { object fixnum } { } define-primitive
 
-\ (exists?) { string } { object } <effect> set-primitive-effect
+\ (exists?) { string } { object } define-primitive
 
-\ (directory) { string } { array } <effect> set-primitive-effect
+\ (directory) { string } { array } define-primitive
 
-\ gc { } { } <effect> set-primitive-effect
+\ gc { } { } define-primitive
 
-\ gc-stats { } { array } <effect> set-primitive-effect
+\ gc-stats { } { array } define-primitive
 
-\ save-image { string } { } <effect> set-primitive-effect
+\ save-image { string } { } define-primitive
 
-\ save-image-and-exit { string } { } <effect> set-primitive-effect
+\ save-image-and-exit { string } { } define-primitive
 
-\ exit { integer } { } <effect> t >>terminated? set-primitive-effect
+\ data-room { } { integer integer array } define-primitive
-
-\ data-room { } { integer integer array } <effect> set-primitive-effect
 \ data-room make-flushable
 
-\ code-room { } { integer integer integer integer } <effect> set-primitive-effect
+\ code-room { } { integer integer integer integer } define-primitive
 \ code-room  make-flushable
 
-\ os-env { string } { object } <effect> set-primitive-effect
+\ os-env { string } { object } define-primitive
 
-\ millis { } { integer } <effect> set-primitive-effect
+\ millis { } { integer } define-primitive
 \ millis make-flushable
 
-\ tag { object } { fixnum } <effect> set-primitive-effect
+\ tag { object } { fixnum } define-primitive
 \ tag make-foldable
 
-\ cwd { } { string } <effect> set-primitive-effect
+\ dlopen { string } { dll } define-primitive
 
-\ cd { string } { } <effect> set-primitive-effect
+\ dlsym { string object } { c-ptr } define-primitive
 
-\ dlopen { string } { dll } <effect> set-primitive-effect
+\ dlclose { dll } { } define-primitive
 
-\ dlsym { string object } { c-ptr } <effect> set-primitive-effect
+\ <byte-array> { integer } { byte-array } define-primitive
-
-\ dlclose { dll } { } <effect> set-primitive-effect
-
-\ <byte-array> { integer } { byte-array } <effect> set-primitive-effect
 \ <byte-array> make-flushable
 
-\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> set-primitive-effect
+\ <displaced-alien> { integer c-ptr } { c-ptr } define-primitive
 \ <displaced-alien> make-flushable
 
-\ alien-signed-cell { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-signed-cell { c-ptr integer } { integer } define-primitive
 \ alien-signed-cell make-flushable
 
-\ set-alien-signed-cell { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-signed-cell { integer c-ptr integer } { } define-primitive
 
-\ alien-unsigned-cell { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-unsigned-cell { c-ptr integer } { integer } define-primitive
 \ alien-unsigned-cell make-flushable
 
-\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-unsigned-cell { integer c-ptr integer } { } define-primitive
 
-\ alien-signed-8 { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-signed-8 { c-ptr integer } { integer } define-primitive
 \ alien-signed-8 make-flushable
 
-\ set-alien-signed-8 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-signed-8 { integer c-ptr integer } { } define-primitive
 
-\ alien-unsigned-8 { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-unsigned-8 { c-ptr integer } { integer } define-primitive
 \ alien-unsigned-8 make-flushable
 
-\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-unsigned-8 { integer c-ptr integer } { } define-primitive
 
-\ alien-signed-4 { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-signed-4 { c-ptr integer } { integer } define-primitive
 \ alien-signed-4 make-flushable
 
-\ set-alien-signed-4 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-signed-4 { integer c-ptr integer } { } define-primitive
 
-\ alien-unsigned-4 { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-unsigned-4 { c-ptr integer } { integer } define-primitive
 \ alien-unsigned-4 make-flushable
 
-\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-unsigned-4 { integer c-ptr integer } { } define-primitive
 
-\ alien-signed-2 { c-ptr integer } { fixnum } <effect> set-primitive-effect
+\ alien-signed-2 { c-ptr integer } { fixnum } define-primitive
 \ alien-signed-2 make-flushable
 
-\ set-alien-signed-2 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-signed-2 { integer c-ptr integer } { } define-primitive
 
-\ alien-unsigned-2 { c-ptr integer } { fixnum } <effect> set-primitive-effect
+\ alien-unsigned-2 { c-ptr integer } { fixnum } define-primitive
 \ alien-unsigned-2 make-flushable
 
-\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-unsigned-2 { integer c-ptr integer } { } define-primitive
 
-\ alien-signed-1 { c-ptr integer } { fixnum } <effect> set-primitive-effect
+\ alien-signed-1 { c-ptr integer } { fixnum } define-primitive
 \ alien-signed-1 make-flushable
 
-\ set-alien-signed-1 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-signed-1 { integer c-ptr integer } { } define-primitive
 
-\ alien-unsigned-1 { c-ptr integer } { fixnum } <effect> set-primitive-effect
+\ alien-unsigned-1 { c-ptr integer } { fixnum } define-primitive
 \ alien-unsigned-1 make-flushable
 
-\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-unsigned-1 { integer c-ptr integer } { } define-primitive
 
-\ alien-float { c-ptr integer } { float } <effect> set-primitive-effect
+\ alien-float { c-ptr integer } { float } define-primitive
 \ alien-float make-flushable
 
-\ set-alien-float { float c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-float { float c-ptr integer } { } define-primitive
 
-\ alien-double { c-ptr integer } { float } <effect> set-primitive-effect
+\ alien-double { c-ptr integer } { float } define-primitive
 \ alien-double make-flushable
 
-\ set-alien-double { float c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-double { float c-ptr integer } { } define-primitive
 
-\ alien-cell { c-ptr integer } { simple-c-ptr } <effect> set-primitive-effect
+\ alien-cell { c-ptr integer } { simple-c-ptr } define-primitive
 \ alien-cell make-flushable
 
-\ set-alien-cell { c-ptr c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-cell { c-ptr c-ptr integer } { } define-primitive
 
-\ alien-address { alien } { integer } <effect> set-primitive-effect
+\ alien-address { alien } { integer } define-primitive
 \ alien-address make-flushable
 
-\ slot { object fixnum } { object } <effect> set-primitive-effect
+\ slot { object fixnum } { object } define-primitive
 \ slot make-flushable
 
-\ set-slot { object object fixnum } { } <effect> set-primitive-effect
+\ set-slot { object object fixnum } { } define-primitive
 
-\ string-nth { fixnum string } { fixnum } <effect> set-primitive-effect
+\ string-nth { fixnum string } { fixnum } define-primitive
 \ string-nth make-flushable
 
-\ set-string-nth { fixnum fixnum string } { } <effect> set-primitive-effect
+\ set-string-nth { fixnum fixnum string } { } define-primitive
 
-\ resize-array { integer array } { array } <effect> set-primitive-effect
+\ resize-array { integer array } { array } define-primitive
 \ resize-array make-flushable
 
-\ resize-byte-array { integer byte-array } { byte-array } <effect> set-primitive-effect
+\ resize-byte-array { integer byte-array } { byte-array } define-primitive
 \ resize-byte-array make-flushable
 
-\ resize-string { integer string } { string } <effect> set-primitive-effect
+\ resize-string { integer string } { string } define-primitive
 \ resize-string make-flushable
 
-\ <array> { integer object } { array } <effect> set-primitive-effect
+\ <array> { integer object } { array } define-primitive
 \ <array> make-flushable
 
-\ begin-scan { } { } <effect> set-primitive-effect
+\ begin-scan { } { } define-primitive
 
-\ next-object { } { object } <effect> set-primitive-effect
+\ next-object { } { object } define-primitive
 
-\ end-scan { } { } <effect> set-primitive-effect
+\ end-scan { } { } define-primitive
 
-\ size { object } { fixnum } <effect> set-primitive-effect
+\ size { object } { fixnum } define-primitive
 \ size make-flushable
 
-\ die { } { } <effect> set-primitive-effect
+\ die { } { } define-primitive
 
-\ fopen { string string } { alien } <effect> set-primitive-effect
+\ fopen { string string } { alien } define-primitive
 
-\ fgetc { alien } { object } <effect> set-primitive-effect
+\ fgetc { alien } { object } define-primitive
 
-\ fwrite { string alien } { } <effect> set-primitive-effect
+\ fwrite { string alien } { } define-primitive
 
-\ fputc { object alien } { } <effect> set-primitive-effect
+\ fputc { object alien } { } define-primitive
 
-\ fread { integer string } { object } <effect> set-primitive-effect
+\ fread { integer string } { object } define-primitive
 
-\ fflush { alien } { } <effect> set-primitive-effect
+\ fflush { alien } { } define-primitive
 
-\ fclose { alien } { } <effect> set-primitive-effect
+\ fclose { alien } { } define-primitive
 
-\ <wrapper> { object } { wrapper } <effect> set-primitive-effect
+\ <wrapper> { object } { wrapper } define-primitive
 \ <wrapper> make-foldable
 
-\ (clone) { object } { object } <effect> set-primitive-effect
+\ (clone) { object } { object } define-primitive
 \ (clone) make-flushable
 
-\ <string> { integer integer } { string } <effect> set-primitive-effect
+\ <string> { integer integer } { string } define-primitive
 \ <string> make-flushable
 
-\ array>quotation { array } { quotation } <effect> set-primitive-effect
+\ array>quotation { array } { quotation } define-primitive
 \ array>quotation make-flushable
 
-\ quotation-xt { quotation } { integer } <effect> set-primitive-effect
+\ quotation-xt { quotation } { integer } define-primitive
 \ quotation-xt make-flushable
 
-\ <tuple> { tuple-layout } { tuple } <effect> set-primitive-effect
+\ <tuple> { tuple-layout } { tuple } define-primitive
 \ <tuple> make-flushable
 
-\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } <effect> set-primitive-effect
+\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } define-primitive
 \ <tuple-layout> make-foldable
 
-\ datastack { } { array } <effect> set-primitive-effect
+\ datastack { } { array } define-primitive
 \ datastack make-flushable
 
-\ retainstack { } { array } <effect> set-primitive-effect
+\ retainstack { } { array } define-primitive
 \ retainstack make-flushable
 
-\ callstack { } { callstack } <effect> set-primitive-effect
+\ callstack { } { callstack } define-primitive
 \ callstack make-flushable
 
-\ callstack>array { callstack } { array } <effect> set-primitive-effect
+\ callstack>array { callstack } { array } define-primitive
 \ callstack>array make-flushable
 
-\ (sleep) { integer } { } <effect> set-primitive-effect
+\ (sleep) { integer } { } define-primitive
 
-\ become { array array } { } <effect> set-primitive-effect
+\ become { array array } { } define-primitive
 
-\ innermost-frame-quot { callstack } { quotation } <effect> set-primitive-effect
+\ innermost-frame-quot { callstack } { quotation } define-primitive
 
-\ innermost-frame-scan { callstack } { fixnum } <effect> set-primitive-effect
+\ innermost-frame-scan { callstack } { fixnum } define-primitive
 
-\ set-innermost-frame-quot { quotation callstack } { } <effect> set-primitive-effect
+\ set-innermost-frame-quot { quotation callstack } { } define-primitive
 
-\ (os-envs) { } { array } <effect> set-primitive-effect
+\ (os-envs) { } { array } define-primitive
 
-\ set-os-env { string string } { } <effect> set-primitive-effect
+\ set-os-env { string string } { } define-primitive
 
-\ unset-os-env { string } { } <effect> set-primitive-effect
+\ unset-os-env { string } { } define-primitive
 
-\ (set-os-envs) { array } { } <effect> set-primitive-effect
+\ (set-os-envs) { array } { } define-primitive
 
 \ do-primitive [ \ do-primitive cannot-infer-effect ] +infer+ set-word-prop
 
-\ dll-valid? { object } { object } <effect> set-primitive-effect
+\ dll-valid? { object } { object } define-primitive
 
-\ modify-code-heap { array object } { } <effect> set-primitive-effect
+\ modify-code-heap { array object } { } define-primitive
 
-\ unimplemented { } { } <effect> set-primitive-effect
+\ unimplemented { } { } define-primitive

unfinished/stack-checker/stack-checker-tests.factor

@@ -9,6 +9,8 @@ threads.private io.streams.string io.timeouts io.thread
 sequences.private destructors combinators ;
 IN: stack-checker.tests
 
+\ infer. must-infer
+
 { 0 2 } [ 2 "Hello" ] must-infer-as
 { 1 2 } [ dup ] must-infer-as
 

unfinished/stack-checker/transforms/transforms.factor

@@ -3,24 +3,43 @@
 USING: fry accessors arrays kernel words sequences generic math
 namespaces quotations assocs combinators classes.tuple
 classes.tuple.private effects summary hashtables classes generic
-sets definitions generic.standard slots.private
+sets definitions generic.standard slots.private continuations
 stack-checker.backend stack-checker.state stack-checker.errors ;
 IN: stack-checker.transforms
 
-: transform-quot ( quot n -- newquot )
+SYMBOL: +transform-quot+
+SYMBOL: +transform-n+
+
+: (apply-transform) ( quot n -- newquot )
     dup zero? [
-        drop '[ recursive-state get @ ]
+        drop recursive-state get 1array
     ] [
-        swap '[
+        consume-d
-            , consume-d
+        [ [ literal value>> ] map ]
-            [ first literal recursion>> ]
+        [ first literal recursion>> ] bi prefix
-            [ [ literal value>> ] each ] bi @
-        ]
     ] if
-    '[ @ swap infer-quot ] ;
+    swap with-datastack ;
+
+: apply-transform ( word -- )
+    [ +inlined+ depends-on ] [
+        [ +transform-quot+ word-prop ]
+        [ +transform-n+ word-prop ]
+        bi (apply-transform)
+        first2 swap infer-quot
+    ] bi ;
+
+: apply-macro ( word -- )
+    [ +inlined+ depends-on ] [
+        [ "macro" word-prop ]
+        [ "declared-effect" word-prop in>> length ]
+        bi (apply-transform)
+        first2 swap infer-quot
+    ] bi ;
 
 : define-transform ( word quot n -- )
-    transform-quot +infer+ set-word-prop ;
+    [ drop +transform-quot+ set-word-prop ]
+    [ nip +transform-n+ set-word-prop ]
+    3bi ;
 
 ! Combinators
 \ cond [ cond>quot ] 1 define-transform