From d42edecffba30584bcc8c1534932d3085319442c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 11 Aug 2008 23:30:18 -0500
Subject: [PATCH 1/3] Updating codegen for new optimizer

---
 unfinished/compiler/generator/authors.txt     |   1 +
 .../compiler/generator/fixup/authors.txt      |   1 +
 .../generator/fixup/fixup-docs.factor         |  16 +
 .../compiler/generator/fixup/fixup.factor     | 154 ++++
 .../compiler/generator/fixup/summary.txt      |   1 +
 .../compiler/generator/generator-docs.factor  |  88 +++
 .../compiler/generator/generator.factor       | 269 +++++++
 .../generator/iterator/iterator.factor        |  41 ++
 .../compiler/generator/registers/authors.txt  |   1 +
 .../generator/registers/registers.factor      | 660 ++++++++++++++++++
 .../compiler/generator/registers/summary.txt  |   1 +
 unfinished/compiler/generator/summary.txt     |   1 +
 unfinished/compiler/generator/tags.txt        |   1 +
 .../compiler/tree/debugger/debugger.factor    |  12 +-
 unfinished/compiler/tree/tree.factor          |   5 +
 .../stack-checker/inlining/inlining.factor    |   4 +-
 16 files changed, 1247 insertions(+), 9 deletions(-)
 create mode 100644 unfinished/compiler/generator/authors.txt
 create mode 100644 unfinished/compiler/generator/fixup/authors.txt
 create mode 100644 unfinished/compiler/generator/fixup/fixup-docs.factor
 create mode 100755 unfinished/compiler/generator/fixup/fixup.factor
 create mode 100644 unfinished/compiler/generator/fixup/summary.txt
 create mode 100755 unfinished/compiler/generator/generator-docs.factor
 create mode 100755 unfinished/compiler/generator/generator.factor
 create mode 100644 unfinished/compiler/generator/iterator/iterator.factor
 create mode 100644 unfinished/compiler/generator/registers/authors.txt
 create mode 100755 unfinished/compiler/generator/registers/registers.factor
 create mode 100644 unfinished/compiler/generator/registers/summary.txt
 create mode 100644 unfinished/compiler/generator/summary.txt
 create mode 100644 unfinished/compiler/generator/tags.txt

diff --git a/unfinished/compiler/generator/authors.txt b/unfinished/compiler/generator/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/unfinished/compiler/generator/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/unfinished/compiler/generator/fixup/authors.txt b/unfinished/compiler/generator/fixup/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/unfinished/compiler/generator/fixup/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/unfinished/compiler/generator/fixup/fixup-docs.factor b/unfinished/compiler/generator/fixup/fixup-docs.factor
new file mode 100644
index 0000000000..a4ff549e8e
--- /dev/null
+++ b/unfinished/compiler/generator/fixup/fixup-docs.factor
@@ -0,0 +1,16 @@
+USING: help.syntax help.markup math kernel
+words strings alien ;
+IN: compiler.generator.fixup
+
+HELP: frame-required
+{ $values { "n" "a non-negative integer" } }
+{ $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ;
+
+HELP: add-literal
+{ $values { "obj" object } { "n" integer } }
+{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
+
+HELP: rel-dlsym
+{ $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } }
+{ $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats."
+} ;
diff --git a/unfinished/compiler/generator/fixup/fixup.factor b/unfinished/compiler/generator/fixup/fixup.factor
new file mode 100755
index 0000000000..e1b4e42e67
--- /dev/null
+++ b/unfinished/compiler/generator/fixup/fixup.factor
@@ -0,0 +1,154 @@
+! Copyright (C) 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays byte-arrays generic assocs hashtables io.binary
+kernel kernel.private math namespaces sequences words
+quotations strings alien.accessors alien.strings layouts system
+combinators math.bitfields words.private cpu.architecture
+math.order accessors growable ;
+IN: compiler.generator.fixup
+
+: no-stack-frame -1 ; inline
+
+TUPLE: frame-required n ;
+
+: frame-required ( n -- ) \ frame-required boa , ;
+
+: stack-frame-size ( code -- n )
+    no-stack-frame [
+        dup frame-required? [ frame-required-n max ] [ drop ] if
+    ] reduce ;
+
+GENERIC: fixup* ( frame-size obj -- frame-size )
+
+: code-format 22 getenv ;
+
+: compiled-offset ( -- n ) building get length code-format * ;
+
+TUPLE: label offset ;
+
+: <label> ( -- label ) label new ;
+
+M: label fixup*
+    compiled-offset swap set-label-offset ;
+
+: define-label ( name -- ) <label> swap set ;
+
+: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
+
+: if-stack-frame ( frame-size quot -- )
+    swap dup no-stack-frame =
+    [ 2drop ] [ stack-frame swap call ] if ; inline
+
+M: word fixup*
+    {
+        { \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
+        { \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
+    } case ;
+
+SYMBOL: relocation-table
+SYMBOL: label-table
+
+! Relocation classes
+: rc-absolute-cell     0 ;
+: rc-absolute          1 ;
+: rc-relative          2 ;
+: rc-absolute-ppc-2/2  3 ;
+: rc-relative-ppc-2    4 ;
+: rc-relative-ppc-3    5 ;
+: rc-relative-arm-3    6 ;
+: rc-indirect-arm      7 ;
+: rc-indirect-arm-pc   8 ;
+
+: rc-absolute? ( n -- ? )
+    dup rc-absolute-cell =
+    over rc-absolute =
+    rot rc-absolute-ppc-2/2 = or or ;
+
+! Relocation types
+: rt-primitive 0 ;
+: rt-dlsym     1 ;
+: rt-literal   2 ;
+: rt-dispatch  3 ;
+: rt-xt        4 ;
+: rt-here      5 ;
+: rt-label     6 ;
+: rt-immediate 7 ;
+
+TUPLE: label-fixup label class ;
+
+: label-fixup ( label class -- ) \ label-fixup boa , ;
+
+M: label-fixup fixup*
+    dup class>> rc-absolute?
+    [ "Absolute labels not supported" throw ] when
+    dup label>> swap class>> compiled-offset 4 - rot
+    3array label-table get push ;
+
+TUPLE: rel-fixup arg class type ;
+
+: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
+
+: push-4 ( value vector -- )
+    [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
+    swap set-alien-unsigned-4 ;
+
+M: rel-fixup fixup*
+    [ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
+    [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
+    [ relocation-table get push-4 ] bi@ ;
+
+M: frame-required fixup* drop ;
+
+M: integer fixup* , ;
+
+: adjoin* ( obj table -- n )
+    2dup swap [ eq? ] curry find drop
+    [ 2nip ] [ dup length >r push r> ] if* ;
+
+SYMBOL: literal-table
+
+: add-literal ( obj -- n ) literal-table get adjoin* ;
+
+: add-dlsym-literals ( symbol dll -- )
+    >r string>symbol r> 2array literal-table get push-all ;
+
+: rel-dlsym ( name dll class -- )
+    >r literal-table get length >r
+    add-dlsym-literals
+    r> r> rt-dlsym rel-fixup ;
+
+: rel-word ( word class -- )
+    >r add-literal r> rt-xt rel-fixup ;
+
+: rel-primitive ( word class -- )
+    >r def>> first r> rt-primitive rel-fixup ;
+
+: rel-literal ( literal class -- )
+    >r add-literal r> rt-literal rel-fixup ;
+
+: rel-this ( class -- )
+    0 swap rt-label rel-fixup ;
+
+: rel-here ( class -- )
+    0 swap rt-here rel-fixup ;
+
+: init-fixup ( -- )
+    BV{ } clone relocation-table set
+    V{ } clone label-table set ;
+
+: resolve-labels ( labels -- labels' )
+    [
+        first3 label-offset
+        [ "Unresolved label" throw ] unless*
+        3array
+    ] map concat ;
+
+: fixup ( code -- literals relocation labels code )
+    [
+        init-fixup
+        dup stack-frame-size swap [ fixup* ] each drop
+
+        literal-table get >array
+        relocation-table get >byte-array
+        label-table get resolve-labels
+    ] { } make ;
diff --git a/unfinished/compiler/generator/fixup/summary.txt b/unfinished/compiler/generator/fixup/summary.txt
new file mode 100644
index 0000000000..ce83e6d253
--- /dev/null
+++ b/unfinished/compiler/generator/fixup/summary.txt
@@ -0,0 +1 @@
+Support for generation of relocatable code
diff --git a/unfinished/compiler/generator/generator-docs.factor b/unfinished/compiler/generator/generator-docs.factor
new file mode 100755
index 0000000000..e00b8d5b28
--- /dev/null
+++ b/unfinished/compiler/generator/generator-docs.factor
@@ -0,0 +1,88 @@
+USING: help.markup help.syntax words debugger generator.fixup
+generator.registers quotations kernel vectors arrays effects
+sequences ;
+IN: compiler.generator
+
+ARTICLE: "generator" "Compiled code generator"
+"Most of the words in the " { $vocab-link "generator" } " vocabulary are internal to the compiler and user code has no reason to call them."
+$nl
+"Debugging information can be enabled or disabled; this hook is used by " { $link "tools.deploy" } ":"
+{ $subsection compiled-stack-traces? }
+"Assembler intrinsics can be defined for low-level optimization:"
+{ $subsection define-intrinsic }
+{ $subsection define-intrinsics }
+{ $subsection define-if-intrinsic }
+{ $subsection define-if-intrinsics }
+"The main entry point into the code generator:"
+{ $subsection generate } ;
+
+ABOUT: "generator"
+
+HELP: compiled
+{ $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
+
+HELP: compiling-word
+{ $var-description "The word currently being compiled, set by " { $link with-generator } "." } ;
+
+HELP: compiling-label
+{ $var-description "The label currently being compiled, set by " { $link with-generator } "." } ;
+
+HELP: compiled-stack-traces?
+{ $values { "?" "a boolean" } }
+{ $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
+
+HELP: literal-table
+{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ;
+
+HELP: begin-compiling
+{ $values { "word" word } { "label" word } }
+{ $description "Prepares to generate machine code for a word." } ;
+
+HELP: with-generator
+{ $values { "node" "a dataflow node" } { "word" word } { "label" word } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
+{ $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the dataflow node." } ;
+
+HELP: generate-node
+{ $values { "node" "a dataflow node" } { "next" "a dataflow node" } }
+{ $contract "Generates machine code for a dataflow node, and outputs the next node to generate machine code for." }
+{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
+
+HELP: generate-nodes
+{ $values { "node" "a dataflow node" } } 
+{ $description "Recursively generate machine code for a dataflow graph." }
+{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
+
+HELP: generate
+{ $values { "word" word } { "label" word } { "node" "a dataflow node" } }
+{ $description "Generates machine code for " { $snippet "label" } " from " { $snippet "node" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ;
+
+HELP: define-intrinsics
+{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot assoc }" } " pairs" } }
+{ $description "Defines a set of assembly intrinsics for the word. When a call to the word is being compiled, each intrinsic is tested in turn; the first applicable one will be called to generate machine code. If no suitable intrinsic is found, a simple call to the word is compiled instead."
+$nl
+"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
+
+HELP: define-intrinsic
+{ $values { "word" word } { "quot" quotation } { "assoc" "an assoc" } }
+{ $description "Defines an assembly intrinsic for the word. When a call to the word is being compiled, this intrinsic will be used if it is found to be applicable. If it is not applicable, a simple call to the word is compiled instead."
+$nl
+"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
+
+HELP: if>boolean-intrinsic
+{ $values { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } }
+{ $description "Generates code which pushes " { $link t } " or " { $link f } " on the data stack, depending on whether the quotation jumps to the label or not." } ;
+
+HELP: define-if-intrinsics
+{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot inputs }" } " pairs" } }
+{ $description "Defines a set of conditional assembly intrinsics for the word, which must have a boolean value as its single output."
+$nl
+"The quotations must have stack effect " { $snippet "( label -- )" } "; they are required to branch to the label if the word evaluates to true."
+$nl
+"The " { $snippet "inputs" } " are in the same format as the " { $link +input+ } " key to " { $link with-template } "; a description can be found in the documentation for thatt word." }
+{ $notes "Conditional intrinsics are used when the word is followed by a call to " { $link if } ". They allow for tighter code to be generated in certain situations; for example, if two integers are being compared and the result is immediately used to branch, the intermediate boolean does not need to be pushed at all." } ;
+
+HELP: define-if-intrinsic
+{ $values { "word" word } { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } { "inputs" "a sequence of input register specifiers" } }
+{ $description "Defines a conditional assembly intrinsic for the word, which must have a boolean value as its single output."
+$nl
+"See " { $link define-if-intrinsics } " for a description of the parameters." } ;
diff --git a/unfinished/compiler/generator/generator.factor b/unfinished/compiler/generator/generator.factor
new file mode 100755
index 0000000000..19e60ae19c
--- /dev/null
+++ b/unfinished/compiler/generator/generator.factor
@@ -0,0 +1,269 @@
+ ! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes combinators
+cpu.architecture effects generic hashtables io kernel
+kernel.private layouts math namespaces prettyprint quotations
+sequences system threads words vectors sets dequeues cursors
+stack-checker.inlining
+compiler.tree compiler.tree.builder compiler.tree.combinators
+compiler.tree.propagation.info compiler.generator.fixup
+compiler.generator.registers compiler.generator.iterator ;
+IN: compiler.generator
+
+SYMBOL: compile-queue
+SYMBOL: compiled
+
+: queue-compile ( word -- )
+    {
+        { [ dup "forgotten" word-prop ] [ ] }
+        { [ dup compiled get key? ] [ ] }
+        { [ dup inlined-block? ] [ ] }
+        { [ dup primitive? ] [ ] }
+        [ dup compile-queue get push-front ]
+    } cond drop ;
+
+: maybe-compile ( word -- )
+    dup compiled>> [ drop ] [ queue-compile ] if ;
+
+SYMBOL: compiling-word
+
+SYMBOL: compiling-label
+
+SYMBOL: compiling-loops
+
+! Label of current word, after prologue, makes recursion faster
+SYMBOL: current-label-start
+
+: compiled-stack-traces? ( -- ? ) 59 getenv ;
+
+: begin-compiling ( word label -- )
+    H{ } clone compiling-loops set
+    compiling-label set
+    compiling-word set
+    compiled-stack-traces?
+    compiling-word get f ?
+    1vector literal-table set
+    f compiling-label get compiled get set-at ;
+
+: save-machine-code ( literals relocation labels code -- )
+    4array compiling-label get compiled get set-at ;
+
+: with-generator ( node word label quot -- )
+    [
+        >r begin-compiling r>
+        { } make fixup
+        save-machine-code
+    ] with-scope ; inline
+
+GENERIC: generate-node ( node -- next )
+
+: generate-nodes ( nodes -- )
+    [ current-node generate-node ] iterate-nodes end-basic-block ;
+
+: init-generate-nodes ( -- )
+    init-templates
+    %save-word-xt
+    %prologue-later
+    current-label-start define-label
+    current-label-start resolve-label ;
+
+: generate ( nodes word label -- )
+    [
+        init-generate-nodes
+        [ generate-nodes ] with-node-iterator
+    ] with-generator ;
+
+: intrinsics ( #call -- quot )
+    word>> "intrinsics" word-prop ;
+
+: if-intrinsics ( #call -- quot )
+    word>> "if-intrinsics" word-prop ;
+
+! node
+M: node generate-node drop iterate-next ;
+
+: %jump ( word -- )
+    dup compiling-label get eq?
+    [ drop current-label-start get ] [ %epilogue-later ] if
+    %jump-label ;
+
+: generate-call ( label -- next )
+    dup maybe-compile
+    end-basic-block
+    dup compiling-loops get at [
+        %jump-label f
+    ] [
+        tail-call? [
+            %jump f
+        ] [
+            0 frame-required
+            %call
+            iterate-next
+        ] if
+    ] ?if ;
+
+! #recursive
+: compile-recursive ( node -- )
+    dup label>> id>> generate-call >r
+    [ child>> ] [ label>> word>> ] [ label>> id>> ] tri generate
+    r> ;
+
+: compiling-loop ( word -- )
+    <label> dup resolve-label swap compiling-loops get set-at ;
+
+: compile-loop ( node -- )
+    end-basic-block
+    [ label>> id>> compiling-loop ] [ child>> generate-nodes ] bi
+    iterate-next ;
+
+M: #recursive generate-node
+    dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
+
+! #if
+: end-false-branch ( label -- )
+    tail-call? [ %return drop ] [ %jump-label ] if ;
+
+: generate-branch ( nodes -- )
+    [ copy-templates generate-nodes ] with-scope ;
+
+: generate-if ( node label -- next )
+    <label> [
+        >r >r children>> first2 swap generate-branch
+        r> r> end-false-branch resolve-label
+        generate-branch
+        init-templates
+    ] keep resolve-label iterate-next ;
+
+M: #if generate-node
+    [ <label> dup %jump-f ]
+    H{ { +input+ { { f "flag" } } } }
+    with-template
+    generate-if ;
+
+! #dispatch
+: dispatch-branch ( nodes word -- label )
+    gensym [
+        [
+            copy-templates
+            %save-dispatch-xt
+            %prologue-later
+            [ generate-nodes ] with-node-iterator
+        ] with-generator
+    ] keep ;
+
+: dispatch-branches ( node -- )
+    children>> [
+        compiling-word get dispatch-branch
+        %dispatch-label
+    ] each ;
+
+: generate-dispatch ( node -- )
+    %dispatch dispatch-branches init-templates ;
+
+M: #dispatch generate-node
+    #! The order here is important, dispatch-branches must
+    #! run after %dispatch, so that each branch gets the
+    #! correct register state
+    tail-call? [
+        generate-dispatch iterate-next
+    ] [
+        compiling-word get gensym [
+            [
+                init-generate-nodes
+                generate-dispatch
+            ] with-generator
+        ] keep generate-call
+    ] if ;
+
+! #call
+: define-intrinsics ( word intrinsics -- )
+    "intrinsics" set-word-prop ;
+
+: define-intrinsic ( word quot assoc -- )
+    2array 1array define-intrinsics ;
+
+: define-if>branch-intrinsics ( word intrinsics -- )
+    "if-intrinsics" set-word-prop ;
+
+: if>boolean-intrinsic ( quot -- )
+    "false" define-label
+    "end" define-label
+    "false" get swap call
+    t "if-scratch" get load-literal
+    "end" get %jump-label
+    "false" resolve-label
+    f "if-scratch" get load-literal
+    "end" resolve-label
+    "if-scratch" get phantom-push ; inline
+
+: define-if>boolean-intrinsics ( word intrinsics -- )
+    [
+        >r [ if>boolean-intrinsic ] curry r>
+        { { f "if-scratch" } } +scratch+ associate assoc-union
+    ] assoc-map "intrinsics" set-word-prop ;
+
+: define-if-intrinsics ( word intrinsics -- )
+    [ +input+ associate ] assoc-map
+    2dup define-if>branch-intrinsics
+    define-if>boolean-intrinsics ;
+
+: define-if-intrinsic ( word quot inputs -- )
+    2array 1array define-if-intrinsics ;
+
+: do-if-intrinsic ( pair -- next )
+    <label> [
+        swap do-template
+        node> next dup >node
+    ] keep generate-if ;
+
+: find-intrinsic ( #call -- pair/f )
+    intrinsics find-template ;
+
+: find-if-intrinsic ( #call -- pair/f )
+    node@ next #if? [
+        if-intrinsics find-template
+    ] [
+        drop f
+    ] if ;
+
+M: #call generate-node
+    dup node-input-infos [ class>> ] map set-operand-classes
+    dup find-if-intrinsic [
+        do-if-intrinsic
+    ] [
+        dup find-intrinsic [
+            do-template iterate-next
+        ] [
+            word>> generate-call
+        ] ?if
+    ] ?if ;
+
+! #call-recursive
+M: #call-recursive generate-node label>> id>> generate-call ;
+
+! #push
+M: #push generate-node
+    literal>> <constant> phantom-push iterate-next ;
+
+! #shuffle
+M: #shuffle generate-node
+    shuffle-effect phantom-shuffle iterate-next ;
+
+M: #>r generate-node
+    in-d>> length
+    phantom->r
+    iterate-next ;
+
+M: #r> generate-node
+    out-d>> length
+    phantom-r>
+    iterate-next ;
+
+! #return
+M: #return generate-node
+    drop end-basic-block %return f ;
+
+M: #return-recursive generate-node
+    end-basic-block
+    label>> id>> compiling-loops get key?
+    [ %return ] unless f ;
diff --git a/unfinished/compiler/generator/iterator/iterator.factor b/unfinished/compiler/generator/iterator/iterator.factor
new file mode 100644
index 0000000000..68881990be
--- /dev/null
+++ b/unfinished/compiler/generator/iterator/iterator.factor
@@ -0,0 +1,41 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces sequences cursors kernel compiler.tree ;
+IN: compiler.generator.iterator
+
+SYMBOL: node-stack
+
+: >node ( cursor -- ) node-stack get push ;
+: node> ( -- cursor ) node-stack get pop ;
+: node@ ( -- cursor ) node-stack get peek ;
+: current-node ( -- node ) node@ value ;
+
+: iterate-next ( -- cursor ) node@ next ;
+
+: iterate-nodes ( cursor quot: ( -- ) -- )
+    over [
+        [ swap >node call node> drop ] keep iterate-nodes
+    ] [
+        2drop
+    ] if ; inline recursive
+
+: with-node-iterator ( quot -- )
+    >r V{ } clone node-stack r> with-variable ; inline
+
+DEFER: (tail-call?)
+
+: tail-phi? ( cursor -- ? )
+    [ value #phi? ] [ next (tail-call?) ] bi and ;
+
+: (tail-call?) ( cursor -- ? )
+    [ value [ #return? ] [ #terminate? ] bi or ]
+    [ tail-phi? ]
+    bi or ;
+
+: tail-call? ( -- ? )
+    node-stack get [
+        next
+        [ (tail-call?) ]
+        [ value #terminate? not ]
+        bi and
+    ] all? ;
diff --git a/unfinished/compiler/generator/registers/authors.txt b/unfinished/compiler/generator/registers/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/unfinished/compiler/generator/registers/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/unfinished/compiler/generator/registers/registers.factor b/unfinished/compiler/generator/registers/registers.factor
new file mode 100755
index 0000000000..dc32afb264
--- /dev/null
+++ b/unfinished/compiler/generator/registers/registers.factor
@@ -0,0 +1,660 @@
+! Copyright (C) 2006, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs classes classes.private classes.algebra
+combinators cpu.architecture generator.fixup hashtables kernel
+layouts math namespaces quotations sequences system vectors
+words effects alien byte-arrays
+accessors sets math.order ;
+IN: compiler.generator.registers
+
+SYMBOL: +input+
+SYMBOL: +output+
+SYMBOL: +scratch+
+SYMBOL: +clobber+
+SYMBOL: known-tag
+
+<PRIVATE
+
+! Value protocol
+GENERIC: set-operand-class ( class obj -- )
+GENERIC: operand-class* ( operand -- class )
+GENERIC: move-spec ( obj -- spec )
+GENERIC: live-vregs* ( obj -- )
+GENERIC: live-loc? ( actual current -- ? )
+GENERIC# (lazy-load) 1 ( value spec -- value )
+GENERIC: lazy-store ( dst src -- )
+GENERIC: minimal-ds-loc* ( min obj -- min )
+
+! This will be a multimethod soon
+DEFER: %move
+
+MIXIN: value
+
+PRIVATE>
+
+: operand-class ( operand -- class )
+    operand-class* object or ;
+
+! Default implementation
+M: value set-operand-class 2drop ;
+M: value operand-class* drop f ;
+M: value live-vregs* drop ;
+M: value live-loc? 2drop f ;
+M: value minimal-ds-loc* drop ;
+M: value lazy-store 2drop ;
+
+! A scratch register for computations
+TUPLE: vreg n reg-class ;
+
+C: <vreg> vreg ( n reg-class -- vreg )
+
+M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ;
+M: vreg live-vregs* , ;
+M: vreg move-spec reg-class>> move-spec ;
+
+INSTANCE: vreg value
+
+M: float-regs move-spec drop float ;
+M: float-regs operand-class* drop float ;
+
+! Temporary register for stack shuffling
+SINGLETON: temp-reg
+
+M: temp-reg move-spec drop f ;
+
+INSTANCE: temp-reg value
+
+! A data stack location.
+TUPLE: ds-loc n class ;
+
+: <ds-loc> ( n -- loc ) f ds-loc boa ;
+
+M: ds-loc minimal-ds-loc* ds-loc-n min ;
+M: ds-loc operand-class* ds-loc-class ;
+M: ds-loc set-operand-class set-ds-loc-class ;
+M: ds-loc live-loc?
+    over ds-loc? [ [ ds-loc-n ] bi@ = not ] [ 2drop t ] if ;
+
+! A retain stack location.
+TUPLE: rs-loc n class ;
+
+: <rs-loc> ( n -- loc ) f rs-loc boa ;
+M: rs-loc operand-class* rs-loc-class ;
+M: rs-loc set-operand-class set-rs-loc-class ;
+M: rs-loc live-loc?
+    over rs-loc? [ [ rs-loc-n ] bi@ = not ] [ 2drop t ] if ;
+
+UNION: loc ds-loc rs-loc ;
+
+M: loc move-spec drop loc ;
+
+INSTANCE: loc value
+
+M: f move-spec drop loc ;
+M: f operand-class* ;
+
+! A stack location which has been loaded into a register. To
+! read the location, we just read the register, but when time
+! comes to save it back to the stack, we know the register just
+! contains a stack value so we don't have to redundantly write
+! it back.
+TUPLE: cached loc vreg ;
+
+C: <cached> cached
+
+M: cached set-operand-class cached-vreg set-operand-class ;
+M: cached operand-class* cached-vreg operand-class* ;
+M: cached move-spec drop cached ;
+M: cached live-vregs* cached-vreg live-vregs* ;
+M: cached live-loc? cached-loc live-loc? ;
+M: cached (lazy-load) >r cached-vreg r> (lazy-load) ;
+M: cached lazy-store
+    2dup cached-loc live-loc?
+    [ "live-locs" get at %move ] [ 2drop ] if ;
+M: cached minimal-ds-loc* cached-loc minimal-ds-loc* ;
+
+INSTANCE: cached value
+
+! A tagged pointer
+TUPLE: tagged vreg class ;
+
+: <tagged> ( vreg -- tagged )
+    f tagged boa ;
+
+M: tagged v>operand tagged-vreg v>operand ;
+M: tagged set-operand-class set-tagged-class ;
+M: tagged operand-class* tagged-class ;
+M: tagged move-spec drop f ;
+M: tagged live-vregs* tagged-vreg , ;
+
+INSTANCE: tagged value
+
+! Unboxed alien pointers
+TUPLE: unboxed-alien vreg ;
+C: <unboxed-alien> unboxed-alien
+M: unboxed-alien v>operand unboxed-alien-vreg v>operand ;
+M: unboxed-alien operand-class* drop simple-alien ;
+M: unboxed-alien move-spec class ;
+M: unboxed-alien live-vregs* unboxed-alien-vreg , ;
+
+INSTANCE: unboxed-alien value
+
+TUPLE: unboxed-byte-array vreg ;
+C: <unboxed-byte-array> unboxed-byte-array
+M: unboxed-byte-array v>operand unboxed-byte-array-vreg v>operand ;
+M: unboxed-byte-array operand-class* drop c-ptr ;
+M: unboxed-byte-array move-spec class ;
+M: unboxed-byte-array live-vregs* unboxed-byte-array-vreg , ;
+
+INSTANCE: unboxed-byte-array value
+
+TUPLE: unboxed-f vreg ;
+C: <unboxed-f> unboxed-f
+M: unboxed-f v>operand unboxed-f-vreg v>operand ;
+M: unboxed-f operand-class* drop \ f ;
+M: unboxed-f move-spec class ;
+M: unboxed-f live-vregs* unboxed-f-vreg , ;
+
+INSTANCE: unboxed-f value
+
+TUPLE: unboxed-c-ptr vreg ;
+C: <unboxed-c-ptr> unboxed-c-ptr
+M: unboxed-c-ptr v>operand unboxed-c-ptr-vreg v>operand ;
+M: unboxed-c-ptr operand-class* drop c-ptr ;
+M: unboxed-c-ptr move-spec class ;
+M: unboxed-c-ptr live-vregs* unboxed-c-ptr-vreg , ;
+
+INSTANCE: unboxed-c-ptr value
+
+! A constant value
+TUPLE: constant value ;
+C: <constant> constant
+M: constant operand-class* constant-value class ;
+M: constant move-spec class ;
+
+INSTANCE: constant value
+
+<PRIVATE
+
+! Moving values between locations and registers
+: %move-bug ( -- * ) "Bug in generator.registers" throw ;
+
+: %unbox-c-ptr ( dst src -- )
+    dup operand-class {
+        { [ dup \ f class<= ] [ drop %unbox-f ] }
+        { [ dup simple-alien class<= ] [ drop %unbox-alien ] }
+        { [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
+        [ drop %unbox-any-c-ptr ]
+    } cond ; inline
+
+: %move-via-temp ( dst src -- )
+    #! For many transfers, such as loc to unboxed-alien, we
+    #! don't have an intrinsic, so we transfer the source to
+    #! temp then temp to the destination.
+    temp-reg over %move
+    operand-class temp-reg
+    tagged new
+        swap >>vreg
+        swap >>class
+    %move ;
+
+: %move ( dst src -- )
+    2dup [ move-spec ] bi@ 2array {
+        { { f f } [ %move-bug ] }
+        { { f unboxed-c-ptr } [ %move-bug ] }
+        { { f unboxed-byte-array } [ %move-bug ] }
+
+        { { f constant } [ constant-value swap load-literal ] }
+
+        { { f float } [ %box-float ] }
+        { { f unboxed-alien } [ %box-alien ] }
+        { { f loc } [ %peek ] }
+
+        { { float f } [ %unbox-float ] }
+        { { unboxed-alien f } [ %unbox-alien ] }
+        { { unboxed-byte-array f } [ %unbox-byte-array ] }
+        { { unboxed-f f } [ %unbox-f ] }
+        { { unboxed-c-ptr f } [ %unbox-c-ptr ] }
+        { { loc f } [ swap %replace ] }
+
+        [ drop %move-via-temp ]
+    } case ;
+
+! A compile-time stack
+TUPLE: phantom-stack height stack ;
+
+M: phantom-stack clone
+    call-next-method [ clone ] change-stack ;
+
+GENERIC: finalize-height ( stack -- )
+
+: new-phantom-stack ( class -- stack )
+    >r 0 V{ } clone r> boa ; inline
+
+: (loc) ( m stack -- n )
+    #! Utility for methods on <loc>
+    height>> - ;
+
+: (finalize-height) ( stack word -- )
+    #! We consolidate multiple stack height changes until the
+    #! last moment, and we emit the final height changing
+    #! instruction here.
+    [
+        over zero? [ 2drop ] [ execute ] if 0
+    ] curry change-height drop ; inline
+
+GENERIC: <loc> ( n stack -- loc )
+
+TUPLE: phantom-datastack < phantom-stack ;
+
+: <phantom-datastack> ( -- stack )
+    phantom-datastack new-phantom-stack ;
+
+M: phantom-datastack <loc> (loc) <ds-loc> ;
+
+M: phantom-datastack finalize-height
+    \ %inc-d (finalize-height) ;
+
+TUPLE: phantom-retainstack < phantom-stack ;
+
+: <phantom-retainstack> ( -- stack )
+    phantom-retainstack new-phantom-stack ;
+
+M: phantom-retainstack <loc> (loc) <rs-loc> ;
+
+M: phantom-retainstack finalize-height
+    \ %inc-r (finalize-height) ;
+
+: phantom-locs ( n phantom -- locs )
+    #! A sequence of n ds-locs or rs-locs indexing the stack.
+    >r <reversed> r> [ <loc> ] curry map ;
+
+: phantom-locs* ( phantom -- locs )
+    [ stack>> length ] keep phantom-locs ;
+
+: phantoms ( -- phantom phantom )
+    phantom-datastack get phantom-retainstack get ;
+
+: (each-loc) ( phantom quot -- )
+    >r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
+
+: each-loc ( quot -- )
+    phantoms 2array swap [ (each-loc) ] curry each ; inline
+
+: adjust-phantom ( n phantom -- )
+    swap [ + ] curry change-height drop ;
+
+: cut-phantom ( n phantom -- seq )
+    swap [ cut* swap ] curry change-stack drop ;
+
+: phantom-append ( seq stack -- )
+    over length over adjust-phantom stack>> push-all ;
+
+: add-locs ( n phantom -- )
+    2dup stack>> length <= [
+        2drop
+    ] [
+        [ phantom-locs ] keep
+        [ stack>> length head-slice* ] keep
+        [ append >vector ] change-stack drop
+    ] if ;
+
+: phantom-input ( n phantom -- seq )
+    2dup add-locs
+    2dup cut-phantom
+    >r >r neg r> adjust-phantom r> ;
+
+: each-phantom ( quot -- ) phantoms rot bi@ ; inline
+
+: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
+
+: live-vregs ( -- seq )
+    [ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ;
+
+: (live-locs) ( phantom -- seq )
+    #! Discard locs which haven't moved
+    [ phantom-locs* ] [ stack>> ] bi zip
+    [ live-loc? ] assoc-filter
+    values ;
+
+: live-locs ( -- seq )
+    [ (live-locs) ] each-phantom append prune ;
+
+! Operands holding pointers to freshly-allocated objects which
+! are guaranteed to be in the nursery
+SYMBOL: fresh-objects
+
+! Computing free registers and initializing allocator
+: reg-spec>class ( spec -- class )
+    float eq? double-float-regs int-regs ? ;
+
+: free-vregs ( reg-class -- seq )
+    #! Free vregs in a given register class
+    \ free-vregs get at ;
+
+: alloc-vreg ( spec -- reg )
+    [ reg-spec>class free-vregs pop ] keep {
+        { f [ <tagged> ] }
+        { unboxed-alien [ <unboxed-alien> ] }
+        { unboxed-byte-array [ <unboxed-byte-array> ] }
+        { unboxed-f [ <unboxed-f> ] }
+        { unboxed-c-ptr [ <unboxed-c-ptr> ] }
+        [ drop ]
+    } case ;
+
+: compatible? ( value spec -- ? )
+    >r move-spec r> {
+        { [ 2dup = ] [ t ] }
+        { [ dup unboxed-c-ptr eq? ] [
+            over { unboxed-byte-array unboxed-alien } member?
+        ] }
+        [ f ]
+    } cond 2nip ;
+
+: allocation ( value spec -- reg-class )
+    {
+        { [ dup quotation? ] [ 2drop f ] }
+        { [ 2dup compatible? ] [ 2drop f ] }
+        [ nip reg-spec>class ]
+    } cond ;
+
+: alloc-vreg-for ( value spec -- vreg )
+    alloc-vreg swap operand-class
+    over tagged? [ >>class ] [ drop ] if ;
+
+M: value (lazy-load)
+    2dup allocation [
+        dupd alloc-vreg-for dup rot %move
+    ] [
+        drop
+    ] if ;
+
+: (compute-free-vregs) ( used class -- vector )
+    #! Find all vregs in 'class' which are not in 'used'.
+    [ vregs length reverse ] keep
+    [ <vreg> ] curry map swap diff
+    >vector ;
+
+: compute-free-vregs ( -- )
+    #! Create a new hashtable for thee free-vregs variable.
+    live-vregs
+    { int-regs double-float-regs }
+    [ 2dup (compute-free-vregs) ] H{ } map>assoc
+    \ free-vregs set
+    drop ;
+
+M: loc lazy-store
+    2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
+
+: do-shuffle ( hash -- )
+    dup assoc-empty? [
+        drop
+    ] [
+        "live-locs" set
+        [ lazy-store ] each-loc
+    ] if ;
+
+: fast-shuffle ( locs -- )
+    #! We have enough free registers to load all shuffle inputs
+    #! at once
+    [ dup f (lazy-load) ] H{ } map>assoc do-shuffle ;
+
+: minimal-ds-loc ( phantom -- n )
+    #! When shuffling more values than can fit in registers, we
+    #! need to find an area on the data stack which isn't in
+    #! use.
+    [ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ;
+
+: find-tmp-loc ( -- n )
+    #! Find an area of the data stack which is not referenced
+    #! from the phantom stacks. We can clobber there all we want
+    [ minimal-ds-loc ] each-phantom min 1- ;
+
+: slow-shuffle-mapping ( locs tmp -- pairs )
+    >r dup length r>
+    [ swap - <ds-loc> ] curry map zip ;
+
+: slow-shuffle ( locs -- )
+    #! We don't have enough free registers to load all shuffle
+    #! inputs, so we use a single temporary register, together
+    #! with the area of the data stack above the stack pointer
+    find-tmp-loc slow-shuffle-mapping [
+        [
+            swap dup cached? [ cached-vreg ] when %move
+        ] assoc-each
+    ] keep >hashtable do-shuffle ;
+
+: fast-shuffle? ( live-locs -- ? )
+    #! Test if we have enough free registers to load all
+    #! shuffle inputs at once.
+    int-regs free-vregs [ length ] bi@ <= ;
+
+: finalize-locs ( -- )
+    #! Perform any deferred stack shuffling.
+    [
+        \ free-vregs [ [ clone ] assoc-map ] change
+        live-locs dup fast-shuffle?
+        [ fast-shuffle ] [ slow-shuffle ] if
+    ] with-scope ;
+
+: finalize-vregs ( -- )
+    #! Store any vregs to their final stack locations.
+    [
+        dup loc? over cached? or [ 2drop ] [ %move ] if
+    ] each-loc ;
+
+: reset-phantom ( phantom -- )
+    #! Kill register assignments but preserve constants and
+    #! class information.
+    dup phantom-locs*
+    over stack>> [
+        dup constant? [ nip ] [
+            operand-class over set-operand-class
+        ] if
+    ] 2map
+    over stack>> delete-all
+    swap stack>> push-all ;
+
+: reset-phantoms ( -- )
+    [ reset-phantom ] each-phantom ;
+
+: finalize-contents ( -- )
+    finalize-locs finalize-vregs reset-phantoms ;
+
+! Loading stacks to vregs
+: free-vregs? ( int# float# -- ? )
+    double-float-regs free-vregs length <=
+    >r int-regs free-vregs length <= r> and ;
+
+: phantom&spec ( phantom spec -- phantom' spec' )
+    >r stack>> r>
+    [ length f pad-left ] keep
+    [ <reversed> ] bi@ ; inline
+
+: phantom&spec-agree? ( phantom spec quot -- ? )
+    >r phantom&spec r> 2all? ; inline
+
+: vreg-substitution ( value vreg -- pair )
+    dupd <cached> 2array ;
+
+: substitute-vreg? ( old new -- ? )
+    #! We don't substitute locs for float or alien vregs,
+    #! since in those cases the boxing overhead might kill us.
+    cached-vreg tagged? >r loc? r> and ;
+
+: substitute-vregs ( values vregs -- )
+    [ vreg-substitution ] 2map
+    [ substitute-vreg? ] assoc-filter >hashtable
+    [ >r stack>> r> substitute-here ] curry each-phantom ;
+
+: set-operand ( value var -- )
+    >r dup constant? [ constant-value ] when r> set ;
+
+: lazy-load ( values template -- )
+    #! Set operand vars here.
+    2dup [ first (lazy-load) ] 2map
+    dup rot [ second set-operand ] 2each
+    substitute-vregs ;
+
+: load-inputs ( -- )
+    +input+ get
+    [ length phantom-datastack get phantom-input ] keep
+    lazy-load ;
+
+: output-vregs ( -- seq seq )
+    +output+ +clobber+ [ get [ get ] map ] bi@ ;
+
+: clash? ( seq -- ? )
+    phantoms [ stack>> ] bi@ append [
+        dup cached? [ cached-vreg ] when swap member?
+    ] with contains? ;
+
+: outputs-clash? ( -- ? )
+    output-vregs append clash? ;
+
+: count-vregs ( reg-classes -- ) [ [ inc ] when* ] each ;
+
+: count-input-vregs ( phantom spec -- )
+    phantom&spec [
+        >r dup cached? [ cached-vreg ] when r> first allocation
+    ] 2map count-vregs ;
+
+: count-scratch-regs ( spec -- )
+    [ first reg-spec>class ] map count-vregs ;
+
+: guess-vregs ( dinput rinput scratch -- int# float# )
+    [
+        0 int-regs set
+        0 double-float-regs set
+        count-scratch-regs
+        phantom-retainstack get swap count-input-vregs
+        phantom-datastack get swap count-input-vregs
+        int-regs get double-float-regs get
+    ] with-scope ;
+
+: alloc-scratch ( -- )
+    +scratch+ get [ >r alloc-vreg r> set ] assoc-each ;
+
+: guess-template-vregs ( -- int# float# )
+    +input+ get { } +scratch+ get guess-vregs ;
+
+: template-inputs ( -- )
+    ! Load input values into registers
+    load-inputs
+    ! Allocate scratch registers
+    alloc-scratch
+    ! If outputs clash, we write values back to the stack
+    outputs-clash? [ finalize-contents ] when ;
+
+: template-outputs ( -- )
+    +output+ get [ get ] map phantom-datastack get phantom-append ;
+
+: value-matches? ( value spec -- ? )
+    #! If the spec is a quotation and the value is a literal
+    #! fixnum, see if the quotation yields true when applied
+    #! to the fixnum. Otherwise, the values don't match. If the
+    #! spec is not a quotation, its a reg-class, in which case
+    #! the value is always good.
+    dup quotation? [
+        over constant?
+        [ >r constant-value r> call ] [ 2drop f ] if
+    ] [
+        2drop t
+    ] if ;
+
+: class-matches? ( actual expected -- ? )
+    {
+        { f [ drop t ] }
+        { known-tag [ dup [ class-tag >boolean ] when ] }
+        [ class<= ]
+    } case ;
+
+: spec-matches? ( value spec -- ? )
+    2dup first value-matches?
+    >r >r operand-class 2 r> ?nth class-matches? r> and ;
+
+: template-matches? ( spec -- ? )
+    phantom-datastack get +input+ rot at
+    [ spec-matches? ] phantom&spec-agree? ;
+
+: ensure-template-vregs ( -- )
+    guess-template-vregs free-vregs? [
+        finalize-contents compute-free-vregs
+    ] unless ;
+
+: clear-phantoms ( -- )
+    [ stack>> delete-all ] each-phantom ;
+
+PRIVATE>
+
+: set-operand-classes ( classes -- )
+    phantom-datastack get
+    over length over add-locs
+    stack>> [ set-operand-class ] 2reverse-each ;
+
+: end-basic-block ( -- )
+    #! Commit all deferred stacking shuffling, and ensure the
+    #! in-memory data and retain stacks are up to date with
+    #! respect to the compiler's current picture.
+    finalize-contents
+    clear-phantoms
+    finalize-heights
+    fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
+
+: with-template ( quot hash -- )
+    clone [
+        ensure-template-vregs
+        template-inputs call template-outputs
+    ] bind
+    compute-free-vregs ; inline
+
+: do-template ( pair -- )
+    #! Use with return value from find-template
+    first2 with-template ;
+
+: fresh-object ( obj -- ) fresh-objects get push ;
+
+: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
+
+: init-templates ( -- )
+    #! Initialize register allocator.
+    V{ } clone fresh-objects set
+    <phantom-datastack> phantom-datastack set
+    <phantom-retainstack> phantom-retainstack set
+    compute-free-vregs ;
+
+: copy-templates ( -- )
+    #! Copies register allocator state, used when compiling
+    #! branches.
+    fresh-objects [ clone ] change
+    phantom-datastack [ clone ] change
+    phantom-retainstack [ clone ] change
+    compute-free-vregs ;
+
+: find-template ( templates -- pair/f )
+    #! Pair has shape { quot hash }
+    [ second template-matches? ] find nip ;
+
+: operand-tag ( operand -- tag/f )
+    operand-class dup [ class-tag ] when ;
+
+UNION: immediate fixnum POSTPONE: f ;
+
+: operand-immediate? ( operand -- ? )
+    operand-class immediate class<= ;
+
+: phantom-push ( obj -- )
+    1 phantom-datastack get adjust-phantom
+    phantom-datastack get stack>> push ;
+
+: phantom-shuffle ( shuffle -- )
+    [ effect-in length phantom-datastack get phantom-input ] keep
+    shuffle* phantom-datastack get phantom-append ;
+
+: phantom->r ( n -- )
+    phantom-datastack get phantom-input
+    phantom-retainstack get phantom-append ;
+
+: phantom-r> ( n -- )
+    phantom-retainstack get phantom-input
+    phantom-datastack get phantom-append ;
diff --git a/unfinished/compiler/generator/registers/summary.txt b/unfinished/compiler/generator/registers/summary.txt
new file mode 100644
index 0000000000..89a46afc03
--- /dev/null
+++ b/unfinished/compiler/generator/registers/summary.txt
@@ -0,0 +1 @@
+Register allocation and intrinsic selection
diff --git a/unfinished/compiler/generator/summary.txt b/unfinished/compiler/generator/summary.txt
new file mode 100644
index 0000000000..cf857ad971
--- /dev/null
+++ b/unfinished/compiler/generator/summary.txt
@@ -0,0 +1 @@
+Final stage of compilation generates machine code from dataflow IR
diff --git a/unfinished/compiler/generator/tags.txt b/unfinished/compiler/generator/tags.txt
new file mode 100644
index 0000000000..86a7c8e637
--- /dev/null
+++ b/unfinished/compiler/generator/tags.txt
@@ -0,0 +1 @@
+compiler
diff --git a/unfinished/compiler/tree/debugger/debugger.factor b/unfinished/compiler/tree/debugger/debugger.factor
index 5e8b8888ee..c5b35438b1 100644
--- a/unfinished/compiler/tree/debugger/debugger.factor
+++ b/unfinished/compiler/tree/debugger/debugger.factor
@@ -21,8 +21,8 @@ MACRO: match-choose ( alist -- )
 
 MATCH-VARS: ?a ?b ?c ;
 
-: pretty-shuffle ( in out -- word/f )
-    2array {
+: pretty-shuffle ( effect -- word/f )
+    [ in>> ] [ out>> ] bi {
         { { { } { } } [ ] }
         { { { ?a } { ?a } } [ ] }
         { { { ?a ?b } { ?a ?b } } [ ] }
@@ -50,13 +50,9 @@ 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 ;
+    shuffle-effect dup pretty-shuffle
+    [ % ] [ shuffle boa , ] ?if ;
 
 : pushed-literals ( node -- seq )
     dup out-d>> [ node-value-info literal>> literalize ] with map ;
diff --git a/unfinished/compiler/tree/tree.factor b/unfinished/compiler/tree/tree.factor
index 016afc3e89..3db97fdfe0 100755
--- a/unfinished/compiler/tree/tree.factor
+++ b/unfinished/compiler/tree/tree.factor
@@ -153,6 +153,11 @@ M: #r> inputs/outputs [ in-r>> ] [ out-d>> ] bi ;
 M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
 M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
 
+: shuffle-effect ( #shuffle -- effect )
+    [ in-d>> ] [ out-d>> ] [ mapping>> ] tri
+    [ at ] curry map
+    <effect> ;
+
 M: vector child-visitor V{ } clone ;
 M: vector #introduce, #introduce node, ;
 M: vector #call, #call node, ;
diff --git a/unfinished/stack-checker/inlining/inlining.factor b/unfinished/stack-checker/inlining/inlining.factor
index 6442bc5740..fcbf18f01c 100644
--- a/unfinished/stack-checker/inlining/inlining.factor
+++ b/unfinished/stack-checker/inlining/inlining.factor
@@ -28,9 +28,11 @@ loop? ;
 
 M: inline-recursive hashcode* id>> hashcode* ;
 
+: inlined-block? ( word -- ? ) "inlined-block" word-prop ;
+
 : <inline-recursive> ( word -- label )
     inline-recursive new
-        gensym >>id
+        gensym t "inlined-block" set-word-prop >>id
         swap >>word ;
 
 : quotation-param? ( obj -- ? )

From aededc406fc23ce687f3e75dfdc1d85914cc1bdc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 12 Aug 2008 02:41:18 -0500
Subject: [PATCH 2/3] Adding FFI to new front-end

---
 basis/alien/c-types/c-types-tests.factor      |  6 ++
 basis/alien/c-types/c-types.factor            | 13 ++-
 .../backward/backward.factor                  |  6 ++
 .../compiler/tree/dead-code/dead-code.factor  |  6 ++
 .../tree/debugger/debugger-tests.factor       |  3 +-
 .../compiler/tree/debugger/debugger.factor    |  2 +-
 .../tree/escape-analysis/simple/simple.factor | 10 +++
 .../tree/propagation/simple/simple.factor     |  6 ++
 unfinished/compiler/tree/tree.factor          | 27 ++++++
 .../tree/tuple-unboxing/tuple-unboxing.factor |  4 +
 unfinished/stack-checker/alien/alien.factor   | 84 +++++++++++++++++++
 .../stack-checker/inlining/inlining.factor    |  2 +-
 .../known-words/known-words.factor            | 22 +++--
 .../stack-checker/visitor/dummy/dummy.factor  |  3 +
 .../stack-checker/visitor/visitor.factor      |  3 +
 15 files changed, 181 insertions(+), 16 deletions(-)
 create mode 100644 unfinished/stack-checker/alien/alien.factor

diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor
index 276dd581c5..edda9e7fdb 100755
--- a/basis/alien/c-types/c-types-tests.factor
+++ b/basis/alien/c-types/c-types-tests.factor
@@ -2,6 +2,12 @@ IN: alien.c-types.tests
 USING: alien alien.syntax alien.c-types kernel tools.test
 sequences system libc alien.strings io.encodings.utf8 ;
 
+\ expand-constants must-infer
+
+: xyz 123 ;
+
+[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
+
 : foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
 
 [ 123 ] [ foo ] unit-test
diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index c553ca5cfb..a9b39f80ab 100755
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
 namespaces parser sequences strings words assocs splitting
 math.parser cpu.architecture alien alien.accessors quotations
 layouts system compiler.units io.files io.encodings.binary
-accessors combinators effects ;
+accessors combinators effects continuations ;
 IN: alien.c-types
 
 DEFER: <int>
@@ -239,15 +239,20 @@ M: long-long-type box-return ( type -- )
     } 2cleave ;
 
 : expand-constants ( c-type -- c-type' )
-    #! We use def>> call instead of execute to get around
-    #! staging violations
     dup array? [
-        unclip >r [ dup word? [ def>> call ] when ] map r> prefix
+        unclip >r [
+            dup word? [
+                def>> { } swap with-datastack first
+            ] when
+        ] map r> prefix
     ] when ;
 
 : malloc-file-contents ( path -- alien len )
     binary file-contents dup malloc-byte-array swap length ;
 
+: if-void ( type true false -- )
+    pick "void" = [ drop nip call ] [ nip call ] if ; inline
+
 [
     <c-type>
         [ alien-cell ] >>getter
diff --git a/unfinished/compiler/tree/dataflow-analysis/backward/backward.factor b/unfinished/compiler/tree/dataflow-analysis/backward/backward.factor
index c9caeb864b..d69202c7ad 100644
--- a/unfinished/compiler/tree/dataflow-analysis/backward/backward.factor
+++ b/unfinished/compiler/tree/dataflow-analysis/backward/backward.factor
@@ -35,6 +35,12 @@ M: #phi backward
     [ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ]
     2bi ;
 
+M: #alien-invoke backward
+    nip [ look-at-inputs ] [ look-at-outputs ] bi ;
+
+M: #alien-indirect backward
+    nip [ look-at-inputs ] [ look-at-outputs ] bi ;
+
 M: node backward 2drop ;
 
 : backward-dfa ( node quot -- assoc ) [ backward ] dfa ; inline
diff --git a/unfinished/compiler/tree/dead-code/dead-code.factor b/unfinished/compiler/tree/dead-code/dead-code.factor
index 6703f924fd..652fa19af3 100644
--- a/unfinished/compiler/tree/dead-code/dead-code.factor
+++ b/unfinished/compiler/tree/dead-code/dead-code.factor
@@ -23,6 +23,12 @@ M: #call mark-live-values
     dup word>> "flushable" word-prop
     [ drop ] [ [ look-at-inputs ] [ look-at-outputs ] bi ] if ;
 
+M: #alien-invoke mark-live-values
+    [ look-at-inputs ] [ look-at-outputs ] bi ;
+
+M: #alien-indirect mark-live-values
+    [ look-at-inputs ] [ look-at-outputs ] bi ;
+
 M: #return mark-live-values
     look-at-inputs ;
 
diff --git a/unfinished/compiler/tree/debugger/debugger-tests.factor b/unfinished/compiler/tree/debugger/debugger-tests.factor
index e6a4385c3e..eb0bbd5ce6 100644
--- a/unfinished/compiler/tree/debugger/debugger-tests.factor
+++ b/unfinished/compiler/tree/debugger/debugger-tests.factor
@@ -1,6 +1,5 @@
 IN: compiler.tree.debugger.tests
 USING: compiler.tree.debugger tools.test ;
 
-\ optimized-quot. must-infer
-\ optimized-word. must-infer
+\ optimized. must-infer
 \ optimizer-report. must-infer
diff --git a/unfinished/compiler/tree/debugger/debugger.factor b/unfinished/compiler/tree/debugger/debugger.factor
index c5b35438b1..c541311ef2 100644
--- a/unfinished/compiler/tree/debugger/debugger.factor
+++ b/unfinished/compiler/tree/debugger/debugger.factor
@@ -22,7 +22,7 @@ MACRO: match-choose ( alist -- )
 MATCH-VARS: ?a ?b ?c ;
 
 : pretty-shuffle ( effect -- word/f )
-    [ in>> ] [ out>> ] bi {
+    [ in>> ] [ out>> ] bi 2array {
         { { { } { } } [ ] }
         { { { ?a } { ?a } } [ ] }
         { { { ?a ?b } { ?a ?b } } [ ] }
diff --git a/unfinished/compiler/tree/escape-analysis/simple/simple.factor b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
index c6c407b048..af42dc5145 100644
--- a/unfinished/compiler/tree/escape-analysis/simple/simple.factor
+++ b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
@@ -80,3 +80,13 @@ M: #call escape-analysis*
 
 M: #return escape-analysis*
     in-d>> add-escaping-values ;
+
+M: #alien-invoke escape-analysis*
+    [ in-d>> add-escaping-values ]
+    [ out-d>> unknown-allocation ]
+    bi ;
+
+M: #alien-indirect escape-analysis*
+    [ in-d>> add-escaping-values ]
+    [ out-d>> unknown-allocation ]
+    bi ;
diff --git a/unfinished/compiler/tree/propagation/simple/simple.factor b/unfinished/compiler/tree/propagation/simple/simple.factor
index 4237738625..45bbbf19db 100644
--- a/unfinished/compiler/tree/propagation/simple/simple.factor
+++ b/unfinished/compiler/tree/propagation/simple/simple.factor
@@ -115,3 +115,9 @@ M: #call propagate-before
 M: #call propagate-after
     dup word>> "input-classes" word-prop dup
     [ propagate-input-classes ] [ 2drop ] if ;
+
+M: #alien-invoke propagate-before
+    out-d>> [ object-info swap set-value-info ] each ;
+
+M: #alien-indirect propagate-before
+    out-d>> [ object-info swap set-value-info ] each ;
diff --git a/unfinished/compiler/tree/tree.factor b/unfinished/compiler/tree/tree.factor
index 3db97fdfe0..175c1ddfdd 100755
--- a/unfinished/compiler/tree/tree.factor
+++ b/unfinished/compiler/tree/tree.factor
@@ -143,6 +143,30 @@ TUPLE: #copy < #renaming in-d out-d ;
         swap >>out-d
         swap >>in-d ;
 
+TUPLE: #alien-node < node params ;
+
+: new-alien-node ( params class -- node )
+    new
+        over in-d>> >>in-d
+        over out-d>> >>out-d
+        swap >>params ; inline
+
+TUPLE: #alien-invoke < #alien-node in-d out-d ;
+
+: #alien-invoke ( params -- node )
+    \ #alien-invoke new-alien-node ;
+
+TUPLE: #alien-indirect < #alien-node in-d out-d ;
+
+: #alien-indirect ( params -- node )
+    \ #alien-indirect new-alien-node ;
+
+TUPLE: #alien-callback < #alien-node ;
+
+: #alien-callback ( params -- node )
+    \ #alien-callback new
+        swap >>params ;
+
 : node, ( node -- ) stack-visitor get push ;
 
 GENERIC: inputs/outputs ( #renaming -- inputs outputs )
@@ -177,3 +201,6 @@ M: vector #phi, #phi node, ;
 M: vector #declare, #declare node, ;
 M: vector #recursive, #recursive node, ;
 M: vector #copy, #copy node, ;
+M: vector #alien-invoke, #alien-invoke node, ;
+M: vector #alien-indirect, #alien-indirect node, ;
+M: vector #alien-callback, #alien-callback node, ;
diff --git a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
index 3b832917d8..1b92d66db4 100644
--- a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
+++ b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
@@ -128,4 +128,8 @@ M: #return unbox-tuples* dup in-d>> assert-not-unboxed ;
 
 M: #introduce unbox-tuples* dup value>> assert-not-unboxed ;
 
+M: #alien-invoke unbox-tuples* dup in-d>> assert-not-unboxed ;
+
+M: #alien-indirect unbox-tuples* dup in-d>> assert-not-unboxed ;
+
 : unbox-tuples ( nodes -- nodes ) [ unbox-tuples* ] map-nodes ;
diff --git a/unfinished/stack-checker/alien/alien.factor b/unfinished/stack-checker/alien/alien.factor
new file mode 100644
index 0000000000..f81b7fdaa3
--- /dev/null
+++ b/unfinished/stack-checker/alien/alien.factor
@@ -0,0 +1,84 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences accessors combinators math namespaces
+init sets words
+alien alien.c-types
+stack-checker.backend stack-checker.errors stack-checker.visitor ;
+IN: stack-checker.alien
+
+TUPLE: alien-node-params return parameters abi in-d out-d ;
+
+TUPLE: alien-invoke-params < alien-node-params library function ;
+
+TUPLE: alien-indirect-params < alien-node-params ;
+
+TUPLE: alien-callback-params < alien-node-params quot xt ;
+
+: pop-parameters ( -- seq )
+    pop-literal nip [ expand-constants ] map ;
+
+: param-prep-quot ( node -- quot )
+    parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
+
+: alien-stack ( params extra -- )
+    over parameters>> length + consume-d >>in-d
+    dup return>> "void" = 0 1 ? produce-d >>out-d
+    drop ;
+
+: return-prep-quot ( node -- quot )
+    return>> [ [ ] ] [ c-type c-type-boxer-quot ] if-void ;
+
+: infer-alien-invoke ( -- )
+    alien-invoke-params new
+    ! Compile-time parameters
+    pop-parameters >>parameters
+    pop-literal nip >>function
+    pop-literal nip >>library
+    pop-literal nip >>return
+    ! Quotation which coerces parameters to required types
+    dup param-prep-quot recursive-state get infer-quot
+    ! Set ABI
+    dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
+    ! Magic #: consume exactly the number of inputs
+    dup 0 alien-stack
+    ! Add node to IR
+    dup #alien-invoke,
+    ! Quotation which coerces return value to required type
+    return-prep-quot recursive-state get infer-quot ;
+
+: infer-alien-indirect ( -- )
+    alien-indirect-params new
+    ! Compile-time parameters
+    pop-literal nip >>abi
+    pop-parameters >>parameters
+    pop-literal nip >>return
+    ! Quotation which coerces parameters to required types
+    dup param-prep-quot [ dip ] curry recursive-state get infer-quot
+    ! Magic #: consume the function pointer, too
+    dup 1 alien-stack
+    ! Add node to IR
+    dup #alien-indirect,
+    ! Quotation which coerces return value to required type
+    return-prep-quot recursive-state get infer-quot ;
+
+! Callbacks are registered in a global hashtable. If you clear
+! this hashtable, they will all be blown away by code GC, beware
+SYMBOL: callbacks
+
+[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
+
+: register-callback ( word -- ) callbacks get conjoin ;
+
+: callback-bottom ( params -- )
+    xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
+    recursive-state get infer-quot ;
+
+: infer-alien-callback ( -- )
+    alien-callback-params new
+    pop-literal nip >>quot
+    pop-literal nip >>abi
+    pop-parameters >>parameters
+    pop-literal nip >>return
+    gensym >>xt
+    dup callback-bottom
+    #alien-callback, ;
diff --git a/unfinished/stack-checker/inlining/inlining.factor b/unfinished/stack-checker/inlining/inlining.factor
index fcbf18f01c..3be2e21b7e 100644
--- a/unfinished/stack-checker/inlining/inlining.factor
+++ b/unfinished/stack-checker/inlining/inlining.factor
@@ -32,7 +32,7 @@ M: inline-recursive hashcode* id>> hashcode* ;
 
 : <inline-recursive> ( word -- label )
     inline-recursive new
-        gensym t "inlined-block" set-word-prop >>id
+        gensym dup t "inlined-block" set-word-prop >>id
         swap >>word ;
 
 : quotation-param? ( obj -- ? )
diff --git a/unfinished/stack-checker/known-words/known-words.factor b/unfinished/stack-checker/known-words/known-words.factor
index 2e0c979f98..eb9a9dbdf7 100755
--- a/unfinished/stack-checker/known-words/known-words.factor
+++ b/unfinished/stack-checker/known-words/known-words.factor
@@ -10,10 +10,14 @@ sequences sequences.private slots.private strings
 strings.private system threads.private classes.tuple
 classes.tuple.private vectors vectors.private words definitions
 words.private assocs summary compiler.units system.private
-combinators locals.backend stack-checker.state
-stack-checker.backend stack-checker.branches
-stack-checker.errors stack-checker.transforms
-stack-checker.visitor ;
+combinators locals.backend
+stack-checker.state
+stack-checker.backend
+stack-checker.branches
+stack-checker.errors
+stack-checker.transforms
+stack-checker.visitor
+stack-checker.alien ;
 IN: stack-checker.known-words
 
 : infer-primitive ( word -- )
@@ -153,13 +157,15 @@ M: object infer-call*
         { \ get-local [ infer-get-local ] }
         { \ drop-locals [ infer-drop-locals ] }
         { \ do-primitive [ \ do-primitive cannot-infer-effect ] }
+        { \ alien-invoke [ infer-alien-invoke ] }
+        { \ alien-indirect [ infer-alien-indirect ] }
+        { \ alien-callback [ infer-alien-callback ] }
     } case ;
 
 {
-    >r r> declare call curry compose
-    execute if dispatch <tuple-boa>
-    (throw) load-locals get-local drop-locals
-    do-primitive
+    >r r> declare call curry compose execute if dispatch
+    <tuple-boa> (throw) load-locals get-local drop-locals
+    do-primitive alien-invoke alien-indirect alien-callback
 } [ t +special+ set-word-prop ] each
 
 { call execute dispatch load-locals get-local drop-locals }
diff --git a/unfinished/stack-checker/visitor/dummy/dummy.factor b/unfinished/stack-checker/visitor/dummy/dummy.factor
index a1ed5c83a1..381405bd31 100644
--- a/unfinished/stack-checker/visitor/dummy/dummy.factor
+++ b/unfinished/stack-checker/visitor/dummy/dummy.factor
@@ -22,3 +22,6 @@ M: f #declare, drop ;
 M: f #recursive, 2drop 2drop ;
 M: f #copy, 2drop ;
 M: f #drop, drop ;
+M: f #alien-invoke, drop ;
+M: f #alien-indirect, drop ;
+M: f #alien-callback, drop ;
diff --git a/unfinished/stack-checker/visitor/visitor.factor b/unfinished/stack-checker/visitor/visitor.factor
index 3afc8f752d..25775ca3f0 100644
--- a/unfinished/stack-checker/visitor/visitor.factor
+++ b/unfinished/stack-checker/visitor/visitor.factor
@@ -27,3 +27,6 @@ HOOK: #enter-recursive, stack-visitor ( label inputs outputs -- )
 HOOK: #return-recursive, stack-visitor ( label inputs outputs -- )
 HOOK: #recursive, stack-visitor ( word label inputs visitor -- )
 HOOK: #copy, stack-visitor ( inputs outputs -- )
+HOOK: #alien-invoke, stack-visitor ( params -- )
+HOOK: #alien-indirect, stack-visitor ( params -- )
+HOOK: #alien-callback, stack-visitor ( params -- )

From 762007b28e0e9d47d4ce8cc59eb07c9898d0b92e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 12 Aug 2008 03:18:15 -0500
Subject: [PATCH 3/3] Debugging front-end, updating FFI codegen

---
 .../compiler/generator/generator.factor       | 321 +++++++++++++++++-
 .../known-words/known-words.factor            |   4 +-
 .../transforms/transforms.factor              |   6 +-
 3 files changed, 323 insertions(+), 8 deletions(-)

diff --git a/unfinished/compiler/generator/generator.factor b/unfinished/compiler/generator/generator.factor
index 19e60ae19c..a4a7815d70 100755
--- a/unfinished/compiler/generator/generator.factor
+++ b/unfinished/compiler/generator/generator.factor
@@ -2,8 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs classes combinators
 cpu.architecture effects generic hashtables io kernel
-kernel.private layouts math namespaces prettyprint quotations
-sequences system threads words vectors sets dequeues cursors
+kernel.private layouts math math.parser namespaces prettyprint
+quotations sequences system threads words vectors sets dequeues
+cursors continuations.private summary alien alien.c-types
+alien.structs alien.strings alien.arrays libc compiler.errors
 stack-checker.inlining
 compiler.tree compiler.tree.builder compiler.tree.combinators
 compiler.tree.propagation.info compiler.generator.fixup
@@ -48,7 +50,7 @@ SYMBOL: current-label-start
 : save-machine-code ( literals relocation labels code -- )
     4array compiling-label get compiled get set-at ;
 
-: with-generator ( node word label quot -- )
+: with-generator ( nodes word label quot -- )
     [
         >r begin-compiling r>
         { } make fixup
@@ -267,3 +269,316 @@ M: #return-recursive generate-node
     end-basic-block
     label>> id>> compiling-loops get key?
     [ %return ] unless f ;
+
+! #alien-invoke
+: large-struct? ( ctype -- ? )
+    dup c-struct? [
+        heap-size struct-small-enough? not
+    ] [ drop f ] if ;
+
+: alien-parameters ( params -- seq )
+    dup parameters>>
+    swap return>> large-struct? [ "void*" prefix ] when ;
+
+: alien-return ( params -- ctype )
+    return>> dup large-struct? [ drop "void" ] when ;
+
+: c-type-stack-align ( type -- align )
+    dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
+
+: parameter-align ( n type -- n delta )
+    over >r c-type-stack-align align dup r> - ;
+
+: parameter-sizes ( types -- total offsets )
+    #! Compute stack frame locations.
+    [
+        0 [
+            [ parameter-align drop dup , ] keep stack-size +
+        ] reduce cell align
+    ] { } make ;
+
+: return-size ( ctype -- n )
+    #! Amount of space we reserve for a return value.
+    dup large-struct? [ heap-size ] [ drop 0 ] if ;
+
+: alien-stack-frame ( params -- n )
+    alien-parameters parameter-sizes drop ;
+
+: alien-invoke-frame ( params -- n )
+    #! One cell is temporary storage, temp@
+    dup return>> return-size
+    swap alien-stack-frame +
+    cell + ;
+
+: set-stack-frame ( n -- )
+    dup [ frame-required ] when* \ stack-frame set ;
+
+: with-stack-frame ( n quot -- )
+    swap set-stack-frame
+    call
+    f set-stack-frame ; inline
+
+GENERIC: reg-size ( register-class -- n )
+
+M: int-regs reg-size drop cell ;
+
+M: single-float-regs reg-size drop 4 ;
+
+M: double-float-regs reg-size drop 8 ;
+
+GENERIC: reg-class-variable ( register-class -- symbol )
+
+M: reg-class reg-class-variable ;
+
+M: float-regs reg-class-variable drop float-regs ;
+
+GENERIC: inc-reg-class ( register-class -- )
+
+M: reg-class inc-reg-class
+    dup reg-class-variable inc
+    fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
+
+M: float-regs inc-reg-class
+    dup call-next-method
+    fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
+
+: reg-class-full? ( class -- ? )
+    [ reg-class-variable get ] [ param-regs length ] bi >= ;
+
+: spill-param ( reg-class -- n reg-class )
+    stack-params get
+    >r reg-size stack-params +@ r>
+    stack-params ;
+
+: fastcall-param ( reg-class -- n reg-class )
+    [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
+
+: alloc-parameter ( parameter -- reg reg-class )
+    c-type-reg-class dup reg-class-full?
+    [ spill-param ] [ fastcall-param ] if
+    [ param-reg ] keep ;
+
+: (flatten-int-type) ( size -- )
+    cell /i "void*" c-type <repetition> % ;
+
+GENERIC: flatten-value-type ( type -- )
+
+M: object flatten-value-type , ;
+
+M: struct-type flatten-value-type ( type -- )
+    stack-size cell align (flatten-int-type) ;
+
+M: long-long-type flatten-value-type ( type -- )
+    stack-size cell align (flatten-int-type) ;
+
+: flatten-value-types ( params -- params )
+    #! Convert value type structs to consecutive void*s.
+    [
+        0 [
+            c-type
+            [ parameter-align (flatten-int-type) ] keep
+            [ stack-size cell align + ] keep
+            flatten-value-type
+        ] reduce drop
+    ] { } make ;
+
+: each-parameter ( parameters quot -- )
+    >r [ parameter-sizes nip ] keep r> 2each ; inline
+
+: reverse-each-parameter ( parameters quot -- )
+    >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
+
+: reset-freg-counts ( -- )
+    { int-regs float-regs stack-params } [ 0 swap set ] each ;
+
+: with-param-regs ( quot -- )
+    #! In quot you can call alloc-parameter
+    [ reset-freg-counts call ] with-scope ; inline
+
+: move-parameters ( node word -- )
+    #! Moves values from C stack to registers (if word is
+    #! %load-param-reg) and registers to C stack (if word is
+    #! %save-param-reg).
+    >r
+    alien-parameters
+    flatten-value-types
+    r> [ >r alloc-parameter r> execute ] curry each-parameter ;
+    inline
+
+: unbox-parameters ( offset node -- )
+    parameters>> [
+        %prepare-unbox >r over + r> unbox-parameter
+    ] reverse-each-parameter drop ;
+
+: prepare-box-struct ( node -- offset )
+    #! Return offset on C stack where to store unboxed
+    #! parameters. If the C function is returning a structure,
+    #! the first parameter is an implicit target area pointer,
+    #! so we need to use a different offset.
+    return>> dup large-struct?
+    [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
+
+: objects>registers ( params -- )
+    #! Generate code for unboxing a list of C types, then
+    #! generate code for moving these parameters to register on
+    #! architectures where parameters are passed in registers.
+    [
+        [ prepare-box-struct ] keep
+        [ unbox-parameters ] keep
+        \ %load-param-reg move-parameters
+    ] with-param-regs ;
+
+: box-return* ( node -- )
+    return>> [ ] [ box-return ] if-void ;
+
+TUPLE: no-such-library name ;
+
+M: no-such-library summary
+    drop "Library not found" ;
+
+M: no-such-library compiler-error-type
+    drop +linkage+ ;
+
+: no-such-library ( name -- )
+    \ no-such-library boa
+    compiling-word get compiler-error ;
+
+TUPLE: no-such-symbol name ;
+
+M: no-such-symbol summary
+    drop "Symbol not found" ;
+
+M: no-such-symbol compiler-error-type
+    drop +linkage+ ;
+
+: no-such-symbol ( name -- )
+    \ no-such-symbol boa
+    compiling-word get compiler-error ;
+
+: check-dlsym ( symbols dll -- )
+    dup dll-valid? [
+        dupd [ dlsym ] curry contains?
+        [ drop ] [ no-such-symbol ] if
+    ] [
+        dll-path no-such-library drop
+    ] if ;
+
+: stdcall-mangle ( symbol node -- symbol )
+    "@"
+    swap parameters>> parameter-sizes drop
+    number>string 3append ;
+
+: alien-invoke-dlsym ( params -- symbols dll )
+    dup function>> dup pick stdcall-mangle 2array
+    swap library>> library dup [ dll>> ] when
+    2dup check-dlsym ;
+
+M: #alien-invoke generate-node
+    params>>
+    dup alien-invoke-frame [
+        end-basic-block
+        %prepare-alien-invoke
+        dup objects>registers
+        %prepare-var-args
+        dup alien-invoke-dlsym %alien-invoke
+        dup %cleanup
+        box-return*
+        iterate-next
+    ] with-stack-frame ;
+
+! #alien-indirect
+M: #alien-indirect generate-node
+    params>>
+    dup alien-invoke-frame [
+        ! Flush registers
+        end-basic-block
+        ! Save registers for GC
+        %prepare-alien-invoke
+        ! Save alien at top of stack to temporary storage
+        %prepare-alien-indirect
+        dup objects>registers
+        %prepare-var-args
+        ! Call alien in temporary storage
+        %alien-indirect
+        dup %cleanup
+        box-return*
+        iterate-next
+    ] with-stack-frame ;
+
+! #alien-callback
+: box-parameters ( params -- )
+    alien-parameters [ box-parameter ] each-parameter ;
+
+: registers>objects ( node -- )
+    [
+        dup \ %save-param-reg move-parameters
+        "nest_stacks" f %alien-invoke
+        box-parameters
+    ] with-param-regs ;
+
+TUPLE: callback-context ;
+
+: current-callback 2 getenv ;
+
+: wait-to-return ( token -- )
+    dup current-callback eq? [
+        drop
+    ] [
+        yield wait-to-return
+    ] if ;
+
+: do-callback ( quot token -- )
+    init-catchstack
+    dup 2 setenv
+    slip
+    wait-to-return ; inline
+
+: callback-return-quot ( ctype -- quot )
+    return>> {
+        { [ dup "void" = ] [ drop [ ] ] }
+        { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
+        [ c-type c-type-unboxer-quot ]
+    } cond ;
+
+: callback-prep-quot ( params -- quot )
+    parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
+
+: wrap-callback-quot ( params -- quot )
+    [
+        [ callback-prep-quot ]
+        [ quot>> ]
+        [ callback-return-quot ] tri 3append ,
+        [ callback-context new do-callback ] %
+    ] [ ] make ;
+
+: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
+
+: callback-unwind ( params -- n )
+    {
+        { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
+        { [ dup return>> large-struct? ] [ drop 4 ] }
+        [ drop 0 ]
+    } cond ;
+
+: %callback-return ( params -- )
+    #! All the extra book-keeping for %unwind is only for x86.
+    #! On other platforms its an alias for %return.
+    dup alien-return
+    [ %unnest-stacks ] [ %callback-value ] if-void
+    callback-unwind %unwind ;
+
+: generate-callback ( params -- )
+    dup xt>> dup [
+        init-templates
+        %prologue-later
+        dup alien-stack-frame [
+            [ registers>objects ]
+            [ wrap-callback-quot %alien-callback ]
+            [ %callback-return ]
+            tri
+        ] with-stack-frame
+    ] with-generator ;
+
+M: #alien-callback generate-node
+    end-basic-block
+    params>> generate-callback iterate-next ;
diff --git a/unfinished/stack-checker/known-words/known-words.factor b/unfinished/stack-checker/known-words/known-words.factor
index eb9a9dbdf7..a0c91f679b 100755
--- a/unfinished/stack-checker/known-words/known-words.factor
+++ b/unfinished/stack-checker/known-words/known-words.factor
@@ -179,10 +179,10 @@ SYMBOL: +primitive+
         { [ dup +shuffle+ word-prop ] [ infer-shuffle-word ] }
         { [ dup +special+ word-prop ] [ infer-special ] }
         { [ dup +primitive+ word-prop ] [ infer-primitive ] }
-        { [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
         { [ dup +transform-quot+ word-prop ] [ apply-transform ] }
-        { [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
         { [ dup "macro" word-prop ] [ apply-macro ] }
+        { [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
+        { [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
         { [ dup recursive-label ] [ call-recursive-word ] }
         [ dup infer-word apply-word/effect ]
     } cond ;
diff --git a/unfinished/stack-checker/transforms/transforms.factor b/unfinished/stack-checker/transforms/transforms.factor
index d9e889f188..f22960dd39 100755
--- a/unfinished/stack-checker/transforms/transforms.factor
+++ b/unfinished/stack-checker/transforms/transforms.factor
@@ -23,10 +23,11 @@ SYMBOL: +transform-n+
     inline
 
 : (apply-transform) ( word quot n -- )
-    consume-d dup [ known literal? ] all? [
+    dup ensure-d [ known literal? ] all? [
         dup empty? [
             drop recursive-state get 1array
         ] [
+            consume-d
             [ #drop, ]
             [ [ literal value>> ] map ]
             [ first literal recursion>> ] tri prefix
@@ -123,7 +124,6 @@ SYMBOL: +transform-n+
 
 : bit-member-quot ( seq -- newquot )
     [
-        [ drop ] % ! drop the sequence itself; we don't use it at run time
         bit-member-seq ,
         [
             {
@@ -140,7 +140,7 @@ SYMBOL: +transform-n+
         bit-member-quot
     ] [
         [ literalize [ t ] ] { } map>assoc
-        [ drop f ] suffix [ nip case ] curry
+        [ drop f ] suffix [ case ] curry
     ] if ;
 
 \ member? [