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-11 22:35:09 -05:00
parent 03d66ba21c ed848621a3
commit 7133caa0e5
22 changed files with 689 additions and 438 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
basis/ui/gadgets/tabs/tabs.factor
View File

@ -48,8 +48,8 @@ DEFER: (del-page)
: del-page ( name tabbed -- ) : del-page ( name tabbed -- )
[ names>> index ] 2keep (del-page) ; [ names>> index ] 2keep (del-page) ;
: <tabbed> ( assoc -- tabbed ) : new-tabbed ( assoc class -- tabbed )
tabbed new-frame new-frame
0 <model> >>model 0 <model> >>model
<pile> 1 >>fill >>toggler <pile> 1 >>fill >>toggler
dup toggler>> @left grid-add dup toggler>> @left grid-add
@ -59,3 +59,4 @@ DEFER: (del-page)
bi bi
dup redo-toggler ; dup redo-toggler ;
: <tabbed> ( assoc -- tabbed ) tabbed new-tabbed ;

7
core/effects/effects.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces sequences strings words assocs USING: kernel math math.parser namespaces sequences strings
combinators accessors arrays ; words assocs combinators accessors arrays ;
IN: effects IN: effects
TUPLE: effect in out terminated? ; TUPLE: effect in out terminated? ;
@ -25,10 +25,11 @@ TUPLE: effect in out terminated? ;
GENERIC: effect>string ( obj -- str ) GENERIC: effect>string ( obj -- str )
M: string effect>string ; M: string effect>string ;
M: word effect>string name>> ; M: word effect>string name>> ;
M: integer effect>string drop "object" ; M: integer effect>string number>string ;
M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ; M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ;
: stack-picture ( seq -- string ) : stack-picture ( seq -- string )
dup integer? [ "object" <repetition> ] when
[ [ effect>string % CHAR: \s , ] each ] "" make ; [ [ effect>string % CHAR: \s , ] each ] "" make ;
M: effect effect>string ( effect -- string ) M: effect effect>string ( effect -- string )

2
core/kernel/kernel-docs.factor
View File

@ -629,7 +629,7 @@ HELP: 2bi*
"The following two lines are equivalent:" "The following two lines are equivalent:"
{ $code { $code
"[ p ] [ q ] 2bi*" "[ p ] [ q ] 2bi*"
">r >r q r> r> q" ">r >r p r> r> q"
} }
} ; } ;

2
extra/backtrack/backtrack.factor
View File

@ -66,3 +66,5 @@ MACRO: amb-execute ( seq -- quot )
tri* if tri* if
] with-scope ; inline ] with-scope ; inline
: cut-amb ( -- )
f failure set ;

266
extra/irc/client/client-tests.factor
View File

@ -1,27 +1,48 @@
USING: kernel tools.test accessors arrays sequences qualified USING: kernel tools.test accessors arrays sequences qualified
io.streams.string io.streams.duplex namespaces threads io io.streams.duplex namespaces threads
calendar irc.client.private irc.client irc.messages.private calendar irc.client.private irc.client irc.messages.private
concurrency.mailboxes classes assocs combinators ; concurrency.mailboxes classes assocs combinators ;
EXCLUDE: irc.messages => join ; EXCLUDE: irc.messages => join ;
RENAME: join irc.messages => join_ RENAME: join irc.messages => join_
IN: irc.client.tests IN: irc.client.tests
! Utilities ! Streams for testing
: <test-stream> ( lines -- stream ) TUPLE: mb-writer lines last-line disposed ;
"\n" join <string-reader> <string-writer> <duplex-stream> ; TUPLE: mb-reader lines disposed ;
: <mb-writer> ( -- mb-writer ) V{ } clone V{ } clone f mb-writer boa ;
: <mb-reader> ( -- mb-reader ) <mailbox> f mb-reader boa ;
: push-line ( line test-reader-stream -- ) lines>> mailbox-put ;
: <test-stream> ( -- stream ) <mb-reader> <mb-writer> <duplex-stream> ;
M: mb-writer stream-write ( line mb-writer -- ) last-line>> push ;
M: mb-writer stream-flush ( mb-writer -- ) drop ;
M: mb-reader stream-readln ( mb-reader -- str/f ) lines>> mailbox-get ;
M: mb-writer stream-nl ( mb-writer -- )
[ [ last-line>> concat ] [ lines>> ] bi push ] keep
V{ } clone >>last-line drop ;
: make-client ( lines -- irc-client ) : spawn-client ( lines listeners -- irc-client )
"someserver" irc-port "factorbot" f <irc-profile> <irc-client> "someserver" irc-port "factorbot" f <irc-profile>
swap [ 2nip <test-stream> f ] curry >>connect ; <irc-client>
t >>is-running
<test-stream> >>stream
dup [ spawn-irc yield ] with-irc-client ;
: set-nick ( irc-client nickname -- ) ! to be used inside with-irc-client quotations
swap profile>> (>>nickname) ; : %add-named-listener ( listener -- ) [ name>> ] keep set+run-listener ;
: %join ( channel -- ) <irc-channel-listener> irc> add-listener ;
: %push-line ( line -- ) irc> stream>> in>> push-line yield ;
: with-dummy-client ( irc-client quot -- ) : read-matching-message ( listener quot: ( msg -- ? ) -- irc-message )
[ current-irc-client ] dip with-variable ; inline [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ;
{ "" } make-client dup "factorbot" set-nick [ : with-irc ( quot: ( -- ) -- )
{ t } [ irc> profile>> nickname>> me? ] unit-test [ spawn-client ] dip [ f %push-line ] compose with-irc-client ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! TESTS
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ { t } [ irc> profile>> nickname>> me? ] unit-test
{ "factorbot" } [ irc> profile>> nickname>> ] unit-test { "factorbot" } [ irc> profile>> nickname>> ] unit-test
@ -32,159 +53,126 @@ IN: irc.client.tests
{ "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
parse-irc-line irc-message-origin ] unit-test parse-irc-line irc-message-origin ] unit-test
] with-dummy-client ] with-irc
! Test login and nickname set ! Test login and nickname set
{ "factorbot" } [ [ { "factorbot2" } [
{ "NOTICE AUTH :*** Looking up your hostname..." ":some.where 001 factorbot2 :Welcome factorbot2" %push-line
"NOTICE AUTH :*** Checking ident" irc> profile>> nickname>>
"NOTICE AUTH :*** Found your hostname" ] unit-test
"NOTICE AUTH :*** No identd (auth) response" ] with-irc
":some.where 001 factorbot :Welcome factorbot"
} make-client
{ [ connect-irc ]
[ drop 0.1 seconds sleep ]
[ profile>> nickname>> ]
[ terminate-irc ]
} cleave ] unit-test
{ join_ "#factortest" } [ [ { join_ "#factortest" } [
{ ":factorbot!n=factorbo@some.where JOIN :#factortest" { ":factorbot!n=factorbo@some.where JOIN :#factortest"
":ircserver.net MODE #factortest +ns"
":ircserver.net 353 factorbot @ #factortest :@factorbot " ":ircserver.net 353 factorbot @ #factortest :@factorbot "
":ircserver.net 366 factorbot #factortest :End of /NAMES list." ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
} make-client } [ %push-line ] each
{ [ "factorbot" set-nick ] irc> join-messages>> 0.1 seconds mailbox-get-timeout
[ connect-irc ] [ class ] [ trailing>> ] bi
[ drop 0.1 seconds sleep ]
[ join-messages>> 0.1 seconds mailbox-get-timeout ]
[ terminate-irc ]
} cleave
[ class ] [ trailing>> ] bi ] unit-test
{ +join+ "somebody" } [
{ ":somebody!n=somebody@some.where JOIN :#factortest" } make-client
{ [ "factorbot" set-nick ]
[ listeners>>
[ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
[ connect-irc ]
[ listeners>> [ "#factortest" ] dip at
[ read-message drop ] [ read-message drop ] [ read-message ] tri ]
[ terminate-irc ]
} cleave
[ action>> ] [ nick>> ] bi
] unit-test ] unit-test
] with-irc
{ privmsg "#factortest" "hello" } [ [ { T{ participant-changed f "somebody" +join+ } } [
{ ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" } make-client "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
{ [ "factorbot" set-nick ] ":somebody!n=somebody@some.where JOIN :#factortest" %push-line
[ listeners>> [ participant-changed? ] read-matching-message
[ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ] ] unit-test
[ connect-irc ] ] with-irc
[ listeners>> [ "#factortest" ] dip at
[ read-message drop ] [ read-message ] bi ] [ { privmsg "#factortest" "hello" } [
[ terminate-irc ] "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
} cleave ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line
[ privmsg? ] read-matching-message
[ class ] [ name>> ] [ trailing>> ] tri [ class ] [ name>> ] [ trailing>> ] tri
] unit-test ] unit-test
] with-irc
{ privmsg "factorbot" "hello" } [ [ { privmsg "factorbot" "hello" } [
{ ":somedude!n=user@isp.net PRIVMSG factorbot :hello" } make-client "somedude" <irc-nick-listener> [ %add-named-listener ] keep
{ [ "factorbot" set-nick ] ":somedude!n=user@isp.net PRIVMSG factorbot :hello" %push-line
[ listeners>> [ privmsg? ] read-matching-message
[ "somedude" [ <irc-nick-listener> ] keep ] dip set-at ]
[ connect-irc ]
[ listeners>> [ "somedude" ] dip at
[ read-message drop ] [ read-message ] bi ]
[ terminate-irc ]
} cleave
[ class ] [ name>> ] [ trailing>> ] tri [ class ] [ name>> ] [ trailing>> ] tri
] unit-test ] unit-test
] with-irc
! Participants lists tests [ { mode } [
{ H{ { "somedude" +normal+ } } } [ "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
{ ":somedude!n=user@isp.net JOIN :#factortest" } make-client ":ircserver.net MODE #factortest +ns" %push-line
{ [ "factorbot" set-nick ] [ mode? ] read-matching-message class
[ listeners>>
[ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
[ connect-irc ]
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at participants>> ]
[ terminate-irc ]
} cleave
] unit-test ] unit-test
] with-irc
{ H{ { "somedude2" +normal+ } } } [ ! Participant lists tests
{ ":somedude!n=user@isp.net PART #factortest" } make-client [ { H{ { "somedude" +normal+ } } } [
{ [ "factorbot" set-nick ] "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
[ listeners>> ":somedude!n=user@isp.net JOIN :#factortest" %push-line
[ "#factortest" [ <irc-channel-listener> participants>>
] unit-test
] with-irc
[ { H{ { "somedude2" +normal+ } } } [
"#factortest" <irc-channel-listener>
H{ { "somedude2" +normal+ } H{ { "somedude2" +normal+ }
{ "somedude" +normal+ } } clone >>participants ] keep { "somedude" +normal+ } } clone >>participants
] dip set-at ] [ %add-named-listener ] keep
[ connect-irc ] ":somedude!n=user@isp.net PART #factortest" %push-line
[ drop 0.1 seconds sleep ] participants>>
[ listeners>> [ "#factortest" ] dip at participants>> ]
[ terminate-irc ]
} cleave
] unit-test ] unit-test
] with-irc
{ H{ { "somedude2" +normal+ } } } [ [ { H{ { "somedude2" +normal+ } } } [
{ ":somedude!n=user@isp.net QUIT" } make-client "#factortest" <irc-channel-listener>
{ [ "factorbot" set-nick ]
[ listeners>>
[ "#factortest" [ <irc-channel-listener>
H{ { "somedude2" +normal+ } H{ { "somedude2" +normal+ }
{ "somedude" +normal+ } } clone >>participants ] keep { "somedude" +normal+ } } clone >>participants
] dip set-at ] [ %add-named-listener ] keep
[ connect-irc ] ":somedude!n=user@isp.net QUIT" %push-line
[ drop 0.1 seconds sleep ] participants>>
[ listeners>> [ "#factortest" ] dip at participants>> ]
[ terminate-irc ]
} cleave
] unit-test ] unit-test
] with-irc
{ H{ { "somedude2" +normal+ } } } [ [ { H{ { "somedude2" +normal+ } } } [
{ ":somedude2!n=user2@isp.net KICK #factortest somedude" } make-client "#factortest" <irc-channel-listener>
{ [ "factorbot" set-nick ]
[ listeners>>
[ "#factortest" [ <irc-channel-listener>
H{ { "somedude2" +normal+ } H{ { "somedude2" +normal+ }
{ "somedude" +normal+ } } clone >>participants ] keep { "somedude" +normal+ } } clone >>participants
] dip set-at ] [ %add-named-listener ] keep
[ connect-irc ] ":somedude2!n=user2@isp.net KICK #factortest somedude" %push-line
[ drop 0.1 seconds sleep ] participants>>
[ listeners>> [ "#factortest" ] dip at participants>> ]
[ terminate-irc ]
} cleave
] unit-test ] unit-test
] with-irc
[ { H{ { "somedude2" +normal+ } } } [
"#factortest" <irc-channel-listener>
H{ { "somedude" +normal+ } } clone >>participants
[ %add-named-listener ] keep
":somedude!n=user2@isp.net NICK :somedude2" %push-line
participants>>
] unit-test
] with-irc
! Namelist change notification ! Namelist change notification
{ T{ participant-changed f f f } } [ [ { T{ participant-changed f f f f } } [
{ ":ircserver.net 353 factorbot @ #factortest :@factorbot " "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
":ircserver.net 366 factorbot #factortest :End of /NAMES list." } make-client ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
{ [ "factorbot" set-nick ] ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
[ listeners>> [ participant-changed? ] read-matching-message
[ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
[ connect-irc ]
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at [ read-message drop ] [ read-message ] bi ]
[ terminate-irc ]
} cleave
] unit-test ] unit-test
] with-irc
{ T{ participant-changed f "somedude" +part+ } } [ [ { T{ participant-changed f "somedude" +part+ f } } [
{ ":somedude!n=user@isp.net QUIT" } make-client "#factortest" <irc-channel-listener>
{ [ "factorbot" set-nick ] H{ { "somedude" +normal+ } } clone >>participants
[ listeners>> [ %add-named-listener ] keep
[ "#factortest" [ <irc-channel-listener> ":somedude!n=user@isp.net QUIT" %push-line
H{ { "somedude" +normal+ } } clone >>participants ] keep [ participant-changed? ] read-matching-message
] dip set-at ]
[ connect-irc ]
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at
[ read-message drop ] [ read-message drop ] [ read-message ] tri ]
[ terminate-irc ]
} cleave
] unit-test ] unit-test
] with-irc
[ { T{ participant-changed f "somedude" +nick+ "somedude2" } } [
"#factortest" <irc-channel-listener>
H{ { "somedude" +normal+ } } clone >>participants
[ %add-named-listener ] keep
":somedude!n=user2@isp.net NICK :somedude2" %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc

81
extra/irc/client/client.factor
View File

@ -41,6 +41,7 @@ SYMBOL: +normal+
SYMBOL: +join+ SYMBOL: +join+
SYMBOL: +part+ SYMBOL: +part+
SYMBOL: +mode+ SYMBOL: +mode+
SYMBOL: +nick+
! listener objects ! listener objects
: <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ; : <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
@ -59,7 +60,7 @@ SYMBOL: +mode+
! Message objects ! Message objects
! ====================================== ! ======================================
TUPLE: participant-changed nick action ; TUPLE: participant-changed nick action parameter ;
C: <participant-changed> participant-changed C: <participant-changed> participant-changed
SINGLETON: irc-listener-end ! send to a listener to stop its execution SINGLETON: irc-listener-end ! send to a listener to stop its execution
@ -100,17 +101,21 @@ M: string to-listener ( message string -- )
listener> [ +server-listener+ listener> ] unless* listener> [ +server-listener+ listener> ] unless*
[ to-listener ] [ drop ] if* ; [ to-listener ] [ drop ] if* ;
M: irc-listener to-listener ( message irc-listener -- )
in-messages>> mailbox-put ;
: unregister-listener ( name -- ) : unregister-listener ( name -- )
irc> listeners>> irc> listeners>>
[ at [ irc-listener-end ] dip to-listener ] [ at [ irc-listener-end ] dip to-listener ]
[ delete-at ] [ delete-at ]
2bi ; 2bi ;
M: irc-listener to-listener ( message irc-listener -- ) : (remove-participant) ( nick listener -- )
in-messages>> mailbox-put ; [ participants>> delete-at ]
[ [ +part+ f <participant-changed> ] dip to-listener ] 2bi ;
: remove-participant ( nick channel -- ) : remove-participant ( nick channel -- )
listener> [ participants>> delete-at ] [ drop ] if* ; listener> [ (remove-participant) ] [ drop ] if* ;
: listeners-with-participant ( nick -- seq ) : listeners-with-participant ( nick -- seq )
irc> listeners>> values irc> listeners>> values
@ -118,10 +123,24 @@ M: irc-listener to-listener ( message irc-listener -- )
with filter ; with filter ;
: remove-participant-from-all ( nick -- ) : remove-participant-from-all ( nick -- )
dup listeners-with-participant [ participants>> delete-at ] with each ; dup listeners-with-participant [ (remove-participant) ] with each ;
: notify-rename ( newnick oldnick listener -- )
[ participant-changed new +nick+ >>action
[ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-listener ;
: rename-participant ( newnick oldnick listener -- )
[ participants>> [ delete-at* drop ] [ [ swap ] dip set-at ] bi ]
[ notify-rename ] 3bi ;
: rename-participant-in-all ( oldnick newnick -- )
swap dup listeners-with-participant [ rename-participant ] with with each ;
: add-participant ( mode nick channel -- ) : add-participant ( mode nick channel -- )
listener> [ participants>> set-at ] [ 2drop ] if* ; listener> [
[ participants>> set-at ]
[ [ +join+ f <participant-changed> ] dip to-listener ] 2bi
] [ 2drop ] if* ;
DEFER: me? DEFER: me?
@ -164,25 +183,6 @@ DEFER: me?
: broadcast-message-to-listeners ( message -- ) : broadcast-message-to-listeners ( message -- )
irc> listeners>> values [ to-listener ] with each ; irc> listeners>> values [ to-listener ] with each ;
GENERIC: handle-participant-change ( irc-message -- )
M: join handle-participant-change ( join -- )
[ prefix>> parse-name +join+ <participant-changed> ]
[ trailing>> ] bi to-listener ;
M: part handle-participant-change ( part -- )
[ prefix>> parse-name +part+ <participant-changed> ]
[ channel>> ] bi to-listener ;
M: kick handle-participant-change ( kick -- )
[ who>> +part+ <participant-changed> ]
[ channel>> ] bi to-listener ;
M: quit handle-participant-change ( quit -- )
prefix>> parse-name
[ +part+ <participant-changed> ] [ listeners-with-participant ] bi
[ to-listener ] with each ;
GENERIC: handle-incoming-irc ( irc-message -- ) GENERIC: handle-incoming-irc ( irc-message -- )
M: irc-message handle-incoming-irc ( irc-message -- ) M: irc-message handle-incoming-irc ( irc-message -- )
@ -201,35 +201,36 @@ M: privmsg handle-incoming-irc ( privmsg -- )
dup irc-message-origin to-listener ; dup irc-message-origin to-listener ;
M: join handle-incoming-irc ( join -- ) M: join handle-incoming-irc ( join -- )
{ [ maybe-forward-join ] [ maybe-forward-join ]
[ dup trailing>> to-listener ] [ dup trailing>> to-listener ]
[ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] [ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
[ handle-participant-change ] tri ;
} cleave ;
M: part handle-incoming-irc ( part -- ) M: part handle-incoming-irc ( part -- )
[ dup channel>> to-listener ] [ dup channel>> to-listener ]
[ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ] [ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ]
[ handle-participant-change ] bi ;
tri ;
M: kick handle-incoming-irc ( kick -- ) M: kick handle-incoming-irc ( kick -- )
{ [ dup channel>> to-listener ] [ dup channel>> to-listener ]
[ [ who>> ] [ channel>> ] bi remove-participant ] [ [ who>> ] [ channel>> ] bi remove-participant ]
[ handle-participant-change ]
[ dup who>> me? [ unregister-listener ] [ drop ] if ] [ dup who>> me? [ unregister-listener ] [ drop ] if ]
} cleave ; tri ;
M: quit handle-incoming-irc ( quit -- ) M: quit handle-incoming-irc ( quit -- )
[ dup prefix>> parse-name listeners-with-participant [ dup prefix>> parse-name listeners-with-participant
[ to-listener ] with each ] [ to-listener ] with each ]
[ handle-participant-change ]
[ prefix>> parse-name remove-participant-from-all ] [ prefix>> parse-name remove-participant-from-all ]
tri ; bi ;
! FIXME: implement this M: mode handle-incoming-irc ( mode -- ) ! FIXME: modify participant list
! M: mode handle-incoming-irc ( mode -- ) call-next-method ; dup channel>> to-listener ;
! M: nick handle-incoming-irc ( nick -- ) call-next-method ;
M: nick handle-incoming-irc ( nick -- )
[ dup prefix>> parse-name listeners-with-participant
[ to-listener ] with each ]
[ [ prefix>> parse-name ] [ trailing>> ] bi rename-participant-in-all ]
bi ;
: >nick/mode ( string -- nick mode ) : >nick/mode ( string -- nick mode )
dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
@ -241,7 +242,7 @@ M: quit handle-incoming-irc ( quit -- )
M: names-reply handle-incoming-irc ( names-reply -- ) M: names-reply handle-incoming-irc ( names-reply -- )
[ names-reply>participants ] [ channel>> listener> ] bi [ [ names-reply>participants ] [ channel>> listener> ] bi [
[ (>>participants) ] [ (>>participants) ]
[ [ f f <participant-changed> ] dip name>> to-listener ] bi [ [ f f f <participant-changed> ] dip name>> to-listener ] bi
] [ drop ] if* ; ] [ drop ] if* ;
M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
@ -367,7 +368,7 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- )
in-messages>> [ irc-connected ] dip mailbox-put ; in-messages>> [ irc-connected ] dip mailbox-put ;
: with-irc-client ( irc-client quot: ( -- ) -- ) : with-irc-client ( irc-client quot: ( -- ) -- )
[ current-irc-client ] dip with-variable ; inline [ \ current-irc-client ] dip with-variable ; inline
PRIVATE> PRIVATE>

11
extra/irc/ui/commands/commands.factor
View File

@ -6,8 +6,15 @@ USING: accessors kernel irc.client irc.messages irc.ui namespaces ;
IN: irc.ui.commands IN: irc.ui.commands
: say ( string -- ) : say ( string -- )
[ client get profile>> nickname>> <own-message> print-irc ] irc-tab get
[ listener get write-message ] bi ; [ window>> client>> profile>> nickname>> <own-message> print-irc ]
[ listener>> write-message ] 2bi ;
: join ( string -- )
irc-tab get window>> join-channel ;
: query ( string -- )
irc-tab get window>> query-nick ;
: quote ( string -- ) : quote ( string -- )
drop ; ! THIS WILL CHANGE drop ; ! THIS WILL CHANGE

72
extra/irc/ui/ui.factor
View File

@ -19,9 +19,9 @@ SYMBOL: listener
SYMBOL: client SYMBOL: client
TUPLE: ui-window client tabs ; TUPLE: ui-window < tabbed client ;
TUPLE: irc-tab < frame listener client userlist ; TUPLE: irc-tab < frame listener client window userlist ;
: write-color ( str color -- ) : write-color ( str color -- )
foreground associate format ; foreground associate format ;
@ -161,44 +161,54 @@ M: object handle-inbox
<scrolling-pane> <scrolling-pane>
[ <pane-stream> swap display ] 2keep ; [ <pane-stream> swap display ] 2keep ;
TUPLE: irc-editor < editor outstream listener client ; TUPLE: irc-editor < editor outstream tab ;
: <irc-editor> ( tab pane -- tab editor ) : <irc-editor> ( tab pane -- tab editor )
over irc-editor new-editor irc-editor new-editor
swap listener>> >>listener swap <pane-stream> >>outstream swap <pane-stream> >>outstream ;
over client>> >>client ;
: editor-send ( irc-editor -- ) : editor-send ( irc-editor -- )
{ [ outstream>> ] { [ outstream>> ]
[ listener>> ] [ [ irc-tab? ] find-parent ]
[ client>> ]
[ editor-string ] [ editor-string ]
[ "" swap set-editor-string ] } cleave [ "" swap set-editor-string ] } cleave
'[ , listener set , client set , parse-message ] with-output-stream ; '[ , irc-tab set , parse-message ] with-output-stream ;
irc-editor "general" f { irc-editor "general" f {
{ T{ key-down f f "RET" } editor-send } { T{ key-down f f "RET" } editor-send }
{ T{ key-down f f "ENTER" } editor-send } { T{ key-down f f "ENTER" } editor-send }
} define-command-map } define-command-map
: <irc-tab> ( listener client -- irc-tab ) : new-irc-tab ( listener ui-window class -- irc-tab )
irc-tab new-frame new-frame
swap client>> >>client swap >>listener swap >>window
swap >>listener
<irc-pane> [ <scroller> @center grid-add ] keep <irc-pane> [ <scroller> @center grid-add ] keep
<irc-editor> <scroller> @bottom grid-add ; <irc-editor> <scroller> @bottom grid-add ;
: <irc-channel-tab> ( listener client -- irc-tab )
<irc-tab>
<pile> [ <scroller> @right grid-add ] keep >>userlist ;
: <irc-server-tab> ( listener client -- irc-tab )
<irc-tab> ;
M: irc-tab graft* M: irc-tab graft*
[ listener>> ] [ client>> ] bi add-listener ; [ listener>> ] [ window>> client>> ] bi add-listener ;
M: irc-tab ungraft* M: irc-tab ungraft*
[ listener>> ] [ client>> ] bi remove-listener ; [ listener>> ] [ window>> client>> ] bi remove-listener ;
TUPLE: irc-channel-tab < irc-tab userlist ;
: <irc-channel-tab> ( listener ui-window -- irc-tab )
irc-tab new-irc-tab
<pile> [ <scroller> @right grid-add ] keep >>userlist ;
TUPLE: irc-server-tab < irc-tab ;
: <irc-server-tab> ( listener -- irc-tab )
f irc-server-tab new-irc-tab ;
M: irc-server-tab ungraft*
[ window>> client>> terminate-irc ]
[ listener>> ] [ window>> client>> ] tri remove-listener ;
: <irc-nick-tab> ( listener ui-window -- irc-tab )
irc-tab new-irc-tab ;
M: irc-tab pref-dim* M: irc-tab pref-dim*
drop { 480 480 } ; drop { 480 480 } ;
@ -206,19 +216,25 @@ M: irc-tab pref-dim*
: join-channel ( name ui-window -- ) : join-channel ( name ui-window -- )
[ dup <irc-channel-listener> ] dip [ dup <irc-channel-listener> ] dip
[ <irc-channel-tab> swap ] keep [ <irc-channel-tab> swap ] keep
tabs>> add-page ; add-page ;
: query-nick ( nick ui-window -- )
[ dup <irc-nick-listener> ] dip
[ <irc-nick-tab> swap ] keep
add-page ;
: irc-window ( ui-window -- ) : irc-window ( ui-window -- )
[ tabs>> ] [ ]
[ client>> profile>> server>> ] bi [ client>> profile>> server>> ] bi
open-window ; open-window ;
: ui-connect ( profile -- ui-window ) : ui-connect ( profile -- ui-window )
<irc-client> ui-window new over >>client swap <irc-client>
[ connect-irc ] { [ [ <irc-server-listener> ] dip add-listener ]
[ [ <irc-server-listener> ] dip add-listener ] [ listeners>> +server-listener+ swap at <irc-server-tab> dup
[ listeners>> +server-listener+ swap at over <irc-tab> "Server" associate ui-window new-tabbed [ swap (>>window) ] keep ]
"Server" associate <tabbed> >>tabs ] tri ; [ >>client ]
[ connect-irc ] } cleave ;
: server-open ( server port nick password channels -- ) : server-open ( server port nick password channels -- )
[ <irc-profile> ui-connect [ irc-window ] keep ] dip [ <irc-profile> ui-connect [ irc-window ] keep ] dip

4
unfinished/compiler/cfg/builder/builder-tests.factor Normal file
View File

@ -0,0 +1,4 @@
IN: compiler.cfg.builder.tests
USING: compiler.cfg.builder tools.test ;
\ build-cfg must-infer

172
unfinished/compiler/cfg/builder/builder.factor
View File

@ -1,29 +1,33 @@
! 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: arrays kernel assocs sequences sequences.lib fry accessors USING: arrays kernel assocs sequences sequences.lib fry accessors
compiler.cfg compiler.vops compiler.vops.builder namespaces math combinators math.order
namespaces math inference.dataflow optimizer.allot combinators compiler.tree
math.order ; compiler.tree.combinators
compiler.tree.propagation.info
compiler.cfg
compiler.vops
compiler.vops.builder ;
IN: compiler.cfg.builder IN: compiler.cfg.builder
! Convert dataflow IR to procedure CFG. ! Convert tree SSA IR to CFG SSA IR.
! We construct the graph and set successors first, then we ! We construct the graph and set successors first, then we
! set predecessors in a separate pass. This simplifies the ! set predecessors in a separate pass. This simplifies the
! logic. ! logic.
SYMBOL: procedures SYMBOL: procedures
SYMBOL: values>vregs
SYMBOL: loop-nesting SYMBOL: loop-nesting
GENERIC: convert* ( node -- ) SYMBOL: values>vregs
GENERIC: convert ( node -- ) GENERIC: convert ( node -- )
M: #introduce convert drop ;
: init-builder ( -- ) : init-builder ( -- )
H{ } clone values>vregs set H{ } clone values>vregs set ;
V{ } clone loop-nesting set ;
: end-basic-block ( -- ) : end-basic-block ( -- )
basic-block get [ %b emit ] when ; basic-block get [ %b emit ] when ;
@ -40,15 +44,12 @@ GENERIC: convert ( node -- )
set-basic-block ; set-basic-block ;
: convert-nodes ( node -- ) : convert-nodes ( node -- )
dup basic-block get and [ [ convert ] each ;
[ convert ] [ successor>> convert-nodes ] bi
] [ drop ] if ;
: (build-cfg) ( node word -- ) : (build-cfg) ( node word -- )
init-builder init-builder
begin-basic-block begin-basic-block
basic-block get swap procedures get set-at basic-block get swap procedures get set-at
%prolog emit
convert-nodes ; convert-nodes ;
: build-cfg ( node word -- procedures ) : build-cfg ( node word -- procedures )
@ -73,10 +74,9 @@ GENERIC: convert ( node -- )
2bi 2bi
] if ; ] if ;
: load-inputs ( node -- ) : load-in-d ( node -- ) in-d>> %data (load-inputs) ;
[ in-d>> %data (load-inputs) ]
[ in-r>> %retain (load-inputs) ] : load-in-r ( node -- ) in-r>> %retain (load-inputs) ;
bi ;
: (store-outputs) ( seq stack -- ) : (store-outputs) ( seq stack -- )
over empty? [ 2drop ] [ over empty? [ 2drop ] [
@ -86,40 +86,21 @@ GENERIC: convert ( node -- )
2bi 2bi
] if ; ] if ;
: store-outputs ( node -- ) : store-out-d ( node -- ) out-d>> %data (store-outputs) ;
[ out-d>> %data (store-outputs) ]
[ out-r>> %retain (store-outputs) ]
bi ;
M: #push convert* : store-out-r ( node -- ) out-r>> %retain (store-outputs) ;
out-d>> [
[ produce-vreg ] [ value-literal ] bi
emit-literal
] each ;
M: #shuffle convert* drop ;
M: #>r convert* drop ;
M: #r> convert* drop ;
M: node convert
[ load-inputs ]
[ convert* ]
[ store-outputs ]
tri ;
: (emit-call) ( word -- ) : (emit-call) ( word -- )
begin-basic-block %call emit begin-basic-block ; begin-basic-block %call emit begin-basic-block ;
: intrinsic-inputs ( node -- ) : intrinsic-inputs ( node -- )
[ load-inputs ] [ load-in-d ]
[ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ] [ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ]
bi ; bi ;
: intrinsic-outputs ( node -- ) : intrinsic-outputs ( node -- )
[ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ] [ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ]
[ store-outputs ] [ store-out-d ]
bi ; bi ;
: intrinsic ( node quot -- ) : intrinsic ( node quot -- )
@ -132,19 +113,17 @@ M: node convert
tri tri
] with-scope ; inline ] with-scope ; inline
USING: kernel.private math.private slots.private USING: kernel.private math.private slots.private ;
optimizer.allot ;
: maybe-emit-fixnum-shift-fast ( node -- node ) : maybe-emit-fixnum-shift-fast ( node -- node )
dup dup in-d>> second node-literal? [ dup dup in-d>> second node-value-info literal>> dup fixnum? [
dup dup in-d>> second node-literal
'[ , emit-fixnum-shift-fast ] intrinsic '[ , emit-fixnum-shift-fast ] intrinsic
] [ ] [
dup param>> (emit-call) drop dup word>> (emit-call)
] if ; ] if ;
: emit-call ( node -- ) : emit-call ( node -- )
dup param>> { dup word>> {
{ \ tag [ [ emit-tag ] intrinsic ] } { \ tag [ [ emit-tag ] intrinsic ] }
{ \ slot [ [ dup emit-slot ] intrinsic ] } { \ slot [ [ dup emit-slot ] intrinsic ] }
@ -175,24 +154,43 @@ optimizer.allot ;
{ \ float> [ [ emit-float> ] intrinsic ] } { \ float> [ [ emit-float> ] intrinsic ] }
{ \ float? [ [ emit-float= ] intrinsic ] } { \ float? [ [ emit-float= ] intrinsic ] }
{ \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] } ! { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] }
{ \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] } ! { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] }
{ \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] } ! { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] }
[ (emit-call) ] [ (emit-call) ]
} case drop ; } case drop ;
M: #call convert emit-call ; M: #call convert emit-call ;
M: #call-label convert : emit-call-loop ( #recursive -- )
dup param>> loop-nesting get at [ dup label>> loop-nesting get at basic-block get successors>> push
basic-block get successors>> push
end-basic-block end-basic-block
basic-block off basic-block off
drop drop ;
] [
(emit-call) : emit-call-recursive ( #recursive -- )
] if* ; label>> id>> (emit-call) ;
M: #call-recursive convert
dup label>> loop?>>
[ emit-call-loop ] [ emit-call-recursive ] if ;
M: #push convert
[
[ out-d>> first produce-vreg ]
[ node-output-infos first literal>> ]
bi emit-literal
]
[ store-out-d ] bi ;
M: #shuffle convert [ load-in-d ] [ store-out-d ] bi ;
M: #>r convert [ load-in-d ] [ store-out-r ] bi ;
M: #r> convert [ load-in-r ] [ store-out-d ] bi ;
M: #terminate convert drop ;
: integer-conditional ( in1 in2 cc -- ) : integer-conditional ( in1 in2 cc -- )
[ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline [ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline
@ -221,50 +219,38 @@ M: #call-label convert
[ set-basic-block ] [ set-basic-block ]
bi ; bi ;
: phi-inputs ( #if -- vregs-seq )
children>>
[ last-node ] map
[ #values? ] filter
[ in-d>> [ value>vreg ] map ] map ;
: phi-outputs ( #if -- vregs )
successor>> out-d>> [ produce-vreg ] map ;
: emit-phi ( #if -- )
[ phi-outputs ] [ phi-inputs ] bi %phi emit ;
M: #if convert M: #if convert
{ [ load-in-d ] [ emit-if ] [ convert-if-children ] tri ;
[ load-inputs ]
[ emit-if ]
[ convert-if-children ]
[ emit-phi ]
} cleave ;
M: #values convert drop ; M: #dispatch convert
"Unimplemented" throw ;
M: #merge convert drop ; M: #phi convert drop ;
M: #entry convert drop ;
M: #declare convert drop ; M: #declare convert drop ;
M: #terminate convert drop ; M: #return convert drop %return emit ;
M: #label convert : convert-recursive ( #recursive -- )
#! Labels create a new procedure. [ [ label>> id>> ] [ child>> ] bi (build-cfg) ]
[ [ param>> ] [ node-child ] bi (build-cfg) ] [ (emit-call) ] bi ; [ (emit-call) ]
bi ;
M: #loop convert : begin-loop ( #recursive -- )
#! Loops become part of the current CFG. label>> basic-block get 2array loop-nesting get push ;
begin-basic-block
[ param>> basic-block get 2array loop-nesting get push ] : end-loop ( -- )
[ node-child convert-nodes ]
bi
loop-nesting get pop* ; loop-nesting get pop* ;
M: #return convert : convert-loop ( #recursive -- )
param>> loop-nesting get key? [ begin-basic-block
%epilog emit [ begin-loop ]
%return emit [ child>> convert-nodes ]
] unless ; [ drop end-loop ]
tri ;
M: #recursive convert
dup label>> loop?>>
[ convert-loop ] [ convert-recursive ] if ;
M: #copy convert drop ;

24
unfinished/compiler/machine/debug/debug.factor → unfinished/compiler/machine/debugger/debugger.factor
View File

@ -1,12 +1,17 @@
! 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 kernel namespaces sequences assocs io USING: accessors kernel namespaces sequences assocs io
prettyprint inference generator optimizer compiler.vops prettyprint inference generator optimizer
compiler.cfg.builder compiler.cfg.simplifier compiler.vops
compiler.machine.builder compiler.machine.simplifier ; compiler.tree.builder
IN: compiler.machine.debug compiler.tree.optimizer
compiler.cfg.builder
compiler.cfg.simplifier
compiler.machine.builder
compiler.machine.simplifier ;
IN: compiler.machine.debugger
: dataflow>linear ( dataflow word -- linear ) : tree>linear ( tree word -- linear )
[ [
init-counter init-counter
build-cfg build-cfg
@ -20,15 +25,16 @@ IN: compiler.machine.debug
] assoc-each ; ] assoc-each ;
: linearized-quot. ( quot -- ) : linearized-quot. ( quot -- )
dataflow optimize build-tree optimize-tree
"Anonymous quotation" dataflow>linear "Anonymous quotation" tree>linear
linear. ; linear. ;
: linearized-word. ( word -- ) : linearized-word. ( word -- )
dup word-dataflow nip optimize swap dataflow>linear linear. ; dup build-tree-from-word nip optimize-tree
dup word-dataflow nip optimize swap tree>linear linear. ;
: >basic-block ( quot -- basic-block ) : >basic-block ( quot -- basic-block )
dataflow optimize build-tree optimize-tree
[ [
init-counter init-counter
"Anonymous quotation" build-cfg "Anonymous quotation" build-cfg

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

@ -22,6 +22,11 @@ IN: compiler.tree.builder
] with-tree-builder nip ] with-tree-builder nip
unclip-last in-d>> ; unclip-last in-d>> ;
: build-sub-tree ( #call quot -- nodes )
[ [ out-d>> ] [ in-d>> ] bi ] dip
build-tree-with
rot #copy suffix ;
: (make-specializer) ( class picker -- quot ) : (make-specializer) ( class picker -- quot )
swap "predicate" word-prop append ; swap "predicate" word-prop append ;

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

@ -0,0 +1,6 @@
IN: compiler.tree.debugger.tests
USING: compiler.tree.debugger tools.test ;
\ optimized-quot. must-infer
\ optimized-word. must-infer
\ optimizer-report. must-infer

144
unfinished/compiler/tree/debugger/debugger.factor Normal file
View File

@ -0,0 +1,144 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs fry match accessors namespaces effects
sequences sequences.private quotations generic macros arrays
prettyprint prettyprint.backend prettyprint.sections math words
combinators io sorting
compiler.tree
compiler.tree.builder
compiler.tree.optimizer
compiler.tree.combinators
compiler.tree.propagation.info ;
IN: compiler.tree.debugger
! A simple tool for turning tree IR into quotations and
! printing reports, for debugging purposes.
GENERIC: node>quot ( node -- )
MACRO: match-choose ( alist -- )
[ '[ , ] ] assoc-map '[ , match-cond ] ;
MATCH-VARS: ?a ?b ?c ;
: pretty-shuffle ( in out -- word/f )
2array {
{ { { } { } } [ ] }
{ { { ?a } { ?a } } [ ] }
{ { { ?a ?b } { ?a ?b } } [ ] }
{ { { ?a ?b ?c } { ?a ?b ?c } } [ ] }
{ { { ?a } { } } [ drop ] }
{ { { ?a ?b } { } } [ 2drop ] }
{ { { ?a ?b ?c } { } } [ 3drop ] }
{ { { ?a } { ?a ?a } } [ dup ] }
{ { { ?a ?b } { ?a ?b ?a ?b } } [ 2dup ] }
{ { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] }
{ { { ?a ?b } { ?a ?b ?a } } [ over ] }
{ { { ?b ?a } { ?a ?b } } [ swap ] }
{ { { ?b ?a ?c } { ?a ?b ?c } } [ swapd ] }
{ { { ?a ?b } { ?a ?a ?b } } [ dupd ] }
{ { { ?a ?b } { ?b ?a ?b } } [ tuck ] }
{ { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
{ { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
{ { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
{ { { ?a ?b } { ?b } } [ nip ] }
{ { { ?a ?b ?c } { ?c } } [ 2nip ] }
{ _ f }
} match-choose ;
TUPLE: shuffle effect ;
M: shuffle pprint* effect>> effect>string text ;
: shuffle-inputs/outputs ( node -- in out )
[ in-d>> ] [ out-d>> ] [ mapping>> ] tri
[ at ] curry map ;
M: #shuffle node>quot
shuffle-inputs/outputs 2dup pretty-shuffle dup
[ 2nip % ] [ drop <effect> shuffle boa , ] if ;
: pushed-literals ( node -- seq )
dup out-d>> [ node-value-info literal>> literalize ] with map ;
M: #push node>quot pushed-literals % ;
M: #call node>quot word>> , ;
M: #call-recursive node>quot label>> id>> , ;
DEFER: nodes>quot
DEFER: label
M: #recursive node>quot
[ label>> id>> literalize , ]
[ child>> nodes>quot , \ label , ]
bi ;
M: #if node>quot
children>> [ nodes>quot ] map % \ if , ;
M: #dispatch node>quot
children>> [ nodes>quot ] map , \ dispatch , ;
M: #>r node>quot in-d>> length \ >r <repetition> % ;
M: #r> node>quot out-d>> length \ r> <repetition> % ;
M: node node>quot drop ;
: nodes>quot ( node -- quot )
[ [ node>quot ] each ] [ ] make ;
: optimized. ( quot/word -- )
dup word? [ specialized-def ] when
build-tree optimize-tree nodes>quot . ;
SYMBOL: words-called
SYMBOL: generics-called
SYMBOL: methods-called
SYMBOL: intrinsics-called
SYMBOL: node-count
: make-report ( word/quot -- assoc )
[
dup word? [ build-tree-from-word nip ] [ build-tree ] if
optimize-tree
H{ } clone words-called set
H{ } clone generics-called set
H{ } clone methods-called set
H{ } clone intrinsics-called set
0 swap [
>r 1+ r>
dup #call? [
word>> {
{ [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
{ [ dup generic? ] [ generics-called ] }
{ [ dup method-body? ] [ methods-called ] }
[ words-called ]
} cond 1 -rot get at+
] [ drop ] if
] each-node
node-count set
] H{ } make-assoc ;
: report. ( report -- )
[
"==== Total number of IR nodes:" print
node-count get .
{
{ generics-called "==== Generic word calls:" }
{ words-called "==== Ordinary word calls:" }
{ methods-called "==== Non-inlined method calls:" }
{ intrinsics-called "==== Open-coded intrinsic calls:" }
} [
nl print get keys natural-sort stack.
] assoc-each
] bind ;
: optimizer-report. ( word -- )
make-report report. ;

24
unfinished/compiler/tree/intrinsics/intrinsics.factor
View File

@ -1,6 +1,26 @@
! 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 ; USING: kernel classes.tuple classes.tuple.private math arrays
byte-arrays words stack-checker.known-words ;
IN: compiler.tree.intrinsics IN: compiler.tree.intrinsics
: <immutable-tuple-boa> ( ... class -- tuple ) "Intrinsic" throw ; : <immutable-tuple-boa> ( ... class -- tuple )
"BUG: missing <immutable-tuple-boa> intrinsic" throw ;
: (tuple) ( layout -- tuple )
"BUG: missing (tuple) intrinsic" throw ;
\ (tuple) { tuple-layout } { tuple } define-primitive
\ (tuple) make-flushable
: (array) ( n -- array )
"BUG: missing (array) intrinsic" throw ;
\ (array) { integer } { array } define-primitive
\ (array) make-flushable
: (byte-array) ( n -- byte-array )
"BUG: missing (byte-array) intrinsic" throw ;
\ (byte-array) { integer } { byte-array } define-primitive
\ (byte-array) make-flushable

93
unfinished/compiler/tree/loop/detection/detection.factor
View File

@ -1,22 +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 sequences namespaces assocs accessors fry USING: kernel sequences namespaces assocs accessors fry
compiler.tree ; compiler.tree dequeues search-dequeues ;
IN: compiler.tree.loop.detection IN: compiler.tree.loop.detection
! A loop is a #recursive which only tail calls itself, and those ! A loop is a #recursive which only tail calls itself, and those
! calls are nested inside other loops only. ! calls are nested inside other loops only. We optimistically
! assume all #recursive nodes are loops, disqualifying them as
TUPLE: recursive-call tail? nesting ; ! we see evidence to the contrary.
! calls is a sequence of recursive-call instances
TUPLE: loop-info calls height ;
! Mapping inline-recursive instances to loop-info instances
SYMBOL: loop-infos
! A sequence of inline-recursive instances
SYMBOL: label-stack
: (tail-calls) ( tail? seq -- seq' ) : (tail-calls) ( tail? seq -- seq' )
reverse [ swap [ and ] keep ] map nip reverse ; reverse [ swap [ and ] keep ] map nip reverse ;
@ -29,6 +20,11 @@ SYMBOL: label-stack
tri or or tri or or
] map (tail-calls) ; ] map (tail-calls) ;
SYMBOL: loop-heights
SYMBOL: loop-calls
SYMBOL: loop-stack
SYMBOL: work-list
GENERIC: collect-loop-info* ( tail? node -- ) GENERIC: collect-loop-info* ( tail? node -- )
: non-tail-label-info ( nodes -- ) : non-tail-label-info ( nodes -- )
@ -37,24 +33,32 @@ GENERIC: collect-loop-info* ( tail? node -- )
: (collect-loop-info) ( tail? nodes -- ) : (collect-loop-info) ( tail? nodes -- )
[ tail-calls ] keep [ collect-loop-info* ] 2each ; [ tail-calls ] keep [ collect-loop-info* ] 2each ;
: remember-loop-info ( #recursive -- ) : remember-loop-info ( label -- )
V{ } clone label-stack get length loop-info boa loop-stack get length swap loop-heights get set-at ;
swap label>> loop-infos get set-at ;
M: #recursive collect-loop-info* M: #recursive collect-loop-info*
nip nip
[ [
[ label-stack [ swap label>> suffix ] change ] [
label>>
[ loop-stack [ swap suffix ] change ]
[ remember-loop-info ] [ remember-loop-info ]
[ t swap child>> (collect-loop-info) ] [ t >>loop? drop ]
tri tri
]
[ t swap child>> (collect-loop-info) ] bi
] with-scope ; ] with-scope ;
: current-loop-nesting ( label -- labels )
loop-stack get swap loop-heights get at tail ;
: disqualify-loop ( label -- )
work-list get push-front ;
M: #call-recursive collect-loop-info* M: #call-recursive collect-loop-info*
label>> loop-infos get at label>>
[ label-stack get swap height>> tail recursive-call boa ] swap [ dup disqualify-loop ] unless
[ calls>> ] dup current-loop-nesting [ loop-calls get push-at ] with each ;
bi push ;
M: #if collect-loop-info* M: #if collect-loop-info*
children>> [ (collect-loop-info) ] with each ; children>> [ (collect-loop-info) ] with each ;
@ -65,39 +69,20 @@ M: #dispatch collect-loop-info*
M: node collect-loop-info* 2drop ; M: node collect-loop-info* 2drop ;
: collect-loop-info ( node -- ) : collect-loop-info ( node -- )
{ } label-stack set { } loop-stack set
H{ } clone loop-infos set H{ } clone loop-calls set
H{ } clone loop-heights set
<hashed-dlist> work-list set
t swap (collect-loop-info) ; t swap (collect-loop-info) ;
! Sub-assoc of loop-infos : disqualify-loops ( -- )
SYMBOL: potential-loops work-list get [
dup loop?>> [
: remove-non-tail-calls ( -- ) [ f >>loop? drop ]
loop-infos get [ loop-calls get at [ disqualify-loop ] each ]
[ nip calls>> [ tail?>> ] all? ] assoc-filter bi
potential-loops set ; ] [ drop ] if
] slurp-dequeue ;
: (remove-non-loop-calls) ( loop-infos -- )
f over [
! If label X is called from within a label Y that is
! no longer a potential loop, then X is no longer a
! potential loop either.
over potential-loops get key? [
potential-loops get '[ , key? ] all?
[ drop ] [ potential-loops get delete-at t or ] if
] [ 2drop ] if
] assoc-each
[ (remove-non-loop-calls) ] [ drop ] if ;
: remove-non-loop-calls ( -- )
! Boolean is set to t if something changed.
! We recurse until a fixed point is reached.
loop-infos get [ calls>> [ nesting>> ] map concat ] assoc-map
(remove-non-loop-calls) ;
: detect-loops ( nodes -- nodes ) : detect-loops ( nodes -- nodes )
dup dup collect-loop-info disqualify-loops ;
collect-loop-info
remove-non-tail-calls
remove-non-loop-calls
potential-loops get [ drop t >>loop? drop ] assoc-each ;

4
unfinished/compiler/tree/elaboration/elaboration.factor → unfinished/compiler/tree/loop/inversion/inversion.factor
View File

@ -1,5 +1,5 @@
! 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.
IN: compiler.tree.elaboration IN: compiler.tree.loop.inversion
: elaborate ( nodes -- nodes' ) ; : invert-loops ( nodes -- nodes' ) ;

4
unfinished/compiler/tree/optimizer/optimizer-tests.factor Normal file
View File

@ -0,0 +1,4 @@
USING: compiler.tree.optimizer tools.test ;
IN: compiler.tree.optimizer.tests
\ optimize-tree must-infer

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

@ -8,7 +8,8 @@ compiler.tree.tuple-unboxing
compiler.tree.def-use compiler.tree.def-use
compiler.tree.dead-code compiler.tree.dead-code
compiler.tree.strength-reduction compiler.tree.strength-reduction
compiler.tree.loop-detection compiler.tree.loop.detection
compiler.tree.loop.inversion
compiler.tree.branch-fusion ; compiler.tree.branch-fusion ;
IN: compiler.tree.optimizer IN: compiler.tree.optimizer
@ -16,11 +17,11 @@ IN: compiler.tree.optimizer
normalize normalize
propagate propagate
cleanup cleanup
detect-loops
invert-loops
fuse-branches
escape-analysis escape-analysis
unbox-tuples unbox-tuples
compute-def-use compute-def-use
remove-dead-code remove-dead-code
strength-reduce strength-reduce ;
detect-loops
fuse-branches
elaborate ;

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

@ -18,10 +18,7 @@ M: word splicing-nodes
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ; [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
M: quotation splicing-nodes M: quotation splicing-nodes
[ [ out-d>> ] [ in-d>> ] bi ] dip build-sub-tree normalize ;
build-tree-with
rot #copy suffix
normalize ;
: propagate-body ( #call -- ) : propagate-body ( #call -- )
body>> (propagate) ; body>> (propagate) ;

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

@ -165,24 +165,27 @@ M: object infer-call*
{ call execute dispatch load-locals get-local drop-locals } { call execute dispatch load-locals get-local drop-locals }
[ t "no-compile" set-word-prop ] each [ t "no-compile" set-word-prop ] each
SYMBOL: +primitive+
: non-inline-word ( word -- ) : non-inline-word ( word -- )
dup +called+ depends-on dup +called+ depends-on
{ {
{ [ dup +shuffle+ word-prop ] [ infer-shuffle-word ] } { [ dup +shuffle+ word-prop ] [ infer-shuffle-word ] }
{ [ dup +special+ word-prop ] [ infer-special ] } { [ dup +special+ word-prop ] [ infer-special ] }
{ [ dup primitive? ] [ infer-primitive ] } { [ dup +primitive+ word-prop ] [ infer-primitive ] }
{ [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] } { [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
{ [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
{ [ dup +transform-quot+ word-prop ] [ apply-transform ] } { [ dup +transform-quot+ word-prop ] [ apply-transform ] }
{ [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
{ [ dup "macro" word-prop ] [ apply-macro ] } { [ dup "macro" word-prop ] [ apply-macro ] }
{ [ dup recursive-label ] [ call-recursive-word ] } { [ dup recursive-label ] [ call-recursive-word ] }
[ dup infer-word apply-word/effect ] [ dup infer-word apply-word/effect ]
} cond ; } cond ;
: define-primitive ( word inputs outputs -- ) : define-primitive ( word inputs outputs -- )
[ 2drop t +primitive+ set-word-prop ]
[ drop "input-classes" set-word-prop ] [ drop "input-classes" set-word-prop ]
[ nip "default-output-classes" set-word-prop ] [ nip "default-output-classes" set-word-prop ]
3bi ; 3tri ;
! Stack effects for all primitives ! Stack effects for all primitives
\ fixnum< { fixnum fixnum } { object } define-primitive \ fixnum< { fixnum fixnum } { object } define-primitive

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

@ -11,31 +11,45 @@ IN: stack-checker.transforms
SYMBOL: +transform-quot+ SYMBOL: +transform-quot+
SYMBOL: +transform-n+ SYMBOL: +transform-n+
: (apply-transform) ( quot n -- newquot ) : give-up-transform ( word -- )
dup zero? [ dup recursive-label
[ call-recursive-word ]
[ dup infer-word apply-word/effect ]
if ;
: ((apply-transform)) ( word quot stack -- )
swap with-datastack first2
dup [ swap infer-quot drop ] [ 2drop give-up-transform ] if ;
inline
: (apply-transform) ( word quot n -- )
consume-d dup [ known literal? ] all? [
dup empty? [
drop recursive-state get 1array drop recursive-state get 1array
] [ ] [
consume-d
[ #drop, ] [ #drop, ]
[ [ literal value>> ] map ] [ [ literal value>> ] map ]
[ first literal recursion>> ] tri prefix [ first literal recursion>> ] tri prefix
] if ] if
swap with-datastack ; ((apply-transform))
] [ 2drop give-up-transform ] if ;
: apply-transform ( word -- ) : apply-transform ( word -- )
[ +inlined+ depends-on ] [ [ +inlined+ depends-on ] [
[ ]
[ +transform-quot+ word-prop ] [ +transform-quot+ word-prop ]
[ +transform-n+ word-prop ] [ +transform-n+ word-prop ]
bi (apply-transform) tri
first2 swap infer-quot (apply-transform)
] bi ; ] bi ;
: apply-macro ( word -- ) : apply-macro ( word -- )
[ +inlined+ depends-on ] [ [ +inlined+ depends-on ] [
[ ]
[ "macro" word-prop ] [ "macro" word-prop ]
[ "declared-effect" word-prop in>> length ] [ "declared-effect" word-prop in>> length ]
bi (apply-transform) tri
first2 swap infer-quot (apply-transform)
] bi ; ] bi ;
: define-transform ( word quot n -- ) : define-transform ( word quot n -- )
@ -66,20 +80,80 @@ SYMBOL: +transform-n+
\ spread [ spread>quot ] 1 define-transform \ spread [ spread>quot ] 1 define-transform
\ (call-next-method) [
[ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
] 2 define-transform
! Constructors
\ boa [ \ boa [
dup tuple-class? [ dup tuple-class? [
dup +inlined+ depends-on dup +inlined+ depends-on
[ "boa-check" word-prop ] [ "boa-check" word-prop ]
[ tuple-layout '[ , <tuple-boa> ] ] [ tuple-layout '[ , <tuple-boa> ] ]
bi append bi append
] [ ] [ drop f ] if
\ boa \ no-method boa time-bomb
] if
] 1 define-transform ] 1 define-transform
\ (call-next-method) [ \ new [
[ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi dup tuple-class? [
] 2 define-transform dup +inlined+ depends-on
dup all-slots rest-slice ! delegate slot
[ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make
] [ drop f ] if
] 1 define-transform
! Membership testing
: bit-member-n 256 ; inline
: bit-member? ( seq -- ? )
#! Can we use a fast byte array test here?
{
{ [ dup length 8 < ] [ f ] }
{ [ dup [ integer? not ] contains? ] [ f ] }
{ [ dup [ 0 < ] contains? ] [ f ] }
{ [ dup [ bit-member-n >= ] contains? ] [ f ] }
[ t ]
} cond nip ;
: bit-member-seq ( seq -- flags )
bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ;
: exact-float? ( f -- ? )
dup float? [ dup >integer >float = ] [ drop f ] if ; inline
: bit-member-quot ( seq -- newquot )
[
[ drop ] % ! drop the sequence itself; we don't use it at run time
bit-member-seq ,
[
{
{ [ over fixnum? ] [ ?nth 1 eq? ] }
{ [ over bignum? ] [ ?nth 1 eq? ] }
{ [ over exact-float? ] [ ?nth 1 eq? ] }
[ 2drop f ]
} cond
] %
] [ ] make ;
: member-quot ( seq -- newquot )
dup bit-member? [
bit-member-quot
] [
[ literalize [ t ] ] { } map>assoc
[ drop f ] suffix [ nip case ] curry
] if ;
\ member? [
dup sequence? [ member-quot ] [ drop f ] if
] 1 define-transform
: memq-quot ( seq -- newquot )
[ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
[ drop f ] suffix [ nip cond ] curry ;
\ memq? [
dup sequence? [ memq-quot ] [ drop f ] if
] 1 define-transform
! Deprecated ! Deprecated
\ get-slots [ [ 1quotation ] map [ cleave ] curry ] 1 define-transform \ get-slots [ [ 1quotation ] map [ cleave ] curry ] 1 define-transform