tail call optimization

examples/irc.factor

@@ -1,49 +1,105 @@
 ! A simple IRC client written in Factor.
 
+IN: irc
+USE: generic
 USE: stdio
 USE: namespaces
 USE: streams
 USE: kernel
 USE: threads
+USE: lists
+USE: strings
+USE: words
+USE: math
 
 SYMBOL: irc-stream
+SYMBOL: channels
 SYMBOL: channel
+SYMBOL: nickname
 
-: irc-write ( str -- )
-    irc-stream get fwrite ;
+: irc-write ( s -- ) irc-stream get fwrite ;
+: irc-print ( s -- ) irc-stream get fprint irc-stream get fflush ;
 
-: irc-print ( str -- )
-    irc-stream get fprint  irc-stream get fflush ;
-
-: join ( chan -- )
-    dup channel set  "JOIN " irc-write irc-print ;
+: nick ( nick -- )
+    dup nickname set  "NICK " irc-write irc-print ;
 
 : login ( nick -- )
-    "NICK " irc-write dup irc-print
+    dup nick
     "USER " irc-write irc-write
     " hostname servername :irc.factor" irc-print ;
 
-: connect ( channel nick server -- )
-    6667 <client> irc-stream set  login join ;
+: connect ( server -- ) 6667 <client> irc-stream set ;
+
+: write-highlighted ( line -- )
+    dup nickname get index-of -1 =
+    f [ [ "ansi-fg" | "3" ] ] ? write-attr ;
+
+: extract-nick ( line -- nick )
+    "!" split1 drop ;
+
+: write-nick ( line -- )
+    "!" split1 drop [ [ "bold" | t ] ] write-attr ;
+
+GENERIC: irc-display
+PREDICATE: string privmsg "PRIVMSG" index-of -1 > ;
+PREDICATE: string action  "ACTION" index-of -1 > ;
+
+M: string irc-display ( line -- )
+    print ;
+
+M: privmsg irc-display ( line -- )
+    "PRIVMSG" split1 >r write-nick r>
+    write-highlighted terpri flush ;
+
+! Doesn't look good
+! M: action irc-display ( line -- )
+!     " * " write
+!     "ACTION" split1 >r write-nick r>
+!     write-highlighted terpri flush ;
 
 : in-loop ( -- )
-    irc-stream get freadln [ print in-loop ] when* ;
+    irc-stream get freadln [ irc-display in-loop ] when* ;
 
-: say ( input -- )
-    "PRIVMSG " irc-write
-    channel get irc-write
-    " :" irc-write irc-print ;
+: input-thread ( -- ) [ in-loop ] in-thread ;
+: disconnect ( -- ) irc-stream get fclose ;
 
-: say-loop ( -- )
-    read [ say say-loop ] when* ;
+: command ( line -- )
+    #! IRC /commands are just words.
+    " " split1 swap [
+        "irc" "listener" "parser" "scratchpad"
+    ] search execute ;
 
-: disconnect ( -- )
-    irc-stream get fclose ;
+: (msg) ( line nick -- )
+    "PRIVMSG " irc-write irc-write " :" irc-write irc-print ;
 
-: input-thread ( -- )
-    [ in-loop ] in-thread ;
+: say ( line -- )
+    channel get [ (msg) ] [ "No channel." print ] ifte* ;
 
-: irc ( channel nick server -- )
-    [ connect  input-thread  say-loop  disconnect ] with-scope ;
+: talk ( input -- ) "/" ?str-head [ command ] [ say ] ifte ;
+: talk-loop ( -- ) read [ talk talk-loop ] when* ;
 
-"#concatenative" "conc" "irc.freenode.net" irc
+: irc ( nick server -- )
+    [
+        channels off
+        channel off
+        connect
+        login
+        input-thread
+        talk-loop
+        disconnect
+    ] with-scope ;
+
+! /commands
+: join ( chan -- )
+    dup channels [ cons ] change
+    dup channel set
+    "JOIN " irc-write irc-print ;
+
+: leave ( chan -- )
+    dup channels [ remove ] change
+    channels get dup [ car ] when channel set
+    "PART " irc-write irc-print ;
+
+: msg ( line -- ) " " split1 swap (msg) ;
+: me ( line -- ) "\u0001ACTION " swap "\u0001" cat3 say ;
+: quit ( line -- ) drop disconnect ;

library/compiler/compiler.factor

@@ -41,10 +41,7 @@ USE: unparser
 USE: vectors
 USE: words
 
-! <LittleDan> peephole?
-! <LittleDan> "whose peephole are we optimizing" "your mom's"
-
-: begin-compiling ( word -- definition )
+: compiling ( word -- definition )
     "verbose-compile" get [
         "Compiling " write dup . flush
     ] when
@@ -52,12 +49,12 @@ USE: words
 
 : (compile) ( word -- )
     #! Should be called inside the with-compiler scope.
-    begin-compiling dataflow optimize linearize generate ;
+    compiling dataflow optimize linearize simplify generate ;
 
 : precompile ( word -- )
     #! Print linear IR of word.
     [
-        word-parameter dataflow optimize linearize [.]
+        word-parameter dataflow optimize linearize simplify [.]
     ] with-scope ;
 
 : compile-postponed ( -- )

library/compiler/linearizer.factor

@@ -96,8 +96,10 @@ SYMBOL: #target ( part of jump table )
 ] "linearizer" set-word-property
 
 : <label> ( -- label )
-    gensym
-    dup t "label" set-word-property ;
+    gensym  dup t "label" set-word-property ;
+
+: label? ( obj -- ? )
+    dup word ? [ "label" word-property ] [ drop f ] ifte ;
 
 : label, ( label -- )
     #label swons , ;

library/compiler/simplifier.factor

@@ -0,0 +1,93 @@
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: compiler
+USE: inference
+USE: errors
+USE: generic
+USE: hashtables
+USE: kernel
+USE: lists
+USE: math
+USE: namespaces
+USE: parser
+USE: prettyprint
+USE: stdio
+USE: strings
+USE: unparser
+USE: vectors
+USE: words
+
+! <LittleDan> peephole?
+! <LittleDan> "whose peephole are we optimizing" "your mom's"
+
+: labels ( linear -- list )
+    #! Make a list of all labels defined in the linear IR.
+    [ [ unswons #label = [ , ] [ drop ] ifte ] each ] make-list ;
+
+: label-called? ( label linear -- ? )
+    [ unswons #label = [ drop f ] [ over = ] ifte ] some? nip ;
+
+: purge-label ( label linear -- )
+    >r dup cdr r> label-called? [ , ] [ drop ] ifte ;
+
+: purge-labels ( linear -- linear )
+    #! Remove all unused labels.
+    [
+        dup [
+            dup car #label = [ over purge-label ] [ , ] ifte
+        ] each drop
+    ] make-list ;
+
+: simplify-node ( node rest -- rest ? )
+    over car "simplifier" word-property [
+        call
+    ] [
+        swap , f
+    ] ifte* ;
+
+: find-label ( label linear -- rest )
+    [ cdr over = ] some? cdr nip ;
+
+: (simplify) ( list -- ? )
+    dup [ uncons simplify-node drop (simplify) ] [ drop ] ifte ;
+
+: simplify ( linear -- linear )
+    purge-labels [ (simplify) ] make-list ;
+
+: follows? ( op list -- ? ) dup [ car car = ] [ 2drop f ] ifte ;
+
+GENERIC: call-simplifier ( node rest -- rest ? )
+
+M: cons call-simplifier ( node rest -- ? )
+    swap , f ;
+
+PREDICATE: cons return-follows #return swap follows? ;
+M: return-follows call-simplifier ( node rest -- rest ? )
+    cdr swap cdr #jump swons , t ;
+
+#call [ call-simplifier ] "simplifier" set-word-property

library/test/compiler/simplifier.factor

@@ -0,0 +1,13 @@
+IN: scratchpad
+USE: compiler
+USE: test
+USE: inference
+USE: lists
+
+[ [ ] ] [ [ ] simplify ] unit-test
+[ [ [ #return ] ] ] [ [ [ #return ] ] simplify ] unit-test
+[ [ [ #jump | car ] ] ] [ [ [ #call | car ] [ #return ] ] simplify ] unit-test
+
+[ [ [ #return ] ] ]
+[ 123 [ [ #call | car ] [ #label | 123 ] [ #return ] ] find-label ]
+unit-test