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

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

db4
Doug Coleman 2008-08-07 17:32:01 -05:00
parent 45d96fdf33 708e24fcb0
commit 04206eb552
61 changed files with 727 additions and 407 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

0
extra/colors/authors.txt → basis/colors/authors.txt
View File

0
extra/colors/colors.factor → basis/colors/colors.factor
View File

0
extra/colors/hsv/authors.txt → basis/colors/hsv/authors.txt
View File

0
extra/colors/hsv/hsv.factor → basis/colors/hsv/hsv.factor
View File

5
basis/disjoint-sets/disjoint-sets.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hints kernel locals math hashtables
assocs fry ;
assocs fry sequences ;
IN: disjoint-sets
TUPLE: disjoint-set
@ -65,6 +64,8 @@ M: disjoint-set add-atom
[ 1 -rot counts>> set-at ]
2tri ;
: add-atoms ( seq disjoint-set -- ) '[ , add-atom ] each ;
GENERIC: equiv-set-size ( a disjoint-set -- n )
M: disjoint-set equiv-set-size [ representative ] keep count ;

6
basis/persistent/hashtables/hashtables-tests.factor
View File

@ -10,6 +10,10 @@ tools.test kernel namespaces random math.ranges sequences fry ;
[ f ] [ "X" PH{ { "A" "B" } } at ] unit-test
! We have to define these first so that they're compiled before
! the below hashtables are parsed...
<<
TUPLE: hash-0-a ;
M: hash-0-a hashcode* 2drop 0 ;
@ -18,6 +22,8 @@ TUPLE: hash-0-b ;
M: hash-0-b hashcode* 2drop 0 ;
>>
[ ] [
PH{ }
"a" T{ hash-0-a } rot new-at

7
basis/persistent/hashtables/hashtables.factor
View File

@ -41,6 +41,13 @@ M: persistent-hash >alist [ root>> >alist% ] { } make ;
: >persistent-hash ( assoc -- phash )
T{ persistent-hash } swap [ spin new-at ] assoc-each ;
M: persistent-hash equal?
over persistent-hash? [ assoc= ] [ 2drop f ] if ;
M: persistent-hash hashcode* nip assoc-size ;
M: persistent-hash clone ;
: PH{ \ } [ >persistent-hash ] parse-literal ; parsing
M: persistent-hash pprint-delims drop \ PH{ \ } ;

18
basis/persistent/sequences/sequences-docs.factor
View File

@ -3,15 +3,21 @@ USING: help.markup help.syntax math sequences kernel ;
HELP: new-nth
{ $values { "val" object } { "i" integer } { "seq" sequence } { "seq'" sequence } }
{ $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." }
{ $notes "This operation runs in " { $snippet "O(log_32 n)" } " time on " { $link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
{ $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." } ;
HELP: ppush
{ $values { "val" object } { "seq" sequence } { "seq'" sequence } }
{ $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." }
{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
{ $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." } ;
HELP: ppop
{ $values { "seq" sequence } { "seq'" sequence } }
{ $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." }
{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
{ $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." } ;
ARTICLE: "persistent.sequences" "Persistent sequence protocol"
"The persistent sequence protocol consists of the non-mutating sequence protocol words, such as " { $link length } " and " { $link nth } ", together with the following operations:"
{ $subsection new-nth }
{ $subsection ppush }
{ $subsection ppop }
"The default implementations of the above run in " { $snippet "O(n)" } " time; the " { $vocab-link "persistent.vectors" } " vocabulary provides an implementation of these operations in " { $snippet "O(1)" } " time." ;
ABOUT: "persistent.sequences"

12
basis/persistent/vectors/vectors-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax kernel math sequences ;
IN: persistent-vectors
IN: persistent.vectors
HELP: PV{
{ $syntax "elements... }" }
@ -12,17 +12,11 @@ HELP: >persistent-vector
HELP: persistent-vector
{ $class-description "The class of persistent vectors." } ;
ARTICLE: "persistent-vectors" "Persistent vectors"
ARTICLE: "persistent.vectors" "Persistent vectors"
"A " { $emphasis "persistent vector" } " differs from an ordinary vector (" { $link "vectors" } ") in that it is immutable, and all operations yield new persistent vectors instead of modifying inputs. Unlike immutable operations on ordinary sequences, persistent vector operations are efficient and run in sub-linear time."
$nl
"The class of persistent vectors:"
{ $subsection persistent-vector }
"Persistent vectors support the immutable sequence protocol, namely as " { $link length } " and " { $link nth } ", and so can be used with most sequence words (" { $link "sequences" } ")."
$nl
"In addition to standard sequence operations, persistent vectors implement efficient operations specific to them. They run in sub-linear time on persistent vectors, and degrate to linear-time algorithms on ordinary sequences:"
{ $subsection new-nth }
{ $subsection ppush }
{ $subsection ppop }
"Converting a sequence into a persistent vector:"
{ $subsection >persistent-vector }
"Persistent vectors have a literal syntax:"
@ -31,4 +25,4 @@ $nl
$nl
"This implementation of persistent vectors is based on the " { $snippet "clojure.lang.PersistentVector" } " class from Rich Hickey's Clojure language for the JVM (" { $url "http://clojure.org" } ")." ;
ABOUT: "persistent-vectors"
ABOUT: "persistent.vectors"

67
extra/24-game/24-game-docs.factor Normal file
View File

@ -0,0 +1,67 @@
USING: help.markup help.syntax math kernel ;
IN: 24-game
HELP: play-game ( -- )
{ $description "Starts the game!" }
{ $examples
{ $unchecked-example
"USE: 24-game"
"play-game"
"{ 8 2 1 2 }\n"
"Commands: { + - * / rot swap q }\n"
"swap\n"
"{ 8 2 2 1 }\n"
"Commands: { + - * / rot swap q }\n"
"-\n"
"{ 8 2 1 }\n"
"Commands: { + - * / rot swap q }\n"
"+\n"
"{ 8 3 }\n"
"Commands: { + - * / swap q }\n"
"*\n"
"You WON!"
}
} ;
HELP: 24-able ( -- vector )
{ $values { "vector" "vector of 4 integers" } }
{ $description
"Produces a vector with 4 integers. With the following condition: "
"If these integers were directly on the stack, one can process them into 24, "
"just using the provided commands and the 4 numbers. The Following are the "
"provided commands: "
{ $link + } ", " { $link - } ", " { $link * } ", "
{ $link / } ", and " { $link swap } "."
}
{ $examples
{ $example
"USE: 24-game"
"24-able vector-24-able?"
"t"
}
{ $notes { $link 24-able? } " is used in " { $link 24-able } "." }
} ;
HELP: 24-able? ( quad -- t/f )
{ $values
{ "quad" "vector of 4 integers" }
{ "t/f" "a boolean" }
}
{ $description
"Tells if it is possible to win 24-game if it was initiated "
"with this sequence."
} ;
HELP: build-quad ( -- array )
{ $values
{ "vector" "an array of 4 numbers" }
}
{ $description "Builds an array of 4 random numbers." } ;
ARTICLE: "24-game" "The Game of 24"
"A classic math game, where one attempts to create 24, by applying "
"arithmetical operations and some shuffle words to a stack of 4 numbers. "
{ $subsection play-game }
{ $subsection 24-able }
{ $subsection 24-able? }
{ $subsection build-quad } ;
ABOUT: "24-game"

56
extra/24-game/24-game.factor
View File

@ -3,36 +3,60 @@
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 ;
arrays words quotations accessors math.parser backtrack assocs ;
IN: 24-game
SYMBOL: commands
: 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 ;
: makes-24? ( a b c d -- ? )
[
2 [ some-rots do-something ] times
maybe-swap do-something
24 =
]
[ 4drop ]
if-amb ;
: q ( -- obj ) "quit" ;
: show-commands ( -- ) "Commands: " write "commands" get unparse print ;
: 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 ;
: 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 ;
: victory? ( vector -- t/f ) { 24 } = ;
: apply-word ( vector word -- array ) 1quotation with-datastack >array ;
: 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 ;
: end-game ( vector -- )
dup victory?
[ drop "You WON!" ]
[ pop number>string " is not 24... You lose." append ]
if print ;
! The following two words are mutually recursive,
! providing the repl loop of the game
: 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 ( -- array ) 4 [ 10 random ] replicate >array ;
: 24-able? ( vector -- t/f ) [ makes-24? ] with-datastack first ;
: 24-able ( -- vector ) build-quad dup 24-able? [ drop build-quad ] unless ;
: set-commands ( -- ) { + - * / rot swap q } commands set ;
: play-game ( -- ) set-commands 24-able repeat ;

1
extra/24-game/authors.txt Normal file
View File

@ -0,0 +1 @@
Reginald Ford

1
extra/24-game/tags.txt
View File

@ -1 +1,2 @@
demos
games

2
extra/boolean-expr/tags.txt
View File

@ -1 +1 @@
demos

21
extra/cfdg/cfdg.factor
View File

@ -5,7 +5,7 @@ USING: kernel alien.c-types combinators namespaces arrays
opengl.gl opengl.glu opengl ui ui.gadgets.slate
vars colors self self.slots
random-weighted colors.hsv cfdg.gl accessors
ui.gadgets.handler ui.gestures assocs ui.gadgets ;
ui.gadgets.handler ui.gestures assocs ui.gadgets macros ;
IN: cfdg
@ -137,6 +137,25 @@ VAR: threshold
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: [rules] ( seq -- quot )
[ unclip swap [ [ do ] curry ] map concat 2array ] map
[ call-random-weighted ] swap prefix
[ when ] swap prefix
[ iterate? ] swap append ;
MACRO: rules ( seq -- quot ) [rules] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: [rule] ( seq -- quot )
[ [ do ] swap prefix ] map concat
[ when ] swap prefix
[ iterate? ] prepend ;
MACRO: rule ( seq -- quot ) [rule] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: background
: set-initial-background ( -- ) T{ hsva f 0 0 1 1 } clone >self ;

34
extra/cfdg/models/chiaroscuro/chiaroscuro.factor
View File

@ -5,34 +5,32 @@ USING: kernel namespaces sequences math
IN: cfdg.models.chiaroscuro
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
DEFER: white
: black ( -- ) iterate? [
{ { 60 [ [ 0.6 s circle ] do
[ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] do ] }
{ 1 [ white black ] } }
call-random-weighted
] when ;
: black ( -- )
{
{ 60 [ 0.6 s circle ] [ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] }
{ 1 [ white black ] }
}
rules ;
: white ( -- ) iterate? [
{ { 60 [
[ 0.6 s circle ] do
[ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] do
] }
{ 1 [
black white
] } }
call-random-weighted
] when ;
: white ( -- )
{
{ 60 [ 0.6 s circle ] [ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] }
{ 1 [ black white ] }
}
rules ;
: chiaroscuro ( -- ) [ 0.5 b black ] do ;
: chiaroscuro ( -- ) { [ 0.5 b black ] } rule ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: init ( -- )
[ -0.5 b ] >background
{ -3 6 -2 6 } >viewport
0.01 >threshold
0.03 >threshold
[ chiaroscuro ] >start-shape ;
: run ( -- ) [ init ] cfdg-window. ;

44
extra/cfdg/models/game1-turn6/game1-turn6.factor
View File

@ -6,29 +6,35 @@ IN: cfdg.models.game1-turn6
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: f-triangles ( -- ) iterate? [
[ 0.1 x 0.1 y -0.33 alpha 20 hue 0.7 sat 0.8 b triangle ] do
[ 10 hue 0.9 sat 0.33 b triangle ] do
[ 0.9 s 10 hue 0.5 sat 1 b triangle ] do
[ 0.8 s 5 r f-triangles ] do
] when ;
: f-triangles ( -- )
{
[ 0.1 x 0.1 y -0.33 alpha 20 hue 0.7 sat 0.80 b triangle ]
[ 10 hue 0.9 sat 0.33 b triangle ]
[ 0.9 s 10 hue 0.5 sat 1.00 b triangle ]
[ 0.8 s 5 r f-triangles ]
}
rule ;
: f-squares ( -- ) iterate? [
[ 0.1 x 0.1 y -0.33 alpha 250 hue 0.7 sat 0.8 b square ] do
[ 220 hue 0.9 sat 0.33 b square ] do
[ 0.9 s 220 hue 0.25 sat 1 b square ] do
[ 0.8 s 5 r f-squares ] do
] when ;
: f-squares ( -- )
{
[ 0.1 x 0.1 y -0.33 alpha 250 hue 0.70 sat 0.80 b square ]
[ 220 hue 0.90 sat 0.33 b square ]
[ 0.9 s 220 hue 0.25 sat 1.00 b square ]
[ 0.8 s 5 r f-squares ]
}
rule ;
DEFER: start
: spiral ( -- ) iterate? [
{ { 1 [ f-squares
[ 0.5 x 0.5 y 45 r f-triangles ] do
[ 1 y 25 r 0.9 s spiral ] do ] }
{ 0.022 [ [ 90 flip 50 hue start ] do ] } }
call-random-weighted
] when ;
: spiral ( -- )
{
{ 1 [ f-squares ]
[ 0.5 x 0.5 y 45 r f-triangles ]
[ 1 y 25 r 0.9 s spiral ] }
{ 0.022 [ 90 flip 50 hue start ] }
}
rules ;
: start ( -- )
[ spiral ] do

34
extra/cfdg/models/rules08/rules08.factor
View File

@ -17,37 +17,21 @@ DEFER: line
: ligne ( -- )
{
{ 1 [ 4.5 y 1.15 0.8 size* -0.3 b line ] do }
{ 1 [ 4.5 y 1.15 0.8 size* -0.3 b line ] }
{ 0.5 [ ] }
}
call-random-weighted ;
rules ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: line ( -- ) [ insct ligne ] recursive ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: line ( -- ) { [ insct ligne ] } rule ;
: sole ( -- )
[
{
{
1 [
[ 1 brightness 0.5 saturation ligne ] do
[ 140 r 1 hue sole ] do
]
}
{ 0.01 [ ] }
}
call-random-weighted
]
recursive ;
{
{ 1 [ 1 brightness 0.5 saturation ligne ] [ 140 r 1 hue sole ] }
{ 0.01 [ ] }
}
rules ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: centre ( -- )
[ 1 b 5 s circle ] do
[ sole ] do ;
: centre ( -- ) { [ 1 b 5 s circle ] [ sole ] } rule ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

28
extra/cfdg/models/spirales/spirales.factor
View File

@ -7,33 +7,19 @@ DEFER: line
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: block ( -- )
[
[ circle ] do
[ 0.3 s 60 flip line ] do
]
recursive ;
: block ( -- ) { [ circle ] [ 0.3 s 60 flip line ] } rule ;
: a1 ( -- )
[
[ 0.95 s 2 x 12 r 0.5 b 10 hue 1.5 sat a1 ] do
[ block ] do
]
recursive ;
: a1 ( -- ) { [ 0.95 s 2 x 12 r 0.5 b 10 hue 1.5 sat a1 ] [ block ] } rule ;
: line ( -- )
-0.3 a
[ 0 rotate a1 ] do
[ 120 rotate a1 ] do
[ 240 rotate a1 ] do ;
: line ( -- ) -0.3 a { [ 0 r a1 ] [ 120 r a1 ] [ 240 r a1 ] } rule ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: init ( -- )
[ -1 b ] >background
{ -20 40 -20 40 } viewport set
[ line ] >start-shape
0.03 >threshold ;
[ -1 b ] >background
{ -20 40 -20 40 } >viewport
[ line ] >start-shape
0.04 >threshold ;
: run ( -- ) [ init ] cfdg-window. ;

2
extra/demos/demos.factor
View File

@ -10,7 +10,7 @@ IN: demos
: demo-vocabs ( -- seq ) "demos" tagged [ second ] map concat [ name>> ] map ;
: <run-vocab-button> ( vocab-name -- button )
dup '[ drop [ , run ] call-listener ] <bevel-button> ;
dup '[ drop [ , run ] call-listener ] <bevel-button> { 0 0 } >>align ;
: <demo-runner> ( -- gadget )
<pile> 1 >>fill demo-vocabs [ <run-vocab-button> add-gadget ] each ;

2
extra/game-input/backend/backend.factor
View File

@ -1,4 +1,4 @@
USING: multiline system parser combinators ;
USING: eval multiline system combinators ;
IN: game-input.backend
STRING: set-backend-for-macosx

1
extra/lisppaste/tags.txt
View File

@ -1,3 +1,2 @@
demos
web
network

2
extra/log-viewer/tags.txt
View File

@ -1 +1 @@
demos

6
extra/lsys/ui/ui.factor
View File

@ -41,7 +41,7 @@ VAR: model
: display ( -- )
black gl-clear
black set-clear-color GL_COLOR_BUFFER_BIT glClear
GL_FLAT glShadeModel
@ -57,7 +57,9 @@ camera> do-look-at
GL_FRONT_AND_BACK GL_LINE glPolygonMode
white gl-color
white color>raw glColor4d
! white set-color
GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd

1
extra/math/derivatives/authors.txt Normal file
View File

@ -0,0 +1 @@
Reginald Ford

1
extra/math/function-tools/authors.txt Normal file
View File

@ -0,0 +1 @@
Reginald Ford

1
extra/math/newtons-method/authors.txt Normal file
View File

@ -0,0 +1 @@
Reginald Ford

1
extra/math/secant-method/authors.txt Normal file
View File

@ -0,0 +1 @@
Reginald Ford

2
extra/morse/tags.txt
View File

@ -1 +1 @@
demos
example

2
extra/msxml-to-csv/tags.txt
View File

@ -1 +1 @@
demos

2
extra/roman/tags.txt
View File

@ -1 +1 @@
demos

2
extra/taxes/tags.txt
View File

@ -1 +1 @@
demos

2
extra/turing/tags.txt
View File

@ -1 +1 @@
demos

5
extra/ui/gadgets/buttons/buttons.factor
View File

@ -199,14 +199,11 @@ M: radio-control model-changed
: <radio-button> ( value model label -- gadget )
<radio-knob> label-on-right radio-button-theme <radio-control> ;
: radio-buttons-theme ( gadget -- )
{ 5 5 } >>gap drop ;
: <radio-buttons> ( model assoc -- gadget )
<filled-pile>
-rot
[ <radio-button> ] <radio-controls>
dup radio-buttons-theme ;
{ 5 5 } >>gap ;
: <toggle-button> ( value model label -- gadget )
<radio-control> bevel-button-theme ;

38
extra/ui/gadgets/theme/theme.factor
View File

@ -18,41 +18,41 @@ IN: ui.gadgets.theme
: plain-gradient
T{ gradient f {
T{ rgba f 0.94 0.94 0.94 1.0 }
T{ rgba f 0.83 0.83 0.83 1.0 }
T{ rgba f 0.83 0.83 0.83 1.0 }
T{ rgba f 0.62 0.62 0.62 1.0 }
T{ gray f 0.94 1.0 }
T{ gray f 0.83 1.0 }
T{ gray f 0.83 1.0 }
T{ gray f 0.62 1.0 }
} } ;
: rollover-gradient
T{ gradient f {
T{ rgba f 1.0 1.0 1.0 1.0 }
T{ rgba f 0.9 0.9 0.9 1.0 }
T{ rgba f 0.9 0.9 0.9 1.0 }
T{ rgba f 0.75 0.75 0.75 1.0 }
T{ gray f 1.0 1.0 }
T{ gray f 0.9 1.0 }
T{ gray f 0.9 1.0 }
T{ gray f 0.75 1.0 }
} } ;
: pressed-gradient
T{ gradient f {
T{ rgba f 0.75 0.75 0.75 1.0 }
T{ rgba f 0.9 0.9 0.9 1.0 }
T{ rgba f 0.9 0.9 0.9 1.0 }
T{ rgba f 1.0 1.0 1.0 1.0 }
T{ gray f 0.75 1.0 }
T{ gray f 0.9 1.0 }
T{ gray f 0.9 1.0 }
T{ gray f 1.0 1.0 }
} } ;
: selected-gradient
T{ gradient f {
T{ rgba f 0.65 0.65 0.65 1.0 }
T{ rgba f 0.8 0.8 0.8 1.0 }
T{ rgba f 0.8 0.8 0.8 1.0 }
T{ rgba f 1.0 1.0 1.0 1.0 }
T{ gray f 0.65 1.0 }
T{ gray f 0.8 1.0 }
T{ gray f 0.8 1.0 }
T{ gray f 1.0 1.0 }
} } ;
: lowered-gradient
T{ gradient f {
T{ rgba f 0.37 0.37 0.37 1.0 }
T{ rgba f 0.43 0.43 0.43 1.0 }
T{ rgba f 0.5 0.5 0.5 1.0 }
T{ gray f 0.37 1.0 }
T{ gray f 0.43 1.0 }
T{ gray f 0.5 1.0 }
} } ;
: sans-serif-font { "sans-serif" plain 12 } ;

1
extra/yahoo/tags.txt
View File

@ -1,2 +1 @@
demos
web

3
unfinished/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -9,12 +9,11 @@ compiler.tree
compiler.tree.combinators
compiler.tree.cleanup
compiler.tree.builder
compiler.tree.copy-equiv
compiler.tree.normalization
compiler.tree.propagation ;
: cleaned-up-tree ( quot -- nodes )
build-tree normalize compute-copy-equiv propagate cleanup ;
build-tree normalize propagate cleanup ;
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test

64
unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces sequences kernel math
combinators sets disjoint-sets fry stack-checker.state
compiler.tree.copy-equiv ;
combinators sets disjoint-sets fry stack-checker.state ;
IN: compiler.tree.escape-analysis.allocations
! A map from values to one of the following:
@ -18,7 +17,7 @@ TUPLE: slot-access slot# value ;
C: <slot-access> slot-access
: (allocation) ( value -- value' allocations )
resolve-copy allocations get ; inline
allocations get ; inline
: allocation ( value -- allocation )
(allocation) at dup slot-access? [
@ -26,16 +25,12 @@ C: <slot-access> slot-access
allocation
] when ;
: record-allocation ( allocation value -- ) (allocation) set-at ;
: unknown-allocation ( value -- ) t swap record-allocation ;
: record-allocation ( allocation value -- )
(allocation) set-at ;
: record-allocations ( allocations values -- )
[ record-allocation ] 2each ;
: unknown-allocations ( values -- )
[ unknown-allocation ] each ;
! We track escaping values with a disjoint set.
SYMBOL: escaping-values
@ -45,15 +40,16 @@ SYMBOL: +escaping+
<disjoint-set> +escaping+ over add-atom ;
: init-escaping-values ( -- )
copies get assoc>disjoint-set +escaping+ over add-atom
escaping-values set ;
<escaping-values> escaping-values set ;
: introduce-value ( values -- )
escaping-values get add-atom ;
: introduce-values ( values -- )
escaping-values get add-atoms ;
: <slot-value> ( -- value )
<value>
[ introduce-value ]
[ escaping-values get add-atom ]
[ ]
tri ;
<value> dup escaping-values get add-atom ;
: record-slot-access ( out slot# in -- )
over zero? [ 3drop ] [
@ -66,13 +62,41 @@ SYMBOL: +escaping+
: merge-slots ( values -- value )
<slot-value> [ merge-values ] keep ;
: equate-values ( value1 value2 -- )
escaping-values get equate ;
: add-escaping-value ( value -- )
+escaping+ equate-values ;
: add-escaping-values ( values -- )
escaping-values get
'[ +escaping+ , equate ] each ;
: unknown-allocation ( value -- )
[ add-escaping-value ]
[ t swap record-allocation ]
bi ;
: unknown-allocations ( values -- )
[ unknown-allocation ] each ;
: escaping-value? ( value -- ? )
+escaping+ escaping-values get equiv? ;
DEFER: copy-value
: copy-allocation ( allocation -- allocation' )
{
{ [ dup not ] [ ] }
{ [ dup t eq? ] [ ] }
[ [ <value> [ introduce-value ] [ copy-value ] [ ] tri ] map ]
} cond ;
: copy-value ( from to -- )
[ equate-values ]
[ [ allocation copy-allocation ] dip record-allocation ]
2bi ;
SYMBOL: escaping-allocations
: compute-escaping-allocations ( -- )
@ -82,3 +106,11 @@ SYMBOL: escaping-allocations
: escaping-allocation? ( value -- ? )
escaping-allocations get key? ;
: unboxed-allocation ( value -- allocation/f )
dup escaping-allocation? [ drop f ] [ allocation ] if ;
: unboxed-slot-access? ( value -- ? )
(allocation) at dup slot-access?
[ value>> unboxed-allocation >boolean ] [ drop f ] if ;

106
unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
View File

@ -1,9 +1,9 @@
IN: compiler.tree.escape-analysis.tests
USING: compiler.tree.escape-analysis
compiler.tree.escape-analysis.allocations compiler.tree.builder
compiler.tree.normalization compiler.tree.copy-equiv
compiler.tree.normalization math.functions
compiler.tree.propagation compiler.tree.cleanup
compiler.tree.combinators compiler.tree sequences math
compiler.tree.combinators compiler.tree sequences math math.private
kernel tools.test accessors slots.private quotations.private
prettyprint classes.tuple.private classes classes.tuple ;
@ -15,7 +15,7 @@ GENERIC: count-unboxed-allocations* ( m node -- n )
out-d>> first escaping-allocation? [ 1+ ] unless ;
M: #call count-unboxed-allocations*
dup word>> \ <tuple-boa> =
dup word>> { <tuple-boa> <complex> } memq?
[ (count-unboxed-allocations) ] [ drop ] if ;
M: #push count-unboxed-allocations*
@ -27,10 +27,8 @@ M: node count-unboxed-allocations* drop ;
: count-unboxed-allocations ( quot -- sizes )
build-tree
normalize
compute-copy-equiv
propagate
cleanup
compute-copy-equiv
escape-analysis
0 swap [ count-unboxed-allocations* ] each-node ;
@ -187,3 +185,101 @@ TUPLE: cons { car read-only } { cdr read-only } ;
1 2 cons boa infinite-cons-loop
] count-unboxed-allocations
] unit-test
TUPLE: rw-box i ;
C: <rw-box> rw-box
[ 0 ] [ [ <rw-box> i>> ] count-unboxed-allocations ] unit-test
: fake-fib ( m -- n )
dup i>> 1 <= [ drop 1 <rw-box> ] when ; inline recursive
[ 0 ] [ [ <rw-box> fake-fib i>> ] count-unboxed-allocations ] unit-test
TUPLE: ro-box { i read-only } ;
C: <ro-box> ro-box
: tuple-fib ( m -- n )
dup i>> 1 <= [
drop 1 <ro-box>
] [
i>> 1- <ro-box>
dup tuple-fib
swap
i>> 1- <ro-box>
tuple-fib
swap i>> swap i>> + <ro-box>
] if ; inline recursive
[ 5 ] [ [ <ro-box> tuple-fib i>> ] count-unboxed-allocations ] unit-test
[ 3 ] [ [ <ro-box> tuple-fib ] count-unboxed-allocations ] unit-test
: bad-tuple-fib-1 ( m -- n )
dup i>> 1 <= [
drop 1 <ro-box>
] [
i>> 1- <ro-box>
dup bad-tuple-fib-1
swap
i>> 1- <ro-box>
bad-tuple-fib-1 dup .
swap i>> swap i>> + <ro-box>
] if ; inline recursive
[ 3 ] [ [ <ro-box> bad-tuple-fib-1 i>> ] count-unboxed-allocations ] unit-test
: bad-tuple-fib-2 ( m -- n )
dup .
dup i>> 1 <= [
drop 1 <ro-box>
] [
i>> 1- <ro-box>
dup bad-tuple-fib-2
swap
i>> 1- <ro-box>
bad-tuple-fib-2
swap i>> swap i>> + <ro-box>
] if ; inline recursive
[ 2 ] [ [ <ro-box> bad-tuple-fib-2 i>> ] count-unboxed-allocations ] unit-test
: tuple-fib-2 ( m -- n )
dup 1 <= [
drop 1 <ro-box>
] [
1- dup tuple-fib-2
swap
1- tuple-fib-2
swap i>> swap i>> + <ro-box>
] if ; inline recursive
[ 2 ] [ [ tuple-fib-2 i>> ] count-unboxed-allocations ] unit-test
: tuple-fib-3 ( m -- n )
dup 1 <= [
drop 1 <ro-box>
] [
1- dup tuple-fib-3
swap
1- tuple-fib-3 dup .
swap i>> swap i>> + <ro-box>
] if ; inline recursive
[ 0 ] [ [ tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
: bad-tuple-fib-3 ( m -- n )
dup 1 <= [
drop 1 <ro-box>
] [
1- dup bad-tuple-fib-3
swap
1- bad-tuple-fib-3
2drop f
] if ; inline recursive
[ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
[ 1 ] [ [ <complex> >rect ] count-unboxed-allocations ] unit-test

3
unfinished/compiler/tree/escape-analysis/escape-analysis.factor
View File

@ -4,7 +4,6 @@ USING: kernel namespaces search-dequeues assocs fry sequences
disjoint-sets
compiler.tree
compiler.tree.def-use
compiler.tree.copy-equiv
compiler.tree.escape-analysis.allocations
compiler.tree.escape-analysis.recursive
compiler.tree.escape-analysis.branches
@ -12,6 +11,8 @@ compiler.tree.escape-analysis.nodes
compiler.tree.escape-analysis.simple ;
IN: compiler.tree.escape-analysis
! This pass must run after propagation
: escape-analysis ( node -- node )
init-escaping-values
H{ } clone allocations set

14
unfinished/compiler/tree/escape-analysis/nodes/nodes.factor
View File

@ -1,10 +1,16 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences compiler.tree ;
USING: kernel sequences
compiler.tree
compiler.tree.def-use
compiler.tree.escape-analysis.allocations ;
IN: compiler.tree.escape-analysis.nodes
GENERIC: escape-analysis* ( node -- )
M: node escape-analysis* drop ;
: (escape-analysis) ( node -- ) [ escape-analysis* ] each ;
: (escape-analysis) ( node -- )
[
[ node-defs-values introduce-values ]
[ escape-analysis* ]
bi
] each ;

1
unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor
View File

@ -1,6 +1,5 @@
IN: compiler.tree.escape-analysis.recursive.tests
USING: kernel tools.test namespaces sequences
compiler.tree.copy-equiv
compiler.tree.escape-analysis.recursive
compiler.tree.escape-analysis.allocations ;

34
unfinished/compiler/tree/escape-analysis/recursive/recursive.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math combinators accessors namespaces
fry disjoint-sets
compiler.tree
compiler.tree.copy-equiv
compiler.tree.combinators
compiler.tree.escape-analysis.nodes
compiler.tree.escape-analysis.branches
@ -17,9 +17,10 @@ IN: compiler.tree.escape-analysis.recursive
[ [ [ allocation ] bi@ congruent? ] 2all? ]
} cond ;
: check-fixed-point ( node alloc1 alloc2 -- node )
[ congruent? ] 2all?
[ dup label>> f >>fixed-point drop ] unless ; inline
: check-fixed-point ( node alloc1 alloc2 -- )
[ congruent? ] 2all? [ drop ] [
label>> f >>fixed-point drop
] if ;
: node-input-allocations ( node -- allocations )
in-d>> [ allocation ] map ;
@ -35,31 +36,26 @@ IN: compiler.tree.escape-analysis.recursive
[ [ merge-values ] 2each ]
[
[ (merge-allocations) ] dip
[ [ allocation ] map check-fixed-point drop ]
[ [ allocation ] map check-fixed-point ]
[ record-allocations ]
2bi
] 2bi ;
M: #recursive escape-analysis* ( #recursive -- )
[
! copies [ clone ] change
child>>
[ first analyze-recursive-phi ]
[ (escape-analysis) ]
bi
] until-fixed-point ;
M: #call-recursive escape-analysis* ( #call-label -- )
dup
[ node-output-allocations ]
[ label>> return>> node-input-allocations ] bi
[ check-fixed-point ] keep
swap out-d>> record-allocations ;
: return-allocations ( node -- allocations )
label>> return>> node-input-allocations ;
! M: #return-recursive escape-analysis* ( #return-recursive -- )
! dup dup label>> calls>> dup empty? [ 3drop ] [
! [ node-input-allocations ]
! [ first node-output-allocations ] bi*
! check-fixed-point drop
! ] if ;
M: #call-recursive escape-analysis* ( #call-label -- )
[ ] [ return-allocations ] [ node-output-allocations ] tri
[ check-fixed-point ] [ drop swap out-d>> record-allocations ] 3bi ;
M: #return-recursive escape-analysis* ( #return-recursive -- )
[ in-d>> ] [ label>> calls>> ] bi
[ out-d>> escaping-values get '[ , equate ] 2each ] with each ;

65
unfinished/compiler/tree/escape-analysis/simple/simple.factor
View File

@ -1,26 +1,43 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences classes.tuple
classes.tuple.private math math.private slots.private
classes.tuple.private arrays math math.private slots.private
combinators dequeues search-dequeues namespaces fry classes
stack-checker.state
classes.algebra stack-checker.state
compiler.tree
compiler.tree.propagation.info
compiler.tree.escape-analysis.nodes
compiler.tree.escape-analysis.allocations ;
IN: compiler.tree.escape-analysis.simple
M: #introduce escape-analysis*
value>> unknown-allocation ;
M: #declare escape-analysis* drop ;
M: #terminate escape-analysis* drop ;
M: #renaming escape-analysis* inputs/outputs [ copy-value ] 2each ;
M: #introduce escape-analysis* value>> unknown-allocation ;
DEFER: record-literal-allocation
: make-literal-slots ( seq -- values )
[ <slot-value> [ swap record-literal-allocation ] keep ] map ;
: record-literal-tuple-allocation ( value object -- )
tuple-slots rest-slice
make-literal-slots
swap record-allocation ;
: record-literal-complex-allocation ( value object -- )
[ real-part ] [ imaginary-part ] bi 2array make-literal-slots
swap record-allocation ;
: record-literal-allocation ( value object -- )
dup class immutable-tuple-class? [
tuple-slots rest-slice
[ <slot-value> [ swap record-literal-allocation ] keep ] map
swap record-allocation
] [
drop unknown-allocation
] if ;
{
{ [ dup class immutable-tuple-class? ] [ record-literal-tuple-allocation ] }
{ [ dup complex? ] [ record-literal-complex-allocation ] }
[ drop unknown-allocation ]
} cond ;
M: #push escape-analysis*
#! Delegation.
@ -34,19 +51,29 @@ M: #push escape-analysis*
record-allocation
] [ out-d>> unknown-allocations ] if ;
: record-complex-allocation ( #call -- )
[ in-d>> ] [ out-d>> first ] bi record-allocation ;
: slot-offset ( #call -- n/f )
dup in-d>>
[ first node-value-info class>> ]
[ second node-value-info literal>> ] 2bi
dup fixnum? [
{
{ [ over tuple class<= ] [ 3 - ] }
{ [ over complex class<= ] [ 1 - ] }
[ drop f ]
} cond nip
] [ 2drop f ] if ;
: record-slot-call ( #call -- )
[ out-d>> first ]
[ dup in-d>> second node-value-info literal>> ]
[ in-d>> first ] tri
over fixnum? [
[ 3 - ] dip record-slot-access
] [
2drop unknown-allocation
] if ;
[ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri
over [ record-slot-access ] [ 2drop unknown-allocation ] if ;
M: #call escape-analysis*
dup word>> {
{ \ <tuple-boa> [ record-tuple-allocation ] }
{ \ <complex> [ record-complex-allocation ] }
{ \ slot [ record-slot-call ] }
[
drop

4
unfinished/compiler/tree/normalization/normalization.factor
View File

@ -128,6 +128,10 @@ M: #recursive normalize*
dup dup label>> introductions>>
eliminate-recursive-introductions ;
M: #enter-recursive normalize*
dup [ label>> ] keep >>enter-recursive drop
dup [ label>> ] [ out-d>> ] bi >>enter-out drop ;
: unchanged-underneath ( #call-recursive -- n )
[ out-d>> length ] [ label>> return>> in-d>> length ] bi - ;

18
unfinished/compiler/tree/optimizer/optimizer.factor
View File

@ -1,18 +1,22 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: compiler.tree.normalization compiler.tree.copy-equiv
compiler.tree.propagation compiler.tree.cleanup
compiler.tree.def-use compiler.tree.untupling
compiler.tree.dead-code compiler.tree.strength-reduction
compiler.tree.loop-detection compiler.tree.branch-fusion ;
USING: compiler.tree.normalization
compiler.tree.propagation
compiler.tree.cleanup
compiler.tree.escape-analysis
compiler.tree.tuple-unboxing
compiler.tree.def-use
compiler.tree.dead-code
compiler.tree.strength-reduction
compiler.tree.loop-detection
compiler.tree.branch-fusion ;
IN: compiler.tree.optimizer
: optimize-tree ( nodes -- nodes' )
normalize
compute-copy-equiv
propagate
cleanup
compute-def-use
escape-analysis
unbox-tuples
compute-def-use
remove-dead-code

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

@ -90,7 +90,7 @@ M: #phi propagate-before ( #phi -- )
[
drop condition-value get
[ [ =t ] [ =t ] bi* <--> ]
[ [ =f ] [ =f ] bi* <--> ] 2bi /\ assume
[ [ =f ] [ =f ] bi* <--> ] 2bi /\
]
}
{
@ -98,19 +98,43 @@ M: #phi propagate-before ( #phi -- )
[
drop condition-value get
[ [ =t ] [ =f ] bi* <--> ]
[ [ =f ] [ =t ] bi* <--> ] 2bi /\ assume
[ [ =f ] [ =t ] bi* <--> ] 2bi /\
]
}
{
{ { t f } { f } }
[ first =t condition-value get =t /\ swap t--> assume ]
[
first =t
condition-value get =t /\
swap t-->
]
}
{
{ { f } { t f } }
[ second =t condition-value get =f /\ swap t--> assume ]
[
second =t
condition-value get =f /\
swap t-->
]
}
[ 3drop ]
} case ;
! {
! { { t f } { } }
! [ B
! first
! [ [ =t ] bi@ <--> ]
! [ [ =f ] bi@ <--> ] 2bi /\
! ]
! }
! {
! { { } { t f } }
! [
! second
! [ [ =t ] bi@ <--> ]
! [ [ =f ] bi@ <--> ] 2bi /\
! ]
! }
[ 3drop f ]
} case assume ;
M: #phi propagate-after ( #phi -- )
condition-value get [

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

@ -3,8 +3,9 @@
USING: arrays assocs math math.intervals kernel accessors
sequences namespaces classes classes.algebra
combinators words
compiler.tree compiler.tree.propagation.info
compiler.tree.copy-equiv ;
compiler.tree
compiler.tree.propagation.info
compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.constraints
! A constraint is a statement about a value.

4
unfinished/compiler/tree/copy-equiv/copy-equiv-tests.factor → unfinished/compiler/tree/propagation/copy/copy-tests.factor
View File

@ -1,5 +1,5 @@
IN: compiler.tree.copy-equiv.tests
USING: compiler.tree.copy-equiv tools.test namespaces kernel
IN: compiler.tree.propagation.copy.tests
USING: compiler.tree.propagation.copy tools.test namespaces kernel
assocs ;
H{ } clone copies set

35
unfinished/compiler/tree/copy-equiv/copy-equiv.factor → unfinished/compiler/tree/propagation/copy/copy.factor
View File

@ -5,7 +5,7 @@ combinators sets locals
compiler.tree
compiler.tree.def-use
compiler.tree.combinators ;
IN: compiler.tree.copy-equiv
IN: compiler.tree.propagation.copy
! Two values are copy-equivalent if they are always identical
! at run-time ("DS" relation). This is just a weak form of
@ -26,8 +26,7 @@ SYMBOL: copies
] if
] ;
: resolve-copy ( copy -- val )
copies get compress-path [ "Unknown value" throw ] unless* ;
: resolve-copy ( copy -- val ) copies get compress-path ;
: is-copy-of ( val copy -- ) copies get set-at ;
@ -37,21 +36,7 @@ SYMBOL: copies
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: #return-recursive compute-copy-equiv*
[ in-d>> ] [ out-d>> ] bi are-copies-of ;
M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ;
: compute-phi-equiv ( inputs outputs -- )
#! An output is a copy of every input if all inputs are
@ -68,13 +53,7 @@ M: #phi compute-copy-equiv*
M: node compute-copy-equiv* drop ;
: amend-copy-equiv ( node -- )
[
[ node-defs-values [ introduce-value ] each ]
[ compute-copy-equiv* ]
bi
] each-node ;
: compute-copy-equiv ( node -- node )
H{ } clone copies set
dup amend-copy-equiv ;
: compute-copy-equiv ( node -- )
[ node-defs-values [ introduce-value ] each ]
[ compute-copy-equiv* ]
bi ;

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

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes classes.algebra kernel
accessors math math.intervals namespaces sequences words
combinators arrays compiler.tree.copy-equiv ;
combinators combinators.short-circuit arrays
compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.info
: false-class? ( class -- ? ) \ f class<= ;
@ -218,6 +219,28 @@ DEFER: (value-info-union)
[ drop null-info ]
[ dup first [ value-info-union ] reduce ] if ;
: literals<= ( info1 info2 -- ? )
{
{ [ dup literal?>> not ] [ 2drop t ] }
{ [ over literal?>> not ] [ 2drop f ] }
[ [ literal>> ] bi@ eql? ]
} cond ;
: value-info<= ( info1 info2 -- ? )
{
{ [ dup not ] [ 2drop t ] }
{ [ over not ] [ 2drop f ] }
[
{
[ [ class>> ] bi@ class<= ]
[ [ interval>> ] bi@ interval-subset? ]
[ literals<= ]
[ [ length>> ] bi@ value-info<= ]
[ [ slots>> ] bi@ [ value-info<= ] 2all? ]
} 2&&
]
} cond ;
! Current value --> info mapping
SYMBOL: value-infos

3
unfinished/compiler/tree/propagation/inlining/inlining.factor
View File

@ -6,7 +6,6 @@ classes.union sets quotations assocs combinators words
namespaces
compiler.tree
compiler.tree.builder
compiler.tree.copy-equiv
compiler.tree.normalization
compiler.tree.propagation.info
compiler.tree.propagation.nodes ;
@ -25,7 +24,7 @@ M: quotation splicing-nodes
normalize ;
: propagate-body ( #call -- )
body>> [ amend-copy-equiv ] [ (propagate) ] bi ;
body>> (propagate) ;
! Dispatch elimination
: eliminate-dispatch ( #call word/quot/f -- ? )

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

@ -3,6 +3,7 @@
USING: sequences accessors kernel assocs sequences
compiler.tree
compiler.tree.def-use
compiler.tree.propagation.copy
compiler.tree.propagation.info ;
IN: compiler.tree.propagation.nodes
@ -15,7 +16,8 @@ GENERIC: propagate-after ( node -- )
GENERIC: propagate-around ( node -- )
: (propagate) ( node -- ) [ propagate-around ] each ;
: (propagate) ( node -- )
[ [ compute-copy-equiv ] [ propagate-around ] bi ] each ;
: extract-value-info ( values -- assoc )
[ dup value-info ] H{ } map>assoc ;

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

@ -1,5 +1,5 @@
USING: kernel compiler.tree.builder compiler.tree
compiler.tree.propagation compiler.tree.copy-equiv
compiler.tree.propagation
compiler.tree.normalization tools.test math math.order
accessors sequences arrays kernel.private vectors
alien.accessors alien.c-types sequences.private
@ -14,7 +14,6 @@ IN: compiler.tree.propagation.tests
: final-info ( quot -- seq )
build-tree
normalize
compute-copy-equiv
propagate
peek node-input-infos ;
@ -145,6 +144,8 @@ IN: compiler.tree.propagation.tests
[ dup string? t xor [ "A" throw ] [ ] if ] final-classes
] unit-test
[ f ] [ [ t xor ] final-classes first null-class? ] unit-test
[ t ] [ [ t or ] final-classes first true-class? ] unit-test
[ t ] [ [ t swap or ] final-classes first true-class? ] unit-test
@ -155,12 +156,20 @@ IN: compiler.tree.propagation.tests
[ t ] [ [ dup not or ] final-classes first true-class? ] unit-test
[ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
[ t ] [ [ dup not swap or ] final-classes first true-class? ] unit-test
[ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
[ t ] [ [ dup not and ] final-classes first false-class? ] unit-test
[ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
[ t ] [ [ dup not swap and ] final-classes first false-class? ] unit-test
[ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
[ t ] [ [ over [ drop f ] when [ "A" throw ] unless ] final-classes first false-class? ] unit-test
[ V{ fixnum } ] [

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

@ -3,6 +3,7 @@
USING: accessors kernel sequences namespaces hashtables
compiler.tree
compiler.tree.def-use
compiler.tree.propagation.copy
compiler.tree.propagation.info
compiler.tree.propagation.nodes
compiler.tree.propagation.simple
@ -12,9 +13,10 @@ compiler.tree.propagation.constraints
compiler.tree.propagation.known-words ;
IN: compiler.tree.propagation
! This pass must run after normalization
: propagate ( node -- node )
[
H{ } clone constraints set
H{ } clone value-infos set
dup (propagate)
] with-scope ;
H{ } clone copies set
H{ } clone constraints set
H{ } clone value-infos set
dup (propagate) ;

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

@ -4,8 +4,8 @@ USING: kernel sequences accessors arrays fry math.intervals
combinators namespaces
stack-checker.inlining
compiler.tree
compiler.tree.copy-equiv
compiler.tree.combinators
compiler.tree.propagation.copy
compiler.tree.propagation.info
compiler.tree.propagation.nodes
compiler.tree.propagation.simple
@ -13,8 +13,9 @@ compiler.tree.propagation.branches
compiler.tree.propagation.constraints ;
IN: compiler.tree.propagation.recursive
: check-fixed-point ( node infos1 infos2 -- node )
sequence= [ dup label>> f >>fixed-point drop ] unless ; inline
: check-fixed-point ( node infos1 infos2 -- )
[ value-info<= ] 2all?
[ drop ] [ label>> f >>fixed-point drop ] if ;
: recursive-stacks ( #enter-recursive -- stacks initial )
[ label>> calls>> [ node-input-infos ] map flip ]
@ -46,19 +47,21 @@ IN: compiler.tree.propagation.recursive
: propagate-recursive-phi ( #enter-recursive -- )
[ ] [ recursive-stacks unify-recursive-stacks ] [ ] tri
[ node-output-infos check-fixed-point drop ] 2keep
out-d>> set-value-infos ;
[ node-output-infos check-fixed-point ]
[ out-d>> set-value-infos drop ]
3bi ;
M: #recursive propagate-around ( #recursive -- )
[
copies [ clone ] change
{ 0 } clone [ USE: math
dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
constraints [ clone ] change
child>>
[ first compute-copy-equiv ]
[ first propagate-recursive-phi ]
[ (propagate) ]
bi
] until-fixed-point ;
tri
] curry until-fixed-point ;
: generalize-return-interval ( info -- info' )
dup [ literal?>> ] [ class>> null-class? ] bi or
@ -67,11 +70,9 @@ M: #recursive propagate-around ( #recursive -- )
: generalize-return ( infos -- infos' )
[ generalize-return-interval ] map ;
M: #call-recursive propagate-before ( #call-label -- )
dup [ node-output-infos ] [ label>> return>> node-input-infos ] bi
[ check-fixed-point ] keep
generalize-return swap out-d>> set-value-infos ;
: return-infos ( node -- infos )
label>> return>> node-input-infos generalize-return ;
M: #return-recursive propagate-before ( #return-recursive -- )
dup [ node-input-infos ] [ in-d>> [ value-info ] map ] bi
check-fixed-point drop ;
M: #call-recursive propagate-before ( #call-label -- )
[ ] [ return-infos ] [ node-output-infos ] tri
[ check-fixed-point ] [ drop swap out-d>> set-value-infos ] 3bi ;

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

@ -39,7 +39,9 @@ TUPLE: #push < node literal out-d ;
swap 1array >>out-d
swap >>literal ;
TUPLE: #shuffle < node mapping in-d out-d ;
TUPLE: #renaming < node ;
TUPLE: #shuffle < #renaming mapping in-d out-d ;
: #shuffle ( inputs outputs mapping -- node )
\ #shuffle new
@ -50,14 +52,14 @@ TUPLE: #shuffle < node mapping in-d out-d ;
: #drop ( inputs -- node )
{ } { } #shuffle ;
TUPLE: #>r < node in-d out-r ;
TUPLE: #>r < #renaming in-d out-r ;
: #>r ( inputs outputs -- node )
\ #>r new
swap >>out-r
swap >>in-d ;
TUPLE: #r> < node in-r out-d ;
TUPLE: #r> < #renaming in-r out-d ;
: #r> ( inputs outputs -- node )
\ #r> new
@ -126,7 +128,7 @@ TUPLE: #enter-recursive < node in-d out-d label ;
swap >>in-d
swap >>label ;
TUPLE: #return-recursive < node in-d out-d label ;
TUPLE: #return-recursive < #renaming in-d out-d label ;
: #return-recursive ( label inputs outputs -- node )
\ #return-recursive new
@ -134,7 +136,7 @@ TUPLE: #return-recursive < node in-d out-d label ;
swap >>in-d
swap >>label ;
TUPLE: #copy < node in-d out-d ;
TUPLE: #copy < #renaming in-d out-d ;
: #copy ( inputs outputs -- node )
\ #copy new
@ -143,6 +145,14 @@ TUPLE: #copy < node in-d out-d ;
: node, ( node -- ) stack-visitor get push ;
GENERIC: inputs/outputs ( #renaming -- inputs outputs )
M: #shuffle inputs/outputs mapping>> unzip swap ;
M: #>r inputs/outputs [ in-d>> ] [ out-r>> ] bi ;
M: #r> inputs/outputs [ in-r>> ] [ out-d>> ] bi ;
M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
M: vector child-visitor V{ } clone ;
M: vector #introduce, #introduce node, ;
M: vector #call, #call node, ;

109
unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor Normal file
View File

@ -0,0 +1,109 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.tuple-unboxing
! This pass must run after escape analysis
! Mapping from values to sequences of values
SYMBOL: unboxed-tuples
: unboxed-tuple ( value -- unboxed-tuple )
unboxed-tuples get at ;
GENERIC: unbox-tuples* ( node -- )
: value-info-slots ( info -- slots )
#! Delegation.
[ info>> ] [ class>> ] bi {
{ [ dup tuple class<= ] [ drop 2 tail ] }
{ [ dup complex class<= ] [ drop ] }
} cond ;
: prepare-unboxed-values ( #push -- values )
out-d>> first unboxed-allocation ;
: prepare-unboxed-info ( #push -- infos values )
dup prepare-unboxed-values dup
[ [ node-output-infos first value-info-slots ] dip ]
[ 2drop f f ]
if ;
: expand-#push ( #push infos values -- )
[ [ literal>> ] dip #push ] 2map >>body drop ;
M: #push unbox-tuples* ( #push -- )
dup prepare-unboxed-info dup [ expand-#push ] [ 3drop ] if ;
: expand-<tuple-boa> ( #call values -- quot )
[ drop in-d>> peek #drop ]
[ [ in-d>> but-last ] dip #copy ]
2bi 2array ;
: expand-<complex> ( #call values -- quot )
[ in-d>> ] dip #copy 1array ;
: expand-constructor ( #call values -- )
[ drop ] [ ] [ drop word>> ] 2tri {
{ <tuple-boa> [ expand-<tuple-boa> ] }
{ <complex> [ expand-<complex> ] }
} case unbox-tuples >>body ;
: unbox-constructor ( #call -- )
dup prepare-unboxed-values dup
[ expand-constructor ] [ 2drop ] if ;
: (flatten-values) ( values -- values' )
[ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ;
: flatten-values ( values -- values' )
(flatten-values) flatten ;
: flatten-value ( values -- values )
1array flatten-values ;
: prepare-slot-access ( #call -- tuple-values slot-values outputs )
[ in-d>> first flatten-value ]
[
[ dup in-d>> second node-value-info literal>> ]
[ out-d>> first unboxed-allocation ]
bi nth flatten-value
]
[ out-d>> flatten-values ]
tri ;
: slot-access-shuffle ( tuple-values slot-values outputs -- #shuffle )
[ nip ] [ zip ] 2bi #shuffle ;
: unbox-slot-access ( #call -- )
dup unboxed-slot-access? [
dup
[ in-d>> second 1array #drop ]
[ prepare-slot-access slot-access-shuffle ]
bi 2array unbox-tuples >>body
] when drop ;
M: #call unbox-tuples* ( #call -- )
dup word>> {
{ \ <tuple-boa> [ unbox-<tuple-boa> ] }
{ \ <complex> [ unbox-<complex> ] }
{ \ slot [ unbox-slot-access ] }
[ 2drop ]
} case ;
M: #copy ... ;
M: #>r ... ;
M: #r> ... ;
M: #shuffle ... ;
M: #terrible ... ;
! These nodes never participate in unboxing
M: #return drop ;
M: #introduce drop ;
: unbox-tuples ( nodes -- nodes )
dup [ unbox-tuples* ] each-node ;

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

@ -1,50 +0,0 @@
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
View File

@ -1,59 +0,0 @@
! 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.dataflow-analysis
compiler.tree.dataflow-analysis.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* mark-escaping-values ;
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 ;

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

@ -17,7 +17,12 @@ IN: stack-checker.inlining
: (inline-word) ( word label -- )
[ [ def>> ] keep ] dip infer-quot-recursive ;
TUPLE: inline-recursive word enter-out return calls fixed-point introductions ;
TUPLE: inline-recursive
word
enter-out enter-recursive
return calls
fixed-point
introductions ;
: <inline-recursive> ( word -- label )
inline-recursive new swap >>word ;