steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2008-07-24 18:48:37 -07:00
parent ce1eda2fcd 2bed94df39
commit b41e619f77
68 changed files with 1585 additions and 911 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
core/kernel/kernel.factor
View File

@ -165,12 +165,16 @@ GENERIC: boa ( ... class -- tuple )
compose compose ; inline compose compose ; inline
! Booleans ! 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 : >boolean ( obj -- ? ) t f ? ; inline
: and ( obj1 obj2 -- ? ) over ? ; inline
: or ( obj1 obj2 -- ? ) dupd ? ; inline : or ( obj1 obj2 -- ? ) dupd ? ; inline
: xor ( obj1 obj2 -- ? ) dup not swap ? ; inline : xor ( obj1 obj2 -- ? ) dup not swap ? ; inline

26
core/math/intervals/intervals-tests.factor
View File

@ -217,7 +217,7 @@ IN: math.intervals.tests
] if ; ] if ;
: random-interval ( -- interval ) : random-interval ( -- interval )
1000 random dup 2 1000 random + + 2000 random 1000 - dup 2 1000 random + +
1 random zero? [ [ neg ] bi@ swap ] when 1 random zero? [ [ neg ] bi@ swap ] when
4 random { 4 random {
{ 0 [ [a,b] ] } { 0 [ [a,b] ] }
@ -274,7 +274,7 @@ IN: math.intervals.tests
: binary-test ( -- ? ) : binary-test ( -- ? )
random-interval random-interval random-binary-op ! 3dup . . . 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 3drop t
] [ ] [
[ >r [ random-element ] bi@ ! 2dup . . [ >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] -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] 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

57
core/math/intervals/intervals.factor
View File

@ -235,11 +235,15 @@ TUPLE: interval { from read-only } { to read-only } ;
: interval/f ( i1 i2 -- i3 ) : interval/f ( i1 i2 -- i3 )
[ [ [ /f ] interval-op ] interval-division-op ] do-empty-interval ; [ [ [ /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 ) : interval-abs ( i1 -- i2 )
dup empty-interval eq? [ {
interval>points [ first2 [ abs ] dip 2array ] bi@ 2array { [ dup empty-interval eq? ] [ ] }
points>interval { [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] }
] unless ; [ (interval-abs) points>interval ]
} cond ;
: interval-mod ( i1 i2 -- i3 ) : interval-mod ( i1 i2 -- i3 )
#! Inaccurate. #! Inaccurate.
@ -307,30 +311,45 @@ SYMBOL: incomparable
: interval>= ( i1 i2 -- ? ) : interval>= ( i1 i2 -- ? )
swap interval<= ; 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 ) : interval-bitand ( i1 i2 -- i3 )
dup 1 [a,a] interval>= [ #! Inaccurate.
1 [a,a] interval- interval-rem [
] [ {
2drop [-inf,inf] {
] if ; [ 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 ) : interval-bitor ( i1 i2 -- i3 )
#! Inaccurate. #! Inaccurate.
[ [
2dup [ 0 [a,a] interval>= ] both? 2dup [ interval-nonnegative? ] both?
[ to>> first 0 swap [a,b] interval-intersect ] [
[ 2drop [-inf,inf] ] [ interval>points [ first ] bi@ ] bi@
if 4array supremum 0 swap next-power-of-2 [a,b]
] [ 2drop [-inf,inf] ] if
] do-empty-interval ; ] do-empty-interval ;
: interval-bitxor ( i1 i2 -- i3 ) : interval-bitxor ( i1 i2 -- i3 )
#! Inaccurate. #! Inaccurate.
[ interval-bitor ;
2dup [ 0 [a,a] interval>= ] both?
[ nip to>> first 0 swap [a,b] ]
[ 2drop [-inf,inf] ]
if
] do-empty-interval ;
: assume< ( i1 i2 -- i3 ) : assume< ( i1 i2 -- i3 )
dup empty-interval eq? [ drop ] [ dup empty-interval eq? [ drop ] [

38
extra/24-game/24-game.factor Normal file
View File

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

2
extra/locals/backend/backend.factor
View File

@ -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 USING: math kernel slots.private inference.known-words
inference.backend sequences effects words ; inference.backend sequences effects words ;
IN: locals.backend IN: locals.backend

9
extra/math/derivatives/derivatives-docs.factor Normal file
View File

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

9
extra/math/derivatives/derivatives.factor Normal file
View File

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

8
extra/math/function-tools/function-tools.factor Normal file
View File

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

11
extra/math/newtons-method/newtons-method.factor Normal file
View File

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

9
extra/math/points/points.factor
View File

@ -1,5 +1,4 @@
USING: kernel arrays math.vectors sequences math ;
USING: kernel arrays math.vectors ;
IN: math.points IN: math.points
@ -20,3 +19,9 @@ PRIVATE>
: v+z ( seq z -- seq ) Z v+ ; : v+z ( seq z -- seq ) Z v+ ;
: 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 / - ;

14
extra/math/secant-method/secant-method.factor Normal file
View File

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

2
extra/project-euler/ave-time/ave-time.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer ! Copyright (c) 2007 Aaron Schaefer
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators io kernel math math.functions math.parser 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 IN: project-euler.ave-time
: collect-benchmarks ( quot n -- seq ) : collect-benchmarks ( quot n -- seq )

3
extra/shell/shell.factor
View File

@ -50,7 +50,6 @@ DEFER: expansion
METHOD: expand { back-quoted-expr } METHOD: expand { back-quoted-expr }
expr>> expr>>
expr expr
ast>>
command>> command>>
expansion expansion
utf8 <process-stream> utf8 <process-stream>
@ -122,7 +121,7 @@ DEFER: shell
{ [ dup f = ] [ drop ] } { [ dup f = ] [ drop ] }
{ [ dup "exit" = ] [ drop ] } { [ dup "exit" = ] [ drop ] }
{ [ dup "" = ] [ drop shell ] } { [ dup "" = ] [ drop shell ] }
{ [ dup expr ] [ expr ast>> chant shell ] } { [ dup expr ] [ expr chant shell ] }
{ [ t ] [ drop "ix: ignoring input" print shell ] } { [ t ] [ drop "ix: ignoring input" print shell ] }
} }
cond ; cond ;

4
extra/ui/gadgets/labelled/labelled.factor
View File

@ -12,9 +12,9 @@ TUPLE: labelled-gadget < track content ;
: <labelled-gadget> ( gadget title -- newgadget ) : <labelled-gadget> ( gadget title -- newgadget )
{ 0 1 } labelled-gadget new-track { 0 1 } labelled-gadget new-track
swap <label> reverse-video-theme f track-add* swap <label> reverse-video-theme f track-add
swap >>content swap >>content
dup content>> 1 track-add* ; dup content>> 1 track-add ;
M: labelled-gadget focusable-child* labelled-gadget-content ; M: labelled-gadget focusable-child* labelled-gadget-content ;

8
extra/ui/gadgets/labels/labels.factor
View File

@ -65,10 +65,10 @@ M: f >label drop <gadget> ;
: label-on-left ( gadget label -- button ) : label-on-left ( gadget label -- button )
{ 1 0 } <track> { 1 0 } <track>
swap >label f track-add* swap >label f track-add
swap 1 track-add* ; swap 1 track-add ;
: label-on-right ( label gadget -- button ) : label-on-right ( label gadget -- button )
{ 1 0 } <track> { 1 0 } <track>
swap f track-add* swap f track-add
swap >label 1 track-add* ; swap >label 1 track-add ;

10
extra/ui/gadgets/slots/slots.factor
View File

@ -71,9 +71,9 @@ M: value-ref finish-editing
: <slot-editor> ( ref -- gadget ) : <slot-editor> ( ref -- gadget )
{ 0 1 } slot-editor new-track { 0 1 } slot-editor new-track
swap >>ref swap >>ref
dup <toolbar> f track-add* dup <toolbar> f track-add
<source-editor> >>text <source-editor> >>text
dup text>> <scroller> 1 track-add* dup text>> <scroller> 1 track-add
dup revert ; dup revert ;
M: slot-editor pref-dim* call-next-method { 600 200 } vmin ; 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 -- ) : display-slot ( gadget editable-slot -- )
dup clear-track dup clear-track
swap 1 track-add* swap 1 track-add
<edit-button> f track-add* <edit-button> f track-add
drop ; drop ;
: update-slot ( editable-slot -- ) : update-slot ( editable-slot -- )
@ -109,7 +109,7 @@ TUPLE: editable-slot < track printer ref ;
[ clear-track ] [ clear-track ]
[ [
dup ref>> <slot-editor> dup ref>> <slot-editor>
[ 1 track-add* drop ] [ 1 track-add drop ]
[ [ scroll>gadget ] [ request-focus ] bi* ] 2bi [ [ scroll>gadget ] [ request-focus ] bi* ] 2bi
] bi ; ] bi ;

2
extra/ui/gadgets/status-bar/status-bar.factor
View File

@ -12,7 +12,7 @@ IN: ui.gadgets.status-bar
: open-status-window ( gadget title -- ) : open-status-window ( gadget title -- )
f <model> [ <world> ] keep f <model> [ <world> ] keep
<status-bar> f track-add* <status-bar> f track-add
open-world-window ; open-world-window ;
: show-summary ( object gadget -- ) : show-summary ( object gadget -- )

2
extra/ui/gadgets/tiling/tiling.factor
View File

@ -38,7 +38,7 @@ TUPLE: tiling < track gadgets tiles first focused ;
: tiling-map-gadgets ( tiling -- tiling ) : tiling-map-gadgets ( tiling -- tiling )
dup clear-track dup clear-track
dup tiling-gadgets-to-map [ 1 track-add* ] each ; dup tiling-gadgets-to-map [ 1 track-add ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

4
extra/ui/gadgets/tracks/tracks-docs.factor
View File

@ -8,7 +8,7 @@ ARTICLE: "ui-track-layout" "Track layouts"
"Creating empty tracks:" "Creating empty tracks:"
{ $subsection <track> } { $subsection <track> }
"Adding children:" "Adding children:"
{ $subsection track-add* } ; { $subsection track-add } ;
HELP: track 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> } "." } ; { $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 } } } { $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 }" } "." } ; { $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 } } } { $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." } ; { $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." } ;

6
extra/ui/gadgets/tracks/tracks-tests.factor
View File

@ -4,13 +4,13 @@ IN: ui.gadgets.tracks.tests
[ { 100 100 } ] [ [ { 100 100 } ] [
{ 0 1 } <track> { 0 1 } <track>
<gadget> { 100 100 } >>dim 1 track-add* <gadget> { 100 100 } >>dim 1 track-add
pref-dim pref-dim
] unit-test ] unit-test
[ { 100 110 } ] [ [ { 100 110 } ] [
{ 0 1 } <track> { 0 1 } <track>
<gadget> { 10 10 } >>dim f track-add* <gadget> { 10 10 } >>dim f track-add
<gadget> { 100 100 } >>dim 1 track-add* <gadget> { 100 100 } >>dim 1 track-add
pref-dim pref-dim
] unit-test ] unit-test

2
extra/ui/gadgets/tracks/tracks.factor
View File

@ -50,7 +50,7 @@ M: track pref-dim* ( gadget -- dim )
tri tri
set-axis ; set-axis ;
: track-add* ( track gadget constraint -- track ) : track-add ( track gadget constraint -- track )
pick sizes>> push add-gadget ; pick sizes>> push add-gadget ;
: track-remove ( track gadget -- track ) : track-remove ( track gadget -- track )

2
extra/ui/gadgets/worlds/worlds.factor
View File

@ -40,7 +40,7 @@ M: world request-focus-on ( child gadget -- )
{ 0 0 } >>window-loc { 0 0 } >>window-loc
swap >>status swap >>status
swap >>title swap >>title
swap 1 track-add* swap 1 track-add
dup request-focus ; dup request-focus ;
M: world layout* M: world layout*

4
extra/ui/tools/browser/browser.factor
View File

@ -22,9 +22,9 @@ TUPLE: browser-gadget < track pane history ;
: <browser-gadget> ( -- gadget ) : <browser-gadget> ( -- gadget )
{ 0 1 } browser-gadget new-track { 0 1 } browser-gadget new-track
dup init-history dup init-history
dup <toolbar> f track-add* dup <toolbar> f track-add
dup <help-pane> >>pane dup <help-pane> >>pane
dup pane>> <scroller> 1 track-add* ; dup pane>> <scroller> 1 track-add ;
M: browser-gadget call-tool* show-help ; M: browser-gadget call-tool* show-help ;

4
extra/ui/tools/debugger/debugger.factor
View File

@ -25,9 +25,9 @@ TUPLE: debugger < track restarts ;
: <debugger> ( error restarts restart-hook -- gadget ) : <debugger> ( error restarts restart-hook -- gadget )
{ 0 1 } debugger new-track { 0 1 } debugger new-track
dup <toolbar> f track-add* dup <toolbar> f track-add
-rot <restart-list> >>restarts -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 ; M: debugger focusable-child* debugger-restarts ;

4
extra/ui/tools/inspector/inspector.factor
View File

@ -17,9 +17,9 @@ TUPLE: inspector-gadget < track object pane ;
: <inspector-gadget> ( -- gadget ) : <inspector-gadget> ( -- gadget )
{ 0 1 } inspector-gadget new-track { 0 1 } inspector-gadget new-track
dup <toolbar> f track-add* dup <toolbar> f track-add
<pane> >>pane <pane> >>pane
dup pane>> <scroller> 1 track-add* ; dup pane>> <scroller> 1 track-add ;
: inspect-object ( obj mirror keys inspector -- ) : inspect-object ( obj mirror keys inspector -- )
2nip swap >>object refresh ; 2nip swap >>object refresh ;

8
extra/ui/tools/listener/listener.factor
View File

@ -14,7 +14,7 @@ TUPLE: listener-gadget < track input output stack ;
: listener-output, ( listener -- listener ) : listener-output, ( listener -- listener )
<scrolling-pane> >>output <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 ) : listener-streams ( listener -- input output )
[ input>> ] [ output>> <pane-stream> ] bi ; [ input>> ] [ output>> <pane-stream> ] bi ;
@ -27,7 +27,7 @@ TUPLE: listener-gadget < track input output stack ;
dup input>> dup input>>
{ 0 100 } <limited-scroller> { 0 100 } <limited-scroller>
"Input" <labelled-gadget> "Input" <labelled-gadget>
f track-add* ; f track-add ;
: welcome. ( -- ) : welcome. ( -- )
"If this is your first time with Factor, please read the " print "If this is your first time with Factor, please read the " print
@ -125,10 +125,10 @@ TUPLE: stack-display < track ;
: <stack-display> ( workspace -- gadget ) : <stack-display> ( workspace -- gadget )
listener>> listener>>
{ 0 1 } stack-display new-track { 0 1 } stack-display new-track
over <toolbar> f track-add* over <toolbar> f track-add
swap swap
stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane> stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
1 track-add* ; 1 track-add ;
M: stack-display tool-scroller M: stack-display tool-scroller
find-workspace workspace-listener tool-scroller ; find-workspace workspace-listener tool-scroller ;

4
extra/ui/tools/profiler/profiler.factor
View File

@ -9,9 +9,9 @@ TUPLE: profiler-gadget < track pane ;
: <profiler-gadget> ( -- gadget ) : <profiler-gadget> ( -- gadget )
{ 0 1 } profiler-gadget new-track { 0 1 } profiler-gadget new-track
dup <toolbar> f track-add* dup <toolbar> f track-add
<pane> >>pane <pane> >>pane
dup pane>> <scroller> 1 track-add* ; dup pane>> <scroller> 1 track-add ;
: with-profiler-pane ( gadget quot -- ) : with-profiler-pane ( gadget quot -- )
>r profiler-gadget-pane r> with-pane ; >r profiler-gadget-pane r> with-pane ;

4
extra/ui/tools/search/search.factor
View File

@ -62,9 +62,9 @@ search-field H{
: <live-search> ( string seq limited? presenter -- gadget ) : <live-search> ( string seq limited? presenter -- gadget )
{ 0 1 } live-search new-track { 0 1 } live-search new-track
<search-field> >>field <search-field> >>field
dup field>> f track-add* dup field>> f track-add
-roll <search-list> >>list -roll <search-list> >>list
dup list>> <scroller> 1 track-add* dup list>> <scroller> 1 track-add
swap swap
over field>> set-editor-string over field>> set-editor-string

8
extra/ui/tools/tools.factor
View File

@ -38,10 +38,10 @@ IN: ui.tools
<listener-gadget> >>listener <listener-gadget> >>listener
dup <workspace-book> >>book dup <workspace-book> >>book
dup <workspace-tabs> f track-add* dup <workspace-tabs> f track-add
dup book>> 1/5 track-add* dup book>> 1/5 track-add
dup listener>> 4/5 track-add* dup listener>> 4/5 track-add
dup <toolbar> f track-add* ; dup <toolbar> f track-add ;
: resize-workspace ( workspace -- ) : resize-workspace ( workspace -- )
dup track-sizes over control-value zero? [ dup track-sizes over control-value zero? [

10
extra/ui/tools/traceback/traceback.factor
View File

@ -30,13 +30,13 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
dup model>> dup model>>
{ 1 0 } <track> { 1 0 } <track>
over <datastack-display> 1/2 track-add* over <datastack-display> 1/2 track-add
swap <retainstack-display> 1/2 track-add* swap <retainstack-display> 1/2 track-add
1/3 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 ) : <namestack-display> ( model -- gadget )
[ [ continuation-name namestack. ] when* ] [ [ continuation-name namestack. ] when* ]

6
extra/ui/tools/walker/walker.factor
View File

@ -62,9 +62,9 @@ M: walker-gadget focusable-child*
swap >>status swap >>status
dup continuation>> <traceback-gadget> >>traceback dup continuation>> <traceback-gadget> >>traceback
dup <toolbar> f track-add* dup <toolbar> f track-add
dup status>> self <thread-status> f track-add* dup status>> self <thread-status> f track-add
dup traceback>> 1 track-add* ; dup traceback>> 1 track-add ;
: walker-help ( -- ) "ui-walker" help-window ; : walker-help ( -- ) "ui-walker" help-window ;

2
extra/ui/tools/workspace/workspace.factor
View File

@ -62,7 +62,7 @@ M: gadget tool-scroller drop f ;
: show-popup ( gadget workspace -- ) : show-popup ( gadget workspace -- )
dup hide-popup dup hide-popup
over >>popup over >>popup
over f track-add* drop over f track-add drop
request-focus ; request-focus ;
: show-titled-popup ( workspace gadget title -- ) : show-titled-popup ( workspace gadget title -- )

17
unfinished/compiler/frontend/frontend-tests.factor
View File

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

79
unfinished/compiler/frontend/frontend.factor
View File

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

10
unfinished/compiler/frontend/frontend-docs.factor → unfinished/compiler/tree/builder/builder-docs.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax sequences quotations words USING: help.markup help.syntax sequences quotations words
compiler.tree stack-checker.errors ; compiler.tree stack-checker.errors ;
IN: compiler.frontend IN: compiler.tree.builder
ARTICLE: "specializers" "Word specializers" 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." "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:" "The specialized version of a word which will be compiled by the compiler can be inspected:"
{ $subsection specialized-def } ; { $subsection specialized-def } ;
HELP: dataflow HELP: build-tree
{ $values { "quot" quotation } { "dataflow" node } } { $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." } { $notes "This is the first stage of the compiler." }
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ; { $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 } } { $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." } ; { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
HELP: specialized-def HELP: specialized-def

6
unfinished/compiler/tree/builder/builder-tests.factor Normal file
View File

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

99
unfinished/compiler/tree/builder/builder.factor
View File

@ -1,32 +1,79 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces kernel sequences compiler.tree USING: fry accessors quotations kernel sequences namespaces assocs
stack-checker.visitor ; 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 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 -- ) GENERIC# build-tree-with 1 ( quot stack -- dataflow )
dataflow-visitor get swap
over last>>
[ [ [ last>> ] dip >>successor drop ] [ >>last drop ] 2bi ]
[ [ >>first ] [ >>last ] bi drop ]
if ;
M: tree-builder child-visitor tree-builder new ; M: callable build-tree-with
M: tree-builder #introduce, #introduce node, ; #! Not safe to call from inference transforms.
M: tree-builder #call, #call node, ; [
M: tree-builder #call-recursive, #call-recursive node, ; >vector meta-d set
M: tree-builder #push, #push node, ; f infer-quot
M: tree-builder #shuffle, #shuffle node, ; ] with-tree-builder nip ;
M: tree-builder #drop, #drop node, ;
M: tree-builder #>r, #>r node, ; : build-tree ( quot -- dataflow ) f build-tree-with ;
M: tree-builder #r>, #r> node, ;
M: tree-builder #return, #return node, ; : (make-specializer) ( class picker -- quot )
M: tree-builder #terminate, #terminate node, ; swap "predicate" word-prop append ;
M: tree-builder #if, [ first>> ] bi@ #if node, ;
M: tree-builder #dispatch, [ first>> ] map #dispatch node, ; : make-specializer ( classes -- quot )
M: tree-builder #phi, #phi node, ; dup length <reversed>
M: tree-builder #declare, #declare node, ; [ (picker) 2array ] 2map
M: tree-builder #recursive, first>> #recursive node, ; [ drop object eq? not ] assoc-filter
M: tree-builder #copy, #copy node, ; 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 ;

17
unfinished/compiler/tree/combinators/combinators-tests.factor Normal file
View File

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

26
unfinished/compiler/tree/combinators/combinators.factor
View File

@ -5,18 +5,6 @@ sequences words vectors math.intervals effects classes
accessors combinators compiler.tree ; accessors combinators compiler.tree ;
IN: compiler.tree.combinators 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 SYMBOL: node-stack
: >node ( node -- ) node-stack get push ; : >node ( node -- ) node-stack get push ;
@ -34,8 +22,8 @@ SYMBOL: node-stack
: (each-node) ( quot -- next ) : (each-node) ( quot -- next )
node@ [ swap call ] 2keep node@ [ swap call ] 2keep
node-children [ children>> [
[ first>> [
[ (each-node) ] keep swap [ (each-node) ] keep swap
] iterate-nodes ] iterate-nodes
] each drop ] each drop
@ -52,15 +40,7 @@ SYMBOL: node-stack
] with-node-iterator ; inline ] with-node-iterator ; inline
: map-children ( node quot -- ) : map-children ( node quot -- )
over [ [ children>> ] dip '[ , change-first drop ] each ; inline
over children>> [
'[ , map ] change-children drop
] [
2drop
] if
] [
2drop
] if ; inline
: (transform-nodes) ( prev node quot -- ) : (transform-nodes) ( prev node quot -- )
dup >r call dup [ dup >r call dup [

50
unfinished/compiler/tree/comparisons/comparisons.factor Normal file
View File

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

42
unfinished/compiler/tree/copy-equiv/copy-equiv.factor Normal file
View File

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

4
unfinished/compiler/tree/dead-code/dead-code-tests.factor
View File

@ -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.dead-code compiler.tree.def-use compiler.tree
compiler.tree.combinators tools.test kernel math compiler.tree.combinators tools.test kernel math
stack-checker.state accessors ; stack-checker.state accessors ;
@ -7,7 +7,7 @@ IN: compiler.tree.dead-code.tests
\ remove-dead-code must-infer \ remove-dead-code must-infer
: count-live-values ( quot -- n ) : count-live-values ( quot -- n )
dataflow build-tree
compute-def-use compute-def-use
remove-dead-code remove-dead-code
compute-def-use compute-def-use

166
unfinished/compiler/tree/dead-code/dead-code.factor
View File

@ -1,106 +1,44 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors namespaces assocs dequeues search-dequeues USING: fry accessors namespaces assocs dequeues search-dequeues
kernel sequences words sets stack-checker.inlining compiler.tree kernel sequences words sets stack-checker.inlining
compiler.tree.combinators compiler.tree.def-use ; compiler.tree
compiler.tree.dfa
compiler.tree.dfa.backward
compiler.tree.combinators ;
IN: compiler.tree.dead-code IN: compiler.tree.dead-code
! Dead code elimination: remove #push and flushable #call whose ! Dead code elimination: remove #push and flushable #call whose
! outputs are unused. ! outputs are unused using backward DFA.
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 ;
GENERIC: mark-live-values ( node -- ) 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: #if mark-live-values look-at-inputs ;
M: #dispatch mark-live-values look-at-inputs ; M: #dispatch mark-live-values look-at-inputs ;
M: #call mark-live-values M: #call mark-live-values
dup word>> "flushable" word-prop [ drop ] [ dup word>> "flushable" word-prop
[ look-at-inputs ] [ drop ] [ [ look-at-inputs ] [ look-at-outputs ] bi ] if ;
[ look-at-outputs ]
bi
] if ;
M: #return mark-live-values M: #return mark-live-values
#! Values returned by local #recursive functions can be #! Values returned by local #recursive functions can be
#! killed if they're unused. #! killed if they're unused.
dup label>> dup label>> [ drop ] [ look-at-inputs ] if ;
[ drop ] [ look-at-inputs ] if ;
M: node mark-live-values drop ; M: node mark-live-values drop ;
GENERIC: propagate* ( value node -- ) SYMBOL: live-values
M: #copy propagate* : live-value? ( value -- ? ) live-values get at ;
#! 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 ;
: compute-live-values ( node -- ) : compute-live-values ( node -- )
#! We add f initially because #phi nodes can have f in their [ mark-live-values ] backward-dfa live-values set ;
#! 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 ;
GENERIC: remove-dead-values* ( node -- ) GENERIC: remove-dead-values* ( node -- )
M: #introduce remove-dead-values*
[ [ live-value? ] filter ] change-values drop ;
M: #>r remove-dead-values* M: #>r remove-dead-values*
dup out-r>> first live-value? [ { } >>out-r ] unless dup out-r>> first live-value? [ { } >>out-r ] unless
dup in-d>> first live-value? [ { } >>in-d ] 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' ) : filter-corresponding-values ( in out -- in' out' )
zip live-values get '[ drop _ , key? ] assoc-filter unzip ; 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' ) : filter-live ( values -- values' )
[ live-value? ] filter ; [ live-value? ] filter ;
@ -133,9 +64,16 @@ M: #shuffle remove-dead-values*
[ filter-live ] change-out-d [ filter-live ] change-out-d
drop ; 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 ) : remove-dead-phi-d ( #phi -- #phi )
dup dup
@ -156,46 +94,54 @@ M: #phi remove-dead-values*
M: node remove-dead-values* drop ; M: node remove-dead-values* drop ;
M: f remove-dead-values* drop ;
GENERIC: remove-dead-nodes* ( node -- newnode/t ) 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 -- ? ) : live-call? ( #call -- ? )
out-d>> [ live-value? ] contains? ; out-d>> [ live-value? ] contains? ;
M: #declare remove-dead-nodes* dup declaration>> prune-if-empty ;
M: #call remove-dead-nodes* M: #call remove-dead-nodes*
dup live-call? [ drop t ] [ dup live-call? [ drop t ] [
[ in-d>> #drop ] [ successor>> ] bi >>successor [ in-d>> #drop ] [ successor>> ] bi >>successor
] if ; ] if ;
: prune-if ( node quot -- successor/t ) M: #shuffle remove-dead-nodes* dup in-d>> prune-if-empty ;
over >r call [ r> successor>> ] [ r> drop t ] if ;
inline
M: #shuffle remove-dead-nodes* M: #push remove-dead-nodes* dup out-d>> prune-if-empty ;
[ in-d>> empty? ] prune-if ;
M: #push remove-dead-nodes* M: #>r remove-dead-nodes* dup in-d>> prune-if-empty ;
[ out-d>> empty? ] prune-if ;
M: #>r remove-dead-nodes* M: #r> remove-dead-nodes* dup in-r>> prune-if-empty ;
[ in-d>> empty? ] prune-if ;
M: #r> remove-dead-nodes* M: #copy remove-dead-nodes* dup in-d>> prune-if-empty ;
[ in-r>> empty? ] prune-if ;
: (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 ; M: node remove-dead-nodes* drop t ;
: (remove-dead-code) ( node -- newnode ) M: f remove-dead-nodes* drop t ;
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 ;
: remove-dead-code ( node -- newnode ) : remove-dead-code ( node -- newnode )
[ [ [ compute-live-values ] [ (remove-dead-code) ] bi ] with-scope ;
[ compute-live-values ]
[ [ (remove-dead-code) ] transform-nodes ] bi
] with-scope ;

6
unfinished/compiler/tree/def-use/def-use-tests.factor
View File

@ -1,13 +1,13 @@
USING: accessors namespaces assocs kernel sequences math USING: accessors namespaces assocs kernel sequences math
tools.test words sets combinators.short-circuit 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 ; compiler.tree.def-use arrays kernel.private ;
IN: compiler.tree.def-use.tests IN: compiler.tree.def-use.tests
\ compute-def-use must-infer \ compute-def-use must-infer
[ t ] [ [ t ] [
[ 1 2 3 ] dataflow compute-def-use drop [ 1 2 3 ] build-tree compute-def-use drop
def-use get { def-use get {
[ assoc-size 3 = ] [ assoc-size 3 = ]
[ values [ uses>> [ #return? ] all? ] all? ] [ values [ uses>> [ #return? ] all? ] all? ]
@ -29,5 +29,5 @@ IN: compiler.tree.def-use.tests
[ [ 1 ] [ call 2 ] curry call + ] [ [ 1 ] [ call 2 ] curry call + ]
[ [ 1 ] [ 2 ] compose swap [ 1 ] [ 2 ] if + * ] [ [ 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 ] each

4
unfinished/compiler/tree/def-use/def-use.factor
View File

@ -28,6 +28,8 @@ TUPLE: definition value node uses ;
GENERIC: node-uses-values ( node -- values ) GENERIC: node-uses-values ( node -- values )
M: #declare node-uses-values declaration>> keys ;
M: #phi node-uses-values M: #phi node-uses-values
[ phi-in-d>> concat ] [ phi-in-r>> concat ] bi [ phi-in-d>> concat ] [ phi-in-r>> concat ] bi
append sift prune ; append sift prune ;
@ -42,6 +44,8 @@ M: #introduce node-defs-values values>> ;
M: #>r node-defs-values out-r>> ; 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>> ; M: node node-defs-values out-d>> ;
: node-def-use ( node -- ) : node-def-use ( node -- )

40
unfinished/compiler/tree/dfa/backward/backward.factor Normal file
View File

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

40
unfinished/compiler/tree/dfa/dfa.factor Normal file
View File

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

53
unfinished/compiler/tree/propagation/branches/branches.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: fry kernel sequences assocs accessors namespaces USING: fry kernel sequences assocs accessors namespaces
math.intervals arrays classes.algebra math.intervals arrays classes.algebra locals
compiler.tree compiler.tree
compiler.tree.def-use compiler.tree.def-use
compiler.tree.propagation.info compiler.tree.propagation.info
@ -14,19 +14,36 @@ IN: compiler.tree.propagation.branches
GENERIC: child-constraints ( node -- seq ) GENERIC: child-constraints ( node -- seq )
M: #if child-constraints M: #if child-constraints
in-d>> first in-d>> first [ =t ] [ =f ] bi 2array ;
[ <true-constraint> ] [ <false-constraint> ] 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 ) : infer-children ( node -- assocs )
[ children>> ] [ child-constraints ] bi [ [ live-children ] [ child-constraints ] bi [
[ [
value-infos [ clone ] change over [
constraints [ clone ] change value-infos [ clone ] change
assume constraints [ clone ] change
(propagate) assume
first>> (propagate)
] [
2drop
value-infos off
constraints off
] if
] H{ } make-assoc ] H{ } make-assoc
] 2map ; ] 2map ;
@ -37,13 +54,23 @@ M: #dispatch child-constraints drop f ;
[ swap (merge-value-infos) ] dip set-value-infos ; [ swap (merge-value-infos) ] dip set-value-infos ;
: propagate-branch-phi ( results #phi -- ) : propagate-branch-phi ( results #phi -- )
[ nip node-defs-values [ introduce-value ] each ]
[ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ] [ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ]
[ [ phi-in-r>> ] [ out-r>> ] 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 -- ) : 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 M: #branch propagate-around
[ infer-children ] [ merge-children ] [ annotate-node ] tri ; [ infer-children ] [ merge-children ] [ annotate-node ] tri ;

60
unfinished/compiler/tree/propagation/constraints/constraints.factor
View File

@ -2,7 +2,9 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs math math.intervals kernel accessors USING: arrays assocs math math.intervals kernel accessors
sequences namespaces disjoint-sets classes classes.algebra 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 IN: compiler.tree.propagation.constraints
! A constraint is a statement about a value. ! A constraint is a statement about a value.
@ -12,25 +14,25 @@ SYMBOL: constraints
GENERIC: assume ( constraint -- ) GENERIC: assume ( constraint -- )
GENERIC: satisfied? ( constraint -- ? ) GENERIC: satisfied? ( constraint -- ? )
GENERIC: satisfiable? ( constraint -- ? )
! Boolean constraints ! Boolean constraints
TUPLE: true-constraint value ; TUPLE: true-constraint value ;
: <true-constraint> ( value -- constriant ) : =t ( value -- constriant ) resolve-copy true-constraint boa ;
resolve-copy true-constraint boa ;
M: true-constraint assume M: true-constraint assume
[ constraints get at [ assume ] when* ] [ constraints get at [ assume ] when* ]
[ \ f class-not <class-info> swap value>> refine-value-info ] [ \ f class-not <class-info> swap value>> refine-value-info ]
bi ; bi ;
M: true-constraint satisfied? M: true-constraint satisfied? value>> \ f class-not value-is? ;
value>> value-info class>> \ f class-not class<= ;
M: true-constraint satisfiable? value>> \ f class-not value-is? ;
TUPLE: false-constraint value ; TUPLE: false-constraint value ;
: <false-constraint> ( value -- constriant ) : =f ( value -- constriant ) resolve-copy false-constraint boa ;
resolve-copy false-constraint boa ;
M: false-constraint assume M: false-constraint assume
[ constraints get at [ assume ] when* ] [ constraints get at [ assume ] when* ]
@ -38,12 +40,15 @@ M: false-constraint assume
bi ; bi ;
M: false-constraint satisfied? 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 ! Class constraints
TUPLE: class-constraint value class ; TUPLE: class-constraint value class ;
: <class-constraint> ( value class -- constraint ) : is-instance-of ( value class -- constraint )
[ resolve-copy ] dip class-constraint boa ; [ resolve-copy ] dip class-constraint boa ;
M: class-constraint assume M: class-constraint assume
@ -52,7 +57,7 @@ M: class-constraint assume
! Interval constraints ! Interval constraints
TUPLE: interval-constraint value interval ; TUPLE: interval-constraint value interval ;
: <interval-constraint> ( value interval -- constraint ) : is-in-interval ( value interval -- constraint )
[ resolve-copy ] dip interval-constraint boa ; [ resolve-copy ] dip interval-constraint boa ;
M: interval-constraint assume M: interval-constraint assume
@ -61,7 +66,7 @@ M: interval-constraint assume
! Literal constraints ! Literal constraints
TUPLE: literal-constraint value literal ; TUPLE: literal-constraint value literal ;
: <literal-constraint> ( value literal -- constraint ) : is-equal-to ( value literal -- constraint )
[ resolve-copy ] dip literal-constraint boa ; [ resolve-copy ] dip literal-constraint boa ;
M: literal-constraint assume M: literal-constraint assume
@ -70,29 +75,48 @@ M: literal-constraint assume
! Implication constraints ! Implication constraints
TUPLE: implication p q ; TUPLE: implication p q ;
C: <implication> implication C: --> implication
M: implication assume M: implication assume
[ q>> ] [ p>> ] bi [ q>> ] [ p>> ] bi
[ constraints get set-at ] [ constraints get set-at ]
[ satisfied? [ assume ] [ drop ] if ] 2bi ; [ satisfied? [ assume ] [ drop ] if ] 2bi ;
M: implication satisfiable?
[ q>> satisfiable? ] [ p>> satisfiable? not ] bi or ;
! Conjunction constraints ! Conjunction constraints
TUPLE: conjunction p q ; TUPLE: conjunction p q ;
C: <conjunction> conjunction C: /\ conjunction
M: conjunction assume [ p>> assume ] [ q>> assume ] bi ; 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 ! No-op
M: f assume drop ; M: f assume drop ;
! Utilities ! Utilities
: if-true ( constraint boolean-value -- constraint' ) : t--> ( constraint boolean-value -- constraint' ) =t swap --> ;
<true-constraint> swap <implication> ;
: if-false ( constraint boolean-value -- constraint' ) : f--> ( constraint boolean-value -- constraint' ) =f swap --> ;
<false-constraint> swap <implication> ;
: <conditional> ( true-constr false-constr boolean-value -- constraint ) : <conditional> ( true-constr false-constr boolean-value -- constraint )
tuck [ if-true ] [ if-false ] 2bi* <conjunction> ; tuck [ t--> ] [ f--> ] 2bi* /\ ;

13
unfinished/compiler/tree/propagation/info/info-tests.factor
View File

@ -2,6 +2,8 @@ USING: accessors math math.intervals sequences classes.algebra
math kernel tools.test compiler.tree.propagation.info ; math kernel tools.test compiler.tree.propagation.info ;
IN: compiler.tree.propagation.info.tests IN: compiler.tree.propagation.info.tests
[ f ] [ 0.0 -0.0 eql? ] unit-test
[ t ] [ [ t ] [
number <class-info> number <class-info>
sequence <class-info> sequence <class-info>
@ -48,3 +50,14 @@ IN: compiler.tree.propagation.info.tests
2 3 (a,b] <interval-info> fixnum <class-info> 2 3 (a,b] <interval-info> fixnum <class-info>
value-info-intersect >literal< value-info-intersect >literal<
] unit-test ] 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

184
unfinished/compiler/tree/propagation/info/info.factor
View File

@ -1,77 +1,99 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes classes.algebra kernel accessors math USING: assocs classes classes.algebra kernel accessors math
math.intervals namespaces disjoint-sets sequences words math.intervals namespaces sequences words combinators arrays
combinators ; compiler.tree.copy-equiv ;
IN: compiler.tree.propagation.info IN: compiler.tree.propagation.info
SYMBOL: +interval+ SYMBOL: +interval+
GENERIC: eql? ( obj1 obj2 -- ? ) GENERIC: eql? ( obj1 obj2 -- ? )
M: object eql? eq? ; M: object eql? eq? ;
M: number eql? [ [ class ] bi@ = ] [ number= ] 2bi and ; M: fixnum eql? eq? ;
M: bignum eql? over bignum? [ = ] [ 2drop f ] if ;
! Disjoint set of copy equivalence M: ratio eql? over ratio? [ = ] [ 2drop f ] if ;
SYMBOL: copies M: float eql? over float? [ [ double>bits ] bi@ = ] [ 2drop f ] if ;
M: complex eql? over complex? [ = ] [ 2drop f ] if ;
: 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 ;
! Value info represents a set of objects. Don't mutate value infos ! Value info represents a set of objects. Don't mutate value infos
! you receive, always construct new ones. We don't declare the ! you receive, always construct new ones. We don't declare the
! slots read-only to allow cloning followed by writing. ! slots read-only to allow cloning followed by writing.
TUPLE: value-info TUPLE: value-info
{ class initial: null } { class initial: null }
interval { interval initial: empty-interval }
literal literal
literal? ; literal?
length ;
: class-interval ( class -- interval ) : class-interval ( class -- interval )
dup real class<= dup real class<=
[ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ; [ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ;
: interval>literal ( class interval -- literal literal? ) : interval>literal ( class interval -- literal literal? )
dup from>> first { #! If interval has zero length and the class is sufficiently
{ [ over interval-length 0 > ] [ 3drop f f ] } #! precise, we can turn it into a literal
{ [ over from>> second not ] [ 3drop f f ] } dup empty-interval eq? [
{ [ over to>> second not ] [ 3drop f f ] } 2drop 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
] [ ] [
drop dup from>> first {
over null class<= [ drop f f f ] [ { [ over interval-length 0 > ] [ 3drop f f ] }
over integer class<= [ integral-closure ] when { [ pick bignum class<= ] [ 2nip >bignum t ] }
2dup interval>literal { [ 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
] if ] if ;
\ value-info boa ; foldable
: <class/interval-info> ( class interval -- info )
<value-info>
swap >>interval
swap >>class
init-value-info ; foldable
: <class-info> ( class -- info ) : <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 ) : <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 ) : <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? ) : intersect-literals ( info1 info2 -- literal literal? )
{ {
@ -81,21 +103,30 @@ literal? ;
[ drop >literal< ] [ drop >literal< ]
} cond ; } cond ;
: interval-intersect' ( i1 i2 -- i3 ) DEFER: value-info-intersect
#! Change core later.
2dup and [ interval-intersect ] [ 2drop f ] if ;
: value-info-intersect ( info1 info2 -- info ) : intersect-lengths ( info1 info2 -- length )
[ [ class>> ] bi@ class-and ] [ length>> ] bi@ {
[ [ interval>> ] bi@ interval-intersect' ]
[ intersect-literals ]
2tri <value-info> ;
: interval-union' ( i1 i2 -- i3 )
{
{ [ dup not ] [ drop ] } { [ dup not ] [ drop ] }
{ [ over not ] [ nip ] } { [ 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 ; } cond ;
: union-literals ( info1 info2 -- literal literal? ) : union-literals ( info1 info2 -- literal literal? )
@ -103,11 +134,31 @@ literal? ;
[ literal>> ] bi@ 2dup eql? [ drop t ] [ 2drop f f ] if [ literal>> ] bi@ 2dup eql? [ drop t ] [ 2drop f f ] if
] [ 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 ) : value-info-union ( info1 info2 -- info )
[ [ class>> ] bi@ class-or ] {
[ [ interval>> ] bi@ interval-union' ] { [ dup class>> null class<= ] [ drop ] }
[ union-literals ] { [ over class>> null class<= ] [ nip ] }
2tri <value-info> ; [ (value-info-union) ]
} cond ;
: value-infos-union ( infos -- info ) : value-infos-union ( infos -- info )
dup first [ value-info-union ] reduce ; dup first [ value-info-union ] reduce ;
@ -126,3 +177,18 @@ SYMBOL: value-infos
: value-literal ( value -- obj ? ) : value-literal ( value -- obj ? )
value-info >literal< ; 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<= ;

230
unfinished/compiler/tree/propagation/known-words/known-words.factor
View File

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

5
unfinished/compiler/tree/propagation/nodes/nodes.factor
View File

@ -16,9 +16,6 @@ GENERIC: propagate-around ( node -- )
: (propagate) ( node -- ) : (propagate) ( node -- )
[ [
[ node-defs-values [ introduce-value ] each ] [ propagate-around ] [ successor>> ] bi
[ propagate-around ]
[ successor>> ]
tri
(propagate) (propagate)
] when* ; ] when* ;

162
unfinished/compiler/tree/propagation/propagation-tests.factor
View File

@ -1,10 +1,20 @@
USING: kernel compiler.frontend compiler.tree USING: kernel compiler.tree.builder compiler.tree
compiler.tree.propagation tools.test math accessors compiler.tree.propagation compiler.tree.copy-equiv
sequences arrays kernel.private ; 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 IN: compiler.tree.propagation.tests
\ propagate must-infer
\ propagate/node must-infer
: final-info ( quot -- seq ) : 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-classes ( quot -- seq )
final-info [ class>> ] map ; final-info [ class>> ] map ;
@ -64,7 +74,7 @@ IN: compiler.tree.propagation.tests
[ { null null } declare + ] final-classes [ { null null } declare + ] final-classes
] unit-test ] unit-test
[ V{ fixnum } ] [ [ V{ null } ] [
[ { null fixnum } declare + ] final-classes [ { null fixnum } declare + ] final-classes
] unit-test ] unit-test
@ -87,3 +97,145 @@ IN: compiler.tree.propagation.tests
[ V{ fixnum } ] [ [ V{ fixnum } ] [
[ >fixnum dup 10 > [ 1 - ] when ] final-classes [ >fixnum dup 10 > [ 1 - ] when ] final-classes
] unit-test ] 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

2
unfinished/compiler/tree/propagation/propagation.factor
View File

@ -1,7 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences namespaces hashtables USING: accessors kernel sequences namespaces hashtables
disjoint-sets
compiler.tree compiler.tree
compiler.tree.def-use compiler.tree.def-use
compiler.tree.propagation.info compiler.tree.propagation.info
@ -17,7 +16,6 @@ IN: compiler.tree.propagation
[ [
H{ } clone constraints set H{ } clone constraints set
>hashtable value-infos set >hashtable value-infos set
<disjoint-set> copies set
(propagate) (propagate)
] with-scope ; ] with-scope ;

12
unfinished/compiler/tree/propagation/recursive/recursive.factor
View File

@ -8,6 +8,12 @@ compiler.tree.propagation.simple
compiler.tree.propagation.branches ; compiler.tree.propagation.branches ;
IN: compiler.tree.propagation.recursive 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 ) : (merge-value-infos) ( inputs -- infos )
[ [ value-info ] map value-infos-union ] map ; [ [ value-info ] map value-infos-union ] map ;
@ -22,11 +28,9 @@ IN: compiler.tree.propagation.recursive
M: #recursive propagate-around ( #recursive -- ) M: #recursive propagate-around ( #recursive -- )
dup dup
[ children>> (propagate) ] node-child
[ node-child propagate-recursive-phi ] bi [ first>> (propagate) ] [ propagate-recursive-phi ] bi
[ drop ] [ propagate-around ] if ; [ drop ] [ propagate-around ] if ;
M: #call-recursive propagate-before ( #call-label -- ) 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 ; [ label>> returns>> flip ] [ out-d>> ] bi merge-value-infos drop ;

98
unfinished/compiler/tree/propagation/simple/simple.factor
View File

@ -1,8 +1,10 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors kernel sequences assocs words namespaces USING: fry accessors kernel sequences sequences.private assocs
classes.algebra combinators classes words namespaces classes.algebra combinators classes
continuations arrays byte-arrays strings
compiler.tree compiler.tree
compiler.tree.def-use
compiler.tree.propagation.info compiler.tree.propagation.info
compiler.tree.propagation.nodes compiler.tree.propagation.nodes
compiler.tree.propagation.constraints ; compiler.tree.propagation.constraints ;
@ -25,34 +27,20 @@ M: #push propagate-before
[ set-value-info ] 2each ; [ set-value-info ] 2each ;
M: #declare propagate-before M: #declare propagate-before
[ [ in-d>> ] [ out-d>> ] bi are-copies-of ] declaration>> [ <class-info> swap refine-value-info ] assoc-each ;
[
[ 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 ;
: predicate-constraints ( value class boolean-value -- constraint ) : predicate-constraints ( value class boolean-value -- constraint )
[ [ <class-constraint> ] dip if-true ] [ [ is-instance-of ] dip t--> ]
[ [ class-not <class-constraint> ] dip if-false ] [ [ class-not is-instance-of ] dip f--> ]
3bi <conjunction> ; 3bi /\ ;
: compute-constraints ( #call -- constraint ) : custom-constraints ( #call quot -- )
dup word>> +constraints+ word-prop [ call assume ] [ [ [ in-d>> ] [ out-d>> ] bi append ] dip
dup word>> predicate? with-datastack first assume ;
[
: compute-constraints ( #call -- )
dup word>> +constraints+ word-prop [ custom-constraints ] [
dup word>> predicate? [
[ in-d>> first ] [ in-d>> first ]
[ word>> "predicating" word-prop ] [ word>> "predicating" word-prop ]
[ out-d>> first ] [ out-d>> first ]
@ -60,6 +48,24 @@ M: #copy propagate-before
] [ drop ] if ] [ drop ] if
] 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 ) : default-output-value-infos ( node -- infos )
dup word>> "default-output-classes" word-prop [ dup word>> "default-output-classes" word-prop [
class-infos class-infos
@ -67,16 +73,37 @@ M: #copy propagate-before
out-d>> length object <class-info> <repetition> out-d>> length object <class-info> <repetition>
] ?if ; ] ?if ;
: call-outputs-quot ( node quot -- infos ) UNION: fixed-length-sequence array byte-array string ;
[ in-d>> [ value-info ] map ] dip with-datastack ;
: output-value-infos ( node word -- infos ) : sequence-constructor? ( node -- ? )
dup word>> +outputs+ word-prop word>> { <array> <byte-array> <string> } memq? ;
[ call-outputs-quot ] [ default-output-value-infos ] if* ;
: 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 M: #call propagate-before
[ [ output-value-infos ] [ out-d>> ] bi set-value-infos ]
[ compute-constraints ] [ compute-constraints ]
[ [ output-value-infos ] [ out-d>> ] bi set-value-infos ] bi ; bi ;
M: node propagate-before drop ; M: node propagate-before drop ;
@ -90,7 +117,10 @@ M: #call propagate-after
M: node propagate-after drop ; M: node propagate-after drop ;
: annotate-node ( node -- ) : 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 M: node propagate-around
[ propagate-before ] [ annotate-node ] [ propagate-after ] tri ; [ propagate-before ] [ annotate-node ] [ propagate-after ] tri ;

47
unfinished/compiler/tree/tree.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs kernel math namespaces parser USING: arrays generic assocs kernel math namespaces parser
sequences words vectors math.intervals effects classes sequences words vectors math.intervals effects classes
accessors combinators stack-checker.state ; accessors combinators stack-checker.state stack-checker.visitor ;
IN: compiler.tree IN: compiler.tree
! High-level tree SSA form. ! 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 ! case of a #phi node, the sequence of sequences in the phi-in-r
! and phi-in-d slots. ! and phi-in-d slots.
! 3) A value is never used in the same node where it is defined. ! 3) A value is never used in the same node where it is defined.
TUPLE: node < identity-tuple TUPLE: node < identity-tuple
in-d out-d in-r out-r info in-d out-d in-r out-r info
history successor children ; successor children ;
M: node hashcode* drop node hashcode* ; 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 ; : node-child ( node -- child ) children>> first ;
: last-node ( node -- last ) : last-node ( node -- last )
@ -57,7 +49,7 @@ TUPLE: #introduce < node values ;
: #introduce ( values -- node ) : #introduce ( values -- node )
\ #introduce new swap >>values ; \ #introduce new swap >>values ;
TUPLE: #call < node word ; TUPLE: #call < node word history ;
: #call ( inputs outputs word -- node ) : #call ( inputs outputs word -- node )
\ #call new \ #call new
@ -137,11 +129,9 @@ TUPLE: #phi < node phi-in-d phi-in-r ;
TUPLE: #declare < node declaration ; TUPLE: #declare < node declaration ;
: #declare ( inputs outputs declaration -- node ) : #declare ( declaration -- node )
\ #declare new \ #declare new
swap >>declaration swap >>declaration ;
swap >>out-d
swap >>in-d ;
TUPLE: #return < node label ; TUPLE: #return < node label ;
@ -172,3 +162,30 @@ DEFER: #tail?
PREDICATE: #tail-phi < #phi successor>> #tail? ; PREDICATE: #tail-phi < #phi successor>> #tail? ;
UNION: #tail POSTPONE: f #return #tail-phi #terminate ; 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, ;

50
unfinished/compiler/tree/untupling/untupling-tests.factor Normal file
View File

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

59
unfinished/compiler/tree/untupling/untupling.factor Normal file
View File

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

23
unfinished/stack-checker/backend/backend.factor
View File

@ -11,6 +11,8 @@ IN: stack-checker.backend
! Word properties we use ! Word properties we use
SYMBOL: +inferred-effect+ SYMBOL: +inferred-effect+
SYMBOL: +cannot-infer+ SYMBOL: +cannot-infer+
SYMBOL: +special+
SYMBOL: +shuffle+
SYMBOL: +infer+ SYMBOL: +infer+
SYMBOL: visited SYMBOL: visited
@ -174,7 +176,7 @@ M: object apply-object push-literal ;
[ [
init-inference init-inference
init-known-values init-known-values
dataflow-visitor off stack-visitor off
dependencies off dependencies off
[ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ] [ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ]
[ finish-word current-effect ] [ finish-word current-effect ]
@ -191,32 +193,19 @@ M: object apply-object push-literal ;
: call-recursive-word ( word -- ) : call-recursive-word ( word -- )
dup required-stack-effect apply-word/effect ; dup required-stack-effect apply-word/effect ;
: custom-infer ( word -- )
[ +inlined+ depends-on ] [ +infer+ word-prop call ] bi ;
: cached-infer ( word -- ) : cached-infer ( word -- )
dup +inferred-effect+ word-prop apply-word/effect ; 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 ) : with-infer ( quot -- effect visitor )
[ [
[ [
V{ } clone recorded set V{ } clone recorded set
init-inference init-inference
init-known-values init-known-values
dataflow-visitor off stack-visitor off
call call
end-infer end-infer
current-effect current-effect
dataflow-visitor get stack-visitor get
] [ ] [ undo-infer ] cleanup ] [ ] [ undo-infer ] cleanup
] with-scope ; ] with-scope ; inline

17
unfinished/stack-checker/branches/branches.factor
View File

@ -65,10 +65,21 @@ SYMBOL: quotations
: infer-branches ( branches -- input children data ) : infer-branches ( branches -- input children data )
[ pop-d ] dip [ pop-d ] dip
[ infer-branch ] map [ 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-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 ; infer-branches [ #dispatch, ] dip compute-phi-function ;

5
unfinished/stack-checker/inlining/inlining.factor
View File

@ -6,7 +6,8 @@ stack-checker.state
stack-checker.visitor stack-checker.visitor
stack-checker.backend stack-checker.backend
stack-checker.branches stack-checker.branches
stack-checker.errors ; stack-checker.errors
stack-checker.known-words ;
IN: stack-checker.inlining IN: stack-checker.inlining
! Code to handle inline words. Much of the complexity stems from ! Code to handle inline words. Much of the complexity stems from
@ -80,7 +81,7 @@ SYMBOL: phi-out
dup recursive-word-inputs dup recursive-word-inputs
meta-d get meta-d get
dataflow-visitor get stack-visitor get
] with-scope ; ] with-scope ;
: inline-recursive-word ( word -- ) : inline-recursive-word ( word -- )

497
unfinished/stack-checker/known-words/known-words.factor
View File

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

2
unfinished/stack-checker/stack-checker-tests.factor
View File

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

39
unfinished/stack-checker/transforms/transforms.factor
View File

@ -3,24 +3,43 @@
USING: fry accessors arrays kernel words sequences generic math USING: fry accessors arrays kernel words sequences generic math
namespaces quotations assocs combinators classes.tuple namespaces quotations assocs combinators classes.tuple
classes.tuple.private effects summary hashtables classes generic 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 ; stack-checker.backend stack-checker.state stack-checker.errors ;
IN: stack-checker.transforms IN: stack-checker.transforms
: transform-quot ( quot n -- newquot ) SYMBOL: +transform-quot+
SYMBOL: +transform-n+
: (apply-transform) ( quot n -- newquot )
dup zero? [ dup zero? [
drop '[ recursive-state get @ ] drop recursive-state get 1array
] [ ] [
swap '[ consume-d
, consume-d [ [ literal value>> ] map ]
[ first literal recursion>> ] [ first literal recursion>> ] bi prefix
[ [ literal value>> ] each ] bi @
]
] if ] 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 -- ) : 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 ! Combinators
\ cond [ cond>quot ] 1 define-transform \ cond [ cond>quot ] 1 define-transform

2
unfinished/stack-checker/visitor/dummy/dummy.factor
View File

@ -16,7 +16,7 @@ M: f #terminate, ;
M: f #if, 3drop ; M: f #if, 3drop ;
M: f #dispatch, 2drop ; M: f #dispatch, 2drop ;
M: f #phi, 2drop 2drop ; M: f #phi, 2drop 2drop ;
M: f #declare, 3drop ; M: f #declare, drop ;
M: f #recursive, drop drop drop drop drop ; M: f #recursive, drop drop drop drop drop ;
M: f #copy, 2drop ; M: f #copy, 2drop ;
M: f #drop, drop ; M: f #drop, drop ;

38
unfinished/stack-checker/visitor/visitor.factor
View File

@ -3,25 +3,25 @@
USING: kernel arrays namespaces ; USING: kernel arrays namespaces ;
IN: stack-checker.visitor 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: #introduce, stack-visitor ( values -- )
HOOK: #call, dataflow-visitor ( inputs outputs word -- ) HOOK: #call, stack-visitor ( inputs outputs word -- )
HOOK: #call-recursive, dataflow-visitor ( inputs outputs word -- ) HOOK: #call-recursive, stack-visitor ( inputs outputs word -- )
HOOK: #push, dataflow-visitor ( literal value -- ) HOOK: #push, stack-visitor ( literal value -- )
HOOK: #shuffle, dataflow-visitor ( inputs outputs mapping -- ) HOOK: #shuffle, stack-visitor ( inputs outputs mapping -- )
HOOK: #drop, dataflow-visitor ( values -- ) HOOK: #drop, stack-visitor ( values -- )
HOOK: #>r, dataflow-visitor ( inputs outputs -- ) HOOK: #>r, stack-visitor ( inputs outputs -- )
HOOK: #r>, dataflow-visitor ( inputs outputs -- ) HOOK: #r>, stack-visitor ( inputs outputs -- )
HOOK: #terminate, dataflow-visitor ( -- ) HOOK: #terminate, stack-visitor ( -- )
HOOK: #if, dataflow-visitor ( ? true false -- ) HOOK: #if, stack-visitor ( ? true false -- )
HOOK: #dispatch, dataflow-visitor ( n branches -- ) HOOK: #dispatch, stack-visitor ( n branches -- )
HOOK: #phi, dataflow-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- ) HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- )
HOOK: #declare, dataflow-visitor ( inputs outputs declaration -- ) HOOK: #declare, stack-visitor ( declaration -- )
HOOK: #return, dataflow-visitor ( label stack -- ) HOOK: #return, stack-visitor ( label stack -- )
HOOK: #recursive, dataflow-visitor ( word label inputs outputs visitor -- ) HOOK: #recursive, stack-visitor ( word label inputs outputs visitor -- )
HOOK: #copy, dataflow-visitor ( inputs outputs -- ) HOOK: #copy, stack-visitor ( inputs outputs -- )