From 75fbaee7efaed6169db1552aa972db8efe90f015 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Jul 2008 00:17:08 -0500 Subject: [PATCH] Stack checker and propagation now themselves infer, improve propagation pass --- .../compiler/frontend/frontend-tests.factor | 21 +- .../tree/combinators/combinators-tests.factor | 17 + .../constraints/constraints.factor | 2 +- .../tree/propagation/info/info-tests.factor | 6 + .../tree/propagation/info/info.factor | 48 +- .../known-words/known-words.factor | 181 +++---- .../tree/propagation/propagation-tests.factor | 62 ++- .../tree/propagation/simple/simple.factor | 18 +- .../stack-checker/backend/backend.factor | 17 +- .../stack-checker/branches/branches.factor | 15 +- .../stack-checker/inlining/inlining.factor | 3 +- .../known-words/known-words.factor | 495 ++++++++++-------- .../stack-checker/stack-checker-tests.factor | 2 + .../transforms/transforms.factor | 39 +- 14 files changed, 511 insertions(+), 415 deletions(-) create mode 100644 unfinished/compiler/tree/combinators/combinators-tests.factor diff --git a/unfinished/compiler/frontend/frontend-tests.factor b/unfinished/compiler/frontend/frontend-tests.factor index 98d75c5553..9e254b2a1e 100644 --- a/unfinished/compiler/frontend/frontend-tests.factor +++ b/unfinished/compiler/frontend/frontend-tests.factor @@ -1,17 +1,6 @@ +IN: compiler.frontend.tests +USING: compiler.frontend tools.test ; - -[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test -[ ] [ [ 1 2 3 ] dataflow [ ] transform-nodes drop ] unit-test - -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 +\ dataflow must-infer +\ dataflow-with must-infer +\ word-dataflow must-infer diff --git a/unfinished/compiler/tree/combinators/combinators-tests.factor b/unfinished/compiler/tree/combinators/combinators-tests.factor new file mode 100644 index 0000000000..d81af543e1 --- /dev/null +++ b/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 diff --git a/unfinished/compiler/tree/propagation/constraints/constraints.factor b/unfinished/compiler/tree/propagation/constraints/constraints.factor index 0d4216a649..0a0e779427 100644 --- a/unfinished/compiler/tree/propagation/constraints/constraints.factor +++ b/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 ; diff --git a/unfinished/compiler/tree/propagation/info/info-tests.factor b/unfinished/compiler/tree/propagation/info/info-tests.factor index 18b9977f7f..5ae54d3b2a 100644 --- a/unfinished/compiler/tree/propagation/info/info-tests.factor +++ b/unfinished/compiler/tree/propagation/info/info-tests.factor @@ -48,3 +48,9 @@ IN: compiler.tree.propagation.info.tests 2 3 (a,b] fixnum value-info-intersect >literal< ] unit-test + +[ T{ value-info f fixnum empty-interval f f } ] [ + fixnum -10 0 [a,b] + fixnum 19 29 [a,b] + value-info-intersect +] unit-test diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor index 25872173d0..76862846cd 100644 --- a/unfinished/compiler/tree/propagation/info/info.factor +++ b/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 { - { [ over interval-length 0 > ] [ 3drop f f ] } - { [ over from>> second not ] [ 3drop f f ] } - { [ over to>> second not ] [ 3drop f f ] } - { [ pick fixnum class<= ] [ 2nip >fixnum t ] } - { [ pick bignum class<= ] [ 2nip >bignum t ] } - { [ pick float class<= ] [ 2nip >float t ] } - [ 3drop f f ] - } cond ; + dup empty-interval eq? [ + 2drop f f + ] [ + dup from>> first { + { [ over interval-length 0 > ] [ 3drop f f ] } + { [ over from>> second not ] [ 3drop f f ] } + { [ over to>> second not ] [ 3drop f f ] } + { [ pick fixnum class<= ] [ 2nip >fixnum t ] } + { [ pick bignum class<= ] [ 2nip >bignum t ] } + { [ pick float class<= ] [ 2nip >float t ] } + [ 3drop f f ] + } cond + ] if ; : ( 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 ) + f f ; foldable + : ( class -- info ) - [-inf,inf] f f ; foldable + [-inf,inf] ; foldable : ( interval -- info ) - real swap f f ; foldable + real swap ; foldable : ( literal -- info ) f [-inf,inf] rot t ; 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 ; -: 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 ; diff --git a/unfinished/compiler/tree/propagation/known-words/known-words.factor b/unfinished/compiler/tree/propagation/known-words/known-words.factor index 900060feb5..524584258a 100644 --- a/unfinished/compiler/tree/propagation/known-words/known-words.factor +++ b/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 -sequences.private arrays assocs classes classes.algebra -combinators generic.math fry locals -compiler.tree.propagation.info -compiler.tree.propagation.nodes +math.partial-dispatch math.intervals math.parser layouts words +sequences sequences.private arrays assocs classes +classes.algebra combinators generic.math splitting fry locals +classes.tuple alien.accessors classes.tuple.private +compiler.tree.propagation.info compiler.tree.propagation.nodes compiler.tree.propagation.constraints ; IN: compiler.tree.propagation.known-words +\ and [ + [ [ ] bi@ ] dip if-true +] +constraints+ set-word-prop + +\ not [ + [ [ ] [ ] bi ] dip + +] +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 } - [ class<= ] with find nip number or ; - -: interval-subset?' ( i1 i2 -- ? ) - { - { [ over not ] [ 2drop t ] } - { [ dup not ] [ 2drop f ] } - [ interval-subset? ] - } cond ; + { fixnum bignum integer rational float real number object } + [ class<= ] with find nip ; : 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 ) - [ f f ] [ ] if* ; - : won't-overflow? ( class interval -- ? ) [ fixnum class<= ] [ fixnum fits? ] bi* and ; : may-overflow ( class interval -- class' interval' ) - 2dup won't-overflow? - [ [ integer math-class-max ] dip ] unless ; + over null class<= [ + 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] ] +outputs+ set-word-prop ; -\ + [ [ interval+ ] [ may-overflow ] binary-op ] each-derived-op -\ + [ [ interval+ ] [ ] binary-op ] each-fast-derived-op +\ + [ [ interval+ ] [ may-overflow number-valued ] binary-op ] each-derived-op +\ + [ [ interval+ ] [ number-valued ] binary-op ] each-fast-derived-op -\ - [ [ interval+ ] [ may-overflow ] binary-op ] each-derived-op -\ - [ [ interval+ ] [ ] binary-op ] each-fast-derived-op +\ - [ [ interval- ] [ may-overflow number-valued ] binary-op ] each-derived-op +\ - [ [ interval- ] [ number-valued ] binary-op ] each-fast-derived-op -\ * [ [ interval* ] [ may-overflow ] binary-op ] each-derived-op -\ * [ [ interval* ] [ ] binary-op ] each-fast-derived-op +\ * [ [ interval* ] [ may-overflow number-valued ] binary-op ] each-derived-op +\ * [ [ interval* ] [ number-valued ] binary-op ] each-fast-derived-op -\ shift [ [ interval-shift-safe ] [ may-overflow ] 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 +\ / [ [ interval/-safe ] [ may-be-rational number-valued ] 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 - in2 i2 i1 op swap-comparison assume-interval - - ] [ - f - ] if + in1 i1 i2 op assume-interval + in2 i2 i1 op swap-comparison assume-interval + ] ; : comparison-constraints ( in1 in2 out op -- constraint ) @@ -185,10 +188,7 @@ most-negative-fixnum most-positive-fixnum [a,b] ] dip ; : comparison-op ( word op -- ) - '[ - [ in-d>> first2 ] [ out-d>> first ] bi - , comparison-constraints - ] +constraints+ set-word-prop ; + '[ , 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 ] +outputs+ set-word-prop ] assoc-each -! -! { -! alien-signed-1 -! alien-unsigned-1 -! alien-signed-2 -! alien-unsigned-2 -! alien-signed-4 -! alien-unsigned-4 -! alien-signed-8 -! alien-unsigned-8 -! } [ -! dup name>> { -! { -! [ "alien-signed-" ?head ] -! [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ] -! } -! { -! [ "alien-unsigned-" ?head ] -! [ string>number 8 * 2^ 1- 0 swap [a,b] ] -! } -! } cond 1array -! [ nip f swap ] curry "output-classes" set-word-prop -! ] each -! -! -! { (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 +{ + alien-signed-1 + alien-unsigned-1 + alien-signed-2 + alien-unsigned-2 + alien-signed-4 + alien-unsigned-4 + alien-signed-8 + alien-unsigned-8 +} [ + dup name>> { + { + [ "alien-signed-" ?head ] + [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ] + } + { + [ "alien-unsigned-" ?head ] + [ string>number 8 * 2^ 1- 0 swap [a,b] ] + } + } cond + [ fixnum fits? fixnum bignum ? ] keep + [ 2nip ] curry +outputs+ set-word-prop +] each -: and-constraints ( in1 in2 out -- constraint ) - [ [ ] bi@ ] dip ; +{ } [ + [ + literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if + [ clear ] dip + ] +outputs+ set-word-prop +] each -! XXX... +\ new [ + literal>> dup tuple-class? [ drop tuple ] unless +] +outputs+ set-word-prop + +! the output of clone has the same type as the input +{ clone (clone) } [ [ ] +outputs+ set-word-prop ] each diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor index 06374e7783..72a9566281 100644 --- a/unfinished/compiler/tree/propagation/propagation-tests.factor +++ b/unfinished/compiler/tree/propagation/propagation-tests.factor @@ -1,8 +1,12 @@ USING: kernel compiler.frontend compiler.tree -compiler.tree.propagation tools.test math accessors -sequences arrays kernel.private ; +compiler.tree.propagation tools.test math math.order +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 diff --git a/unfinished/compiler/tree/propagation/simple/simple.factor b/unfinished/compiler/tree/propagation/simple/simple.factor index 1c77fe1fc6..f7dea223b5 100644 --- a/unfinished/compiler/tree/propagation/simple/simple.factor +++ b/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 ] dip if-false ] 3bi ; -: compute-constraints ( #call -- constraint ) - dup word>> +constraints+ word-prop [ call assume ] [ - dup word>> predicate? - [ +: custom-constraints ( #call quot -- ) + [ [ in-d>> ] [ out-d>> ] bi append ] dip + 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 ; diff --git a/unfinished/stack-checker/backend/backend.factor b/unfinished/stack-checker/backend/backend.factor index 645e4d0c1e..8fb897d8c6 100755 --- a/unfinished/stack-checker/backend/backend.factor +++ b/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 diff --git a/unfinished/stack-checker/branches/branches.factor b/unfinished/stack-checker/branches/branches.factor index 55aa452c10..dd7e37c2df 100644 --- a/unfinished/stack-checker/branches/branches.factor +++ b/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 [ ] map infer-branches [ #dispatch, ] dip compute-phi-function ; diff --git a/unfinished/stack-checker/inlining/inlining.factor b/unfinished/stack-checker/inlining/inlining.factor index 45252f117f..231d7078b9 100644 --- a/unfinished/stack-checker/inlining/inlining.factor +++ b/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 diff --git a/unfinished/stack-checker/known-words/known-words.factor b/unfinished/stack-checker/known-words/known-words.factor index 362c4f1394..6c36dd25a9 100755 --- a/unfinished/stack-checker/known-words/known-words.factor +++ b/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 -io.streams.c kernel kernel.private math math.private memory -namespaces namespaces.private parser prettyprint quotations -quotations.private sbufs sbufs.private sequences -sequences.private slots.private strings strings.private system -threads.private classes.tuple classes.tuple.private vectors -vectors.private words words.private assocs summary -compiler.units system.private -stack-checker.state stack-checker.backend stack-checker.branches -stack-checker.errors stack-checker.visitor ; +hashtables hashtables.private io io.backend io.files +io.files.private io.streams.c kernel kernel.private math +math.private memory namespaces namespaces.private parser +prettyprint quotations quotations.private sbufs sbufs.private +sequences sequences.private slots.private strings +strings.private system threads.private classes.tuple +classes.tuple.private vectors vectors.private words definitions +words.private assocs summary compiler.units system.private +combinators locals.backend stack-checker.state +stack-checker.backend stack-checker.branches +stack-checker.errors stack-checker.transforms +stack-checker.visitor ; IN: stack-checker.known-words -: infer-shuffle ( shuffle -- ) - [ 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, ; - -: define-shuffle ( word shuffle -- ) - '[ , infer-shuffle ] +infer+ set-word-prop ; +: infer-primitive ( word -- ) + dup + [ "input-classes" word-prop ] + [ "default-output-classes" word-prop ] bi + apply-word/effect ; { { 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 -\ r> [ 1 infer-r> ] +infer+ set-word-prop +: infer-shuffle ( shuffle -- ) + [ 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, -] +infer+ set-word-prop + #declare, ; -! 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 - -\ call t "no-compile" set-word-prop - -\ curry [ +: infer-curry ( -- ) 2 consume-d dup first2 make-known [ push-d ] [ 1array ] bi - \ curry #call, -] +infer+ set-word-prop + \ curry #call, ; -\ compose [ +: infer-compose ( -- ) 2 consume-d dup first2 make-known [ push-d ] [ 1array ] bi - \ compose #call, -] +infer+ set-word-prop + \ compose #call, ; -\ execute [ +: infer-execute ( -- ) pop-literal nip dup word? [ apply-object ] [ drop "execute must be given a word" time-bomb - ] if -] +infer+ set-word-prop + ] if ; -\ execute t "no-compile" set-word-prop - -\ 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 [ ] map infer-dispatch -] +infer+ set-word-prop - -\ dispatch t "no-compile" set-word-prop - -! Variadic tuple constructor -\ [ +: infer- ( -- ) \ peek-d literal value>> size>> { tuple } - apply-word/effect -] +infer+ set-word-prop + apply-word/effect ; -! Non-standard control flow -\ (throw) [ +: infer-(throw) ( -- ) \ (throw) peek-d literal value>> 2 + f t >>terminated? - apply-word/effect -] +infer+ set-word-prop + apply-word/effect ; -: set-primitive-effect ( word effect -- ) - [ in>> "input-classes" set-word-prop ] - [ out>> "default-output-classes" set-word-prop ] - [ dupd '[ , , apply-word/effect ] +infer+ set-word-prop ] - 2tri ; +: infer-exit ( -- ) + \ exit + { integer } { } t >>terminated? + apply-word/effect ; + +: infer-load-locals ( -- ) + pop-literal nip + [ dup reverse infer-shuffle ] + [ infer->r ] + bi ; + +: infer-get-local ( -- ) + pop-literal nip + [ infer-r> ] + [ dup 0 prefix infer-shuffle ] + [ infer->r ] + tri ; + +: infer-drop-locals ( -- ) + pop-literal nip + [ infer-r> ] + [ { } 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 ] } + { \ [ infer- ] } + { \ (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 + (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 } set-primitive-effect +\ fixnum< { fixnum fixnum } { object } define-primitive \ fixnum< make-foldable -\ fixnum<= { fixnum fixnum } { object } set-primitive-effect +\ fixnum<= { fixnum fixnum } { object } define-primitive \ fixnum<= make-foldable -\ fixnum> { fixnum fixnum } { object } set-primitive-effect +\ fixnum> { fixnum fixnum } { object } define-primitive \ fixnum> make-foldable -\ fixnum>= { fixnum fixnum } { object } set-primitive-effect +\ fixnum>= { fixnum fixnum } { object } define-primitive \ fixnum>= make-foldable -\ eq? { object object } { object } set-primitive-effect +\ eq? { object object } { object } define-primitive \ eq? make-foldable -\ rehash-string { string } { } set-primitive-effect - -\ bignum>fixnum { bignum } { fixnum } set-primitive-effect +\ bignum>fixnum { bignum } { fixnum } define-primitive \ bignum>fixnum make-foldable -\ float>fixnum { float } { fixnum } set-primitive-effect +\ float>fixnum { float } { fixnum } define-primitive \ bignum>fixnum make-foldable -\ fixnum>bignum { fixnum } { bignum } set-primitive-effect +\ fixnum>bignum { fixnum } { bignum } define-primitive \ fixnum>bignum make-foldable -\ float>bignum { float } { bignum } set-primitive-effect +\ float>bignum { float } { bignum } define-primitive \ float>bignum make-foldable -\ fixnum>float { fixnum } { float } set-primitive-effect +\ fixnum>float { fixnum } { float } define-primitive \ fixnum>float make-foldable -\ bignum>float { bignum } { float } set-primitive-effect +\ bignum>float { bignum } { float } define-primitive \ bignum>float make-foldable -\ { integer integer } { ratio } set-primitive-effect +\ { integer integer } { ratio } define-primitive \ make-foldable -\ string>float { string } { float } set-primitive-effect +\ string>float { string } { float } define-primitive \ string>float make-foldable -\ float>string { float } { string } set-primitive-effect +\ float>string { float } { string } define-primitive \ float>string make-foldable -\ float>bits { real } { integer } set-primitive-effect +\ float>bits { real } { integer } define-primitive \ float>bits make-foldable -\ double>bits { real } { integer } set-primitive-effect +\ double>bits { real } { integer } define-primitive \ double>bits make-foldable -\ bits>float { integer } { float } set-primitive-effect +\ bits>float { integer } { float } define-primitive \ bits>float make-foldable -\ bits>double { integer } { float } set-primitive-effect +\ bits>double { integer } { float } define-primitive \ bits>double make-foldable -\ { real real } { complex } set-primitive-effect +\ { real real } { complex } define-primitive \ make-foldable -\ fixnum+ { fixnum fixnum } { integer } set-primitive-effect +\ fixnum+ { fixnum fixnum } { integer } define-primitive \ fixnum+ make-foldable -\ fixnum+fast { fixnum fixnum } { fixnum } set-primitive-effect +\ fixnum+fast { fixnum fixnum } { fixnum } define-primitive \ fixnum+fast make-foldable -\ fixnum- { fixnum fixnum } { integer } set-primitive-effect +\ fixnum- { fixnum fixnum } { integer } define-primitive \ fixnum- make-foldable -\ fixnum-fast { fixnum fixnum } { fixnum } set-primitive-effect +\ fixnum-fast { fixnum fixnum } { fixnum } define-primitive \ fixnum-fast make-foldable -\ fixnum* { fixnum fixnum } { integer } set-primitive-effect +\ fixnum* { fixnum fixnum } { integer } define-primitive \ fixnum* make-foldable -\ fixnum*fast { fixnum fixnum } { fixnum } set-primitive-effect +\ fixnum*fast { fixnum fixnum } { fixnum } define-primitive \ fixnum*fast make-foldable -\ fixnum/i { fixnum fixnum } { integer } set-primitive-effect +\ fixnum/i { fixnum fixnum } { integer } define-primitive \ fixnum/i make-foldable -\ fixnum-mod { fixnum fixnum } { fixnum } set-primitive-effect +\ fixnum-mod { fixnum fixnum } { fixnum } define-primitive \ fixnum-mod make-foldable -\ fixnum/mod { fixnum fixnum } { integer fixnum } set-primitive-effect +\ fixnum/mod { fixnum fixnum } { integer fixnum } define-primitive \ fixnum/mod make-foldable -\ fixnum-bitand { fixnum fixnum } { fixnum } set-primitive-effect +\ fixnum-bitand { fixnum fixnum } { fixnum } define-primitive \ fixnum-bitand make-foldable -\ fixnum-bitor { fixnum fixnum } { fixnum } set-primitive-effect +\ fixnum-bitor { fixnum fixnum } { fixnum } define-primitive \ fixnum-bitor make-foldable -\ fixnum-bitxor { fixnum fixnum } { fixnum } set-primitive-effect +\ fixnum-bitxor { fixnum fixnum } { fixnum } define-primitive \ fixnum-bitxor make-foldable -\ fixnum-bitnot { fixnum } { fixnum } set-primitive-effect +\ fixnum-bitnot { fixnum } { fixnum } define-primitive \ fixnum-bitnot make-foldable -\ fixnum-shift { fixnum fixnum } { integer } set-primitive-effect +\ fixnum-shift { fixnum fixnum } { integer } define-primitive \ fixnum-shift make-foldable -\ fixnum-shift-fast { fixnum fixnum } { fixnum } set-primitive-effect +\ fixnum-shift-fast { fixnum fixnum } { fixnum } define-primitive \ fixnum-shift-fast make-foldable -\ bignum= { bignum bignum } { object } set-primitive-effect +\ bignum= { bignum bignum } { object } define-primitive \ bignum= make-foldable -\ bignum+ { bignum bignum } { bignum } set-primitive-effect +\ bignum+ { bignum bignum } { bignum } define-primitive \ bignum+ make-foldable -\ bignum- { bignum bignum } { bignum } set-primitive-effect +\ bignum- { bignum bignum } { bignum } define-primitive \ bignum- make-foldable -\ bignum* { bignum bignum } { bignum } set-primitive-effect +\ bignum* { bignum bignum } { bignum } define-primitive \ bignum* make-foldable -\ bignum/i { bignum bignum } { bignum } set-primitive-effect +\ bignum/i { bignum bignum } { bignum } define-primitive \ bignum/i make-foldable -\ bignum-mod { bignum bignum } { bignum } set-primitive-effect +\ bignum-mod { bignum bignum } { bignum } define-primitive \ bignum-mod make-foldable -\ bignum/mod { bignum bignum } { bignum bignum } set-primitive-effect +\ bignum/mod { bignum bignum } { bignum bignum } define-primitive \ bignum/mod make-foldable -\ bignum-bitand { bignum bignum } { bignum } set-primitive-effect +\ bignum-bitand { bignum bignum } { bignum } define-primitive \ bignum-bitand make-foldable -\ bignum-bitor { bignum bignum } { bignum } set-primitive-effect +\ bignum-bitor { bignum bignum } { bignum } define-primitive \ bignum-bitor make-foldable -\ bignum-bitxor { bignum bignum } { bignum } set-primitive-effect +\ bignum-bitxor { bignum bignum } { bignum } define-primitive \ bignum-bitxor make-foldable -\ bignum-bitnot { bignum } { bignum } set-primitive-effect +\ bignum-bitnot { bignum } { bignum } define-primitive \ bignum-bitnot make-foldable -\ bignum-shift { bignum bignum } { bignum } set-primitive-effect +\ bignum-shift { bignum bignum } { bignum } define-primitive \ bignum-shift make-foldable -\ bignum< { bignum bignum } { object } set-primitive-effect +\ bignum< { bignum bignum } { object } define-primitive \ bignum< make-foldable -\ bignum<= { bignum bignum } { object } set-primitive-effect +\ bignum<= { bignum bignum } { object } define-primitive \ bignum<= make-foldable -\ bignum> { bignum bignum } { object } set-primitive-effect +\ bignum> { bignum bignum } { object } define-primitive \ bignum> make-foldable -\ bignum>= { bignum bignum } { object } set-primitive-effect +\ bignum>= { bignum bignum } { object } define-primitive \ bignum>= make-foldable -\ bignum-bit? { bignum integer } { object } set-primitive-effect +\ bignum-bit? { bignum integer } { object } define-primitive \ bignum-bit? make-foldable -\ bignum-log2 { bignum } { bignum } set-primitive-effect +\ bignum-log2 { bignum } { bignum } define-primitive \ bignum-log2 make-foldable -\ byte-array>bignum { byte-array } { bignum } set-primitive-effect +\ byte-array>bignum { byte-array } { bignum } define-primitive \ byte-array>bignum make-foldable -\ float= { float float } { object } set-primitive-effect +\ float= { float float } { object } define-primitive \ float= make-foldable -\ float+ { float float } { float } set-primitive-effect +\ float+ { float float } { float } define-primitive \ float+ make-foldable -\ float- { float float } { float } set-primitive-effect +\ float- { float float } { float } define-primitive \ float- make-foldable -\ float* { float float } { float } set-primitive-effect +\ float* { float float } { float } define-primitive \ float* make-foldable -\ float/f { float float } { float } set-primitive-effect +\ float/f { float float } { float } define-primitive \ float/f make-foldable -\ float< { float float } { object } set-primitive-effect +\ float< { float float } { object } define-primitive \ float< make-foldable -\ float-mod { float float } { float } set-primitive-effect +\ float-mod { float float } { float } define-primitive \ float-mod make-foldable -\ float<= { float float } { object } set-primitive-effect +\ float<= { float float } { object } define-primitive \ float<= make-foldable -\ float> { float float } { object } set-primitive-effect +\ float> { float float } { object } define-primitive \ float> make-foldable -\ float>= { float float } { object } set-primitive-effect +\ float>= { float float } { object } define-primitive \ float>= make-foldable -\ { object object } { word } set-primitive-effect +\ { object object } { word } define-primitive \ make-flushable -\ word-xt { word } { integer integer } set-primitive-effect +\ word-xt { word } { integer integer } define-primitive \ word-xt make-flushable -\ getenv { fixnum } { object } set-primitive-effect +\ getenv { fixnum } { object } define-primitive \ getenv make-flushable -\ setenv { object fixnum } { } set-primitive-effect +\ setenv { object fixnum } { } define-primitive -\ (exists?) { string } { object } set-primitive-effect +\ (exists?) { string } { object } define-primitive -\ (directory) { string } { array } set-primitive-effect +\ (directory) { string } { array } define-primitive -\ gc { } { } set-primitive-effect +\ gc { } { } define-primitive -\ gc-stats { } { array } set-primitive-effect +\ gc-stats { } { array } define-primitive -\ save-image { string } { } set-primitive-effect +\ save-image { string } { } define-primitive -\ save-image-and-exit { string } { } set-primitive-effect +\ save-image-and-exit { string } { } define-primitive -\ exit { integer } { } t >>terminated? set-primitive-effect - -\ data-room { } { integer integer array } set-primitive-effect +\ data-room { } { integer integer array } define-primitive \ data-room make-flushable -\ code-room { } { integer integer integer integer } set-primitive-effect +\ code-room { } { integer integer integer integer } define-primitive \ code-room make-flushable -\ os-env { string } { object } set-primitive-effect +\ os-env { string } { object } define-primitive -\ millis { } { integer } set-primitive-effect +\ millis { } { integer } define-primitive \ millis make-flushable -\ tag { object } { fixnum } set-primitive-effect +\ tag { object } { fixnum } define-primitive \ tag make-foldable -\ cwd { } { string } set-primitive-effect +\ dlopen { string } { dll } define-primitive -\ cd { string } { } set-primitive-effect +\ dlsym { string object } { c-ptr } define-primitive -\ dlopen { string } { dll } set-primitive-effect +\ dlclose { dll } { } define-primitive -\ dlsym { string object } { c-ptr } set-primitive-effect - -\ dlclose { dll } { } set-primitive-effect - -\ { integer } { byte-array } set-primitive-effect +\ { integer } { byte-array } define-primitive \ make-flushable -\ { integer c-ptr } { c-ptr } set-primitive-effect +\ { integer c-ptr } { c-ptr } define-primitive \ make-flushable -\ alien-signed-cell { c-ptr integer } { integer } 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 } { } set-primitive-effect +\ set-alien-signed-cell { integer c-ptr integer } { } define-primitive -\ alien-unsigned-cell { c-ptr integer } { integer } 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 } { } set-primitive-effect +\ set-alien-unsigned-cell { integer c-ptr integer } { } define-primitive -\ alien-signed-8 { c-ptr integer } { integer } 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 } { } set-primitive-effect +\ set-alien-signed-8 { integer c-ptr integer } { } define-primitive -\ alien-unsigned-8 { c-ptr integer } { integer } 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 } { } set-primitive-effect +\ set-alien-unsigned-8 { integer c-ptr integer } { } define-primitive -\ alien-signed-4 { c-ptr integer } { integer } 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 } { } set-primitive-effect +\ set-alien-signed-4 { integer c-ptr integer } { } define-primitive -\ alien-unsigned-4 { c-ptr integer } { integer } 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 } { } set-primitive-effect +\ set-alien-unsigned-4 { integer c-ptr integer } { } define-primitive -\ alien-signed-2 { c-ptr integer } { fixnum } 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 } { } set-primitive-effect +\ set-alien-signed-2 { integer c-ptr integer } { } define-primitive -\ alien-unsigned-2 { c-ptr integer } { fixnum } 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 } { } set-primitive-effect +\ set-alien-unsigned-2 { integer c-ptr integer } { } define-primitive -\ alien-signed-1 { c-ptr integer } { fixnum } 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 } { } set-primitive-effect +\ set-alien-signed-1 { integer c-ptr integer } { } define-primitive -\ alien-unsigned-1 { c-ptr integer } { fixnum } 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 } { } set-primitive-effect +\ set-alien-unsigned-1 { integer c-ptr integer } { } define-primitive -\ alien-float { c-ptr integer } { float } set-primitive-effect +\ alien-float { c-ptr integer } { float } define-primitive \ alien-float make-flushable -\ set-alien-float { float c-ptr integer } { } set-primitive-effect +\ set-alien-float { float c-ptr integer } { } define-primitive -\ alien-double { c-ptr integer } { float } set-primitive-effect +\ alien-double { c-ptr integer } { float } define-primitive \ alien-double make-flushable -\ set-alien-double { float c-ptr integer } { } set-primitive-effect +\ set-alien-double { float c-ptr integer } { } define-primitive -\ alien-cell { c-ptr integer } { simple-c-ptr } 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 } { } set-primitive-effect +\ set-alien-cell { c-ptr c-ptr integer } { } define-primitive -\ alien-address { alien } { integer } set-primitive-effect +\ alien-address { alien } { integer } define-primitive \ alien-address make-flushable -\ slot { object fixnum } { object } set-primitive-effect +\ slot { object fixnum } { object } define-primitive \ slot make-flushable -\ set-slot { object object fixnum } { } set-primitive-effect +\ set-slot { object object fixnum } { } define-primitive -\ string-nth { fixnum string } { fixnum } set-primitive-effect +\ string-nth { fixnum string } { fixnum } define-primitive \ string-nth make-flushable -\ set-string-nth { fixnum fixnum string } { } set-primitive-effect +\ set-string-nth { fixnum fixnum string } { } define-primitive -\ resize-array { integer array } { array } set-primitive-effect +\ resize-array { integer array } { array } define-primitive \ resize-array make-flushable -\ resize-byte-array { integer byte-array } { byte-array } set-primitive-effect +\ resize-byte-array { integer byte-array } { byte-array } define-primitive \ resize-byte-array make-flushable -\ resize-string { integer string } { string } set-primitive-effect +\ resize-string { integer string } { string } define-primitive \ resize-string make-flushable -\ { integer object } { array } set-primitive-effect +\ { integer object } { array } define-primitive \ make-flushable -\ begin-scan { } { } set-primitive-effect +\ begin-scan { } { } define-primitive -\ next-object { } { object } set-primitive-effect +\ next-object { } { object } define-primitive -\ end-scan { } { } set-primitive-effect +\ end-scan { } { } define-primitive -\ size { object } { fixnum } set-primitive-effect +\ size { object } { fixnum } define-primitive \ size make-flushable -\ die { } { } set-primitive-effect +\ die { } { } define-primitive -\ fopen { string string } { alien } set-primitive-effect +\ fopen { string string } { alien } define-primitive -\ fgetc { alien } { object } set-primitive-effect +\ fgetc { alien } { object } define-primitive -\ fwrite { string alien } { } set-primitive-effect +\ fwrite { string alien } { } define-primitive -\ fputc { object alien } { } set-primitive-effect +\ fputc { object alien } { } define-primitive -\ fread { integer string } { object } set-primitive-effect +\ fread { integer string } { object } define-primitive -\ fflush { alien } { } set-primitive-effect +\ fflush { alien } { } define-primitive -\ fclose { alien } { } set-primitive-effect +\ fclose { alien } { } define-primitive -\ { object } { wrapper } set-primitive-effect +\ { object } { wrapper } define-primitive \ make-foldable -\ (clone) { object } { object } set-primitive-effect +\ (clone) { object } { object } define-primitive \ (clone) make-flushable -\ { integer integer } { string } set-primitive-effect +\ { integer integer } { string } define-primitive \ make-flushable -\ array>quotation { array } { quotation } set-primitive-effect +\ array>quotation { array } { quotation } define-primitive \ array>quotation make-flushable -\ quotation-xt { quotation } { integer } set-primitive-effect +\ quotation-xt { quotation } { integer } define-primitive \ quotation-xt make-flushable -\ { tuple-layout } { tuple } set-primitive-effect +\ { tuple-layout } { tuple } define-primitive \ make-flushable -\ { word fixnum array fixnum } { tuple-layout } set-primitive-effect +\ { word fixnum array fixnum } { tuple-layout } define-primitive \ make-foldable -\ datastack { } { array } set-primitive-effect +\ datastack { } { array } define-primitive \ datastack make-flushable -\ retainstack { } { array } set-primitive-effect +\ retainstack { } { array } define-primitive \ retainstack make-flushable -\ callstack { } { callstack } set-primitive-effect +\ callstack { } { callstack } define-primitive \ callstack make-flushable -\ callstack>array { callstack } { array } set-primitive-effect +\ callstack>array { callstack } { array } define-primitive \ callstack>array make-flushable -\ (sleep) { integer } { } set-primitive-effect +\ (sleep) { integer } { } define-primitive -\ become { array array } { } set-primitive-effect +\ become { array array } { } define-primitive -\ innermost-frame-quot { callstack } { quotation } set-primitive-effect +\ innermost-frame-quot { callstack } { quotation } define-primitive -\ innermost-frame-scan { callstack } { fixnum } set-primitive-effect +\ innermost-frame-scan { callstack } { fixnum } define-primitive -\ set-innermost-frame-quot { quotation callstack } { } set-primitive-effect +\ set-innermost-frame-quot { quotation callstack } { } define-primitive -\ (os-envs) { } { array } set-primitive-effect +\ (os-envs) { } { array } define-primitive -\ set-os-env { string string } { } set-primitive-effect +\ set-os-env { string string } { } define-primitive -\ unset-os-env { string } { } set-primitive-effect +\ unset-os-env { string } { } define-primitive -\ (set-os-envs) { array } { } set-primitive-effect +\ (set-os-envs) { array } { } define-primitive \ do-primitive [ \ do-primitive cannot-infer-effect ] +infer+ set-word-prop -\ dll-valid? { object } { object } set-primitive-effect +\ dll-valid? { object } { object } define-primitive -\ modify-code-heap { array object } { } set-primitive-effect +\ modify-code-heap { array object } { } define-primitive -\ unimplemented { } { } set-primitive-effect +\ unimplemented { } { } define-primitive diff --git a/unfinished/stack-checker/stack-checker-tests.factor b/unfinished/stack-checker/stack-checker-tests.factor index acc3d7c0a4..e6dfbbdf26 100755 --- a/unfinished/stack-checker/stack-checker-tests.factor +++ b/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 diff --git a/unfinished/stack-checker/transforms/transforms.factor b/unfinished/stack-checker/transforms/transforms.factor index c379bced75..8b0f903074 100755 --- a/unfinished/stack-checker/transforms/transforms.factor +++ b/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 - [ first literal recursion>> ] - [ [ literal value>> ] each ] bi @ - ] + consume-d + [ [ literal value>> ] map ] + [ first literal recursion>> ] bi prefix ] 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