Stack checker and propagation now themselves infer, improve propagation pass

db4
Slava Pestov 2008-07-23 00:17:08 -05:00
parent 052b93ab03
commit 75fbaee7ef
14 changed files with 511 additions and 415 deletions

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;
: <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> ;

View File

@ -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 [
[ [ <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 }
[ 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> ( 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?
[ [ 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]
<class/interval-info>
] +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 <interval-constraint>
in2 i2 i1 op swap-comparison assume-interval <interval-constraint>
<conjunction>
] [
f
] if
in1 i1 i2 op assume-interval <interval-constraint>
in2 i2 i1 op swap-comparison assume-interval <interval-constraint>
<conjunction>
] ;
: 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 -- )
'[
[ 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
<class/interval-info>
] +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> <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
{
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 <class/interval-info>
[ 2nip ] curry +outputs+ set-word-prop
] each
: and-constraints ( in1 in2 out -- constraint )
[ [ <true-constraint> ] bi@ ] dip <conditional> ;
{ <tuple> <tuple-boa> } [
[
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

View File

@ -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

View File

@ -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 )
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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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 <effect>
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 <curried> make-known
[ push-d ] [ 1array ] bi
\ curry #call,
] +infer+ set-word-prop
\ curry #call, ;
\ compose [
: infer-compose ( -- )
2 consume-d
dup first2 <composed> 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 [ <literal> ] map infer-dispatch
] +infer+ set-word-prop
\ dispatch t "no-compile" set-word-prop
! Variadic tuple constructor
\ <tuple-boa> [
: infer-<tuple-boa> ( -- )
\ <tuple-boa>
peek-d literal value>> size>> { tuple } <effect>
apply-word/effect
] +infer+ set-word-prop
apply-word/effect ;
! Non-standard control flow
\ (throw) [
: infer-(throw) ( -- )
\ (throw)
peek-d literal value>> 2 + f <effect> 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? <effect>
apply-word/effect ;
: 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 } <effect> set-primitive-effect
\ bignum>fixnum { bignum } { fixnum } define-primitive
\ 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 } <effect> set-primitive-effect
\ data-room { } { integer integer array } define-primitive
\ 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
\ dlclose { dll } { } <effect> set-primitive-effect
\ <byte-array> { integer } { byte-array } <effect> set-primitive-effect
\ <byte-array> { integer } { byte-array } define-primitive
\ <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

View File

@ -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

View File

@ -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