Merge branch 'master' of git://tiodante.com/git/factor

core/effects/effects.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! 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
 
 TUPLE: effect in out terminated? ;
@@ -25,10 +25,11 @@ TUPLE: effect in out terminated? ;
 GENERIC: effect>string ( obj -- str )
 M: string effect>string ;
 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 ;
 
 : stack-picture ( seq -- string )
+    dup integer? [ "object" <repetition> ] when
     [ [ effect>string % CHAR: \s , ] each ] "" make ;
 
 M: effect effect>string ( effect -- string )

extra/irc/client/client-tests.factor

@@ -49,10 +49,10 @@ M: mb-writer stream-nl ( mb-writer -- )
   { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
 
   { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
-                      parse-irc-line irc-message-origin ] unit-test
+                      parse-irc-line forward-name ] unit-test
 
   { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
-                   parse-irc-line irc-message-origin ] unit-test
+                   parse-irc-line forward-name ] unit-test
 ] with-irc
 
 ! Test login and nickname set

extra/irc/client/client.factor

@@ -3,7 +3,7 @@
 USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
        accessors destructors namespaces io assocs arrays qualified fry
        continuations threads strings classes combinators splitting hashtables
-       ascii irc.messages irc.messages.private ;
+       ascii irc.messages ;
 RENAME: join sequences => sjoin
 EXCLUDE: sequences => join ;
 IN: irc.client
@@ -67,7 +67,6 @@ SINGLETON: irc-listener-end ! send to a listener to stop its execution
 SINGLETON: irc-end          ! sent when the client isn't running anymore
 SINGLETON: irc-disconnected ! sent when connection is lost
 SINGLETON: irc-connected    ! sent when connection is established
-UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
 
 : terminate-irc ( irc-client -- )
     [ is-running>> ] keep and [
@@ -122,6 +121,9 @@ M: irc-listener to-listener ( message irc-listener -- )
     [ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ]
     with filter ;
 
+: to-listeners-with-participant ( message nickname -- )
+    listeners-with-participant [ to-listener ] with each ;
+
 : remove-participant-from-all ( nick -- )
     dup listeners-with-participant [ (remove-participant) ] with each ;
 
@@ -145,7 +147,7 @@ M: irc-listener to-listener ( message irc-listener -- )
 DEFER: me?
 
 : maybe-forward-join ( join -- )
-    [ prefix>> parse-name me? ] keep and
+    [ irc-message-sender me? ] keep and
     [ irc> join-messages>> mailbox-put ] when* ;
 
 ! ======================================
@@ -177,60 +179,64 @@ DEFER: me?
 : me? ( string -- ? )
     irc> profile>> nickname>> = ;
 
-: irc-message-origin ( irc-message -- name )
+GENERIC: forward-name ( irc-message -- name )
-    dup name>> me? [ prefix>> parse-name ] [ name>> ] if ;
+M: join forward-name ( join -- name ) trailing>> ;
+M: part forward-name ( part -- name ) channel>> ;
+M: kick forward-name ( kick -- name ) channel>> ;
+M: mode forward-name ( mode -- name ) channel>> ;
+M: privmsg forward-name ( privmsg -- name )
+    dup name>> me? [ irc-message-sender ] [ name>> ] if ;
 
-: broadcast-message-to-listeners ( message -- )
+UNION: single-forward join part kick mode privmsg ;
-    irc> listeners>> values [ to-listener ] with each ;
+UNION: multiple-forward nick quit ;
+UNION: broadcast-forward irc-end irc-disconnected irc-connected ;
+GENERIC: forward-message ( irc-message -- )
 
-GENERIC: handle-incoming-irc ( irc-message -- )
+M: irc-message forward-message ( irc-message -- )
-
-M: irc-message handle-incoming-irc ( irc-message -- )
     +server-listener+ listener> [ to-listener ] [ drop ] if* ;
 
-M: logged-in handle-incoming-irc ( logged-in -- )
+M: single-forward forward-message ( forward-single -- )
+    dup forward-name to-listener ;
+
+M: multiple-forward forward-message ( multiple-forward -- )
+    dup irc-message-sender to-listeners-with-participant ;
+
+M: join forward-message ( join -- )
+    [ maybe-forward-join ] [ call-next-method ] bi ;
+    
+M: broadcast-forward forward-message ( irc-broadcasted-message -- )
+    irc> listeners>> values [ to-listener ] with each ;
+
+GENERIC: process-message ( irc-message -- )
+
+M: object process-message ( object -- )
+    drop ;
+    
+M: logged-in process-message ( logged-in -- )
     name>> irc> profile>> (>>nickname) ;
 
-M: ping handle-incoming-irc ( ping -- )
+M: ping process-message ( ping -- )
     trailing>> /PONG ;
 
-M: nick-in-use handle-incoming-irc ( nick-in-use -- )
+M: nick-in-use process-message ( nick-in-use -- )
     name>> "_" append /NICK ;
 
-M: privmsg handle-incoming-irc ( privmsg -- )
+M: join process-message ( join -- )
-    dup irc-message-origin to-listener ;
+    [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri add-participant ;
 
-M: join handle-incoming-irc ( join -- )
+M: part process-message ( part -- )
-    [ maybe-forward-join ]
+    [ irc-message-sender ] [ channel>> ] bi remove-participant ;
-    [ dup trailing>> to-listener ]
-    [ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
-    tri ;
 
-M: part handle-incoming-irc ( part -- )
+M: kick process-message ( kick -- )
-    [ dup channel>> to-listener ]
-    [ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ]
-    bi ;
-
-M: kick handle-incoming-irc ( kick -- )
-    [ dup channel>> to-listener ]
     [ [ who>> ] [ channel>> ] bi remove-participant ]
     [ dup who>> me? [ unregister-listener ] [ drop ] if ]
-    tri ;
-
-M: quit handle-incoming-irc ( quit -- )
-    [ dup prefix>> parse-name listeners-with-participant
-      [ to-listener ] with each ]
-    [ prefix>> parse-name remove-participant-from-all ]
     bi ;
 
-M: mode handle-incoming-irc ( mode -- ) ! FIXME: modify participant list
+M: quit process-message ( quit -- )
-    dup channel>> to-listener ;
+    irc-message-sender remove-participant-from-all ;
 
-M: nick handle-incoming-irc ( nick -- )
+M: nick process-message ( nick -- )
-    [ dup prefix>> parse-name listeners-with-participant
+    [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
-      [ to-listener ] with each ]
-    [ [ prefix>> parse-name ] [ trailing>> ] bi rename-participant-in-all ]
-    bi ;
 
 : >nick/mode ( string -- nick mode )
     dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
@@ -239,22 +245,20 @@ M: nick handle-incoming-irc ( nick -- )
     trailing>> [ blank? ] trim " " split
     [ >nick/mode 2array ] map >hashtable ;
 
-M: names-reply handle-incoming-irc ( names-reply -- )
+M: names-reply process-message ( names-reply -- )
     [ names-reply>participants ] [ channel>> listener> ] bi [
         [ (>>participants) ]
         [ [ f f f <participant-changed> ] dip name>> to-listener ] bi
     ] [ drop ] if* ;
 
-M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
+: handle-incoming-irc ( irc-message -- )
-    broadcast-message-to-listeners ;
+    [ forward-message ] [ process-message ] bi ;
 
 ! ======================================
 ! Client message handling
 ! ======================================
 
-GENERIC: handle-outgoing-irc ( obj -- )
+: handle-outgoing-irc ( irc-message -- )
-
-M: irc-message handle-outgoing-irc ( irc-message -- )
     irc-message>client-line irc-print ;
 
 ! ======================================

extra/irc/messages/messages-tests.factor

@@ -3,7 +3,9 @@ USING: kernel tools.test accessors arrays qualified
 EXCLUDE: sequences => join ;
 IN: irc.messages.tests
 
-! Parsing tests
+
+{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
+
 irc-message new
     ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
     "someuser!n=user@some.where" >>prefix

extra/irc/messages/messages.factor

@@ -98,6 +98,11 @@ M: irc-message irc-message>server-line ( irc-message -- string )
 
 PRIVATE>
 
+UNION: sender-in-prefix privmsg join part quit kick mode nick ;
+GENERIC: irc-message-sender ( irc-message -- sender )
+M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender )
+    prefix>> parse-name ;
+
 : string>irc-message ( string -- object )
     dup split-prefix split-trailing
     [ [ blank? ] trim " " split unclip swap ] dip

unfinished/compiler/cfg/builder/builder-tests.factor

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

unfinished/compiler/cfg/builder/builder.factor

@@ -1,29 +1,33 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 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
 
-! Convert dataflow IR to procedure CFG.
+! Convert tree SSA IR to CFG SSA IR.
+
 ! We construct the graph and set successors first, then we
 ! set predecessors in a separate pass. This simplifies the
 ! logic.
 
 SYMBOL: procedures
 
-SYMBOL: values>vregs
-
 SYMBOL: loop-nesting
 
-GENERIC: convert* ( node -- )
+SYMBOL: values>vregs
 
 GENERIC: convert ( node -- )
 
+M: #introduce convert drop ;
+
 : init-builder ( -- )
-    H{ } clone values>vregs set
+    H{ } clone values>vregs set ;
-    V{ } clone loop-nesting set ;
 
 : end-basic-block ( -- )
     basic-block get [ %b emit ] when ;
@@ -40,15 +44,12 @@ GENERIC: convert ( node -- )
     set-basic-block ;
 
 : convert-nodes ( node -- )
-    dup basic-block get and [
+    [ convert ] each ;
-        [ convert ] [ successor>> convert-nodes ] bi
-    ] [ drop ] if ;
 
 : (build-cfg) ( node word -- )
     init-builder
     begin-basic-block
     basic-block get swap procedures get set-at
-    %prolog emit
     convert-nodes ;
 
 : build-cfg ( node word -- procedures )
@@ -73,10 +74,9 @@ GENERIC: convert ( node -- )
         2bi
     ] 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 -- )
     over empty? [ 2drop ] [
@@ -86,40 +86,21 @@ GENERIC: convert ( node -- )
         2bi
     ] 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 -- )
     begin-basic-block %call emit begin-basic-block ;
 
 : intrinsic-inputs ( node -- )
-    [ load-inputs ]
+    [ load-in-d ]
     [ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ]
     bi ;
 
 : intrinsic-outputs ( node -- )
     [ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ]
-    [ store-outputs ]
+    [ store-out-d ]
     bi ;
 
 : intrinsic ( node quot -- )
@@ -132,19 +113,17 @@ M: node convert
         tri
     ] 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 )
-    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
     ] [
-        dup param>> (emit-call)
+        drop dup word>> (emit-call)
     ] if ;
 
 : emit-call ( node -- )
-    dup param>> {
+    dup word>> {
         { \ tag [ [ emit-tag ] intrinsic ] }
 
         { \ slot [ [ dup emit-slot ] intrinsic ] }
@@ -175,24 +154,43 @@ optimizer.allot ;
         { \ 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) ]
     } case drop ;
 
 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-recursive ( #recursive -- )
-        (emit-call)
+    label>> id>> (emit-call) ;
-    ] if* ;
+
+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 -- )
     [ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline
@@ -221,50 +219,38 @@ M: #call-label convert
     [ set-basic-block ]
     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
-    {
+    [ 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: #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* ;
 
-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 ;

unfinished/compiler/machine/debugger/debugger.factor

@@ -1,12 +1,17 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 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
         build-cfg
@@ -20,15 +25,16 @@ IN: compiler.machine.debug
     ] assoc-each ;
 
 : linearized-quot. ( quot -- )
-    dataflow optimize
+    build-tree optimize-tree
-    "Anonymous quotation" dataflow>linear
+    "Anonymous quotation" tree>linear
     linear. ;
 
 : 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 )
-    dataflow optimize
+    build-tree optimize-tree
     [
         init-counter
         "Anonymous quotation" build-cfg

unfinished/compiler/tree/debugger/debugger-tests.factor

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

unfinished/compiler/tree/debugger/debugger.factor

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

unfinished/compiler/tree/loop/inversion/inversion.factor

@@ -0,0 +1,5 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.tree.loop.inversion
+
+: invert-loops ( nodes -- nodes' ) ;

unfinished/compiler/tree/optimizer/optimizer-tests.factor

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

unfinished/compiler/tree/optimizer/optimizer.factor

@@ -9,6 +9,7 @@ compiler.tree.def-use
 compiler.tree.dead-code
 compiler.tree.strength-reduction
 compiler.tree.loop.detection
+compiler.tree.loop.inversion
 compiler.tree.branch-fusion ;
 IN: compiler.tree.optimizer