Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
b41e619f77
|
|
@ -165,12 +165,16 @@ GENERIC: boa ( ... class -- tuple )
|
|||
compose compose ; inline
|
||||
|
||||
! Booleans
|
||||
: not ( obj -- ? ) f eq? ; inline
|
||||
: not ( obj -- ? )
|
||||
#! Not inline because its special-cased by compiler.
|
||||
f eq? ;
|
||||
|
||||
: and ( obj1 obj2 -- ? )
|
||||
#! Not inline because its special-cased by compiler.
|
||||
over ? ;
|
||||
|
||||
: >boolean ( obj -- ? ) t f ? ; inline
|
||||
|
||||
: and ( obj1 obj2 -- ? ) over ? ; inline
|
||||
|
||||
: or ( obj1 obj2 -- ? ) dupd ? ; inline
|
||||
|
||||
: xor ( obj1 obj2 -- ? ) dup not swap ? ; inline
|
||||
|
|
|
|||
|
|
@ -217,7 +217,7 @@ IN: math.intervals.tests
|
|||
] if ;
|
||||
|
||||
: random-interval ( -- interval )
|
||||
1000 random dup 2 1000 random + +
|
||||
2000 random 1000 - dup 2 1000 random + +
|
||||
1 random zero? [ [ neg ] bi@ swap ] when
|
||||
4 random {
|
||||
{ 0 [ [a,b] ] }
|
||||
|
|
@ -274,7 +274,7 @@ IN: math.intervals.tests
|
|||
|
||||
: binary-test ( -- ? )
|
||||
random-interval random-interval random-binary-op ! 3dup . . .
|
||||
0 pick interval-contains? over first { / /i } member? and [
|
||||
0 pick interval-contains? over first { / /i mod rem } member? and [
|
||||
3drop t
|
||||
] [
|
||||
[ >r [ random-element ] bi@ ! 2dup . .
|
||||
|
|
@ -310,3 +310,25 @@ IN: math.intervals.tests
|
|||
[ t ] [ -10 10 [a,b] -100 0 [a,b] assume<= -10 0 [a,b] = ] unit-test
|
||||
|
||||
[ t ] [ -10 10 [a,b] 0 100 [a,b] assume<= -10 10 [a,b] = ] unit-test
|
||||
|
||||
[ t ] [ -10 10 [a,b] interval-abs 0 10 [a,b] = ] unit-test
|
||||
|
||||
! Test that commutative interval ops really are
|
||||
: random-interval-or-empty ( -- )
|
||||
10 random 0 = [ empty-interval ] [ random-interval ] if ;
|
||||
|
||||
: random-commutative-op ( -- op )
|
||||
{
|
||||
interval+ interval*
|
||||
interval-bitor interval-bitand interval-bitxor
|
||||
interval-max interval-min
|
||||
} random ;
|
||||
|
||||
[ t ] [
|
||||
80000 [
|
||||
drop
|
||||
random-interval-or-empty random-interval-or-empty
|
||||
random-commutative-op
|
||||
[ execute ] [ swapd execute ] 3bi =
|
||||
] all?
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -235,11 +235,15 @@ TUPLE: interval { from read-only } { to read-only } ;
|
|||
: interval/f ( i1 i2 -- i3 )
|
||||
[ [ [ /f ] interval-op ] interval-division-op ] do-empty-interval ;
|
||||
|
||||
: (interval-abs) ( i1 -- i2 )
|
||||
interval>points [ first2 [ abs ] dip 2array ] bi@ 2array ;
|
||||
|
||||
: interval-abs ( i1 -- i2 )
|
||||
dup empty-interval eq? [
|
||||
interval>points [ first2 [ abs ] dip 2array ] bi@ 2array
|
||||
points>interval
|
||||
] unless ;
|
||||
{
|
||||
{ [ dup empty-interval eq? ] [ ] }
|
||||
{ [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] }
|
||||
[ (interval-abs) points>interval ]
|
||||
} cond ;
|
||||
|
||||
: interval-mod ( i1 i2 -- i3 )
|
||||
#! Inaccurate.
|
||||
|
|
@ -307,30 +311,45 @@ SYMBOL: incomparable
|
|||
: interval>= ( i1 i2 -- ? )
|
||||
swap interval<= ;
|
||||
|
||||
: interval-bitand-pos ( i1 i2 -- ? )
|
||||
[ to>> first ] bi@ min 0 swap [a,b] ;
|
||||
|
||||
: interval-bitand-neg ( i1 i2 -- ? )
|
||||
dup from>> first 0 < [ drop ] [ nip ] if
|
||||
0 swap to>> first [a,b] ;
|
||||
|
||||
: interval-nonnegative? ( i -- ? )
|
||||
from>> first 0 >= ;
|
||||
|
||||
: interval-bitand ( i1 i2 -- i3 )
|
||||
dup 1 [a,a] interval>= [
|
||||
1 [a,a] interval- interval-rem
|
||||
] [
|
||||
2drop [-inf,inf]
|
||||
] if ;
|
||||
#! Inaccurate.
|
||||
[
|
||||
{
|
||||
{
|
||||
[ 2dup [ interval-nonnegative? ] both? ]
|
||||
[ interval-bitand-pos ]
|
||||
}
|
||||
{
|
||||
[ 2dup [ interval-nonnegative? ] either? ]
|
||||
[ interval-bitand-neg ]
|
||||
}
|
||||
[ 2drop [-inf,inf] ]
|
||||
} cond
|
||||
] do-empty-interval ;
|
||||
|
||||
: interval-bitor ( i1 i2 -- i3 )
|
||||
#! Inaccurate.
|
||||
[
|
||||
2dup [ 0 [a,a] interval>= ] both?
|
||||
[ to>> first 0 swap [a,b] interval-intersect ]
|
||||
[ 2drop [-inf,inf] ]
|
||||
if
|
||||
2dup [ interval-nonnegative? ] both?
|
||||
[
|
||||
[ interval>points [ first ] bi@ ] bi@
|
||||
4array supremum 0 swap next-power-of-2 [a,b]
|
||||
] [ 2drop [-inf,inf] ] if
|
||||
] do-empty-interval ;
|
||||
|
||||
: interval-bitxor ( i1 i2 -- i3 )
|
||||
#! Inaccurate.
|
||||
[
|
||||
2dup [ 0 [a,a] interval>= ] both?
|
||||
[ nip to>> first 0 swap [a,b] ]
|
||||
[ 2drop [-inf,inf] ]
|
||||
if
|
||||
] do-empty-interval ;
|
||||
interval-bitor ;
|
||||
|
||||
: assume< ( i1 i2 -- i3 )
|
||||
dup empty-interval eq? [ drop ] [
|
||||
|
|
|
|||
|
|
@ -0,0 +1,38 @@
|
|||
! Copyright © 2008 Reginald Keith Ford II
|
||||
! 24, the Factor game!
|
||||
|
||||
USING: kernel random namespaces shuffle sequences
|
||||
parser io math prettyprint combinators continuations
|
||||
vectors words quotations accessors math.parser
|
||||
backtrack math.ranges locals fry memoize macros assocs ;
|
||||
|
||||
IN: 24-game
|
||||
|
||||
: nop ;
|
||||
: do-something ( a b -- c ) { + - * } amb-execute ;
|
||||
: maybe-swap ( a b -- a b ) { nop swap } amb-execute ;
|
||||
: some-rots ( a b c -- a b c )
|
||||
#! Try each permutation of 3 elements.
|
||||
{ nop rot -rot swap spin swapd } amb-execute ;
|
||||
: makes-24? ( a b c d -- ? ) [ some-rots do-something some-rots do-something maybe-swap do-something 24 = ] [ 4drop ] if-amb ;
|
||||
: vector-24-able? ( vector -- t/f ) [ makes-24? ] with-datastack first ;
|
||||
: q ( -- obj ) "quit" ;
|
||||
: show-commands ( -- ) "Commands: " write "commands" get unparse print ;
|
||||
: report ( vector -- ) unparse print show-commands ;
|
||||
: give-help ( -- ) "Command not found..." print show-commands ;
|
||||
: find-word ( string choices -- word ) [ name>> = ] with find nip ;
|
||||
: obtain-word ( -- word ) readln "commands" get find-word dup [ drop give-help obtain-word ] unless ;
|
||||
: done? ( vector -- t/f ) 1 swap length = ;
|
||||
: victory? ( vector -- t/f ) V{ 24 } = ;
|
||||
: apply-word ( vector word -- vector ) 1quotation with-datastack >vector ;
|
||||
: update-commands ( vector -- ) length 3 < [ "commands" [ \ rot swap remove ] change ] [ ] if ;
|
||||
DEFER: check-status
|
||||
: quit-game ( vector -- ) drop "you're a quitter" print ;
|
||||
: quit? ( vector -- t/f ) peek "quit" = ;
|
||||
: end-game ( vector -- ) dup victory? [ drop "You WON!" ] [ pop number>string " is not 24... You lose." append ] if print ;
|
||||
: repeat ( vector -- ) dup report obtain-word apply-word dup update-commands check-status ;
|
||||
: check-status ( object -- ) dup done? [ end-game ] [ dup quit? [ quit-game ] [ repeat ] if ] if ;
|
||||
: build-quad ( -- vector ) 4 [ 10 random ] replicate >vector ;
|
||||
: 24-able ( -- vector ) build-quad dup vector-24-able? [ drop build-quad ] unless ;
|
||||
: set-commands ( -- ) { + - * / rot swap q } "commands" set ;
|
||||
: play-game ( -- ) set-commands 24-able repeat ;
|
||||
|
|
@ -1,3 +1,5 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel slots.private inference.known-words
|
||||
inference.backend sequences effects words ;
|
||||
IN: locals.backend
|
||||
|
|
|
|||
|
|
@ -0,0 +1,9 @@
|
|||
USING: help.markup help.syntax ;
|
||||
|
||||
IN: math.derivatives
|
||||
|
||||
HELP: derivative ( x function -- m )
|
||||
{ $values { "x" "the x-position on the function" } { "function" "a differentiable function" } }
|
||||
{ $description "Finds the slope of the tangent line at the given x-position on the given function." } ;
|
||||
|
||||
{ derivative-func } related-words
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
! Copyright © 2008 Reginald Keith Ford II
|
||||
! Tool for computing the derivative of a function at a point
|
||||
USING: kernel math math.points math.function-tools ;
|
||||
IN: math.derivatives
|
||||
|
||||
: small-amount ( -- n ) 1.0e-12 ;
|
||||
: near ( x -- y ) small-amount + ;
|
||||
: derivative ( x function -- m ) 2dup [ near ] dip [ eval ] 2bi@ slope ;
|
||||
: derivative-func ( function -- function ) [ derivative ] curry ;
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
! Copyright © 2008 Reginald Keith Ford II
|
||||
! Tools for quickly comparing, transforming, and evaluating mathematical Factor functions
|
||||
|
||||
USING: kernel math arrays ;
|
||||
IN: math.function-tools
|
||||
: difference-func ( func func -- func ) [ bi - ] 2curry ;
|
||||
: eval ( x func -- pt ) dupd call 2array ;
|
||||
: eval3d ( x y func -- pt ) [ 2dup ] dip call 3array ;
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
! Copyright © 2008 Reginald Keith Ford II
|
||||
! Newton's Method of approximating roots
|
||||
|
||||
USING: kernel math math.derivatives ;
|
||||
IN: math.newtons-method
|
||||
|
||||
<PRIVATE
|
||||
: newton-step ( x function -- x2 ) dupd [ call ] [ derivative ] 2bi / - ;
|
||||
: newton-precision ( -- n ) 7 ;
|
||||
PRIVATE>
|
||||
: newton-method ( guess function -- x ) newton-precision [ [ newton-step ] keep ] times drop ;
|
||||
|
|
@ -1,5 +1,4 @@
|
|||
|
||||
USING: kernel arrays math.vectors ;
|
||||
USING: kernel arrays math.vectors sequences math ;
|
||||
|
||||
IN: math.points
|
||||
|
||||
|
|
@ -20,3 +19,9 @@ PRIVATE>
|
|||
: v+z ( seq z -- seq ) Z v+ ;
|
||||
: v-z ( seq z -- seq ) Z v- ;
|
||||
|
||||
: rise ( pt2 pt1 -- n ) [ second ] bi@ - ;
|
||||
: run ( pt2 pt1 -- n ) [ first ] bi@ - ;
|
||||
: slope ( pt pt -- slope ) [ rise ] [ run ] 2bi / ;
|
||||
: distance ( point point -- float ) v- norm ;
|
||||
: midpoint ( point point -- point ) v+ 2 v/n ;
|
||||
: linear-solution ( pt pt -- x ) [ drop first2 ] [ slope ] 2bi / - ;
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
! Copyright © 2008 Reginald Keith Ford II
|
||||
! Secant Method of approximating roots
|
||||
|
||||
USING: kernel math math.function-tools math.points math.vectors ;
|
||||
IN: math.secant-method
|
||||
|
||||
<PRIVATE
|
||||
: secant-solution ( x1 x2 function -- solution ) [ eval ] curry bi@ linear-solution ;
|
||||
: secant-step ( x1 x2 func -- x2 x3 func ) 2dup [ secant-solution ] 2dip swapd ;
|
||||
: secant-precision ( -- n ) 11 ;
|
||||
PRIVATE>
|
||||
: secant-method ( left right function -- x ) secant-precision [ secant-step ] times drop v+ 2 v*n ;
|
||||
! : close-enough? ( a b -- t/f ) - abs tiny-amount < ;
|
||||
! : secant-method2 ( left right function -- x ) 2over close-enough? [ drop average ] [ secant-step secant-method ] if ;
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays combinators io kernel math math.functions math.parser
|
||||
math.statistics namespaces sequences tools.time ;
|
||||
math.statistics namespaces sequences tools.time continuations ;
|
||||
IN: project-euler.ave-time
|
||||
|
||||
: collect-benchmarks ( quot n -- seq )
|
||||
|
|
|
|||
|
|
@ -50,7 +50,6 @@ DEFER: expansion
|
|||
METHOD: expand { back-quoted-expr }
|
||||
expr>>
|
||||
expr
|
||||
ast>>
|
||||
command>>
|
||||
expansion
|
||||
utf8 <process-stream>
|
||||
|
|
@ -122,7 +121,7 @@ DEFER: shell
|
|||
{ [ dup f = ] [ drop ] }
|
||||
{ [ dup "exit" = ] [ drop ] }
|
||||
{ [ dup "" = ] [ drop shell ] }
|
||||
{ [ dup expr ] [ expr ast>> chant shell ] }
|
||||
{ [ dup expr ] [ expr chant shell ] }
|
||||
{ [ t ] [ drop "ix: ignoring input" print shell ] }
|
||||
}
|
||||
cond ;
|
||||
|
|
|
|||
|
|
@ -12,9 +12,9 @@ TUPLE: labelled-gadget < track content ;
|
|||
|
||||
: <labelled-gadget> ( gadget title -- newgadget )
|
||||
{ 0 1 } labelled-gadget new-track
|
||||
swap <label> reverse-video-theme f track-add*
|
||||
swap <label> reverse-video-theme f track-add
|
||||
swap >>content
|
||||
dup content>> 1 track-add* ;
|
||||
dup content>> 1 track-add ;
|
||||
|
||||
M: labelled-gadget focusable-child* labelled-gadget-content ;
|
||||
|
||||
|
|
|
|||
|
|
@ -65,10 +65,10 @@ M: f >label drop <gadget> ;
|
|||
|
||||
: label-on-left ( gadget label -- button )
|
||||
{ 1 0 } <track>
|
||||
swap >label f track-add*
|
||||
swap 1 track-add* ;
|
||||
swap >label f track-add
|
||||
swap 1 track-add ;
|
||||
|
||||
: label-on-right ( label gadget -- button )
|
||||
{ 1 0 } <track>
|
||||
swap f track-add*
|
||||
swap >label 1 track-add* ;
|
||||
swap f track-add
|
||||
swap >label 1 track-add ;
|
||||
|
|
|
|||
|
|
@ -71,9 +71,9 @@ M: value-ref finish-editing
|
|||
: <slot-editor> ( ref -- gadget )
|
||||
{ 0 1 } slot-editor new-track
|
||||
swap >>ref
|
||||
dup <toolbar> f track-add*
|
||||
dup <toolbar> f track-add
|
||||
<source-editor> >>text
|
||||
dup text>> <scroller> 1 track-add*
|
||||
dup text>> <scroller> 1 track-add
|
||||
dup revert ;
|
||||
|
||||
M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
|
||||
|
|
@ -97,8 +97,8 @@ TUPLE: editable-slot < track printer ref ;
|
|||
|
||||
: display-slot ( gadget editable-slot -- )
|
||||
dup clear-track
|
||||
swap 1 track-add*
|
||||
<edit-button> f track-add*
|
||||
swap 1 track-add
|
||||
<edit-button> f track-add
|
||||
drop ;
|
||||
|
||||
: update-slot ( editable-slot -- )
|
||||
|
|
@ -109,7 +109,7 @@ TUPLE: editable-slot < track printer ref ;
|
|||
[ clear-track ]
|
||||
[
|
||||
dup ref>> <slot-editor>
|
||||
[ 1 track-add* drop ]
|
||||
[ 1 track-add drop ]
|
||||
[ [ scroll>gadget ] [ request-focus ] bi* ] 2bi
|
||||
] bi ;
|
||||
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ IN: ui.gadgets.status-bar
|
|||
|
||||
: open-status-window ( gadget title -- )
|
||||
f <model> [ <world> ] keep
|
||||
<status-bar> f track-add*
|
||||
<status-bar> f track-add
|
||||
open-world-window ;
|
||||
|
||||
: show-summary ( object gadget -- )
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ TUPLE: tiling < track gadgets tiles first focused ;
|
|||
|
||||
: tiling-map-gadgets ( tiling -- tiling )
|
||||
dup clear-track
|
||||
dup tiling-gadgets-to-map [ 1 track-add* ] each ;
|
||||
dup tiling-gadgets-to-map [ 1 track-add ] each ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ ARTICLE: "ui-track-layout" "Track layouts"
|
|||
"Creating empty tracks:"
|
||||
{ $subsection <track> }
|
||||
"Adding children:"
|
||||
{ $subsection track-add* } ;
|
||||
{ $subsection track-add } ;
|
||||
|
||||
HELP: track
|
||||
{ $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." } ;
|
||||
|
|
@ -17,7 +17,7 @@ HELP: <track>
|
|||
{ $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } }
|
||||
{ $description "Creates a new track which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ;
|
||||
|
||||
HELP: track-add*
|
||||
HELP: track-add
|
||||
{ $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }
|
||||
{ $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,13 +4,13 @@ IN: ui.gadgets.tracks.tests
|
|||
|
||||
[ { 100 100 } ] [
|
||||
{ 0 1 } <track>
|
||||
<gadget> { 100 100 } >>dim 1 track-add*
|
||||
<gadget> { 100 100 } >>dim 1 track-add
|
||||
pref-dim
|
||||
] unit-test
|
||||
|
||||
[ { 100 110 } ] [
|
||||
{ 0 1 } <track>
|
||||
<gadget> { 10 10 } >>dim f track-add*
|
||||
<gadget> { 100 100 } >>dim 1 track-add*
|
||||
<gadget> { 10 10 } >>dim f track-add
|
||||
<gadget> { 100 100 } >>dim 1 track-add
|
||||
pref-dim
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ M: track pref-dim* ( gadget -- dim )
|
|||
tri
|
||||
set-axis ;
|
||||
|
||||
: track-add* ( track gadget constraint -- track )
|
||||
: track-add ( track gadget constraint -- track )
|
||||
pick sizes>> push add-gadget ;
|
||||
|
||||
: track-remove ( track gadget -- track )
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@ M: world request-focus-on ( child gadget -- )
|
|||
{ 0 0 } >>window-loc
|
||||
swap >>status
|
||||
swap >>title
|
||||
swap 1 track-add*
|
||||
swap 1 track-add
|
||||
dup request-focus ;
|
||||
|
||||
M: world layout*
|
||||
|
|
|
|||
|
|
@ -22,9 +22,9 @@ TUPLE: browser-gadget < track pane history ;
|
|||
: <browser-gadget> ( -- gadget )
|
||||
{ 0 1 } browser-gadget new-track
|
||||
dup init-history
|
||||
dup <toolbar> f track-add*
|
||||
dup <toolbar> f track-add
|
||||
dup <help-pane> >>pane
|
||||
dup pane>> <scroller> 1 track-add* ;
|
||||
dup pane>> <scroller> 1 track-add ;
|
||||
|
||||
M: browser-gadget call-tool* show-help ;
|
||||
|
||||
|
|
|
|||
|
|
@ -25,9 +25,9 @@ TUPLE: debugger < track restarts ;
|
|||
|
||||
: <debugger> ( error restarts restart-hook -- gadget )
|
||||
{ 0 1 } debugger new-track
|
||||
dup <toolbar> f track-add*
|
||||
dup <toolbar> f track-add
|
||||
-rot <restart-list> >>restarts
|
||||
dup restarts>> rot <debugger-display> <scroller> 1 track-add* ;
|
||||
dup restarts>> rot <debugger-display> <scroller> 1 track-add ;
|
||||
|
||||
M: debugger focusable-child* debugger-restarts ;
|
||||
|
||||
|
|
|
|||
|
|
@ -17,9 +17,9 @@ TUPLE: inspector-gadget < track object pane ;
|
|||
|
||||
: <inspector-gadget> ( -- gadget )
|
||||
{ 0 1 } inspector-gadget new-track
|
||||
dup <toolbar> f track-add*
|
||||
dup <toolbar> f track-add
|
||||
<pane> >>pane
|
||||
dup pane>> <scroller> 1 track-add* ;
|
||||
dup pane>> <scroller> 1 track-add ;
|
||||
|
||||
: inspect-object ( obj mirror keys inspector -- )
|
||||
2nip swap >>object refresh ;
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ TUPLE: listener-gadget < track input output stack ;
|
|||
|
||||
: listener-output, ( listener -- listener )
|
||||
<scrolling-pane> >>output
|
||||
dup output>> <scroller> "Output" <labelled-gadget> 1 track-add* ;
|
||||
dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ;
|
||||
|
||||
: listener-streams ( listener -- input output )
|
||||
[ input>> ] [ output>> <pane-stream> ] bi ;
|
||||
|
|
@ -27,7 +27,7 @@ TUPLE: listener-gadget < track input output stack ;
|
|||
dup input>>
|
||||
{ 0 100 } <limited-scroller>
|
||||
"Input" <labelled-gadget>
|
||||
f track-add* ;
|
||||
f track-add ;
|
||||
|
||||
: welcome. ( -- )
|
||||
"If this is your first time with Factor, please read the " print
|
||||
|
|
@ -125,10 +125,10 @@ TUPLE: stack-display < track ;
|
|||
: <stack-display> ( workspace -- gadget )
|
||||
listener>>
|
||||
{ 0 1 } stack-display new-track
|
||||
over <toolbar> f track-add*
|
||||
over <toolbar> f track-add
|
||||
swap
|
||||
stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
|
||||
1 track-add* ;
|
||||
1 track-add ;
|
||||
|
||||
M: stack-display tool-scroller
|
||||
find-workspace workspace-listener tool-scroller ;
|
||||
|
|
|
|||
|
|
@ -9,9 +9,9 @@ TUPLE: profiler-gadget < track pane ;
|
|||
|
||||
: <profiler-gadget> ( -- gadget )
|
||||
{ 0 1 } profiler-gadget new-track
|
||||
dup <toolbar> f track-add*
|
||||
dup <toolbar> f track-add
|
||||
<pane> >>pane
|
||||
dup pane>> <scroller> 1 track-add* ;
|
||||
dup pane>> <scroller> 1 track-add ;
|
||||
|
||||
: with-profiler-pane ( gadget quot -- )
|
||||
>r profiler-gadget-pane r> with-pane ;
|
||||
|
|
|
|||
|
|
@ -62,9 +62,9 @@ search-field H{
|
|||
: <live-search> ( string seq limited? presenter -- gadget )
|
||||
{ 0 1 } live-search new-track
|
||||
<search-field> >>field
|
||||
dup field>> f track-add*
|
||||
dup field>> f track-add
|
||||
-roll <search-list> >>list
|
||||
dup list>> <scroller> 1 track-add*
|
||||
dup list>> <scroller> 1 track-add
|
||||
|
||||
swap
|
||||
over field>> set-editor-string
|
||||
|
|
|
|||
|
|
@ -38,10 +38,10 @@ IN: ui.tools
|
|||
<listener-gadget> >>listener
|
||||
dup <workspace-book> >>book
|
||||
|
||||
dup <workspace-tabs> f track-add*
|
||||
dup book>> 1/5 track-add*
|
||||
dup listener>> 4/5 track-add*
|
||||
dup <toolbar> f track-add* ;
|
||||
dup <workspace-tabs> f track-add
|
||||
dup book>> 1/5 track-add
|
||||
dup listener>> 4/5 track-add
|
||||
dup <toolbar> f track-add ;
|
||||
|
||||
: resize-workspace ( workspace -- )
|
||||
dup track-sizes over control-value zero? [
|
||||
|
|
|
|||
|
|
@ -30,13 +30,13 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
|
|||
|
||||
dup model>>
|
||||
{ 1 0 } <track>
|
||||
over <datastack-display> 1/2 track-add*
|
||||
swap <retainstack-display> 1/2 track-add*
|
||||
1/3 track-add*
|
||||
over <datastack-display> 1/2 track-add
|
||||
swap <retainstack-display> 1/2 track-add
|
||||
1/3 track-add
|
||||
|
||||
dup model>> <callstack-display> 2/3 track-add*
|
||||
dup model>> <callstack-display> 2/3 track-add
|
||||
|
||||
dup <toolbar> f track-add* ;
|
||||
dup <toolbar> f track-add ;
|
||||
|
||||
: <namestack-display> ( model -- gadget )
|
||||
[ [ continuation-name namestack. ] when* ]
|
||||
|
|
|
|||
|
|
@ -62,9 +62,9 @@ M: walker-gadget focusable-child*
|
|||
swap >>status
|
||||
dup continuation>> <traceback-gadget> >>traceback
|
||||
|
||||
dup <toolbar> f track-add*
|
||||
dup status>> self <thread-status> f track-add*
|
||||
dup traceback>> 1 track-add* ;
|
||||
dup <toolbar> f track-add
|
||||
dup status>> self <thread-status> f track-add
|
||||
dup traceback>> 1 track-add ;
|
||||
|
||||
: walker-help ( -- ) "ui-walker" help-window ;
|
||||
|
||||
|
|
|
|||
|
|
@ -62,7 +62,7 @@ M: gadget tool-scroller drop f ;
|
|||
: show-popup ( gadget workspace -- )
|
||||
dup hide-popup
|
||||
over >>popup
|
||||
over f track-add* drop
|
||||
over f track-add drop
|
||||
request-focus ;
|
||||
|
||||
: show-titled-popup ( workspace gadget title -- )
|
||||
|
|
|
|||
|
|
@ -1,17 +0,0 @@
|
|||
|
||||
|
||||
[ ] [ [ 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
|
||||
|
|
@ -1,79 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry accessors quotations kernel sequences namespaces assocs
|
||||
words generic generic.standard generic.standard.engines arrays
|
||||
kernel.private combinators vectors stack-checker
|
||||
stack-checker.state stack-checker.visitor stack-checker.errors
|
||||
stack-checker.backend compiler.tree.builder ;
|
||||
IN: compiler.frontend
|
||||
|
||||
: with-dataflow ( quot -- dataflow )
|
||||
[ tree-builder new dataflow-visitor set ] prepose
|
||||
with-infer first>> ; inline
|
||||
|
||||
GENERIC# dataflow-with 1 ( quot stack -- dataflow )
|
||||
|
||||
M: callable dataflow-with
|
||||
#! Not safe to call from inference transforms.
|
||||
[
|
||||
>vector meta-d set
|
||||
f infer-quot
|
||||
] with-dataflow nip ;
|
||||
|
||||
: dataflow ( quot -- dataflow ) f dataflow-with ;
|
||||
|
||||
: (make-specializer) ( class picker -- quot )
|
||||
swap "predicate" word-prop append ;
|
||||
|
||||
: make-specializer ( classes -- quot )
|
||||
dup length <reversed>
|
||||
[ (picker) 2array ] 2map
|
||||
[ drop object eq? not ] assoc-filter
|
||||
dup empty? [ drop [ t ] ] [
|
||||
[ (make-specializer) ] { } assoc>map
|
||||
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
|
||||
] if ;
|
||||
|
||||
: specializer-cases ( quot word -- default alist )
|
||||
dup [ array? ] all? [ 1array ] unless [
|
||||
[ make-specializer ] keep
|
||||
'[ , declare ] pick append
|
||||
] { } map>assoc ;
|
||||
|
||||
: method-declaration ( method -- quot )
|
||||
dup "method-generic" word-prop dispatch# object <array>
|
||||
swap "method-class" word-prop prefix ;
|
||||
|
||||
: specialize-method ( quot method -- quot' )
|
||||
method-declaration '[ , declare ] prepend ;
|
||||
|
||||
: specialize-quot ( quot specializer -- quot' )
|
||||
specializer-cases alist>quot ;
|
||||
|
||||
: standard-method? ( method -- ? )
|
||||
dup method-body? [
|
||||
"method-generic" word-prop standard-generic?
|
||||
] [ drop f ] if ;
|
||||
|
||||
: specialized-def ( word -- quot )
|
||||
dup def>> swap {
|
||||
{ [ dup standard-method? ] [ specialize-method ] }
|
||||
{
|
||||
[ dup "specializer" word-prop ]
|
||||
[ "specializer" word-prop specialize-quot ]
|
||||
}
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
: word-dataflow ( word -- effect dataflow )
|
||||
[
|
||||
[
|
||||
dup +cannot-infer+ word-prop [ cannot-infer-effect ] when
|
||||
dup "no-compile" word-prop [ cannot-infer-effect ] when
|
||||
dup specialized-def over dup 2array 1array infer-quot
|
||||
finish-word
|
||||
] maybe-cannot-infer
|
||||
] with-dataflow ;
|
||||
|
||||
: specialized-length ( specializer -- n )
|
||||
dup [ array? ] all? [ first ] when length ;
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
USING: help.markup help.syntax sequences quotations words
|
||||
compiler.tree stack-checker.errors ;
|
||||
IN: compiler.frontend
|
||||
IN: compiler.tree.builder
|
||||
|
||||
ARTICLE: "specializers" "Word specializers"
|
||||
"The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class."
|
||||
|
|
@ -22,15 +22,15 @@ $nl
|
|||
"The specialized version of a word which will be compiled by the compiler can be inspected:"
|
||||
{ $subsection specialized-def } ;
|
||||
|
||||
HELP: dataflow
|
||||
HELP: build-tree
|
||||
{ $values { "quot" quotation } { "dataflow" node } }
|
||||
{ $description "Attempts to construct a dataflow graph showing stack flow in the quotation." }
|
||||
{ $description "Attempts to construct tree SSA IR from a quotation." }
|
||||
{ $notes "This is the first stage of the compiler." }
|
||||
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
|
||||
|
||||
HELP: dataflow-with
|
||||
HELP: build-tree-with
|
||||
{ $values { "quot" quotation } { "stack" sequence } { "dataflow" node } }
|
||||
{ $description "Attempts to construct a dataflow graph showing stack flow in the quotation, starting with an initial data stack of values." }
|
||||
{ $description "Attempts to construct tree SSA IR from a quotaiton, starting with an initial data stack of values." }
|
||||
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
|
||||
|
||||
HELP: specialized-def
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
IN: compiler.tree.builder.tests
|
||||
USING: compiler.tree.builder tools.test ;
|
||||
|
||||
\ build-tree must-infer
|
||||
\ build-tree-with must-infer
|
||||
\ build-tree-from-word must-infer
|
||||
|
|
@ -1,32 +1,79 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors namespaces kernel sequences compiler.tree
|
||||
stack-checker.visitor ;
|
||||
USING: fry accessors quotations kernel sequences namespaces assocs
|
||||
words generic generic.standard generic.standard.engines arrays
|
||||
kernel.private combinators vectors stack-checker
|
||||
stack-checker.state stack-checker.visitor stack-checker.errors
|
||||
stack-checker.backend compiler.tree ;
|
||||
IN: compiler.tree.builder
|
||||
|
||||
TUPLE: tree-builder first last ;
|
||||
: with-tree-builder ( quot -- dataflow )
|
||||
[ node-list new stack-visitor set ] prepose
|
||||
with-infer first>> ; inline
|
||||
|
||||
: node, ( node -- )
|
||||
dataflow-visitor get swap
|
||||
over last>>
|
||||
[ [ [ last>> ] dip >>successor drop ] [ >>last drop ] 2bi ]
|
||||
[ [ >>first ] [ >>last ] bi drop ]
|
||||
if ;
|
||||
GENERIC# build-tree-with 1 ( quot stack -- dataflow )
|
||||
|
||||
M: tree-builder child-visitor tree-builder new ;
|
||||
M: tree-builder #introduce, #introduce node, ;
|
||||
M: tree-builder #call, #call node, ;
|
||||
M: tree-builder #call-recursive, #call-recursive node, ;
|
||||
M: tree-builder #push, #push node, ;
|
||||
M: tree-builder #shuffle, #shuffle node, ;
|
||||
M: tree-builder #drop, #drop node, ;
|
||||
M: tree-builder #>r, #>r node, ;
|
||||
M: tree-builder #r>, #r> node, ;
|
||||
M: tree-builder #return, #return node, ;
|
||||
M: tree-builder #terminate, #terminate node, ;
|
||||
M: tree-builder #if, [ first>> ] bi@ #if node, ;
|
||||
M: tree-builder #dispatch, [ first>> ] map #dispatch node, ;
|
||||
M: tree-builder #phi, #phi node, ;
|
||||
M: tree-builder #declare, #declare node, ;
|
||||
M: tree-builder #recursive, first>> #recursive node, ;
|
||||
M: tree-builder #copy, #copy node, ;
|
||||
M: callable build-tree-with
|
||||
#! Not safe to call from inference transforms.
|
||||
[
|
||||
>vector meta-d set
|
||||
f infer-quot
|
||||
] with-tree-builder nip ;
|
||||
|
||||
: build-tree ( quot -- dataflow ) f build-tree-with ;
|
||||
|
||||
: (make-specializer) ( class picker -- quot )
|
||||
swap "predicate" word-prop append ;
|
||||
|
||||
: make-specializer ( classes -- quot )
|
||||
dup length <reversed>
|
||||
[ (picker) 2array ] 2map
|
||||
[ drop object eq? not ] assoc-filter
|
||||
dup empty? [ drop [ t ] ] [
|
||||
[ (make-specializer) ] { } assoc>map
|
||||
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
|
||||
] if ;
|
||||
|
||||
: specializer-cases ( quot word -- default alist )
|
||||
dup [ array? ] all? [ 1array ] unless [
|
||||
[ make-specializer ] keep
|
||||
'[ , declare ] pick append
|
||||
] { } map>assoc ;
|
||||
|
||||
: method-declaration ( method -- quot )
|
||||
dup "method-generic" word-prop dispatch# object <array>
|
||||
swap "method-class" word-prop prefix ;
|
||||
|
||||
: specialize-method ( quot method -- quot' )
|
||||
method-declaration '[ , declare ] prepend ;
|
||||
|
||||
: specialize-quot ( quot specializer -- quot' )
|
||||
specializer-cases alist>quot ;
|
||||
|
||||
: standard-method? ( method -- ? )
|
||||
dup method-body? [
|
||||
"method-generic" word-prop standard-generic?
|
||||
] [ drop f ] if ;
|
||||
|
||||
: specialized-def ( word -- quot )
|
||||
dup def>> swap {
|
||||
{ [ dup standard-method? ] [ specialize-method ] }
|
||||
{
|
||||
[ dup "specializer" word-prop ]
|
||||
[ "specializer" word-prop specialize-quot ]
|
||||
}
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
: build-tree-from-word ( word -- effect dataflow )
|
||||
[
|
||||
[
|
||||
dup +cannot-infer+ word-prop [ cannot-infer-effect ] when
|
||||
dup "no-compile" word-prop [ cannot-infer-effect ] when
|
||||
dup specialized-def over dup 2array 1array infer-quot
|
||||
finish-word
|
||||
] maybe-cannot-infer
|
||||
] with-tree-builder ;
|
||||
|
||||
: specialized-length ( specializer -- n )
|
||||
dup [ array? ] all? [ first ] when length ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,17 @@
|
|||
IN: compiler.tree.combinators.tests
|
||||
USING: compiler.tree.combinators compiler.tree.builder tools.test
|
||||
kernel ;
|
||||
|
||||
[ ] [ [ 1 ] build-tree [ ] transform-nodes drop ] unit-test
|
||||
[ ] [ [ 1 2 3 ] build-tree [ ] 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
|
||||
|
|
@ -5,18 +5,6 @@ sequences words vectors math.intervals effects classes
|
|||
accessors combinators compiler.tree ;
|
||||
IN: compiler.tree.combinators
|
||||
|
||||
: node-exists? ( node quot -- ? )
|
||||
over [
|
||||
2dup 2slip rot [
|
||||
2drop t
|
||||
] [
|
||||
[ [ children>> ] [ successor>> ] bi suffix ] dip
|
||||
'[ , node-exists? ] contains?
|
||||
] if
|
||||
] [
|
||||
2drop f
|
||||
] if ; inline
|
||||
|
||||
SYMBOL: node-stack
|
||||
|
||||
: >node ( node -- ) node-stack get push ;
|
||||
|
|
@ -34,8 +22,8 @@ SYMBOL: node-stack
|
|||
|
||||
: (each-node) ( quot -- next )
|
||||
node@ [ swap call ] 2keep
|
||||
node-children [
|
||||
[
|
||||
children>> [
|
||||
first>> [
|
||||
[ (each-node) ] keep swap
|
||||
] iterate-nodes
|
||||
] each drop
|
||||
|
|
@ -52,15 +40,7 @@ SYMBOL: node-stack
|
|||
] with-node-iterator ; inline
|
||||
|
||||
: map-children ( node quot -- )
|
||||
over [
|
||||
over children>> [
|
||||
'[ , map ] change-children drop
|
||||
] [
|
||||
2drop
|
||||
] if
|
||||
] [
|
||||
2drop
|
||||
] if ; inline
|
||||
[ children>> ] dip '[ , change-first drop ] each ; inline
|
||||
|
||||
: (transform-nodes) ( prev node quot -- )
|
||||
dup >r call dup [
|
||||
|
|
|
|||
|
|
@ -0,0 +1,50 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math math.order math.intervals assocs combinators ;
|
||||
IN: compiler.tree.comparisons
|
||||
|
||||
! Some utilities for working with comparison operations.
|
||||
|
||||
: comparison-ops { < > <= >= } ;
|
||||
|
||||
: generic-comparison-ops { before? after? before=? after=? } ;
|
||||
|
||||
: assumption ( i1 i2 op -- i3 )
|
||||
{
|
||||
{ \ < [ assume< ] }
|
||||
{ \ > [ assume> ] }
|
||||
{ \ <= [ assume<= ] }
|
||||
{ \ >= [ assume>= ] }
|
||||
} case ;
|
||||
|
||||
: interval-comparison ( i1 i2 op -- result )
|
||||
{
|
||||
{ \ < [ interval< ] }
|
||||
{ \ > [ interval> ] }
|
||||
{ \ <= [ interval<= ] }
|
||||
{ \ >= [ interval>= ] }
|
||||
} case ;
|
||||
|
||||
: swap-comparison ( op -- op' )
|
||||
{
|
||||
{ < > }
|
||||
{ > < }
|
||||
{ <= >= }
|
||||
{ >= <= }
|
||||
} at ;
|
||||
|
||||
: negate-comparison ( op -- op' )
|
||||
{
|
||||
{ < >= }
|
||||
{ > <= }
|
||||
{ <= > }
|
||||
{ >= < }
|
||||
} at ;
|
||||
|
||||
: specific-comparison ( op -- op' )
|
||||
{
|
||||
{ before? < }
|
||||
{ after? > }
|
||||
{ before=? <= }
|
||||
{ after=? >= }
|
||||
} at ;
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces disjoint-sets sequences assocs
|
||||
kernel accessors fry
|
||||
compiler.tree compiler.tree.def-use compiler.tree.combinators ;
|
||||
IN: compiler.tree.copy-equiv
|
||||
|
||||
! Disjoint set of copy equivalence
|
||||
SYMBOL: copies
|
||||
|
||||
: is-copy-of ( val copy -- ) copies get equate ;
|
||||
|
||||
: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
|
||||
|
||||
: resolve-copy ( copy -- val ) copies get representative ;
|
||||
|
||||
: introduce-value ( val -- ) copies get add-atom ;
|
||||
|
||||
GENERIC: compute-copy-equiv* ( node -- )
|
||||
|
||||
M: #shuffle compute-copy-equiv*
|
||||
[ out-d>> dup ] [ mapping>> ] bi
|
||||
'[ , at ] map swap are-copies-of ;
|
||||
|
||||
M: #>r compute-copy-equiv*
|
||||
[ in-d>> ] [ out-r>> ] bi are-copies-of ;
|
||||
|
||||
M: #r> compute-copy-equiv*
|
||||
[ in-r>> ] [ out-d>> ] bi are-copies-of ;
|
||||
|
||||
M: #copy compute-copy-equiv*
|
||||
[ in-d>> ] [ out-d>> ] bi are-copies-of ;
|
||||
|
||||
M: node compute-copy-equiv* drop ;
|
||||
|
||||
: compute-copy-equiv ( node -- node )
|
||||
<disjoint-set> copies set
|
||||
dup [
|
||||
[ node-defs-values [ introduce-value ] each ]
|
||||
[ compute-copy-equiv* ]
|
||||
bi
|
||||
] each-node ;
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
USING: namespaces assocs sequences compiler.frontend
|
||||
USING: namespaces assocs sequences compiler.tree.builder
|
||||
compiler.tree.dead-code compiler.tree.def-use compiler.tree
|
||||
compiler.tree.combinators tools.test kernel math
|
||||
stack-checker.state accessors ;
|
||||
|
|
@ -7,7 +7,7 @@ IN: compiler.tree.dead-code.tests
|
|||
\ remove-dead-code must-infer
|
||||
|
||||
: count-live-values ( quot -- n )
|
||||
dataflow
|
||||
build-tree
|
||||
compute-def-use
|
||||
remove-dead-code
|
||||
compute-def-use
|
||||
|
|
|
|||
|
|
@ -1,106 +1,44 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry accessors namespaces assocs dequeues search-dequeues
|
||||
kernel sequences words sets stack-checker.inlining compiler.tree
|
||||
compiler.tree.combinators compiler.tree.def-use ;
|
||||
kernel sequences words sets stack-checker.inlining
|
||||
compiler.tree
|
||||
compiler.tree.dfa
|
||||
compiler.tree.dfa.backward
|
||||
compiler.tree.combinators ;
|
||||
IN: compiler.tree.dead-code
|
||||
|
||||
! Dead code elimination: remove #push and flushable #call whose
|
||||
! outputs are unused.
|
||||
|
||||
SYMBOL: live-values
|
||||
SYMBOL: work-list
|
||||
|
||||
: live-value? ( value -- ? )
|
||||
live-values get at ;
|
||||
|
||||
: look-at-value ( values -- )
|
||||
work-list get push-front ;
|
||||
|
||||
: look-at-values ( values -- )
|
||||
work-list get '[ , push-front ] each ;
|
||||
|
||||
! outputs are unused using backward DFA.
|
||||
GENERIC: mark-live-values ( node -- )
|
||||
|
||||
: look-at-inputs ( node -- ) in-d>> look-at-values ;
|
||||
|
||||
: look-at-outputs ( node -- ) out-d>> look-at-values ;
|
||||
|
||||
M: #introduce mark-live-values look-at-outputs ;
|
||||
|
||||
M: #if mark-live-values look-at-inputs ;
|
||||
|
||||
M: #dispatch mark-live-values look-at-inputs ;
|
||||
|
||||
M: #call mark-live-values
|
||||
dup word>> "flushable" word-prop [ drop ] [
|
||||
[ look-at-inputs ]
|
||||
[ look-at-outputs ]
|
||||
bi
|
||||
] if ;
|
||||
dup word>> "flushable" word-prop
|
||||
[ drop ] [ [ look-at-inputs ] [ look-at-outputs ] bi ] if ;
|
||||
|
||||
M: #return mark-live-values
|
||||
#! Values returned by local #recursive functions can be
|
||||
#! killed if they're unused.
|
||||
dup label>>
|
||||
[ drop ] [ look-at-inputs ] if ;
|
||||
dup label>> [ drop ] [ look-at-inputs ] if ;
|
||||
|
||||
M: node mark-live-values drop ;
|
||||
|
||||
GENERIC: propagate* ( value node -- )
|
||||
SYMBOL: live-values
|
||||
|
||||
M: #copy propagate*
|
||||
#! If the output of a copy is live, then the corresponding
|
||||
#! input is live also.
|
||||
[ out-d>> index ] keep in-d>> nth look-at-value ;
|
||||
|
||||
M: #call propagate*
|
||||
#! If any of the outputs of a call are live, then all
|
||||
#! inputs and outputs must be live.
|
||||
nip [ look-at-inputs ] [ look-at-outputs ] bi ;
|
||||
|
||||
M: #call-recursive propagate*
|
||||
#! If the output of a copy is live, then the corresponding
|
||||
#! inputs to #return nodes are live also.
|
||||
[ out-d>> <reversed> index ] keep label>> returns>>
|
||||
[ <reversed> nth look-at-value ] with each ;
|
||||
|
||||
M: #>r propagate* nip in-d>> first look-at-value ;
|
||||
|
||||
M: #r> propagate* nip in-r>> first look-at-value ;
|
||||
|
||||
M: #shuffle propagate* mapping>> at look-at-value ;
|
||||
|
||||
: look-at-corresponding ( value inputs outputs -- )
|
||||
[ index ] dip over [ nth look-at-values ] [ 2drop ] if ;
|
||||
|
||||
M: #phi propagate*
|
||||
#! If any of the outputs of a #phi are live, then the
|
||||
#! corresponding inputs are live too.
|
||||
[ [ out-d>> ] [ phi-in-d>> ] bi look-at-corresponding ]
|
||||
[ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ]
|
||||
2bi ;
|
||||
|
||||
M: node propagate* 2drop ;
|
||||
|
||||
: propogate-liveness ( value -- )
|
||||
live-values get 2dup key? [
|
||||
2drop
|
||||
] [
|
||||
dupd conjoin
|
||||
dup defined-by propagate*
|
||||
] if ;
|
||||
: live-value? ( value -- ? ) live-values get at ;
|
||||
|
||||
: compute-live-values ( node -- )
|
||||
#! We add f initially because #phi nodes can have f in their
|
||||
#! inputs.
|
||||
<hashed-dlist> work-list set
|
||||
H{ { f f } } clone live-values set
|
||||
[ mark-live-values ] each-node
|
||||
work-list get [ propogate-liveness ] slurp-dequeue ;
|
||||
[ mark-live-values ] backward-dfa live-values set ;
|
||||
|
||||
GENERIC: remove-dead-values* ( node -- )
|
||||
|
||||
M: #introduce remove-dead-values*
|
||||
[ [ live-value? ] filter ] change-values drop ;
|
||||
|
||||
M: #>r remove-dead-values*
|
||||
dup out-r>> first live-value? [ { } >>out-r ] unless
|
||||
dup in-d>> first live-value? [ { } >>in-d ] unless
|
||||
|
|
@ -118,13 +56,6 @@ M: #push remove-dead-values*
|
|||
: filter-corresponding-values ( in out -- in' out' )
|
||||
zip live-values get '[ drop _ , key? ] assoc-filter unzip ;
|
||||
|
||||
: remove-dead-copies ( node -- )
|
||||
dup
|
||||
[ in-d>> ] [ out-d>> ] bi
|
||||
filter-corresponding-values
|
||||
[ >>in-d ] [ >>out-d ] bi*
|
||||
drop ;
|
||||
|
||||
: filter-live ( values -- values' )
|
||||
[ live-value? ] filter ;
|
||||
|
||||
|
|
@ -133,9 +64,16 @@ M: #shuffle remove-dead-values*
|
|||
[ filter-live ] change-out-d
|
||||
drop ;
|
||||
|
||||
M: #declare remove-dead-values* remove-dead-copies ;
|
||||
M: #declare remove-dead-values*
|
||||
[ [ drop live-value? ] assoc-filter ] change-declaration
|
||||
drop ;
|
||||
|
||||
M: #copy remove-dead-values* remove-dead-copies ;
|
||||
M: #copy remove-dead-values*
|
||||
dup
|
||||
[ in-d>> ] [ out-d>> ] bi
|
||||
filter-corresponding-values
|
||||
[ >>in-d ] [ >>out-d ] bi*
|
||||
drop ;
|
||||
|
||||
: remove-dead-phi-d ( #phi -- #phi )
|
||||
dup
|
||||
|
|
@ -156,46 +94,54 @@ M: #phi remove-dead-values*
|
|||
|
||||
M: node remove-dead-values* drop ;
|
||||
|
||||
M: f remove-dead-values* drop ;
|
||||
|
||||
GENERIC: remove-dead-nodes* ( node -- newnode/t )
|
||||
|
||||
: prune-if-empty ( node seq -- successor/t )
|
||||
empty? [ successor>> ] [ drop t ] if ; inline
|
||||
|
||||
M: #introduce remove-dead-nodes* dup values>> prune-if-empty ;
|
||||
|
||||
: live-call? ( #call -- ? )
|
||||
out-d>> [ live-value? ] contains? ;
|
||||
|
||||
M: #declare remove-dead-nodes* dup declaration>> prune-if-empty ;
|
||||
|
||||
M: #call remove-dead-nodes*
|
||||
dup live-call? [ drop t ] [
|
||||
[ in-d>> #drop ] [ successor>> ] bi >>successor
|
||||
] if ;
|
||||
|
||||
: prune-if ( node quot -- successor/t )
|
||||
over >r call [ r> successor>> ] [ r> drop t ] if ;
|
||||
inline
|
||||
M: #shuffle remove-dead-nodes* dup in-d>> prune-if-empty ;
|
||||
|
||||
M: #shuffle remove-dead-nodes*
|
||||
[ in-d>> empty? ] prune-if ;
|
||||
M: #push remove-dead-nodes* dup out-d>> prune-if-empty ;
|
||||
|
||||
M: #push remove-dead-nodes*
|
||||
[ out-d>> empty? ] prune-if ;
|
||||
M: #>r remove-dead-nodes* dup in-d>> prune-if-empty ;
|
||||
|
||||
M: #>r remove-dead-nodes*
|
||||
[ in-d>> empty? ] prune-if ;
|
||||
M: #r> remove-dead-nodes* dup in-r>> prune-if-empty ;
|
||||
|
||||
M: #r> remove-dead-nodes*
|
||||
[ in-r>> empty? ] prune-if ;
|
||||
M: #copy remove-dead-nodes* dup in-d>> prune-if-empty ;
|
||||
|
||||
: (remove-dead-code) ( node -- newnode )
|
||||
[
|
||||
dup remove-dead-values*
|
||||
dup remove-dead-nodes* dup t eq?
|
||||
[ drop ] [ nip (remove-dead-code) ] if
|
||||
] transform-nodes ;
|
||||
|
||||
M: #if remove-dead-nodes*
|
||||
[ (remove-dead-code) ] map-children t ;
|
||||
|
||||
M: #dispatch remove-dead-nodes*
|
||||
[ (remove-dead-code) ] map-children t ;
|
||||
|
||||
M: #recursive remove-dead-nodes*
|
||||
[ (remove-dead-code) ] change-child drop t ;
|
||||
|
||||
M: node remove-dead-nodes* drop t ;
|
||||
|
||||
: (remove-dead-code) ( node -- newnode )
|
||||
dup [
|
||||
dup remove-dead-values*
|
||||
dup remove-dead-nodes* dup t eq? [
|
||||
drop dup [ (remove-dead-code) ] map-children
|
||||
] [
|
||||
nip (remove-dead-code)
|
||||
] if
|
||||
] when ;
|
||||
M: f remove-dead-nodes* drop t ;
|
||||
|
||||
: remove-dead-code ( node -- newnode )
|
||||
[
|
||||
[ compute-live-values ]
|
||||
[ [ (remove-dead-code) ] transform-nodes ] bi
|
||||
] with-scope ;
|
||||
[ [ compute-live-values ] [ (remove-dead-code) ] bi ] with-scope ;
|
||||
|
|
|
|||
|
|
@ -1,13 +1,13 @@
|
|||
USING: accessors namespaces assocs kernel sequences math
|
||||
tools.test words sets combinators.short-circuit
|
||||
stack-checker.state compiler.tree compiler.frontend
|
||||
stack-checker.state compiler.tree compiler.tree.builder
|
||||
compiler.tree.def-use arrays kernel.private ;
|
||||
IN: compiler.tree.def-use.tests
|
||||
|
||||
\ compute-def-use must-infer
|
||||
|
||||
[ t ] [
|
||||
[ 1 2 3 ] dataflow compute-def-use drop
|
||||
[ 1 2 3 ] build-tree compute-def-use drop
|
||||
def-use get {
|
||||
[ assoc-size 3 = ]
|
||||
[ values [ uses>> [ #return? ] all? ] all? ]
|
||||
|
|
@ -29,5 +29,5 @@ IN: compiler.tree.def-use.tests
|
|||
[ [ 1 ] [ call 2 ] curry call + ]
|
||||
[ [ 1 ] [ 2 ] compose swap [ 1 ] [ 2 ] if + * ]
|
||||
} [
|
||||
[ ] swap [ dataflow compute-def-use drop ] curry unit-test
|
||||
[ ] swap [ build-tree compute-def-use drop ] curry unit-test
|
||||
] each
|
||||
|
|
|
|||
|
|
@ -28,6 +28,8 @@ TUPLE: definition value node uses ;
|
|||
|
||||
GENERIC: node-uses-values ( node -- values )
|
||||
|
||||
M: #declare node-uses-values declaration>> keys ;
|
||||
|
||||
M: #phi node-uses-values
|
||||
[ phi-in-d>> concat ] [ phi-in-r>> concat ] bi
|
||||
append sift prune ;
|
||||
|
|
@ -42,6 +44,8 @@ M: #introduce node-defs-values values>> ;
|
|||
|
||||
M: #>r node-defs-values out-r>> ;
|
||||
|
||||
M: #phi node-defs-values [ out-d>> ] [ out-r>> ] bi append ;
|
||||
|
||||
M: node node-defs-values out-d>> ;
|
||||
|
||||
: node-def-use ( node -- )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,40 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: compiler.tree.dfa.backward
|
||||
USING: accessors sequences assocs kernel compiler.tree
|
||||
compiler.tree.dfa ;
|
||||
|
||||
GENERIC: backward ( value node -- )
|
||||
|
||||
M: #copy backward
|
||||
#! If the output of a copy is live, then the corresponding
|
||||
#! input is live also.
|
||||
[ out-d>> index ] keep in-d>> nth look-at-value ;
|
||||
|
||||
M: #call backward
|
||||
#! If any of the outputs of a call are live, then all
|
||||
#! inputs and outputs must be live.
|
||||
nip [ look-at-inputs ] [ look-at-outputs ] bi ;
|
||||
|
||||
M: #call-recursive backward
|
||||
#! If the output of a copy is live, then the corresponding
|
||||
#! inputs to #return nodes are live also.
|
||||
[ out-d>> <reversed> index ] keep label>> returns>>
|
||||
[ <reversed> nth look-at-value ] with each ;
|
||||
|
||||
M: #>r backward nip in-d>> first look-at-value ;
|
||||
|
||||
M: #r> backward nip in-r>> first look-at-value ;
|
||||
|
||||
M: #shuffle backward mapping>> at look-at-value ;
|
||||
|
||||
M: #phi backward
|
||||
#! If any of the outputs of a #phi are live, then the
|
||||
#! corresponding inputs are live too.
|
||||
[ [ out-d>> ] [ phi-in-d>> ] bi look-at-corresponding ]
|
||||
[ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ]
|
||||
2bi ;
|
||||
|
||||
M: node backward 2drop ;
|
||||
|
||||
: backward-dfa ( node quot -- assoc ) [ backward ] dfa ; inline
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry accessors namespaces assocs dequeues search-dequeues
|
||||
kernel sequences words sets stack-checker.inlining compiler.tree
|
||||
compiler.tree.def-use compiler.tree.combinators ;
|
||||
IN: compiler.tree.dfa
|
||||
|
||||
! Dataflow analysis
|
||||
SYMBOL: work-list
|
||||
|
||||
: look-at-value ( values -- )
|
||||
work-list get push-front ;
|
||||
|
||||
: look-at-values ( values -- )
|
||||
work-list get '[ , push-front ] each ;
|
||||
|
||||
: look-at-inputs ( node -- ) in-d>> look-at-values ;
|
||||
|
||||
: look-at-outputs ( node -- ) out-d>> look-at-values ;
|
||||
|
||||
: look-at-corresponding ( value inputs outputs -- )
|
||||
[ index ] dip over [ nth look-at-values ] [ 2drop ] if ;
|
||||
|
||||
: init-dfa ( -- )
|
||||
#! We add f initially because #phi nodes can have f in their
|
||||
#! inputs.
|
||||
<hashed-dlist> work-list set ;
|
||||
|
||||
: iterate-dfa ( value assoc quot -- )
|
||||
2over key? [
|
||||
3drop
|
||||
] [
|
||||
[ dupd conjoin dup defined-by ] dip call
|
||||
] if ; inline
|
||||
|
||||
: dfa ( node mark-quot iterate-quot -- assoc )
|
||||
init-dfa
|
||||
[ each-node ] dip
|
||||
work-list get H{ { f f } } clone
|
||||
[ rot '[ , , iterate-dfa ] slurp-dequeue ] keep ; inline
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry kernel sequences assocs accessors namespaces
|
||||
math.intervals arrays classes.algebra
|
||||
math.intervals arrays classes.algebra locals
|
||||
compiler.tree
|
||||
compiler.tree.def-use
|
||||
compiler.tree.propagation.info
|
||||
|
|
@ -14,19 +14,36 @@ IN: compiler.tree.propagation.branches
|
|||
GENERIC: child-constraints ( node -- seq )
|
||||
|
||||
M: #if child-constraints
|
||||
in-d>> first
|
||||
[ <true-constraint> ] [ <false-constraint> ] bi
|
||||
2array ;
|
||||
in-d>> first [ =t ] [ =f ] bi 2array ;
|
||||
|
||||
M: #dispatch child-constraints drop f ;
|
||||
M: #dispatch child-constraints
|
||||
children>> length f <repetition> ;
|
||||
|
||||
GENERIC: live-children ( #branch -- children )
|
||||
|
||||
M: #if live-children
|
||||
[ children>> ] [ in-d>> first value-info possible-boolean-values ] bi
|
||||
[ t swap memq? [ first ] [ drop f ] if ]
|
||||
[ f swap memq? [ second ] [ drop f ] if ]
|
||||
2bi 2array ;
|
||||
|
||||
M: #dispatch live-children
|
||||
[ children>> ] [ in-d>> first value-info interval>> ] bi
|
||||
'[ , interval-contains? [ drop f ] unless ] map-index ;
|
||||
|
||||
: infer-children ( node -- assocs )
|
||||
[ children>> ] [ child-constraints ] bi [
|
||||
[ live-children ] [ child-constraints ] bi [
|
||||
[
|
||||
value-infos [ clone ] change
|
||||
constraints [ clone ] change
|
||||
assume
|
||||
(propagate)
|
||||
over [
|
||||
value-infos [ clone ] change
|
||||
constraints [ clone ] change
|
||||
assume
|
||||
first>> (propagate)
|
||||
] [
|
||||
2drop
|
||||
value-infos off
|
||||
constraints off
|
||||
] if
|
||||
] H{ } make-assoc
|
||||
] 2map ;
|
||||
|
||||
|
|
@ -37,13 +54,23 @@ M: #dispatch child-constraints drop f ;
|
|||
[ swap (merge-value-infos) ] dip set-value-infos ;
|
||||
|
||||
: propagate-branch-phi ( results #phi -- )
|
||||
[ nip node-defs-values [ introduce-value ] each ]
|
||||
[ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ]
|
||||
[ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ]
|
||||
2tri ;
|
||||
2bi ;
|
||||
|
||||
:: branch-phi-constraints ( x #phi -- )
|
||||
#phi [ out-d>> ] [ phi-in-d>> ] bi [
|
||||
first2 2dup and [ USE: prettyprint
|
||||
[ [ =t x =t /\ ] [ =t x =f /\ ] bi* \/ swap t--> dup . assume ]
|
||||
[ [ =f x =t /\ ] [ =f x =f /\ ] bi* \/ swap f--> dup . assume ]
|
||||
3bi
|
||||
] [ 3drop ] if
|
||||
] 2each ;
|
||||
|
||||
: merge-children ( results node -- )
|
||||
successor>> propagate-branch-phi ;
|
||||
[ successor>> propagate-branch-phi ]
|
||||
[ [ in-d>> first ] [ successor>> ] bi 2drop ] ! branch-phi-constraints ]
|
||||
bi ;
|
||||
|
||||
M: #branch propagate-around
|
||||
[ infer-children ] [ merge-children ] [ annotate-node ] tri ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,9 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs math math.intervals kernel accessors
|
||||
sequences namespaces disjoint-sets classes classes.algebra
|
||||
combinators words compiler.tree compiler.tree.propagation.info ;
|
||||
combinators words
|
||||
compiler.tree compiler.tree.propagation.info
|
||||
compiler.tree.copy-equiv ;
|
||||
IN: compiler.tree.propagation.constraints
|
||||
|
||||
! A constraint is a statement about a value.
|
||||
|
|
@ -12,25 +14,25 @@ SYMBOL: constraints
|
|||
|
||||
GENERIC: assume ( constraint -- )
|
||||
GENERIC: satisfied? ( constraint -- ? )
|
||||
GENERIC: satisfiable? ( constraint -- ? )
|
||||
|
||||
! Boolean constraints
|
||||
TUPLE: true-constraint value ;
|
||||
|
||||
: <true-constraint> ( value -- constriant )
|
||||
resolve-copy true-constraint boa ;
|
||||
: =t ( value -- constriant ) resolve-copy true-constraint boa ;
|
||||
|
||||
M: true-constraint assume
|
||||
[ constraints get at [ assume ] when* ]
|
||||
[ \ f class-not <class-info> swap value>> refine-value-info ]
|
||||
bi ;
|
||||
|
||||
M: true-constraint satisfied?
|
||||
value>> value-info class>> \ f class-not class<= ;
|
||||
M: true-constraint satisfied? value>> \ f class-not value-is? ;
|
||||
|
||||
M: true-constraint satisfiable? value>> \ f class-not value-is? ;
|
||||
|
||||
TUPLE: false-constraint value ;
|
||||
|
||||
: <false-constraint> ( value -- constriant )
|
||||
resolve-copy false-constraint boa ;
|
||||
: =f ( value -- constriant ) resolve-copy false-constraint boa ;
|
||||
|
||||
M: false-constraint assume
|
||||
[ constraints get at [ assume ] when* ]
|
||||
|
|
@ -38,12 +40,15 @@ M: false-constraint assume
|
|||
bi ;
|
||||
|
||||
M: false-constraint satisfied?
|
||||
value>> value-info class>> \ f class-not class<= ;
|
||||
value>> value-info class>> \ f class<= ;
|
||||
|
||||
M: false-constraint satisfiable?
|
||||
value>> value-info class>> \ f classes-intersect? ;
|
||||
|
||||
! Class constraints
|
||||
TUPLE: class-constraint value class ;
|
||||
|
||||
: <class-constraint> ( value class -- constraint )
|
||||
: is-instance-of ( value class -- constraint )
|
||||
[ resolve-copy ] dip class-constraint boa ;
|
||||
|
||||
M: class-constraint assume
|
||||
|
|
@ -52,7 +57,7 @@ M: class-constraint assume
|
|||
! Interval constraints
|
||||
TUPLE: interval-constraint value interval ;
|
||||
|
||||
: <interval-constraint> ( value interval -- constraint )
|
||||
: is-in-interval ( value interval -- constraint )
|
||||
[ resolve-copy ] dip interval-constraint boa ;
|
||||
|
||||
M: interval-constraint assume
|
||||
|
|
@ -61,7 +66,7 @@ M: interval-constraint assume
|
|||
! Literal constraints
|
||||
TUPLE: literal-constraint value literal ;
|
||||
|
||||
: <literal-constraint> ( value literal -- constraint )
|
||||
: is-equal-to ( value literal -- constraint )
|
||||
[ resolve-copy ] dip literal-constraint boa ;
|
||||
|
||||
M: literal-constraint assume
|
||||
|
|
@ -70,29 +75,48 @@ M: literal-constraint assume
|
|||
! Implication constraints
|
||||
TUPLE: implication p q ;
|
||||
|
||||
C: <implication> implication
|
||||
C: --> implication
|
||||
|
||||
M: implication assume
|
||||
[ q>> ] [ p>> ] bi
|
||||
[ constraints get set-at ]
|
||||
[ satisfied? [ assume ] [ drop ] if ] 2bi ;
|
||||
|
||||
M: implication satisfiable?
|
||||
[ q>> satisfiable? ] [ p>> satisfiable? not ] bi or ;
|
||||
|
||||
! Conjunction constraints
|
||||
TUPLE: conjunction p q ;
|
||||
|
||||
C: <conjunction> conjunction
|
||||
C: /\ conjunction
|
||||
|
||||
M: conjunction assume [ p>> assume ] [ q>> assume ] bi ;
|
||||
|
||||
M: conjunction satisfiable?
|
||||
[ p>> satisfiable? ] [ q>> satisfiable? ] bi and ;
|
||||
|
||||
! Disjunction constraints
|
||||
TUPLE: disjunction p q ;
|
||||
|
||||
C: \/ disjunction
|
||||
|
||||
M: disjunction assume
|
||||
{
|
||||
{ [ dup p>> satisfiable? not ] [ q>> assume ] }
|
||||
{ [ dup q>> satisfiable? not ] [ p>> assume ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
M: disjunction satisfiable?
|
||||
[ p>> satisfiable? ] [ q>> satisfiable? ] bi or ;
|
||||
|
||||
! No-op
|
||||
M: f assume drop ;
|
||||
|
||||
! Utilities
|
||||
: if-true ( constraint boolean-value -- constraint' )
|
||||
<true-constraint> swap <implication> ;
|
||||
: t--> ( constraint boolean-value -- constraint' ) =t swap --> ;
|
||||
|
||||
: if-false ( constraint boolean-value -- constraint' )
|
||||
<false-constraint> swap <implication> ;
|
||||
: f--> ( constraint boolean-value -- constraint' ) =f swap --> ;
|
||||
|
||||
: <conditional> ( true-constr false-constr boolean-value -- constraint )
|
||||
tuck [ if-true ] [ if-false ] 2bi* <conjunction> ;
|
||||
tuck [ t--> ] [ f--> ] 2bi* /\ ;
|
||||
|
|
|
|||
|
|
@ -2,6 +2,8 @@ USING: accessors math math.intervals sequences classes.algebra
|
|||
math kernel tools.test compiler.tree.propagation.info ;
|
||||
IN: compiler.tree.propagation.info.tests
|
||||
|
||||
[ f ] [ 0.0 -0.0 eql? ] unit-test
|
||||
|
||||
[ t ] [
|
||||
number <class-info>
|
||||
sequence <class-info>
|
||||
|
|
@ -48,3 +50,14 @@ 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 null 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
|
||||
|
||||
[ 3 t ] [
|
||||
3 <literal-info>
|
||||
null <class-info> value-info-union >literal<
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,77 +1,99 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs classes classes.algebra kernel accessors math
|
||||
math.intervals namespaces disjoint-sets sequences words
|
||||
combinators ;
|
||||
math.intervals namespaces sequences words combinators arrays
|
||||
compiler.tree.copy-equiv ;
|
||||
IN: compiler.tree.propagation.info
|
||||
|
||||
SYMBOL: +interval+
|
||||
|
||||
GENERIC: eql? ( obj1 obj2 -- ? )
|
||||
M: object eql? eq? ;
|
||||
M: number eql? [ [ class ] bi@ = ] [ number= ] 2bi and ;
|
||||
|
||||
! Disjoint set of copy equivalence
|
||||
SYMBOL: copies
|
||||
|
||||
: is-copy-of ( val copy -- ) copies get equate ;
|
||||
|
||||
: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
|
||||
|
||||
: resolve-copy ( copy -- val ) copies get representative ;
|
||||
|
||||
: introduce-value ( val -- ) copies get add-atom ;
|
||||
M: fixnum eql? eq? ;
|
||||
M: bignum eql? over bignum? [ = ] [ 2drop f ] if ;
|
||||
M: ratio eql? over ratio? [ = ] [ 2drop f ] if ;
|
||||
M: float eql? over float? [ [ double>bits ] bi@ = ] [ 2drop f ] if ;
|
||||
M: complex eql? over complex? [ = ] [ 2drop f ] if ;
|
||||
|
||||
! Value info represents a set of objects. Don't mutate value infos
|
||||
! you receive, always construct new ones. We don't declare the
|
||||
! slots read-only to allow cloning followed by writing.
|
||||
TUPLE: value-info
|
||||
{ class initial: null }
|
||||
interval
|
||||
{ interval initial: empty-interval }
|
||||
literal
|
||||
literal? ;
|
||||
literal?
|
||||
length ;
|
||||
|
||||
: class-interval ( class -- interval )
|
||||
dup real class<=
|
||||
[ +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 ;
|
||||
|
||||
: <value-info> ( class interval literal literal? -- info )
|
||||
[
|
||||
2nip
|
||||
[ class ]
|
||||
[ dup real? [ [a,a] ] [ drop [-inf,inf] ] if ]
|
||||
[ ]
|
||||
tri t
|
||||
#! If interval has zero length and the class is sufficiently
|
||||
#! precise, we can turn it into a literal
|
||||
dup empty-interval eq? [
|
||||
2drop f f
|
||||
] [
|
||||
drop
|
||||
over null class<= [ drop f f f ] [
|
||||
over integer class<= [ integral-closure ] when
|
||||
2dup interval>literal
|
||||
dup from>> first {
|
||||
{ [ over interval-length 0 > ] [ 3drop f f ] }
|
||||
{ [ pick bignum class<= ] [ 2nip >bignum t ] }
|
||||
{ [ pick integer class<= ] [ 2nip >fixnum t ] }
|
||||
{ [ pick float class<= ] [
|
||||
2nip dup zero? [ drop f f ] [ >float t ] if
|
||||
] }
|
||||
[ 3drop f f ]
|
||||
} cond
|
||||
] if ;
|
||||
|
||||
: <value-info> ( -- info ) \ value-info new ;
|
||||
|
||||
: init-value-info ( info -- info )
|
||||
dup literal?>> [
|
||||
dup literal>> class >>class
|
||||
dup literal>> dup real? [ [a,a] ] [ drop [-inf,inf] ] if >>interval
|
||||
] [
|
||||
dup [ class>> null class<= ] [ interval>> empty-interval eq? ] bi or [
|
||||
null >>class
|
||||
empty-interval >>interval
|
||||
] [
|
||||
dup class>> integer class<= [ [ integral-closure ] change-interval ] when
|
||||
dup [ class>> ] [ interval>> ] bi interval>literal
|
||||
[ >>literal ] [ >>literal? ] bi*
|
||||
] if
|
||||
] if
|
||||
\ value-info boa ; foldable
|
||||
] if ;
|
||||
|
||||
: <class/interval-info> ( class interval -- info )
|
||||
<value-info>
|
||||
swap >>interval
|
||||
swap >>class
|
||||
init-value-info ; foldable
|
||||
|
||||
: <class-info> ( class -- info )
|
||||
[-inf,inf] f f <value-info> ; foldable
|
||||
dup word? [ dup +interval+ word-prop ] [ f ] if [-inf,inf] or
|
||||
<class/interval-info> ; foldable
|
||||
|
||||
: <interval-info> ( interval -- info )
|
||||
real swap f f <value-info> ; foldable
|
||||
<value-info>
|
||||
real >>class
|
||||
swap >>interval
|
||||
init-value-info ; foldable
|
||||
|
||||
: <literal-info> ( literal -- info )
|
||||
f [-inf,inf] rot t <value-info> ; foldable
|
||||
<value-info>
|
||||
swap >>literal
|
||||
t >>literal?
|
||||
init-value-info ; foldable
|
||||
|
||||
: >literal< ( info -- literal literal? ) [ literal>> ] [ literal?>> ] bi ;
|
||||
: <sequence-info> ( value -- info )
|
||||
<value-info>
|
||||
object >>class
|
||||
[-inf,inf] >>interval
|
||||
swap value-info >>length
|
||||
init-value-info ; foldable
|
||||
|
||||
: >literal< ( info -- literal literal? )
|
||||
[ literal>> ] [ literal?>> ] bi ;
|
||||
|
||||
: intersect-literals ( info1 info2 -- literal literal? )
|
||||
{
|
||||
|
|
@ -81,21 +103,30 @@ literal? ;
|
|||
[ drop >literal< ]
|
||||
} cond ;
|
||||
|
||||
: interval-intersect' ( i1 i2 -- i3 )
|
||||
#! Change core later.
|
||||
2dup and [ interval-intersect ] [ 2drop f ] if ;
|
||||
DEFER: value-info-intersect
|
||||
|
||||
: value-info-intersect ( info1 info2 -- info )
|
||||
[ [ class>> ] bi@ class-and ]
|
||||
[ [ interval>> ] bi@ interval-intersect' ]
|
||||
[ intersect-literals ]
|
||||
2tri <value-info> ;
|
||||
|
||||
: interval-union' ( i1 i2 -- i3 )
|
||||
{
|
||||
: intersect-lengths ( info1 info2 -- length )
|
||||
[ length>> ] bi@ {
|
||||
{ [ dup not ] [ drop ] }
|
||||
{ [ over not ] [ nip ] }
|
||||
[ interval-union ]
|
||||
[ value-info-intersect ]
|
||||
} cond ;
|
||||
|
||||
: (value-info-intersect) ( info1 info2 -- info )
|
||||
[ <value-info> ] 2dip
|
||||
{
|
||||
[ [ class>> ] bi@ class-and >>class ]
|
||||
[ [ interval>> ] bi@ interval-intersect >>interval ]
|
||||
[ intersect-literals [ >>literal ] [ >>literal? ] bi* ]
|
||||
[ intersect-lengths >>length ]
|
||||
} 2cleave
|
||||
init-value-info ;
|
||||
|
||||
: value-info-intersect ( info1 info2 -- info )
|
||||
{
|
||||
{ [ dup class>> null class<= ] [ nip ] }
|
||||
{ [ over class>> null class<= ] [ drop ] }
|
||||
[ (value-info-intersect) ]
|
||||
} cond ;
|
||||
|
||||
: union-literals ( info1 info2 -- literal literal? )
|
||||
|
|
@ -103,11 +134,31 @@ literal? ;
|
|||
[ literal>> ] bi@ 2dup eql? [ drop t ] [ 2drop f f ] if
|
||||
] [ 2drop f f ] if ;
|
||||
|
||||
DEFER: value-info-union
|
||||
|
||||
: union-lengths ( info1 info2 -- length )
|
||||
[ length>> ] bi@ {
|
||||
{ [ dup not ] [ nip ] }
|
||||
{ [ over not ] [ drop ] }
|
||||
[ value-info-union ]
|
||||
} cond ;
|
||||
|
||||
: (value-info-union) ( info1 info2 -- info )
|
||||
[ <value-info> ] 2dip
|
||||
{
|
||||
[ [ class>> ] bi@ class-or >>class ]
|
||||
[ [ interval>> ] bi@ interval-union >>interval ]
|
||||
[ union-literals [ >>literal ] [ >>literal? ] bi* ]
|
||||
[ union-lengths >>length ]
|
||||
} 2cleave
|
||||
init-value-info ;
|
||||
|
||||
: value-info-union ( info1 info2 -- info )
|
||||
[ [ class>> ] bi@ class-or ]
|
||||
[ [ interval>> ] bi@ interval-union' ]
|
||||
[ union-literals ]
|
||||
2tri <value-info> ;
|
||||
{
|
||||
{ [ dup class>> null class<= ] [ drop ] }
|
||||
{ [ over class>> null class<= ] [ nip ] }
|
||||
[ (value-info-union) ]
|
||||
} cond ;
|
||||
|
||||
: value-infos-union ( infos -- info )
|
||||
dup first [ value-info-union ] reduce ;
|
||||
|
|
@ -126,3 +177,18 @@ SYMBOL: value-infos
|
|||
|
||||
: value-literal ( value -- obj ? )
|
||||
value-info >literal< ;
|
||||
|
||||
: possible-boolean-values ( info -- values )
|
||||
dup literal?>> [
|
||||
literal>> 1array
|
||||
] [
|
||||
class>> {
|
||||
{ [ dup null class<= ] [ { } ] }
|
||||
{ [ dup \ f class-not class<= ] [ { t } ] }
|
||||
{ [ dup \ f class<= ] [ { f } ] }
|
||||
[ { t f } ]
|
||||
} cond nip
|
||||
] if ;
|
||||
|
||||
: value-is? ( value class -- ? )
|
||||
[ value-info class>> ] dip class<= ;
|
||||
|
|
|
|||
|
|
@ -1,12 +1,13 @@
|
|||
! 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
|
||||
compiler.tree.propagation.constraints ;
|
||||
math.partial-dispatch math.intervals math.parser math.order
|
||||
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
|
||||
compiler.tree.comparisons ;
|
||||
IN: compiler.tree.propagation.known-words
|
||||
|
||||
\ fixnum
|
||||
|
|
@ -66,40 +67,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* ;
|
||||
[ [ interval>> ] bi@ ] dip call ; inline
|
||||
|
||||
: 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,63 +117,35 @@ 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
|
||||
|
||||
: assume-interval ( i1 i2 op -- i3 )
|
||||
{
|
||||
{ \ < [ assume< ] }
|
||||
{ \ > [ assume> ] }
|
||||
{ \ <= [ assume<= ] }
|
||||
{ \ >= [ assume>= ] }
|
||||
} case ;
|
||||
|
||||
: swap-comparison ( op -- op' )
|
||||
{
|
||||
{ < > }
|
||||
{ > < }
|
||||
{ <= >= }
|
||||
{ >= <= }
|
||||
} at ;
|
||||
|
||||
: negate-comparison ( op -- op' )
|
||||
{
|
||||
{ < >= }
|
||||
{ > <= }
|
||||
{ <= > }
|
||||
{ >= < }
|
||||
} at ;
|
||||
|
||||
:: (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 assumption is-in-interval
|
||||
in2 i2 i1 op swap-comparison assumption is-in-interval
|
||||
/\
|
||||
] ;
|
||||
|
||||
: comparison-constraints ( in1 in2 out op -- constraint )
|
||||
|
|
@ -184,13 +155,35 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
3bi
|
||||
] dip <conditional> ;
|
||||
|
||||
: comparison-op ( word op -- )
|
||||
'[
|
||||
[ in-d>> first2 ] [ out-d>> first ] bi
|
||||
, comparison-constraints
|
||||
] +constraints+ set-word-prop ;
|
||||
: define-comparison-constraints ( word op -- )
|
||||
'[ , comparison-constraints ] +constraints+ set-word-prop ;
|
||||
|
||||
{ < > <= >= } [ dup [ comparison-op ] curry each-derived-op ] each
|
||||
comparison-ops
|
||||
[ dup '[ , define-comparison-constraints ] each-derived-op ] each
|
||||
|
||||
generic-comparison-ops [
|
||||
dup specific-comparison
|
||||
'[ , , define-comparison-constraints ] each-derived-op
|
||||
] each
|
||||
|
||||
! Remove redundant comparisons
|
||||
: fold-comparison ( info1 info2 word -- info )
|
||||
[ [ interval>> ] bi@ ] dip interval-comparison {
|
||||
{ incomparable [ object <class-info> ] }
|
||||
{ t [ t <literal-info> ] }
|
||||
{ f [ f <literal-info> ] }
|
||||
} case ;
|
||||
|
||||
comparison-ops [
|
||||
[
|
||||
dup '[ , fold-comparison ] +outputs+ set-word-prop
|
||||
] each-derived-op
|
||||
] each
|
||||
|
||||
generic-comparison-ops [
|
||||
dup specific-comparison
|
||||
'[ , fold-comparison ] +outputs+ set-word-prop
|
||||
] each
|
||||
|
||||
{
|
||||
{ >fixnum fixnum }
|
||||
|
|
@ -201,71 +194,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
|
||||
|
|
|
|||
|
|
@ -16,9 +16,6 @@ GENERIC: propagate-around ( node -- )
|
|||
|
||||
: (propagate) ( node -- )
|
||||
[
|
||||
[ node-defs-values [ introduce-value ] each ]
|
||||
[ propagate-around ]
|
||||
[ successor>> ]
|
||||
tri
|
||||
[ propagate-around ] [ successor>> ] bi
|
||||
(propagate)
|
||||
] when* ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,20 @@
|
|||
USING: kernel compiler.frontend compiler.tree
|
||||
compiler.tree.propagation tools.test math accessors
|
||||
sequences arrays kernel.private ;
|
||||
USING: kernel compiler.tree.builder compiler.tree
|
||||
compiler.tree.propagation compiler.tree.copy-equiv
|
||||
compiler.tree.def-use tools.test math math.order
|
||||
accessors sequences arrays kernel.private vectors
|
||||
alien.accessors alien.c-types sequences.private
|
||||
byte-arrays ;
|
||||
IN: compiler.tree.propagation.tests
|
||||
|
||||
\ propagate must-infer
|
||||
\ propagate/node must-infer
|
||||
|
||||
: final-info ( quot -- seq )
|
||||
dataflow propagate last-node node-input-infos ;
|
||||
build-tree
|
||||
compute-def-use
|
||||
compute-copy-equiv
|
||||
propagate
|
||||
last-node node-input-infos ;
|
||||
|
||||
: final-classes ( quot -- seq )
|
||||
final-info [ class>> ] map ;
|
||||
|
|
@ -64,7 +74,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 +97,145 @@ 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 } ] [
|
||||
[
|
||||
123 bitand
|
||||
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
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[ 0 dup 10 > [ 2 * ] when ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ f } ] [
|
||||
[ [ 0.0 ] [ -0.0 ] if ] final-literals
|
||||
] unit-test
|
||||
|
||||
[ V{ 1.5 } ] [
|
||||
[ /f 1.5 min 1.5 max ] final-literals
|
||||
] unit-test
|
||||
|
||||
[ V{ 1.5 } ] [
|
||||
[
|
||||
/f
|
||||
dup 1.5 <= [ dup 1.5 >= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
|
||||
] final-literals
|
||||
] unit-test
|
||||
|
||||
[ V{ 1.5 } ] [
|
||||
[
|
||||
/f
|
||||
dup 1.5 <= [ dup 10 >= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
|
||||
] final-literals
|
||||
] unit-test
|
||||
|
||||
[ V{ f } ] [
|
||||
[
|
||||
/f
|
||||
dup 0.0 <= [ dup 0.0 >= [ drop 0.0 ] unless ] [ drop 0.0 ] if
|
||||
] final-literals
|
||||
] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[ 0 dup 10 > [ 100 * ] when ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[ 0 dup 10 > [ drop "foo" ] when ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[ { fixnum } declare 3 3 - + ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ t } ] [
|
||||
[ dup 10 < [ 3 * 30 < ] [ drop t ] if ] final-literals
|
||||
] unit-test
|
||||
|
||||
[ V{ "d" } ] [
|
||||
[
|
||||
3 {
|
||||
[ "a" ]
|
||||
[ "b" ]
|
||||
[ "c" ]
|
||||
[ "d" ]
|
||||
[ "e" ]
|
||||
[ "f" ]
|
||||
[ "g" ]
|
||||
[ "h" ]
|
||||
} dispatch
|
||||
] final-literals
|
||||
] unit-test
|
||||
|
||||
[ V{ "hi" } ] [
|
||||
[ [ "hi" ] [ 123 3 throw ] if ] final-literals
|
||||
] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[ >fixnum dup 100 < [ 1+ ] [ "Oops" throw ] if ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ -1 } ] [
|
||||
[ 0 dup 100 < not [ 1+ ] [ 1- ] if ] final-literals
|
||||
] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[ [ 1 >r ] [ 2 >r ] if r> 3 + ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ 2 } ] [
|
||||
[ [ 1 ] [ 1 ] if 1 + ] final-literals
|
||||
] unit-test
|
||||
|
||||
[ V{ t } ] [ [ 10 f <array> length 10 = ] final-literals ] unit-test
|
||||
|
||||
[ V{ t } ] [ [ [ 10 f <array> ] [ 10 <byte-array> ] if length 10 = ] final-literals ] unit-test
|
||||
|
||||
[ V{ t } ] [ [ [ 1 f <array> ] [ 2 f <array> ] if length 3 < ] final-literals ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences namespaces hashtables
|
||||
disjoint-sets
|
||||
compiler.tree
|
||||
compiler.tree.def-use
|
||||
compiler.tree.propagation.info
|
||||
|
|
@ -17,7 +16,6 @@ IN: compiler.tree.propagation
|
|||
[
|
||||
H{ } clone constraints set
|
||||
>hashtable value-infos set
|
||||
<disjoint-set> copies set
|
||||
(propagate)
|
||||
] with-scope ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,6 +8,12 @@ compiler.tree.propagation.simple
|
|||
compiler.tree.propagation.branches ;
|
||||
IN: compiler.tree.propagation.recursive
|
||||
|
||||
! What if we reach a fixed point for the phi but not for the
|
||||
! #call-label output?
|
||||
|
||||
! We need to compute scalar evolution so that sccp doesn't
|
||||
! evaluate loops
|
||||
|
||||
: (merge-value-infos) ( inputs -- infos )
|
||||
[ [ value-info ] map value-infos-union ] map ;
|
||||
|
||||
|
|
@ -22,11 +28,9 @@ IN: compiler.tree.propagation.recursive
|
|||
|
||||
M: #recursive propagate-around ( #recursive -- )
|
||||
dup
|
||||
[ children>> (propagate) ]
|
||||
[ node-child propagate-recursive-phi ] bi
|
||||
node-child
|
||||
[ first>> (propagate) ] [ propagate-recursive-phi ] bi
|
||||
[ drop ] [ propagate-around ] if ;
|
||||
|
||||
M: #call-recursive propagate-before ( #call-label -- )
|
||||
#! What if we reach a fixed point for the phi but not for the
|
||||
#! #call-label output?
|
||||
[ label>> returns>> flip ] [ out-d>> ] bi merge-value-infos drop ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,10 @@
|
|||
! 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
|
||||
USING: fry accessors kernel sequences sequences.private assocs
|
||||
words namespaces classes.algebra combinators classes
|
||||
continuations arrays byte-arrays strings
|
||||
compiler.tree
|
||||
compiler.tree.def-use
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.nodes
|
||||
compiler.tree.propagation.constraints ;
|
||||
|
|
@ -25,34 +27,20 @@ M: #push propagate-before
|
|||
[ set-value-info ] 2each ;
|
||||
|
||||
M: #declare propagate-before
|
||||
[ [ in-d>> ] [ out-d>> ] bi are-copies-of ]
|
||||
[
|
||||
[ declaration>> class-infos ] [ out-d>> ] bi
|
||||
refine-value-infos
|
||||
] bi ;
|
||||
|
||||
M: #shuffle propagate-before
|
||||
[ out-d>> dup ] [ mapping>> ] bi
|
||||
'[ , at ] map swap are-copies-of ;
|
||||
|
||||
M: #>r propagate-before
|
||||
[ in-d>> ] [ out-r>> ] bi are-copies-of ;
|
||||
|
||||
M: #r> propagate-before
|
||||
[ in-r>> ] [ out-d>> ] bi are-copies-of ;
|
||||
|
||||
M: #copy propagate-before
|
||||
[ in-d>> ] [ out-d>> ] bi are-copies-of ;
|
||||
declaration>> [ <class-info> swap refine-value-info ] assoc-each ;
|
||||
|
||||
: predicate-constraints ( value class boolean-value -- constraint )
|
||||
[ [ <class-constraint> ] dip if-true ]
|
||||
[ [ class-not <class-constraint> ] dip if-false ]
|
||||
3bi <conjunction> ;
|
||||
[ [ is-instance-of ] dip t--> ]
|
||||
[ [ class-not is-instance-of ] dip f--> ]
|
||||
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 ]
|
||||
|
|
@ -60,6 +48,24 @@ M: #copy propagate-before
|
|||
] [ drop ] if
|
||||
] if* ;
|
||||
|
||||
: call-outputs-quot ( node -- infos )
|
||||
[ in-d>> [ value-info ] map ]
|
||||
[ word>> +outputs+ word-prop ]
|
||||
bi with-datastack ;
|
||||
|
||||
: foldable-call? ( #call -- ? )
|
||||
dup word>> "foldable" word-prop [
|
||||
in-d>> [ value-info literal?>> ] all?
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
: fold-call ( #call -- infos )
|
||||
[ in-d>> [ value-info literal>> ] map ]
|
||||
[ word>> [ execute ] curry ]
|
||||
bi with-datastack
|
||||
[ <literal-info> ] map ;
|
||||
|
||||
: default-output-value-infos ( node -- infos )
|
||||
dup word>> "default-output-classes" word-prop [
|
||||
class-infos
|
||||
|
|
@ -67,16 +73,37 @@ M: #copy propagate-before
|
|||
out-d>> length object <class-info> <repetition>
|
||||
] ?if ;
|
||||
|
||||
: call-outputs-quot ( node quot -- infos )
|
||||
[ in-d>> [ value-info ] map ] dip with-datastack ;
|
||||
UNION: fixed-length-sequence array byte-array string ;
|
||||
|
||||
: output-value-infos ( node word -- infos )
|
||||
dup word>> +outputs+ word-prop
|
||||
[ call-outputs-quot ] [ default-output-value-infos ] if* ;
|
||||
: sequence-constructor? ( node -- ? )
|
||||
word>> { <array> <byte-array> <string> } memq? ;
|
||||
|
||||
: propagate-sequence-constructor ( node -- infos )
|
||||
[ default-output-value-infos first ]
|
||||
[ in-d>> first <sequence-info> ]
|
||||
bi value-info-intersect 1array ;
|
||||
|
||||
: length-accessor? ( node -- ? )
|
||||
dup in-d>> first fixed-length-sequence value-is?
|
||||
[ word>> \ length eq? ] [ drop f ] if ;
|
||||
|
||||
: propagate-length ( node -- infos )
|
||||
in-d>> first value-info length>>
|
||||
[ array-capacity <class-info> ] unless* 1array ;
|
||||
|
||||
: output-value-infos ( node -- infos )
|
||||
{
|
||||
{ [ dup foldable-call? ] [ fold-call ] }
|
||||
{ [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
|
||||
{ [ dup length-accessor? ] [ propagate-length ] }
|
||||
{ [ dup word>> +outputs+ word-prop ] [ call-outputs-quot ] }
|
||||
[ default-output-value-infos ]
|
||||
} cond ;
|
||||
|
||||
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 ;
|
||||
|
||||
|
|
@ -90,7 +117,10 @@ M: #call propagate-after
|
|||
M: node propagate-after drop ;
|
||||
|
||||
: annotate-node ( node -- )
|
||||
dup node-values [ dup value-info ] H{ } map>assoc >>info drop ;
|
||||
dup
|
||||
[ node-defs-values ] [ node-uses-values ] bi append
|
||||
[ dup value-info ] H{ } map>assoc
|
||||
>>info drop ;
|
||||
|
||||
M: node propagate-around
|
||||
[ propagate-before ] [ annotate-node ] [ propagate-after ] tri ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic assocs kernel math namespaces parser
|
||||
sequences words vectors math.intervals effects classes
|
||||
accessors combinators stack-checker.state ;
|
||||
accessors combinators stack-checker.state stack-checker.visitor ;
|
||||
IN: compiler.tree
|
||||
|
||||
! High-level tree SSA form.
|
||||
|
|
@ -16,20 +16,12 @@ IN: compiler.tree
|
|||
! case of a #phi node, the sequence of sequences in the phi-in-r
|
||||
! and phi-in-d slots.
|
||||
! 3) A value is never used in the same node where it is defined.
|
||||
|
||||
TUPLE: node < identity-tuple
|
||||
in-d out-d in-r out-r info
|
||||
history successor children ;
|
||||
successor children ;
|
||||
|
||||
M: node hashcode* drop node hashcode* ;
|
||||
|
||||
: node-shuffle ( node -- shuffle )
|
||||
[ in-d>> ] [ out-d>> ] bi <effect> ;
|
||||
|
||||
: node-values ( node -- values )
|
||||
{ [ in-d>> ] [ out-d>> ] [ in-r>> ] [ out-r>> ] } cleave
|
||||
4array concat ;
|
||||
|
||||
: node-child ( node -- child ) children>> first ;
|
||||
|
||||
: last-node ( node -- last )
|
||||
|
|
@ -57,7 +49,7 @@ TUPLE: #introduce < node values ;
|
|||
: #introduce ( values -- node )
|
||||
\ #introduce new swap >>values ;
|
||||
|
||||
TUPLE: #call < node word ;
|
||||
TUPLE: #call < node word history ;
|
||||
|
||||
: #call ( inputs outputs word -- node )
|
||||
\ #call new
|
||||
|
|
@ -137,11 +129,9 @@ TUPLE: #phi < node phi-in-d phi-in-r ;
|
|||
|
||||
TUPLE: #declare < node declaration ;
|
||||
|
||||
: #declare ( inputs outputs declaration -- node )
|
||||
: #declare ( declaration -- node )
|
||||
\ #declare new
|
||||
swap >>declaration
|
||||
swap >>out-d
|
||||
swap >>in-d ;
|
||||
swap >>declaration ;
|
||||
|
||||
TUPLE: #return < node label ;
|
||||
|
||||
|
|
@ -172,3 +162,30 @@ DEFER: #tail?
|
|||
PREDICATE: #tail-phi < #phi successor>> #tail? ;
|
||||
|
||||
UNION: #tail POSTPONE: f #return #tail-phi #terminate ;
|
||||
|
||||
TUPLE: node-list first last ;
|
||||
|
||||
: node, ( node -- )
|
||||
stack-visitor get swap
|
||||
over last>>
|
||||
[ [ [ last>> ] dip >>successor drop ] [ >>last drop ] 2bi ]
|
||||
[ [ >>first ] [ >>last ] bi drop ]
|
||||
if ;
|
||||
|
||||
M: node-list child-visitor node-list new ;
|
||||
M: node-list #introduce, #introduce node, ;
|
||||
M: node-list #call, #call node, ;
|
||||
M: node-list #call-recursive, #call-recursive node, ;
|
||||
M: node-list #push, #push node, ;
|
||||
M: node-list #shuffle, #shuffle node, ;
|
||||
M: node-list #drop, #drop node, ;
|
||||
M: node-list #>r, #>r node, ;
|
||||
M: node-list #r>, #r> node, ;
|
||||
M: node-list #return, #return node, ;
|
||||
M: node-list #terminate, #terminate node, ;
|
||||
M: node-list #if, #if node, ;
|
||||
M: node-list #dispatch, #dispatch node, ;
|
||||
M: node-list #phi, #phi node, ;
|
||||
M: node-list #declare, #declare node, ;
|
||||
M: node-list #recursive, #recursive node, ;
|
||||
M: node-list #copy, #copy node, ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,50 @@
|
|||
IN: compiler.tree.untupling.tests
|
||||
USING: assocs math kernel quotations.private slots.private
|
||||
compiler.tree.builder
|
||||
compiler.tree.def-use
|
||||
compiler.tree.copy-equiv
|
||||
compiler.tree.untupling
|
||||
tools.test ;
|
||||
|
||||
: check-untupling ( quot -- sizes )
|
||||
build-tree
|
||||
compute-copy-equiv
|
||||
compute-def-use
|
||||
compute-untupling
|
||||
values ;
|
||||
|
||||
[ { } ] [ [ 1 [ + ] curry ] check-untupling ] unit-test
|
||||
|
||||
[ { 2 } ] [ [ 1 [ + ] curry drop ] check-untupling ] unit-test
|
||||
|
||||
[ { 2 } ] [ [ 1 [ + ] curry 3 slot ] check-untupling ] unit-test
|
||||
|
||||
[ { 2 } ] [ [ 1 [ + ] curry 3 slot drop ] check-untupling ] unit-test
|
||||
|
||||
[ { 2 } ] [ [ 1 [ + ] curry uncurry ] check-untupling ] unit-test
|
||||
|
||||
[ { 2 } ] [ [ 2 1 [ + ] curry call ] check-untupling ] unit-test
|
||||
|
||||
[ { 2 } ] [ [ 2 1 [ + ] curry call ] check-untupling ] unit-test
|
||||
|
||||
[ { } ] [ [ [ 1 [ + ] curry ] [ [ ] ] if ] check-untupling ] unit-test
|
||||
|
||||
[ { 2 2 } ] [
|
||||
[ [ 1 [ + ] curry ] [ 2 [ * ] curry ] if uncurry ] check-untupling
|
||||
] unit-test
|
||||
|
||||
[ { } ] [
|
||||
[ [ 1 [ + ] curry ] [ 2 [ * ] curry ] if ] check-untupling
|
||||
] unit-test
|
||||
|
||||
[ { 2 2 2 } ] [
|
||||
[ [ 1 [ + ] curry ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if ] if uncurry ] check-untupling
|
||||
] unit-test
|
||||
|
||||
[ { 2 2 } ] [
|
||||
[ [ 1 [ + ] curry 4 ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if uncurry ] if ] check-untupling
|
||||
] unit-test
|
||||
|
||||
[ { } ] [
|
||||
[ [ 1 [ + ] curry ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if ] if ] check-untupling
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,59 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors slots.private kernel namespaces disjoint-sets
|
||||
math sequences assocs classes.tuple.private combinators fry sets
|
||||
compiler.tree compiler.tree.combinators compiler.tree.copy-equiv
|
||||
compiler.tree.dfa compiler.tree.dfa.backward ;
|
||||
IN: compiler.tree.untupling
|
||||
|
||||
SYMBOL: escaping-values
|
||||
|
||||
: mark-escaping-values ( node -- )
|
||||
in-d>> escaping-values get '[ resolve-copy , conjoin ] each ;
|
||||
|
||||
SYMBOL: untupling-candidates
|
||||
|
||||
: untupling-candidate ( #call class -- )
|
||||
#! 1- for delegate
|
||||
size>> 1- swap out-d>> first resolve-copy
|
||||
untupling-candidates get set-at ;
|
||||
|
||||
GENERIC: compute-untupling* ( node -- )
|
||||
|
||||
M: #call compute-untupling*
|
||||
dup word>> {
|
||||
{ \ <tuple-boa> [ dup in-d>> peek untupling-candidate ] }
|
||||
{ \ curry [ \ curry tuple-layout untupling-candidate ] }
|
||||
{ \ compose [ \ compose tuple-layout untupling-candidate ] }
|
||||
{ \ slot [ drop ] }
|
||||
[ drop mark-escaping-values ]
|
||||
} case ;
|
||||
|
||||
M: #return compute-untupling*
|
||||
dup label>> [ drop ] [ mark-escaping-values ] if ;
|
||||
|
||||
M: node compute-untupling* drop ;
|
||||
|
||||
GENERIC: check-consistency* ( node -- )
|
||||
|
||||
: check-value-consistency ( out-value in-values -- )
|
||||
swap escaping-values get key? [
|
||||
escaping-values get '[ , conjoin ] each
|
||||
] [
|
||||
untupling-candidates get 2dup '[ , at ] map all-equal?
|
||||
[ 2drop ] [ '[ , delete-at ] each ] if
|
||||
] if ;
|
||||
|
||||
M: #phi check-consistency*
|
||||
[ [ out-d>> ] [ phi-in-d>> ] bi [ check-value-consistency ] 2each ]
|
||||
[ [ out-r>> ] [ phi-in-r>> ] bi [ check-value-consistency ] 2each ]
|
||||
bi ;
|
||||
|
||||
M: node check-consistency* drop ;
|
||||
|
||||
: compute-untupling ( node -- assoc )
|
||||
H{ } clone escaping-values set
|
||||
H{ } clone untupling-candidates set
|
||||
[ [ compute-untupling* ] each-node ]
|
||||
[ [ check-consistency* ] each-node ] bi
|
||||
untupling-candidates get escaping-values get assoc-diff ;
|
||||
|
|
@ -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
|
||||
|
|
@ -174,7 +176,7 @@ M: object apply-object push-literal ;
|
|||
[
|
||||
init-inference
|
||||
init-known-values
|
||||
dataflow-visitor off
|
||||
stack-visitor off
|
||||
dependencies off
|
||||
[ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ]
|
||||
[ finish-word current-effect ]
|
||||
|
|
@ -191,32 +193,19 @@ 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 )
|
||||
[
|
||||
[
|
||||
V{ } clone recorded set
|
||||
init-inference
|
||||
init-known-values
|
||||
dataflow-visitor off
|
||||
stack-visitor off
|
||||
call
|
||||
end-infer
|
||||
current-effect
|
||||
dataflow-visitor get
|
||||
stack-visitor get
|
||||
] [ ] [ undo-infer ] cleanup
|
||||
] with-scope ;
|
||||
] with-scope ; inline
|
||||
|
|
|
|||
|
|
@ -65,10 +65,21 @@ SYMBOL: quotations
|
|||
: infer-branches ( branches -- input children data )
|
||||
[ pop-d ] dip
|
||||
[ infer-branch ] map
|
||||
[ dataflow-visitor branch-variable ] keep ;
|
||||
[ stack-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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -80,7 +81,7 @@ SYMBOL: phi-out
|
|||
|
||||
dup recursive-word-inputs
|
||||
meta-d get
|
||||
dataflow-visitor get
|
||||
stack-visitor get
|
||||
] with-scope ;
|
||||
|
||||
: inline-recursive-word ( word -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
[ length ensure-d ] keep zip
|
||||
#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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ M: f #terminate, ;
|
|||
M: f #if, 3drop ;
|
||||
M: f #dispatch, 2drop ;
|
||||
M: f #phi, 2drop 2drop ;
|
||||
M: f #declare, 3drop ;
|
||||
M: f #declare, drop ;
|
||||
M: f #recursive, drop drop drop drop drop ;
|
||||
M: f #copy, 2drop ;
|
||||
M: f #drop, drop ;
|
||||
|
|
|
|||
|
|
@ -3,25 +3,25 @@
|
|||
USING: kernel arrays namespaces ;
|
||||
IN: stack-checker.visitor
|
||||
|
||||
SYMBOL: dataflow-visitor
|
||||
SYMBOL: stack-visitor
|
||||
|
||||
HOOK: child-visitor dataflow-visitor ( -- visitor )
|
||||
HOOK: child-visitor stack-visitor ( -- visitor )
|
||||
|
||||
: nest-visitor ( -- ) child-visitor dataflow-visitor set ;
|
||||
: nest-visitor ( -- ) child-visitor stack-visitor set ;
|
||||
|
||||
HOOK: #introduce, dataflow-visitor ( values -- )
|
||||
HOOK: #call, dataflow-visitor ( inputs outputs word -- )
|
||||
HOOK: #call-recursive, dataflow-visitor ( inputs outputs word -- )
|
||||
HOOK: #push, dataflow-visitor ( literal value -- )
|
||||
HOOK: #shuffle, dataflow-visitor ( inputs outputs mapping -- )
|
||||
HOOK: #drop, dataflow-visitor ( values -- )
|
||||
HOOK: #>r, dataflow-visitor ( inputs outputs -- )
|
||||
HOOK: #r>, dataflow-visitor ( inputs outputs -- )
|
||||
HOOK: #terminate, dataflow-visitor ( -- )
|
||||
HOOK: #if, dataflow-visitor ( ? true false -- )
|
||||
HOOK: #dispatch, dataflow-visitor ( n branches -- )
|
||||
HOOK: #phi, dataflow-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- )
|
||||
HOOK: #declare, dataflow-visitor ( inputs outputs declaration -- )
|
||||
HOOK: #return, dataflow-visitor ( label stack -- )
|
||||
HOOK: #recursive, dataflow-visitor ( word label inputs outputs visitor -- )
|
||||
HOOK: #copy, dataflow-visitor ( inputs outputs -- )
|
||||
HOOK: #introduce, stack-visitor ( values -- )
|
||||
HOOK: #call, stack-visitor ( inputs outputs word -- )
|
||||
HOOK: #call-recursive, stack-visitor ( inputs outputs word -- )
|
||||
HOOK: #push, stack-visitor ( literal value -- )
|
||||
HOOK: #shuffle, stack-visitor ( inputs outputs mapping -- )
|
||||
HOOK: #drop, stack-visitor ( values -- )
|
||||
HOOK: #>r, stack-visitor ( inputs outputs -- )
|
||||
HOOK: #r>, stack-visitor ( inputs outputs -- )
|
||||
HOOK: #terminate, stack-visitor ( -- )
|
||||
HOOK: #if, stack-visitor ( ? true false -- )
|
||||
HOOK: #dispatch, stack-visitor ( n branches -- )
|
||||
HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- )
|
||||
HOOK: #declare, stack-visitor ( declaration -- )
|
||||
HOOK: #return, stack-visitor ( label stack -- )
|
||||
HOOK: #recursive, stack-visitor ( word label inputs outputs visitor -- )
|
||||
HOOK: #copy, stack-visitor ( inputs outputs -- )
|
||||
|
|
|
|||
Loading…
Reference in New Issue