From 27dd4f17019d5287d1d9ab524694e7cd81bbddd4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 4 Mar 2008 22:04:56 -0600
Subject: [PATCH 1/5] Working on Windows launcher stream inheritance

---
 extra/io/launcher/launcher-docs.factor       |  16 ++-
 extra/io/windows/nt/launcher/launcher.factor | 116 ++++++++++++-------
 extra/io/windows/windows.factor              |   2 +-
 3 files changed, 88 insertions(+), 46 deletions(-)

diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor
index 96639dee87..31d7e7a60d 100755
--- a/extra/io/launcher/launcher-docs.factor
+++ b/extra/io/launcher/launcher-docs.factor
@@ -35,33 +35,43 @@ HELP: +environment-mode+
 HELP: +stdin+
 { $description "Launch descriptor key. Must equal one of the following:"
     { $list
-        { { $link f } " - standard input is inherited" }
+        { { $link f } " - standard input is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
+        { { $link +inherit+ } " - standard input is inherited from the current process" }
         { { $link +closed+ } " - standard input is closed" }
         { "a path name - standard input is read from the given file, which must exist" }
+        { "a file stream or a socket - standard input is read from the given stream, which must be closed after the process has been started" }
     }
 } ;
 
 HELP: +stdout+
 { $description "Launch descriptor key. Must equal one of the following:"
     { $list
-        { { $link f } " - standard output is inherited" }
+        { { $link f } " - standard output is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
+        { { $link +inherit+ } " - standard output is inherited from the current process" }
         { { $link +closed+ } " - standard output is closed" }
         { "a path name - standard output is written to the given file, which is overwritten if it already exists" }
+        { "a file stream or a socket - standard output is written to the given stream, which must be closed after the process has been started" }
     }
 } ;
 
 HELP: +stderr+
 { $description "Launch descriptor key. Must equal one of the following:"
     { $list
-        { { $link f } " - standard error is inherited" }
+        { { $link f } " - standard error is inherited from the current process" }
+        { { $link +inherit+ } " - same as above" }
+        { { $link +stdout+ } " - standard error is merged with standard output" }
         { { $link +closed+ } " - standard error is closed" }
         { "a path name - standard error is written to the given file, which is overwritten if it already exists" }
+        { "a file stream or a socket - standard error is written to the given stream, which must be closed after the process has been started" }
     }
 } ;
 
 HELP: +closed+
 { $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
 
+HELP: +inherit+
+{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
+
 HELP: +prepend-environment+
 { $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence."
 $nl
diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor
index cd9bb9baef..a4a3122b4d 100755
--- a/extra/io/windows/nt/launcher/launcher.factor
+++ b/extra/io/windows/nt/launcher/launcher.factor
@@ -1,18 +1,38 @@
-! Copyright (C) 2007 Doug Coleman, Slava Pestov.
+! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays continuations destructors io
 io.windows libc io.nonblocking io.streams.duplex windows.types
 math windows.kernel32 windows namespaces io.launcher kernel
 sequences windows.errors assocs splitting system strings
 io.windows.launcher io.windows.nt.pipes io.backend
-combinators ;
+combinators shuffle ;
 IN: io.windows.nt.launcher
 
+: duplicate-handle ( handle -- handle' )
+    GetCurrentProcess ! source process
+    swap ! handle
+    GetCurrentProcess ! target process
+    f <void*> [ ! target handle
+        DUPLICATE_SAME_ACCESS ! desired access
+        TRUE ! inherit handle
+        DUPLICATE_CLOSE_SOURCE ! options
+        DuplicateHandle win32-error=0/f
+    ] keep *void* ;
+
 ! The below code is based on the example given in
 ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
 
-: (redirect) ( path access-mode create-mode -- handle )
-    >r >r
+: redirect-default ( default obj access-mode create-mode -- handle )
+    3drop ;
+
+: redirect-inherit ( default obj access-mode create-mode -- handle )
+    4drop f ;
+
+: redirect-closed ( default obj access-mode create-mode -- handle )
+    drop 2nip null-pipe ;
+
+: redirect-file ( default path access-mode create-mode -- handle )
+    >r >r >r drop r>
     normalize-pathname
     r> ! access-mode
     share-mode
@@ -22,47 +42,59 @@ IN: io.windows.nt.launcher
     f ! template file
     CreateFile dup invalid-handle? dup close-later ;
 
-: redirect ( obj access-mode create-mode -- handle )
-    {
-        { [ pick not ] [ 3drop f ] }
-        { [ pick +closed+ eq? ] [ drop nip null-pipe ] }
-        { [ pick string? ] [ (redirect) ] }
-    } cond ;
-
-: ?closed or dup t eq? [ drop f ] when ;
-
-: inherited-stdout ( args -- handle )
-    CreateProcess-args-stdout-pipe
-    [ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ;
-
-: redirect-stdout ( args -- handle )
-    +stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect
-    swap inherited-stdout ?closed ;
-
-: inherited-stderr ( args -- handle )
-    drop STD_ERROR_HANDLE GetStdHandle ;
-
-: redirect-stderr ( args -- handle )
-    +stderr+ get
-    dup +stdout+ eq? [
-        drop
-        CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput
-    ] [
-        GENERIC_WRITE CREATE_ALWAYS redirect
-        swap inherited-stderr ?closed
-    ] if ;
-
-: inherited-stdin ( args -- handle )
-    CreateProcess-args-stdin-pipe
-    [ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ;
-
-: redirect-stdin ( args -- handle )
-    +stdin+ get GENERIC_READ OPEN_EXISTING redirect
-    swap inherited-stdin ?closed ;
-
 : set-inherit ( handle ? -- )
     >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
 
+: redirect-stream ( default stream access-mode create-mode -- handle )
+    2drop nip
+    underlying-handle win32-file-handle
+    duplicate-handle dup t set-inherit ;
+
+: redirect ( default obj access-mode create-mode -- handle )
+    {
+        { [ pick not ] [ redirect-default ] }
+        { [ pick +inherit+ eq? ] [ redirect-inherit ] }
+        { [ pick +closed+ eq? ] [ redirect-closed ] }
+        { [ pick string? ] [ redirect-file ] }
+        { [ t ] [ redirect-stream ] }
+    } cond ;
+
+: default-stdout ( args -- handle )
+    CreateProcess-args-stdout-pipe dup [ pipe-out ] when ;
+
+: redirect-stdout ( args -- handle )
+    default-stdout
+    +stdout+ get
+    GENERIC_WRITE
+    CREATE_ALWAYS
+    redirect
+    STD_OUTPUT_HANDLE GetStdHandle or ;
+
+: redirect-stderr ( args -- handle )
+    +stderr+ get +stdout+ eq? [
+        CreateProcess-args-lpStartupInfo
+        STARTUPINFO-hStdOutput
+    ] [
+        drop
+        f
+        +stderr+ get
+        GENERIC_WRITE
+        CREATE_ALWAYS
+        redirect
+        STD_ERROR_HANDLE GetStdHandle or
+    ] if ;
+
+: default-stdin ( args -- handle )
+    CreateProcess-args-stdin-pipe dup [ pipe-in ] when ;
+
+: redirect-stdin ( args -- handle )
+    default-stdin
+    +stdin+ get
+    GENERIC_READ
+    OPEN_EXISTING
+    redirect
+    STD_INPUT_HANDLE GetStdHandle or ;
+
 : add-pipe-dtors ( pipe -- )
     dup
     pipe-in close-later
diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor
index 38b7d4829c..291bef6018 100755
--- a/extra/io/windows/windows.factor
+++ b/extra/io/windows/windows.factor
@@ -55,7 +55,7 @@ M: win32-file close-handle ( handle -- )
 : open-file ( path access-mode create-mode flags -- handle )
     [
         >r >r >r normalize-pathname r>
-        share-mode f r> r> CreateFile-flags f CreateFile
+        share-mode security-attributes-inherit r> r> CreateFile-flags f CreateFile
         dup invalid-handle? dup close-later
         dup add-completion
     ] with-destructors ;

From 18d8f449b9f319a9f25b637ea0cb284ae5745467 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 4 Mar 2008 22:13:30 -0600
Subject: [PATCH 2/5] Remove unnecessary method tuple, move its slots to word
 properties

---
 core/generic/generic-docs.factor        |  10 +-
 core/generic/generic.factor             |  52 +-
 core/generic/math/math.factor           |   2 +-
 core/generic/standard/standard.factor   |   2 +-
 core/inference/backend/backend.factor   |   3 +-
 core/optimizer/inlining/inlining.factor | 416 ++++++-------
 core/optimizer/optimizer-tests.factor   | 756 ++++++++++++------------
 core/prettyprint/prettyprint.factor     |  14 +-
 core/words/words.factor                 |   2 +-
 9 files changed, 629 insertions(+), 628 deletions(-)

diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 631aa7e62d..b2fba47d3a 100755
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -116,16 +116,18 @@ HELP: method-spec
 { $class-description "The class of method specifiers, which are two-element arrays consisting of a class word followed by a generic word." }
 { $examples { $code "{ fixnum + }" "{ editor draw-gadget* }" } } ;
 
+HELP: method-body
+{ $class-description "The class of method bodies, which are words with special word properties set." } ;
+
 HELP: method
-{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method } " or " { $link f } } }
-{ $description "Looks up a method definition." }
-{ $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ;
+{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
+{ $description "Looks up a method definition." } ;
 
 { method define-method POSTPONE: M: } related-words
 
 HELP: <method>
 { $values { "def" "a quotation" } { "method" "a new method definition" } }
-{ $description "Creates a new  "{ $link method } " instance." } ;
+{ $description "Creates a new method." } ;
 
 HELP: methods
 { $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 35cc471033..dbff82777f 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -33,8 +33,6 @@ M: generic definition drop f ;
     dup { "unannotated-def" } reset-props
     dup dup "combination" word-prop perform-combination define ;
 
-TUPLE: method word def specializer generic loc ;
-
 : method ( class generic -- method/f )
     "methods" word-prop at ;
 
@@ -47,7 +45,7 @@ PREDICATE: pair method-spec
 : methods ( word -- assoc )
     "methods" word-prop
     [ keys sort-classes ] keep
-    [ dupd at method-word ] curry { } map>assoc ;
+    [ dupd at ] curry { } map>assoc ;
 
 TUPLE: check-method class generic ;
 
@@ -63,29 +61,33 @@ TUPLE: check-method class generic ;
 : method-word-name ( class word -- string )
     word-name "/" rot word-name 3append ;
 
-: make-method-def ( quot word combination -- quot )
+: make-method-def ( quot class generic -- quot )
     "combination" word-prop method-prologue swap append ;
 
-PREDICATE: word method-body "method" word-prop >boolean ;
+PREDICATE: word method-body "method-def" word-prop >boolean ;
 
 M: method-body stack-effect
-    "method" word-prop method-generic stack-effect ;
+    "method-generic" word-prop stack-effect ;
 
-: <method-word> ( quot class generic -- word )
-    [ make-method-def ] 2keep
-    method-word-name f <word>
-    dup rot define
-    dup xref ;
+: method-word-props ( quot class generic -- assoc )
+    [
+        "method-generic" set
+        "method-class" set
+        "method-def" set
+    ] H{ } make-assoc ;
 
-: <method> ( quot class generic -- method )
+: <method> ( quot class generic -- word )
     check-method
-    [ <method-word> ] 3keep f \ method construct-boa
-    dup method-word over "method" set-word-prop ;
+    [ make-method-def ] 3keep
+    [ method-word-props ] 2keep
+    method-word-name f <word>
+    tuck set-word-props
+    dup rot define ;
 
 : redefine-method ( quot class generic -- )
-    [ method set-method-def ] 3keep
+    [ method swap "method-def" set-word-prop ] 3keep
     [ make-method-def ] 2keep
-    method method-word swap define ;
+    method swap define ;
 
 : define-method ( quot class generic -- )
     >r bootstrap-word r>
@@ -102,21 +104,22 @@ M: method-body stack-effect
 
 ! Definition protocol
 M: method-spec where
-    dup first2 method [ method-word ] [ second ] ?if where ;
+    dup first2 method [ ] [ second ] ?if where ;
 
 M: method-spec set-where
-    first2 method method-word set-where ;
+    first2 method set-where ;
 
 M: method-spec definer
     drop \ M: \ ; ;
 
 M: method-spec definition
-    first2 method dup [ method-def ] when ;
+    first2 method dup
+    [ "method-def" word-prop ] when ;
 
 : forget-method ( class generic -- )
     check-method
     [ delete-at* ] with-methods
-    [ method-word forget-word ] [ drop ] if ;
+    [ forget-word ] [ drop ] if ;
 
 M: method-spec forget*
     first2 forget-method ;
@@ -125,11 +128,11 @@ M: method-body definer
     drop \ M: \ ; ;
 
 M: method-body definition
-    "method" word-prop method-def ;
+    "method-def" word-prop ;
 
 M: method-body forget*
-    "method" word-prop
-    { method-specializer method-generic } get-slots
+    dup "method-class" word-prop
+    swap "method-generic" word-prop
     forget-method ;
 
 : implementors* ( classes -- words )
@@ -168,8 +171,7 @@ M: word subwords drop f ;
 
 M: generic subwords
     dup "methods" word-prop values
-    swap "default-method" word-prop add
-    [ method-word ] map ;
+    swap "default-method" word-prop add ;
 
 M: generic forget-word
     dup subwords [ forget-word ] each (forget-word) ;
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 0b2b9fcca3..27b0ddb7a2 100755
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ;
 
 : applicable-method ( generic class -- quot )
     over method
-    [ method-word word-def ]
+    [ word-def ]
     [ default-math-method ] ?if ;
 
 : object-method ( generic -- quot )
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 230ec446c7..313f487c99 100755
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -69,7 +69,7 @@ TUPLE: no-method object generic ;
     ] if ;
 
 : default-method ( word -- pair )
-    "default-method" word-prop method-word
+    "default-method" word-prop
     object bootstrap-word swap 2array ;
 
 : method-alist>quot ( alist base-class -- quot )
diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index cadf326692..2a2e6995eb 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -10,8 +10,7 @@ IN: inference.backend
     recursive-state get at ;
 
 : inline? ( word -- ? )
-    dup "method" word-prop
-    [ method-generic inline? ] [ "inline" word-prop ] ?if ;
+    dup "method-generic" word-prop swap or "inline" word-prop ;
 
 : local-recursive-state ( -- assoc )
     recursive-state get dup keys
diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor
index f3709780f9..04d7ab4ee5 100755
--- a/core/optimizer/inlining/inlining.factor
+++ b/core/optimizer/inlining/inlining.factor
@@ -1,208 +1,208 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic assocs inference inference.class
-inference.dataflow inference.backend inference.state io kernel
-math namespaces sequences vectors words quotations hashtables
-combinators classes generic.math continuations optimizer.def-use
-optimizer.backend generic.standard optimizer.specializers
-optimizer.def-use optimizer.pattern-match generic.standard
-optimizer.control kernel.private ;
-IN: optimizer.inlining
-
-: remember-inlining ( node history -- )
-    [ swap set-node-history ] curry each-node ;
-
-: inlining-quot ( node quot -- node )
-    over node-in-d dataflow-with
-    dup rot infer-classes/node ;
-
-: splice-quot ( #call quot history -- node )
-    #! Must add history *before* splicing in, otherwise
-    #! the rest of the IR will also remember the history
-    pick node-history append
-    >r dupd inlining-quot dup r> remember-inlining
-    tuck splice-node ;
-
-! A heuristic to avoid excessive inlining
-DEFER: (flat-length)
-
-: word-flat-length ( word -- n )
-    {
-        ! heuristic: { ... } declare comes up in method bodies
-        ! and we don't care about it
-        { [ dup \ declare eq? ] [ drop -2 ] }
-        ! recursive
-        { [ dup get ] [ drop 1 ] }
-        ! not inline
-        { [ dup inline? not ] [ drop 1 ] }
-        ! inline
-        { [ t ] [ dup dup set word-def (flat-length) ] }
-    } cond ;
-
-: (flat-length) ( seq -- n )
-    [
-        {
-            { [ dup quotation? ] [ (flat-length) 1+ ] }
-            { [ dup array? ] [ (flat-length) ] }
-            { [ dup word? ] [ word-flat-length ] }
-            { [ t ] [ drop 1 ] }
-        } cond
-    ] map sum ;
-
-: flat-length ( seq -- n )
-    [ word-def (flat-length) ] with-scope ;
-
-! Single dispatch method inlining optimization
-: specific-method ( class word -- class ) order min-class ;
-
-: node-class# ( node n -- class )
-    over node-in-d <reversed> ?nth node-class ;
-
-: dispatching-class ( node word -- class )
-    [ dispatch# node-class# ] keep specific-method ;
-
-: inline-standard-method ( node word -- node )
-    2dup dispatching-class dup [
-        over +inlined+ depends-on
-        swap method method-word 1quotation f splice-quot
-    ] [
-        3drop t
-    ] if ;
-
-! Partial dispatch of math-generic words
-: math-both-known? ( word left right -- ? )
-    math-class-max swap specific-method ;
-
-: inline-math-method ( #call word -- node )
-    over node-input-classes first2 3dup math-both-known?
-    [ math-method f splice-quot ] [ 2drop 2drop t ] if ;
-
-: inline-method ( #call -- node )
-    dup node-param {
-        { [ dup standard-generic? ] [ inline-standard-method ] }
-        { [ dup math-generic? ] [ inline-math-method ] }
-        { [ t ] [ 2drop t ] }
-    } cond ;
-
-! Resolve type checks at compile time where possible
-: comparable? ( actual testing -- ? )
-    #! If actual is a subset of testing or if the two classes
-    #! are disjoint, return t.
-    2dup class< >r classes-intersect? not r> or ;
-
-: optimize-predicate? ( #call -- ? )
-    dup node-param "predicating" word-prop dup [
-        >r node-class-first r> comparable?
-    ] [
-        2drop f
-    ] if ;
-
-: literal-quot ( node literals -- quot )
-    #! Outputs a quotation which drops the node's inputs, and
-    #! pushes some literals.
-    >r node-in-d length \ drop <repetition>
-    r> [ literalize ] map append >quotation ;
-
-: inline-literals ( node literals -- node )
-    #! Make #shuffle -> #push -> #return -> successor
-    dupd literal-quot f splice-quot ;
-
-: evaluate-predicate ( #call -- ? )
-    dup node-param "predicating" word-prop >r
-    node-class-first r> class< ;
-
-: optimize-predicate ( #call -- node )
-    #! If the predicate is followed by a branch we fold it
-    #! immediately
-    dup evaluate-predicate swap
-    dup node-successor #if? [
-        dup drop-inputs >r
-        node-successor swap 0 1 ? fold-branch
-        r> [ set-node-successor ] keep
-    ] [
-        swap 1array inline-literals
-    ] if ;
-
-: optimizer-hooks ( node -- conditions )
-    node-param "optimizer-hooks" word-prop ;
-
-: optimizer-hook ( node -- pair/f )
-    dup optimizer-hooks [ first call ] find 2nip ;
-
-: optimize-hook ( node -- )
-    dup optimizer-hook second call ;
-
-: define-optimizers ( word optimizers -- )
-    "optimizer-hooks" set-word-prop ;
-
-: flush-eval? ( #call -- ? )
-    dup node-param "flushable" word-prop [
-        node-out-d [ unused? ] all?
-    ] [
-        drop f
-    ] if ;
-
-: flush-eval ( #call -- node )
-    dup node-param +inlined+ depends-on
-    dup node-out-d length f <repetition> inline-literals ;
-
-: partial-eval? ( #call -- ? )
-    dup node-param "foldable" word-prop [
-        dup node-in-d [ node-literal? ] with all?
-    ] [
-        drop f
-    ] if ;
-
-: literal-in-d ( #call -- inputs )
-    dup node-in-d [ node-literal ] with map ;
-
-: partial-eval ( #call -- node )
-    dup node-param +inlined+ depends-on
-    dup literal-in-d over node-param 1quotation
-    [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
-
-: define-identities ( words identities -- )
-    [ "identities" set-word-prop ] curry each ;
-
-: find-identity ( node -- quot )
-    [ node-param "identities" word-prop ] keep
-    [ swap first in-d-match? ] curry find
-    nip dup [ second ] when ;
-
-: apply-identities ( node -- node/f )
-    dup find-identity dup [ f splice-quot ] [ 2drop f ] if ;
-
-: optimistic-inline? ( #call -- ? )
-    dup node-param "specializer" word-prop dup [
-        >r node-input-classes r> specialized-length tail*
-        [ types length 1 = ] all?
-    ] [
-        2drop f
-    ] if ;
-
-: splice-word-def ( #call word -- node )
-    dup +inlined+ depends-on
-    dup word-def swap 1array splice-quot ;
-
-: optimistic-inline ( #call -- node )
-    dup node-param over node-history memq? [
-        drop t
-    ] [
-        dup node-param splice-word-def
-    ] if ;
-
-: method-body-inline? ( #call -- ? )
-    node-param dup method-body?
-    [ flat-length 10 <= ] [ drop f ] if ;
-
-M: #call optimize-node*
-    {
-        { [ dup flush-eval? ] [ flush-eval ] }
-        { [ dup partial-eval? ] [ partial-eval ] }
-        { [ dup find-identity ] [ apply-identities ] }
-        { [ dup optimizer-hook ] [ optimize-hook ] }
-        { [ dup optimize-predicate? ] [ optimize-predicate ] }
-        { [ dup optimistic-inline? ] [ optimistic-inline ] }
-        { [ dup method-body-inline? ] [ optimistic-inline ] }
-        { [ t ] [ inline-method ] }
-    } cond dup not ;
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays generic assocs inference inference.class
+inference.dataflow inference.backend inference.state io kernel
+math namespaces sequences vectors words quotations hashtables
+combinators classes generic.math continuations optimizer.def-use
+optimizer.backend generic.standard optimizer.specializers
+optimizer.def-use optimizer.pattern-match generic.standard
+optimizer.control kernel.private ;
+IN: optimizer.inlining
+
+: remember-inlining ( node history -- )
+    [ swap set-node-history ] curry each-node ;
+
+: inlining-quot ( node quot -- node )
+    over node-in-d dataflow-with
+    dup rot infer-classes/node ;
+
+: splice-quot ( #call quot history -- node )
+    #! Must add history *before* splicing in, otherwise
+    #! the rest of the IR will also remember the history
+    pick node-history append
+    >r dupd inlining-quot dup r> remember-inlining
+    tuck splice-node ;
+
+! A heuristic to avoid excessive inlining
+DEFER: (flat-length)
+
+: word-flat-length ( word -- n )
+    {
+        ! heuristic: { ... } declare comes up in method bodies
+        ! and we don't care about it
+        { [ dup \ declare eq? ] [ drop -2 ] }
+        ! recursive
+        { [ dup get ] [ drop 1 ] }
+        ! not inline
+        { [ dup inline? not ] [ drop 1 ] }
+        ! inline
+        { [ t ] [ dup dup set word-def (flat-length) ] }
+    } cond ;
+
+: (flat-length) ( seq -- n )
+    [
+        {
+            { [ dup quotation? ] [ (flat-length) 1+ ] }
+            { [ dup array? ] [ (flat-length) ] }
+            { [ dup word? ] [ word-flat-length ] }
+            { [ t ] [ drop 1 ] }
+        } cond
+    ] map sum ;
+
+: flat-length ( seq -- n )
+    [ word-def (flat-length) ] with-scope ;
+
+! Single dispatch method inlining optimization
+: specific-method ( class word -- class ) order min-class ;
+
+: node-class# ( node n -- class )
+    over node-in-d <reversed> ?nth node-class ;
+
+: dispatching-class ( node word -- class )
+    [ dispatch# node-class# ] keep specific-method ;
+
+: inline-standard-method ( node word -- node )
+    2dup dispatching-class dup [
+        over +inlined+ depends-on
+        swap method 1quotation f splice-quot
+    ] [
+        3drop t
+    ] if ;
+
+! Partial dispatch of math-generic words
+: math-both-known? ( word left right -- ? )
+    math-class-max swap specific-method ;
+
+: inline-math-method ( #call word -- node )
+    over node-input-classes first2 3dup math-both-known?
+    [ math-method f splice-quot ] [ 2drop 2drop t ] if ;
+
+: inline-method ( #call -- node )
+    dup node-param {
+        { [ dup standard-generic? ] [ inline-standard-method ] }
+        { [ dup math-generic? ] [ inline-math-method ] }
+        { [ t ] [ 2drop t ] }
+    } cond ;
+
+! Resolve type checks at compile time where possible
+: comparable? ( actual testing -- ? )
+    #! If actual is a subset of testing or if the two classes
+    #! are disjoint, return t.
+    2dup class< >r classes-intersect? not r> or ;
+
+: optimize-predicate? ( #call -- ? )
+    dup node-param "predicating" word-prop dup [
+        >r node-class-first r> comparable?
+    ] [
+        2drop f
+    ] if ;
+
+: literal-quot ( node literals -- quot )
+    #! Outputs a quotation which drops the node's inputs, and
+    #! pushes some literals.
+    >r node-in-d length \ drop <repetition>
+    r> [ literalize ] map append >quotation ;
+
+: inline-literals ( node literals -- node )
+    #! Make #shuffle -> #push -> #return -> successor
+    dupd literal-quot f splice-quot ;
+
+: evaluate-predicate ( #call -- ? )
+    dup node-param "predicating" word-prop >r
+    node-class-first r> class< ;
+
+: optimize-predicate ( #call -- node )
+    #! If the predicate is followed by a branch we fold it
+    #! immediately
+    dup evaluate-predicate swap
+    dup node-successor #if? [
+        dup drop-inputs >r
+        node-successor swap 0 1 ? fold-branch
+        r> [ set-node-successor ] keep
+    ] [
+        swap 1array inline-literals
+    ] if ;
+
+: optimizer-hooks ( node -- conditions )
+    node-param "optimizer-hooks" word-prop ;
+
+: optimizer-hook ( node -- pair/f )
+    dup optimizer-hooks [ first call ] find 2nip ;
+
+: optimize-hook ( node -- )
+    dup optimizer-hook second call ;
+
+: define-optimizers ( word optimizers -- )
+    "optimizer-hooks" set-word-prop ;
+
+: flush-eval? ( #call -- ? )
+    dup node-param "flushable" word-prop [
+        node-out-d [ unused? ] all?
+    ] [
+        drop f
+    ] if ;
+
+: flush-eval ( #call -- node )
+    dup node-param +inlined+ depends-on
+    dup node-out-d length f <repetition> inline-literals ;
+
+: partial-eval? ( #call -- ? )
+    dup node-param "foldable" word-prop [
+        dup node-in-d [ node-literal? ] with all?
+    ] [
+        drop f
+    ] if ;
+
+: literal-in-d ( #call -- inputs )
+    dup node-in-d [ node-literal ] with map ;
+
+: partial-eval ( #call -- node )
+    dup node-param +inlined+ depends-on
+    dup literal-in-d over node-param 1quotation
+    [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
+
+: define-identities ( words identities -- )
+    [ "identities" set-word-prop ] curry each ;
+
+: find-identity ( node -- quot )
+    [ node-param "identities" word-prop ] keep
+    [ swap first in-d-match? ] curry find
+    nip dup [ second ] when ;
+
+: apply-identities ( node -- node/f )
+    dup find-identity dup [ f splice-quot ] [ 2drop f ] if ;
+
+: optimistic-inline? ( #call -- ? )
+    dup node-param "specializer" word-prop dup [
+        >r node-input-classes r> specialized-length tail*
+        [ types length 1 = ] all?
+    ] [
+        2drop f
+    ] if ;
+
+: splice-word-def ( #call word -- node )
+    dup +inlined+ depends-on
+    dup word-def swap 1array splice-quot ;
+
+: optimistic-inline ( #call -- node )
+    dup node-param over node-history memq? [
+        drop t
+    ] [
+        dup node-param splice-word-def
+    ] if ;
+
+: method-body-inline? ( #call -- ? )
+    node-param dup method-body?
+    [ flat-length 10 <= ] [ drop f ] if ;
+
+M: #call optimize-node*
+    {
+        { [ dup flush-eval? ] [ flush-eval ] }
+        { [ dup partial-eval? ] [ partial-eval ] }
+        { [ dup find-identity ] [ apply-identities ] }
+        { [ dup optimizer-hook ] [ optimize-hook ] }
+        { [ dup optimize-predicate? ] [ optimize-predicate ] }
+        { [ dup optimistic-inline? ] [ optimistic-inline ] }
+        { [ dup method-body-inline? ] [ optimistic-inline ] }
+        { [ t ] [ inline-method ] }
+    } cond dup not ;
diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor
index 5116d66715..3abccecc7f 100755
--- a/core/optimizer/optimizer-tests.factor
+++ b/core/optimizer/optimizer-tests.factor
@@ -1,378 +1,378 @@
-USING: arrays compiler.units generic hashtables inference kernel
-kernel.private math optimizer prettyprint sequences sbufs
-strings tools.test vectors words sequences.private quotations
-optimizer.backend classes inference.dataflow tuples.private
-continuations growable optimizer.inlining namespaces hints ;
-IN: optimizer.tests
-
-[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
-    H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union*
-] unit-test
-
-[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [
-    H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
-] unit-test
-
-! Test method inlining
-[ f ] [ fixnum { } min-class ] unit-test
-
-[ string ] [
-    \ string
-    [ integer string array reversed sbuf
-    slice vector quotation ]
-    sort-classes min-class
-] unit-test
-
-[ fixnum ] [
-    \ fixnum
-    [ fixnum integer object ]
-    sort-classes min-class
-] unit-test
-
-[ integer ] [
-    \ fixnum
-    [ integer float object ]
-    sort-classes min-class
-] unit-test
-
-[ object ] [
-    \ word
-    [ integer float object ]
-    sort-classes min-class
-] unit-test
-
-[ reversed ] [
-    \ reversed
-    [ integer reversed slice ]
-    sort-classes min-class
-] unit-test
-
-GENERIC: xyz ( obj -- obj )
-M: array xyz xyz ;
-
-[ t ] [ \ xyz compiled? ] unit-test
-
-! Test predicate inlining
-: pred-test-1
-    dup fixnum? [
-        dup integer? [ "integer" ] [ "nope" ] if
-    ] [
-        "not a fixnum"
-    ] if ;
-
-[ 1 "integer" ] [ 1 pred-test-1 ] unit-test
-
-TUPLE: pred-test ;
-
-: pred-test-2
-    dup tuple? [
-        dup pred-test? [ "pred-test" ] [ "nope" ] if
-    ] [
-        "not a tuple"
-    ] if ;
-
-[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
-
-: pred-test-3
-    dup pred-test? [
-        dup tuple? [ "pred-test" ] [ "nope" ] if
-    ] [
-        "not a tuple"
-    ] if ;
-
-[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
-
-: inline-test
-    "nom" = ;
-
-[ t ] [ "nom" inline-test ] unit-test
-[ f ] [ "shayin" inline-test ] unit-test
-[ f ] [ 3 inline-test ] unit-test
-
-: fixnum-declarations >fixnum 24 shift 1234 bitxor ;
-
-[ ] [ 1000000 fixnum-declarations . ] unit-test
-
-! regression
-
-: literal-not-branch 0 not [ ] [ ] if ;
-
-[ ] [ literal-not-branch ] unit-test
-
-! regression
-
-: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
-: bad-kill-2 bad-kill-1 drop ;
-
-[ 3 ] [ t bad-kill-2 ] unit-test
-
-! regression
-: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
-: the-test ( -- x y ) 2 dup (the-test) ;
-
-[ 2 0 ] [ the-test ] unit-test
-
-! regression
-: (double-recursion) ( start end -- )
-    < [
-        6 1 (double-recursion)
-        3 2 (double-recursion)
-    ] when ; inline
-
-: double-recursion 0 2 (double-recursion) ;
-
-[ ] [ double-recursion ] unit-test
-
-! regression
-: double-label-1 ( a b c -- d )
-    [ f double-label-1 ] [ swap nth-unsafe ] if ; inline
-
-: double-label-2 ( a -- b )
-    dup array? [ ] [ ] if 0 t double-label-1 ;
-
-[ 0 ] [ 10 double-label-2 ] unit-test
-
-! regression
-GENERIC: void-generic ( obj -- * )
-: breakage "hi" void-generic ;
-[ t ] [ \ breakage compiled? ] unit-test
-[ breakage ] must-fail
-
-! regression
-: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline
-: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline
-: test-2 ( -- ) 5 test-1 ;
-
-[ f ] [ f test-2 ] unit-test
-
-: branch-fold-regression-0 ( m -- n )
-    t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
-
-: branch-fold-regression-1 ( -- m )
-    10 branch-fold-regression-0 ;
-
-[ 10 ] [ branch-fold-regression-1 ] unit-test
-
-! another regression
-: constant-branch-fold-0 "hey" ; foldable
-: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline
-[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
-
-! another regression
-: foo f ;
-: bar foo 4 4 = and ;
-[ f ] [ bar ] unit-test
-
-! ensure identities are working in some form
-[ t ] [
-    [ { number } declare 0 + ] dataflow optimize
-    [ #push? ] node-exists? not
-] unit-test
-
-! compiling <tuple> with a non-literal class failed
-: <tuple>-regression <tuple> ;
-
-[ t ] [ \ <tuple>-regression compiled? ] unit-test
-
-GENERIC: foozul ( a -- b )
-M: reversed foozul ;
-M: integer foozul ;
-M: slice foozul ;
-
-[ reversed ] [ reversed \ foozul specific-method ] unit-test
-
-! regression
-: constant-fold-2 f ; foldable
-: constant-fold-3 4 ; foldable
-
-[ f t ] [
-    [ constant-fold-2 constant-fold-3 4 = ] compile-call
-] unit-test
-
-: constant-fold-4 f ; foldable
-: constant-fold-5 f ; foldable
-
-[ f ] [
-    [ constant-fold-4 constant-fold-5 or ] compile-call
-] unit-test
-
-[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
-[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
-
-[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
-[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
-[ 0 ] [ 5 [ dup - ] compile-call ] unit-test
-
-[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
-[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
-[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
-[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
-[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
-[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
-
-[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
-[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
-
-[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
-[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
-[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
-[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test
-[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test
-
-[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
-[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
-[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
-[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test
-[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test
-
-[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
-[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test
-[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test
-[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
-[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
-
-[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
-[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
-
-[ f ] [ 5 [ dup < ] compile-call ] unit-test
-[ t ] [ 5 [ dup <= ] compile-call ] unit-test
-[ f ] [ 5 [ dup > ] compile-call ] unit-test
-[ t ] [ 5 [ dup >= ] compile-call ] unit-test
-
-[ t ] [ 5 [ dup eq? ] compile-call ] unit-test
-[ t ] [ 5 [ dup = ] compile-call ] unit-test
-[ t ] [ 5 [ dup number= ] compile-call ] unit-test
-[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
-
-GENERIC: detect-number ( obj -- obj )
-M: number detect-number ;
-
-[ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
-
-! Regression
-[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
-
-! Regression
-USE: sorting
-USE: sorting.private
-
-: old-binsearch ( elt quot seq -- elt quot i )
-    dup length 1 <= [
-        slice-from
-    ] [
-        [ midpoint swap call ] 3keep roll dup zero?
-        [ drop dup slice-from swap midpoint@ + ]
-        [ partition old-binsearch ] if
-    ] if ; inline
-
-[ 10 ] [
-    10 20 >vector <flat-slice>
-    [ [ - ] swap old-binsearch ] compile-call 2nip
-] unit-test
-
-! Regression
-TUPLE: silly-tuple a b ;
-
-[ 1 2 { silly-tuple-a silly-tuple-b } ] [
-    T{ silly-tuple f 1 2 }
-    [
-        { silly-tuple-a silly-tuple-b } [ get-slots ] keep
-    ] compile-call
-] unit-test
-
-! Regression
-: empty-compound ;
-
-: node-successor-f-bug ( x -- * )
-    [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
-
-[ t ] [ \ node-successor-f-bug compiled? ] unit-test
-
-[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
-
-[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
-
-! Make sure we have sane heuristics
-: should-inline? method method-word flat-length 10 <= ;
-
-[ t ] [ \ fixnum \ shift should-inline? ] unit-test
-[ f ] [ \ array \ equal? should-inline? ] unit-test
-[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
-[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
-[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
-[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
-
-! Regression
-: lift-throw-tail-regression
-    dup integer? [ "an integer" ] [
-        dup string? [ "a string" ] [
-            "error" throw
-        ] if
-    ] if ;
-
-[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test
-[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
-[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
-
-: lift-loop-tail-test-1 ( a quot -- )
-    over even? [
-        [ >r 3 - r> call ] keep lift-loop-tail-test-1
-    ] [
-        over 0 < [
-            2drop
-        ] [
-            [ >r 2 - r> call ] keep lift-loop-tail-test-1
-        ] if
-    ] if ; inline
-
-: lift-loop-tail-test-2
-    10 [ ] lift-loop-tail-test-1 1 2 3 ;
-
-[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
-
-! Make sure we don't lose
-GENERIC: generic-inline-test ( x -- y )
-M: integer generic-inline-test ;
-
-: generic-inline-test-1
-    1
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test ;
-
-[ { t f } ] [
-    \ generic-inline-test-1 word-def dataflow
-    [ optimize-1 , optimize-1 , drop ] { } make
-] unit-test
-
-! Forgot a recursive inline check
-: recursive-inline-hang ( a -- a )
-    dup array? [ recursive-inline-hang ] when ;
-
-HINTS: recursive-inline-hang array ;
-
-: recursive-inline-hang-1
-    { } recursive-inline-hang ;
-
-[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test
-
-DEFER: recursive-inline-hang-3
-
-: recursive-inline-hang-2 ( a -- a )
-    dup array? [ recursive-inline-hang-3 ] when ;
-
-HINTS: recursive-inline-hang-2 array ;
-
-: recursive-inline-hang-3 ( a -- a )
-    dup array? [ recursive-inline-hang-2 ] when ;
-
-HINTS: recursive-inline-hang-3 array ;
-
-
+USING: arrays compiler.units generic hashtables inference kernel
+kernel.private math optimizer prettyprint sequences sbufs
+strings tools.test vectors words sequences.private quotations
+optimizer.backend classes inference.dataflow tuples.private
+continuations growable optimizer.inlining namespaces hints ;
+IN: optimizer.tests
+
+[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
+    H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union*
+] unit-test
+
+[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [
+    H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
+] unit-test
+
+! Test method inlining
+[ f ] [ fixnum { } min-class ] unit-test
+
+[ string ] [
+    \ string
+    [ integer string array reversed sbuf
+    slice vector quotation ]
+    sort-classes min-class
+] unit-test
+
+[ fixnum ] [
+    \ fixnum
+    [ fixnum integer object ]
+    sort-classes min-class
+] unit-test
+
+[ integer ] [
+    \ fixnum
+    [ integer float object ]
+    sort-classes min-class
+] unit-test
+
+[ object ] [
+    \ word
+    [ integer float object ]
+    sort-classes min-class
+] unit-test
+
+[ reversed ] [
+    \ reversed
+    [ integer reversed slice ]
+    sort-classes min-class
+] unit-test
+
+GENERIC: xyz ( obj -- obj )
+M: array xyz xyz ;
+
+[ t ] [ \ xyz compiled? ] unit-test
+
+! Test predicate inlining
+: pred-test-1
+    dup fixnum? [
+        dup integer? [ "integer" ] [ "nope" ] if
+    ] [
+        "not a fixnum"
+    ] if ;
+
+[ 1 "integer" ] [ 1 pred-test-1 ] unit-test
+
+TUPLE: pred-test ;
+
+: pred-test-2
+    dup tuple? [
+        dup pred-test? [ "pred-test" ] [ "nope" ] if
+    ] [
+        "not a tuple"
+    ] if ;
+
+[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
+
+: pred-test-3
+    dup pred-test? [
+        dup tuple? [ "pred-test" ] [ "nope" ] if
+    ] [
+        "not a tuple"
+    ] if ;
+
+[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
+
+: inline-test
+    "nom" = ;
+
+[ t ] [ "nom" inline-test ] unit-test
+[ f ] [ "shayin" inline-test ] unit-test
+[ f ] [ 3 inline-test ] unit-test
+
+: fixnum-declarations >fixnum 24 shift 1234 bitxor ;
+
+[ ] [ 1000000 fixnum-declarations . ] unit-test
+
+! regression
+
+: literal-not-branch 0 not [ ] [ ] if ;
+
+[ ] [ literal-not-branch ] unit-test
+
+! regression
+
+: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
+: bad-kill-2 bad-kill-1 drop ;
+
+[ 3 ] [ t bad-kill-2 ] unit-test
+
+! regression
+: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
+: the-test ( -- x y ) 2 dup (the-test) ;
+
+[ 2 0 ] [ the-test ] unit-test
+
+! regression
+: (double-recursion) ( start end -- )
+    < [
+        6 1 (double-recursion)
+        3 2 (double-recursion)
+    ] when ; inline
+
+: double-recursion 0 2 (double-recursion) ;
+
+[ ] [ double-recursion ] unit-test
+
+! regression
+: double-label-1 ( a b c -- d )
+    [ f double-label-1 ] [ swap nth-unsafe ] if ; inline
+
+: double-label-2 ( a -- b )
+    dup array? [ ] [ ] if 0 t double-label-1 ;
+
+[ 0 ] [ 10 double-label-2 ] unit-test
+
+! regression
+GENERIC: void-generic ( obj -- * )
+: breakage "hi" void-generic ;
+[ t ] [ \ breakage compiled? ] unit-test
+[ breakage ] must-fail
+
+! regression
+: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline
+: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline
+: test-2 ( -- ) 5 test-1 ;
+
+[ f ] [ f test-2 ] unit-test
+
+: branch-fold-regression-0 ( m -- n )
+    t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
+
+: branch-fold-regression-1 ( -- m )
+    10 branch-fold-regression-0 ;
+
+[ 10 ] [ branch-fold-regression-1 ] unit-test
+
+! another regression
+: constant-branch-fold-0 "hey" ; foldable
+: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline
+[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
+
+! another regression
+: foo f ;
+: bar foo 4 4 = and ;
+[ f ] [ bar ] unit-test
+
+! ensure identities are working in some form
+[ t ] [
+    [ { number } declare 0 + ] dataflow optimize
+    [ #push? ] node-exists? not
+] unit-test
+
+! compiling <tuple> with a non-literal class failed
+: <tuple>-regression <tuple> ;
+
+[ t ] [ \ <tuple>-regression compiled? ] unit-test
+
+GENERIC: foozul ( a -- b )
+M: reversed foozul ;
+M: integer foozul ;
+M: slice foozul ;
+
+[ reversed ] [ reversed \ foozul specific-method ] unit-test
+
+! regression
+: constant-fold-2 f ; foldable
+: constant-fold-3 4 ; foldable
+
+[ f t ] [
+    [ constant-fold-2 constant-fold-3 4 = ] compile-call
+] unit-test
+
+: constant-fold-4 f ; foldable
+: constant-fold-5 f ; foldable
+
+[ f ] [
+    [ constant-fold-4 constant-fold-5 or ] compile-call
+] unit-test
+
+[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
+
+[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
+[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
+[ 0 ] [ 5 [ dup - ] compile-call ] unit-test
+
+[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
+[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
+[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
+[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
+[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
+[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
+
+[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
+[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
+
+[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
+[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
+[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
+[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test
+[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test
+
+[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
+[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
+[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test
+[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test
+
+[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test
+[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test
+[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
+[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
+
+[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
+
+[ f ] [ 5 [ dup < ] compile-call ] unit-test
+[ t ] [ 5 [ dup <= ] compile-call ] unit-test
+[ f ] [ 5 [ dup > ] compile-call ] unit-test
+[ t ] [ 5 [ dup >= ] compile-call ] unit-test
+
+[ t ] [ 5 [ dup eq? ] compile-call ] unit-test
+[ t ] [ 5 [ dup = ] compile-call ] unit-test
+[ t ] [ 5 [ dup number= ] compile-call ] unit-test
+[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
+
+GENERIC: detect-number ( obj -- obj )
+M: number detect-number ;
+
+[ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
+
+! Regression
+[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
+
+! Regression
+USE: sorting
+USE: sorting.private
+
+: old-binsearch ( elt quot seq -- elt quot i )
+    dup length 1 <= [
+        slice-from
+    ] [
+        [ midpoint swap call ] 3keep roll dup zero?
+        [ drop dup slice-from swap midpoint@ + ]
+        [ partition old-binsearch ] if
+    ] if ; inline
+
+[ 10 ] [
+    10 20 >vector <flat-slice>
+    [ [ - ] swap old-binsearch ] compile-call 2nip
+] unit-test
+
+! Regression
+TUPLE: silly-tuple a b ;
+
+[ 1 2 { silly-tuple-a silly-tuple-b } ] [
+    T{ silly-tuple f 1 2 }
+    [
+        { silly-tuple-a silly-tuple-b } [ get-slots ] keep
+    ] compile-call
+] unit-test
+
+! Regression
+: empty-compound ;
+
+: node-successor-f-bug ( x -- * )
+    [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
+
+[ t ] [ \ node-successor-f-bug compiled? ] unit-test
+
+[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
+
+[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
+
+! Make sure we have sane heuristics
+: should-inline? method flat-length 10 <= ;
+
+[ t ] [ \ fixnum \ shift should-inline? ] unit-test
+[ f ] [ \ array \ equal? should-inline? ] unit-test
+[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
+[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
+[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
+[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
+
+! Regression
+: lift-throw-tail-regression
+    dup integer? [ "an integer" ] [
+        dup string? [ "a string" ] [
+            "error" throw
+        ] if
+    ] if ;
+
+[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test
+[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
+[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
+
+: lift-loop-tail-test-1 ( a quot -- )
+    over even? [
+        [ >r 3 - r> call ] keep lift-loop-tail-test-1
+    ] [
+        over 0 < [
+            2drop
+        ] [
+            [ >r 2 - r> call ] keep lift-loop-tail-test-1
+        ] if
+    ] if ; inline
+
+: lift-loop-tail-test-2
+    10 [ ] lift-loop-tail-test-1 1 2 3 ;
+
+[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
+
+! Make sure we don't lose
+GENERIC: generic-inline-test ( x -- y )
+M: integer generic-inline-test ;
+
+: generic-inline-test-1
+    1
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test
+    generic-inline-test ;
+
+[ { t f } ] [
+    \ generic-inline-test-1 word-def dataflow
+    [ optimize-1 , optimize-1 , drop ] { } make
+] unit-test
+
+! Forgot a recursive inline check
+: recursive-inline-hang ( a -- a )
+    dup array? [ recursive-inline-hang ] when ;
+
+HINTS: recursive-inline-hang array ;
+
+: recursive-inline-hang-1
+    { } recursive-inline-hang ;
+
+[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test
+
+DEFER: recursive-inline-hang-3
+
+: recursive-inline-hang-2 ( a -- a )
+    dup array? [ recursive-inline-hang-3 ] when ;
+
+HINTS: recursive-inline-hang-2 array ;
+
+: recursive-inline-hang-3 ( a -- a )
+    dup array? [ recursive-inline-hang-2 ] when ;
+
+HINTS: recursive-inline-hang-3 array ;
+
+
diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor
index 2efc9b4e67..6cb03e4199 100755
--- a/core/prettyprint/prettyprint.factor
+++ b/core/prettyprint/prettyprint.factor
@@ -175,10 +175,10 @@ M: method-spec synopsis*
     dup definer. [ pprint-word ] each ;
 
 M: method-body synopsis*
-    dup definer.
-    "method" word-prop dup
-    method-specializer pprint*
-    method-generic pprint* ;
+    dup dup
+    definer.
+    "method-class" word-prop pprint*
+    "method-generic" word-prop pprint* ;
 
 M: mixin-instance synopsis*
     dup definer.
@@ -269,7 +269,7 @@ M: builtin-class see-class*
 
 : see-implementors ( class -- seq )
     dup implementors
-    [ method method-word ] with map
+    [ method ] with map
     natural-sort ;
 
 : see-class ( class -- )
@@ -280,9 +280,7 @@ M: builtin-class see-class*
     ] when drop ;
 
 : see-methods ( generic -- seq )
-    "methods" word-prop
-    [ nip method-word ] { } assoc>map
-    natural-sort ;
+    "methods" word-prop values natural-sort ;
 
 M: word see
     dup see-class
diff --git a/core/words/words.factor b/core/words/words.factor
index e8b3fd9781..c9505d3d1d 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -68,7 +68,7 @@ SYMBOL: bootstrapping?
 : crossref? ( word -- ? )
     {
         { [ dup "forgotten" word-prop ] [ f ] }
-        { [ dup "method" word-prop ] [ t ] }
+        { [ dup "method-definition" word-prop ] [ t ] }
         { [ dup word-vocabulary ] [ t ] }
         { [ t ] [ f ] }
     } cond nip ;

From c51ad0aa5a7af55782f0ae5aed8cce039b015b2a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 4 Mar 2008 22:44:46 -0600
Subject: [PATCH 3/5] Update modules for method changes

---
 extra/locals/locals.factor           | 12 ++++++------
 extra/tools/profiler/profiler.factor |  5 ++---
 2 files changed, 8 insertions(+), 9 deletions(-)

diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index 2e6fd6485d..79af9e63f8 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -279,7 +279,7 @@ MACRO: with-locals ( form -- quot ) lambda-rewrite ;
 ! are unified
 : create-method ( class generic -- method )
     2dup method dup
-    [ 2nip method-word ]
+    [ 2nip ]
     [ drop 2dup [ ] -rot define-method create-method ] if ;
 
 : CREATE-METHOD ( -- class generic body )
@@ -369,14 +369,14 @@ M: lambda-method definition
 
 : method-stack-effect
     dup "lambda" word-prop lambda-vars
-    swap "method" word-prop method-generic stack-effect dup [ effect-out ] when
+    swap "method-generic" word-prop stack-effect
+    dup [ effect-out ] when
     <effect> ;
 
 M: lambda-method synopsis*
-    dup definer.
-    dup "method" word-prop dup
-        method-specializer pprint*
-        method-generic pprint*
+    dup dup definer.
+    "method-specializer" word-prop pprint*
+    "method-generic" word-prop pprint*
     method-stack-effect effect>string comment. ;
 
 PRIVATE>
diff --git a/extra/tools/profiler/profiler.factor b/extra/tools/profiler/profiler.factor
index 784c9e8da6..467fcc14f4 100755
--- a/extra/tools/profiler/profiler.factor
+++ b/extra/tools/profiler/profiler.factor
@@ -29,9 +29,8 @@ M: string (profile.)
     dup <vocab-profile> write-object ;
 
 M: method-body (profile.)
-    "method" word-prop
-    dup method-specializer over method-generic 2array synopsis
-    swap method-generic <usage-profile> write-object ;
+    dup synopsis swap "method-generic" word-prop
+    <usage-profile> write-object ;
 
 : counter. ( obj n -- )
     [

From e933cf97fe035697209df546430393445c2b0ab3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 4 Mar 2008 22:46:01 -0600
Subject: [PATCH 4/5] Add $vocab-subsection

---
 core/vocabs/vocabs.factor                     |  2 ++
 extra/help/markup/markup.factor               | 26 ++++++++++++++-----
 extra/logging/insomniac/insomniac-docs.factor |  2 +-
 extra/logging/logging-docs.factor             |  6 ++---
 4 files changed, 25 insertions(+), 11 deletions(-)
 mode change 100644 => 100755 extra/help/markup/markup.factor
 mode change 100644 => 100755 extra/logging/insomniac/insomniac-docs.factor
 mode change 100644 => 100755 extra/logging/logging-docs.factor

diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor
index 720a1ef645..1a3fecc3fb 100755
--- a/core/vocabs/vocabs.factor
+++ b/core/vocabs/vocabs.factor
@@ -55,6 +55,8 @@ M: f vocab-docs-loaded? ;
 
 M: f set-vocab-docs-loaded? 2drop ;
 
+M: f vocab-help ;
+
 : create-vocab ( name -- vocab )
     dictionary get [ <vocab> ] cache ;
 
diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor
old mode 100644
new mode 100755
index 5f1b027823..a866293bbe
--- a/extra/help/markup/markup.factor
+++ b/extra/help/markup/markup.factor
@@ -144,20 +144,32 @@ M: f print-element drop ;
 : $link ( element -- )
     first ($link) ;
 
-: ($subsection) ( object -- )
-    [ article-title ] keep >link write-object ;
+: ($long-link) ( object -- )
+    dup article-title swap >link write-link ;
 
-: $subsection ( element -- )
+: ($subsection) ( element quot -- )
     [
         subsection-style get [
             bullet get write bl
-            first ($subsection)
+            call
         ] with-style
-    ] ($block) ;
+    ] ($block) ; inline
 
-: ($vocab-link) ( vocab -- ) dup f >vocab-link write-link ;
+: $subsection ( element -- )
+    [ first ($long-link) ] ($subsection) ;
 
-: $vocab-link ( element -- ) first ($vocab-link) ;
+: ($vocab-link) ( text vocab -- ) f >vocab-link write-link ;
+
+: $vocab-subsection ( element -- )
+    [
+        first2 dup vocab-help dup [
+            2nip ($long-link)
+        ] [
+            drop ($vocab-link)
+        ] if
+    ] ($subsection) ;
+
+: $vocab-link ( element -- ) first dup ($vocab-link) ;
 
 : $vocabulary ( element -- )
     first word-vocabulary [
diff --git a/extra/logging/insomniac/insomniac-docs.factor b/extra/logging/insomniac/insomniac-docs.factor
old mode 100644
new mode 100755
index 64ac3b4ff6..93485e4c7c
--- a/extra/logging/insomniac/insomniac-docs.factor
+++ b/extra/logging/insomniac/insomniac-docs.factor
@@ -27,7 +27,7 @@ HELP: schedule-insomniac
 { $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } }
 { $description "Starts a thread which e-mails log reports and rotates logs daily." } ;
 
-ARTICLE: "logging.insomniac" "Automating log analysis and rotation"
+ARTICLE: "logging.insomniac" "Automated log analysis"
 "The " { $vocab-link "logging.insomniac" } " vocabulary builds on the " { $vocab-link "logging.analysis" } " vocabulary. It provides support for e-mailing log reports and rotating logs on a daily basis. E-mails are sent using the " { $vocab-link "smtp" } " vocabulary."
 $nl
 "Required configuration parameters:"
diff --git a/extra/logging/logging-docs.factor b/extra/logging/logging-docs.factor
old mode 100644
new mode 100755
index 939388026d..715b1551b9
--- a/extra/logging/logging-docs.factor
+++ b/extra/logging/logging-docs.factor
@@ -115,9 +115,9 @@ ARTICLE: "logging" "Logging framework"
 { $subsection "logging.levels" }
 { $subsection "logging.messages" }
 { $subsection "logging.rotation" }
-{ $subsection "logging.parser" }
-{ $subsection "logging.analysis" }
-{ $subsection "logging.insomniac" }
+{ $vocab-subsection "Log file parser" "logging.parser" }
+{ $vocab-subsection "Log analysis" "logging.analysis" }
+{ $vocab-subsection "Automated log analysis" "logging.insomniac" }
 { $subsection "logging.server" } ;
 
 ABOUT: "logging"

From fa898aa8c6cfbb331f6141a28b0f8a331fc602d5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Wed, 5 Mar 2008 15:02:02 -0600
Subject: [PATCH 5/5] Fixes

---
 extra/benchmark/sockets/sockets.factor     | 123 ++++++++++-----------
 extra/bootstrap/image/upload/upload.factor |   2 +-
 2 files changed, 59 insertions(+), 66 deletions(-)

diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor
index c739bb787c..4927776575 100755
--- a/extra/benchmark/sockets/sockets.factor
+++ b/extra/benchmark/sockets/sockets.factor
@@ -1,65 +1,58 @@
-USING: io.sockets io kernel math threads
-debugger tools.time prettyprint concurrency.count-downs
-namespaces arrays continuations ;
-IN: benchmark.sockets
-
-SYMBOL: counter
-
-: number-of-requests 1 ;
-
-: server-addr "127.0.0.1" 7777 <inet4> ;
-
-: server-loop ( server -- )
-    dup accept [
-        [
-            read1 CHAR: x = [
-                "server" get dispose
-            ] [
-                number-of-requests
-                [ read1 write1 flush ] times
-                counter get count-down
-            ] if
-        ] with-stream
-    ] curry "Client handler" spawn drop server-loop ;
-
-: simple-server ( -- )
-    [
-        server-addr <server> dup "server" set [
-            server-loop
-        ] with-disposal
-    ] ignore-errors ;
-
-: simple-client ( -- )
-    server-addr <client> [
-        CHAR: b write1 flush
-        number-of-requests
-        [ CHAR: a dup write1 flush read1 assert= ] times
-        counter get count-down
-    ] with-stream ;
-
-: stop-server ( -- )
-    server-addr <client> [
-        CHAR: x write1
-    ] with-stream ;
-
-: clients ( n -- )
-    dup pprint " clients: " write [
-        dup 2 * <count-down> counter set
-        [ simple-server ] "Simple server" spawn drop
-        yield yield
-        [ [ simple-client ] "Simple client" spawn drop ] times
-        counter get await
-        stop-server
-        yield yield
-    ] time ;
-
-: socket-benchmarks
-    10 clients
-    20 clients
-    40 clients ;
-    ! 80 clients
-    ! 160 clients
-    ! 320 clients
-    ! 640 clients ;
-
-MAIN: socket-benchmarks
+USING: io.sockets io kernel math threads
+debugger tools.time prettyprint concurrency.count-downs
+namespaces arrays continuations ;
+IN: benchmark.sockets
+
+SYMBOL: counter
+
+: number-of-requests 1 ;
+
+: server-addr "127.0.0.1" 7777 <inet4> ;
+
+: server-loop ( server -- )
+    dup accept [
+        [
+            read1 CHAR: x = [
+                "server" get dispose
+            ] [
+                number-of-requests
+                [ read1 write1 flush ] times
+                counter get count-down
+            ] if
+        ] with-stream
+    ] curry "Client handler" spawn drop server-loop ;
+
+: simple-server ( -- )
+    [
+        server-addr <server> dup "server" set [
+            server-loop
+        ] with-disposal
+    ] ignore-errors ;
+
+: simple-client ( -- )
+    server-addr <client> [
+        CHAR: b write1 flush
+        number-of-requests
+        [ CHAR: a dup write1 flush read1 assert= ] times
+        counter get count-down
+    ] with-stream ;
+
+: stop-server ( -- )
+    server-addr <client> [
+        CHAR: x write1
+    ] with-stream ;
+
+: clients ( n -- )
+    dup pprint " clients: " write [
+        dup 2 * <count-down> counter set
+        [ simple-server ] "Simple server" spawn drop
+        yield yield
+        [ [ simple-client ] "Simple client" spawn drop ] times
+        counter get await
+        stop-server
+        yield yield
+    ] time ;
+
+: socket-benchmarks ;
+
+MAIN: socket-benchmarks
diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor
index 084f30a103..3c0b464dbf 100755
--- a/extra/bootstrap/image/upload/upload.factor
+++ b/extra/bootstrap/image/upload/upload.factor
@@ -8,7 +8,7 @@ SYMBOL: upload-images-destination
 
 : destination ( -- dest )
   upload-images-destination get
-  "slava@/var/www/factorcode.org/newsite/images/latest/"
+  "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
   or ;
 
 : checksums "checksums.txt" temp-file ;