From 8c44395e3a51f0200cacd29af70737b914e91fa5 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Thu, 30 Mar 2006 21:13:11 +0000
Subject: [PATCH 001/112] Start 0.82

---
 library/windows/load.factor | 2 +-
 version.factor              | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/library/windows/load.factor b/library/windows/load.factor
index f41cb2e218..e68cbfae05 100644
--- a/library/windows/load.factor
+++ b/library/windows/load.factor
@@ -32,4 +32,4 @@ USING: alien compiler kernel namespaces parser sequences words ;
 ] when
 
 IN: kernel
-: default-shell "tty" ;
+: default-shell "ui" ;
diff --git a/version.factor b/version.factor
index cd4fdfd04d..2f8468adf4 100644
--- a/version.factor
+++ b/version.factor
@@ -1,2 +1,2 @@
 IN: kernel
-: version "0.81" ;
+: version "0.82" ;

From ce48c96903fc1c2add6208a43f1ba95680af9987 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Thu, 30 Mar 2006 21:39:56 +0000
Subject: [PATCH 002/112] You can now define Objective C methods which return
 structures

---
 TODO.FACTOR.txt                  |  1 -
 library/cocoa/subclassing.factor | 18 ++++++++++++------
 2 files changed, 12 insertions(+), 7 deletions(-)

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 71281d07b8..959ae4d4ff 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -5,7 +5,6 @@ should fix in 0.82:
 - when generating a 32-bit image on a 64-bit system, large numbers which should
   be bignums become fixnums
 - httpd fep
-- defining methods returning structs in objc
 - expired aliens in view hash
 - clicks sent twice
 - speed up ideas:
diff --git a/library/cocoa/subclassing.factor b/library/cocoa/subclassing.factor
index c231027dff..d84a3505d9 100644
--- a/library/cocoa/subclassing.factor
+++ b/library/cocoa/subclassing.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: objc
 USING: alien arrays compiler hashtables kernel kernel-internals
-libc math namespaces sequences strings words ;
+libc lists math namespaces sequences strings words ;
 
 : init-method ( method alien -- )
     >r first3 r>
@@ -64,13 +64,19 @@ libc math namespaces sequences strings words ;
     >r 1array r> append
     [ [ alien>objc-types get hash % CHAR: 0 , ] each ] "" make ;
 
-: prepare-method ( { name ret types quot } -- { name type imp  } )
-    [ first3 encode-types ] keep
-    [ 1 swap tail % \ alien-callback , ] [ ] make compile-quot
-    3array ;
+: struct-return ( ret types quot -- ret types quot )
+    pick c-struct? [
+        pick c-size [ memcpy ] curry append
+        >r { "void*" } swap append >r drop "void" r> r>
+    ] when ;
+
+: prepare-method ( ret types quot -- type imp )
+    >r [ encode-types ] 2keep r>
+    [ struct-return 3array % \ alien-callback , ] [ ] make
+    compile-quot ;
 
 : prepare-methods ( methods -- methods )
-    [ prepare-method ] map ;
+    [ first4 prepare-method 3array ] map ;
 
 : define-objc-class ( superclass name imeth cmeth -- )
     pick >r

From 22c0257dbe11cea9cac659c93b1de222e893fc53 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sat, 1 Apr 2006 01:16:03 +0000
Subject: [PATCH 003/112] Clear out expired aliens in Cocoa UI startup

---
 TODO.FACTOR.txt         |  6 +++---
 library/cocoa/ui.factor | 14 +++++++++-----
 2 files changed, 12 insertions(+), 8 deletions(-)

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 959ae4d4ff..6930251b8f 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,17 +1,15 @@
 should fix in 0.82:
 
+- 3 >n fep
 - amd64 %box-struct
 - get factor running on mac intel
 - when generating a 32-bit image on a 64-bit system, large numbers which should
   be bignums become fixnums
 - httpd fep
-- expired aliens in view hash
 - clicks sent twice
 - speed up ideas:
   - only do clipping for certain gadgets
   - use glRect
-- remove <char*>, <ushort*>, set-char*-nth, set-ushort*-nth since they
-  have incorrect semantics
 - cocoa: global menu bar with useful commands
 
 + portability:
@@ -58,6 +56,8 @@ should fix in 0.82:
 - core foundation should use unicode strings
 - alien>utf16-string, utf16-string>alien words
 - can <void*> only be called with an alien?
+- remove <char*>, <ushort*>, set-char*-nth, set-ushort*-nth since they
+  have incorrect semantics
 - improve callback efficiency
 - float intrinsics
 - complex float type
diff --git a/library/cocoa/ui.factor b/library/cocoa/ui.factor
index fb0ba981e2..0dc64f8d63 100644
--- a/library/cocoa/ui.factor
+++ b/library/cocoa/ui.factor
@@ -3,11 +3,11 @@
 IN: objc-FactorView
 DEFER: FactorView
 
-USING: arrays cocoa errors freetype gadgets gadgets-launchpad
-gadgets-layouts gadgets-listener gadgets-panes hashtables kernel
-lists math namespaces objc objc-NSApplication objc-NSEvent
-objc-NSObject objc-NSOpenGLContext objc-NSOpenGLView objc-NSView
-objc-NSWindow sequences threads ;
+USING: alien arrays cocoa errors freetype gadgets
+gadgets-launchpad gadgets-layouts gadgets-listener gadgets-panes
+hashtables kernel lists math namespaces objc objc-NSApplication
+objc-NSEvent objc-NSObject objc-NSOpenGLContext
+objc-NSOpenGLView objc-NSView objc-NSWindow sequences threads ;
 
 ! Cocoa backend for Factor UI
 
@@ -18,6 +18,9 @@ SYMBOL: views
 
 H{ } clone views set-global
 
+: purge-expired ( hash -- hash )
+    [ drop expired? not ] hash-subset ;
+
 : view ( handle -- world ) views get hash ;
 
 : mouse-location ( view event -- loc )
@@ -189,6 +192,7 @@ IN: shells
     [
         [
             init-ui
+            purge-expired
             launchpad-window
             listener-window
             finish-launching

From da0633925cf0d0f530feb0ac24b9a8e7d9798fab Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sat, 1 Apr 2006 01:16:39 +0000
Subject: [PATCH 004/112] Refactor compiler code to deal with stack locations
 in a more orthogonal manner

---
 library/compiler/basic-blocks.factor | 15 +++----
 library/compiler/intrinsics.factor   | 32 ++++++++-------
 library/compiler/linearizer.factor   | 18 +++++++--
 library/compiler/stack.factor        | 58 +++++++++++-----------------
 library/compiler/vops.factor         | 28 +++-----------
 5 files changed, 69 insertions(+), 82 deletions(-)

diff --git a/library/compiler/basic-blocks.factor b/library/compiler/basic-blocks.factor
index 5abd56c0ee..9fcab8a9d6 100644
--- a/library/compiler/basic-blocks.factor
+++ b/library/compiler/basic-blocks.factor
@@ -19,6 +19,7 @@ USING: arrays hashtables kernel lists math namespaces sequences ;
 : vop-in ( vop n -- input ) swap vop-inputs nth ;
 : set-vop-in ( input vop n -- ) swap vop-inputs set-nth ;
 : vop-out ( vop n -- input ) swap vop-outputs nth ;
+: set-vop-out ( output vop n -- ) swap vop-outputs set-nth ;
 
 : (split-blocks) ( n linear -- )
     2dup length = [
@@ -49,17 +50,17 @@ M: %inc-d simplify-stack* ( vop -- ) d-height accum-height ;
 
 M: %inc-r simplify-stack* ( vop -- ) r-height accum-height ;
 
-GENERIC: update-loc ( loc -- )
+GENERIC: update-loc ( loc -- loc )
 
-M: ds-loc update-loc
-    dup ds-loc-n d-height get - swap set-ds-loc-n ;
+M: ds-loc update-loc ds-loc-n d-height get - <ds-loc> ;
 
-M: cs-loc update-loc
-    dup cs-loc-n r-height get - swap set-cs-loc-n ;
+M: cs-loc update-loc cs-loc-n r-height get - <cs-loc> ;
 
-M: %peek simplify-stack* ( vop -- ) 0 vop-in update-loc ;
+M: %peek simplify-stack* ( vop -- )
+    0 [ vop-in update-loc ] 2keep set-vop-in ;
 
-M: %replace simplify-stack* ( vop -- ) 0 vop-out update-loc ;
+M: %replace simplify-stack* ( vop -- )
+    0 [ vop-out update-loc ] 2keep set-vop-out ;
 
 : simplify-stack ( block -- )
     #! Combine all %inc-d/%inc-r into two final ones.
diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index dfd5f0f222..156e13f85a 100644
--- a/library/compiler/intrinsics.factor
+++ b/library/compiler/intrinsics.factor
@@ -64,7 +64,7 @@ namespaces sequences words ;
     in-2
     -1 %inc-d ,
     0 1 %char-slot ,
-    1 <vreg> 0 %replace-d ,
+    T{ vreg f 1 } T{ ds-loc f 0 } %replace ,
 ] "intrinsic" set-word-prop
 
 \ set-char-slot [
@@ -102,23 +102,27 @@ namespaces sequences words ;
     -1 %inc-d ,
 ] "intrinsic" set-word-prop
 
-: value/vreg-list ( in -- list )
-    [ 0 swap length 1- ] keep
-    [ >r 2dup r> 3array >r 1- >r 1+ r> r> ] map 2nip ;
+GENERIC: load-value ( vreg loc value -- )
 
-: values>vregs ( in -- in )
-    value/vreg-list
-    dup [ first3 load-value ] each
-    [ first <vreg> ] map ;
+M: object load-value ( vreg loc value -- )
+    drop %peek , ;
+
+M: value load-value ( vreg loc value -- )
+    nip value-literal swap load-literal ;
 
 : binary-inputs ( node -- in1 in2 )
-    node-in-d values>vregs first2 swap ;
+    node-in-d
+    T{ vreg f 0 } T{ ds-loc f 1 } pick first load-value
+    T{ vreg f 1 } T{ ds-loc f 0 } rot second load-value
+    T{ vreg f 1 } T{ vreg f 0 } ;
 
 : binary-op-reg ( node op -- )
     >r binary-inputs dup -1 %inc-d , r> execute , out-1 ; inline
 
 : binary-imm ( node -- in1 in2 )
-    -1 %inc-d , in-1 node-peek value-literal 0 <vreg> ;
+    -1 %inc-d ,
+    T{ vreg f 0 } T{ ds-loc f 1 } pick node-peek load-value
+    node-peek value-literal T{ vreg f 0 } ;
 
 : binary-op-imm ( node op -- )
     >r binary-imm dup r> execute , out-1 ; inline
@@ -176,7 +180,7 @@ namespaces sequences words ;
     in-2
     -1 %inc-d ,
     1 <vreg> 0 <vreg> 2 <vreg> %fixnum-mod ,
-    T{ vreg f 2 } 0 %replace-d ,
+    T{ vreg f 2 } T{ ds-loc f 0 } %replace ,
 ] "intrinsic" set-word-prop
 
 \ fixnum/mod [
@@ -186,8 +190,8 @@ namespaces sequences words ;
     { T{ vreg f 1 } T{ vreg f 0 } }
     { T{ vreg f 2 } T{ vreg f 0 } }
     %fixnum/mod ,
-    T{ vreg f 2 } 0 %replace-d ,
-    T{ vreg f 0 } 1 %replace-d ,
+    T{ vreg f 2 } T{ ds-loc f 0 } %replace ,
+    T{ vreg f 0 } T{ ds-loc f 1 } %replace ,
 ] "intrinsic" set-word-prop
 
 \ fixnum-bitnot [
@@ -208,7 +212,7 @@ namespaces sequences words ;
     in-1
     dup cell-bits neg <= [
         drop 0 <vreg> 2 <vreg> %fixnum-sgn ,
-        T{ vreg f 2 } 0 %replace-d ,
+        T{ vreg f 2 } T{ ds-loc f 0 } %replace ,
     ] [
         neg 0 <vreg> 0 <vreg> %fixnum>> ,
         out-1
diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index 39d8da2a46..6bd2443d43 100644
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -81,10 +81,20 @@ M: #label linearize* ( node -- next )
     renamed-label swap node-child linearize-1
     r> ;
 
-: in-1 0 0 %peek-d , ;
-: in-2 0 1 %peek-d ,  1 0 %peek-d , ;
-: in-3 0 2 %peek-d ,  1 1 %peek-d ,  2 0 %peek-d , ;
-: out-1 T{ vreg f 0 } 0 %replace-d , ;
+: in-1
+    T{ vreg f 0 } T{ ds-loc f 0 } %peek , ;
+
+: in-2
+    T{ vreg f 0 } T{ ds-loc f 1 } %peek ,
+    T{ vreg f 1 } T{ ds-loc f 0 } %peek , ;
+
+: in-3
+    T{ vreg f 0 } T{ ds-loc f 2 } %peek ,
+    T{ vreg f 1 } T{ ds-loc f 1 } %peek ,
+    T{ vreg f 2 } T{ ds-loc f 0 } %peek , ;
+
+: out-1
+    T{ vreg f 0 } T{ ds-loc f 0 } %replace , ;
 
 : intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
 
diff --git a/library/compiler/stack.factor b/library/compiler/stack.factor
index 22e4ba42e8..6301a81d57 100644
--- a/library/compiler/stack.factor
+++ b/library/compiler/stack.factor
@@ -10,16 +10,8 @@ sequences vectors words ;
     #! by GC, and is indexed through a table.
     dup fixnum? swap f eq? or ;
 
-GENERIC: load-value ( vreg n value -- )
-
-M: object load-value ( vreg n value -- )
-    drop %peek-d , ;
-
-: load-literal ( vreg obj -- )
-    dup immediate? [ %immediate ] [ %indirect ] if , ;
-
-M: value load-value ( vreg n value -- )
-    nip value-literal load-literal ;
+: load-literal ( obj vreg -- )
+    over immediate? [ %immediate ] [ %indirect ] if , ;
 
 SYMBOL: vreg-allocator
 SYMBOL: live-d
@@ -31,53 +23,49 @@ SYMBOL: live-r
     rot live-r get member? not and
     or ;
 
-: stack>vreg ( value stack-pos loader -- )
-    pick >r vreg-allocator get r> set
-    pick value-dropped? [ pick get pick pick execute , ] unless
-    3drop vreg-allocator inc ; inline
+: stack>vreg ( value stack-pos -- )
+    vreg-allocator get <vreg> pick set
+    over value-dropped? [ 2drop ] [ >r get r> %peek , ] if
+    vreg-allocator inc ;
 
-: (stacks>vregs) ( stack loader -- )
-    swap reverse-slice dup length
-    [ pick stack>vreg ] 2each drop ; inline
+: stacks<>vregs ( values quot quot -- )
+    >r >r dup reverse-slice swap length r> map r> 2each ; inline
 
 : stacks>vregs ( #shuffle -- )
     dup
-    node-in-d \ %peek-d (stacks>vregs)
-    node-in-r \ %peek-r (stacks>vregs) ;
+    node-in-d [ <ds-loc> ] [ stack>vreg ] stacks<>vregs
+    node-in-r [ <cs-loc> ] [ stack>vreg ] stacks<>vregs ;
 
 : shuffle-height ( #shuffle -- )
     dup node-out-d length over node-in-d length - %inc-d ,
     dup node-out-r length swap node-in-r length - %inc-r , ;
 
-: literal>stack ( stack-pos value storer -- )
-    >r value-literal r> fixnum-imm? pick immediate? and [
-        >r 0 swap load-literal 0 <vreg> r>
-    ] unless swapd execute , ; inline
+: literal>stack ( value stack-pos -- )
+    swap value-literal fixnum-imm? over immediate? and
+    [ T{ vreg f 0 } load-literal T{ vreg f 0 } ] unless
+    swap %replace , ; inline
 
-: computed>stack >r get <vreg> swap r> execute , ;
-
-: vreg>stack ( stack-pos value storer -- )
+: vreg>stack ( value stack-pos -- )
     {
-        { [ over not ] [ 3drop ] }
+        { [ over not ] [ 2drop ] }
         { [ over value? ] [ literal>stack ] }
-        { [ t ] [ computed>stack ] }
-    } cond ; inline
-
-: (vregs>stack) ( stack storer -- )
-    swap reverse-slice [ length ] keep
-    [ pick vreg>stack ] 2each drop ; inline
+        { [ t ] [ >r get r> %replace , ] }
+    } cond ;
 
 : (vregs>stacks) ( stack stack -- )
-    \ %replace-r (vregs>stack) \ %replace-d (vregs>stack) ;
+    [ <cs-loc> ] [ vreg>stack ] stacks<>vregs
+    [ <ds-loc> ] [ vreg>stack ] stacks<>vregs ;
 
 : literals/computed ( stack -- literals computed )
     dup [ dup value? [ drop f ] unless ] map
     swap [ dup value? [ drop f ] when ] map ;
 
 : vregs>stacks ( -- )
+    #! We store literals last because storing a literal to a
+    #! stack slot actually clobbers a vreg.
     live-d get literals/computed
     live-r get literals/computed
-    swapd (vregs>stacks) (vregs>stacks) ;
+    swapd vregs>stacks vregs>stacks ;
 
 : live-stores ( instack outstack -- stack )
     #! Avoid storing a value into its former position.
diff --git a/library/compiler/vops.factor b/library/compiler/vops.factor
index aa31799bed..291f7cda0c 100644
--- a/library/compiler/vops.factor
+++ b/library/compiler/vops.factor
@@ -153,53 +153,37 @@ C: %target-label make-vop ;
 ! stack operations
 TUPLE: %peek ;
 C: %peek make-vop ;
-
+: %peek swap src/dest-vop <%peek> ;
 M: %peek basic-block? drop t ;
 
-: %peek swap <vreg> src/dest-vop <%peek> ;
-
-: %peek-d ( vreg n -- vop ) <ds-loc> %peek ;
-
-: %peek-r ( vreg n -- vop ) <cs-loc> %peek ;
-
 TUPLE: %replace ;
 C: %replace make-vop ;
-
-M: %replace basic-block? drop t ;
-
 : %replace ( vreg loc -- vop ) src/dest-vop <%replace> ;
-
-: %replace-d ( vreg n -- vop ) <ds-loc> %replace ;
-
-: %replace-r ( vreg n -- vop ) <cs-loc> %replace ;
+M: %replace basic-block? drop t ;
 
 TUPLE: %inc-d ;
 C: %inc-d make-vop ;
 : %inc-d ( n -- node ) src-vop <%inc-d> ;
-
 M: %inc-d basic-block? drop t ;
 
 TUPLE: %inc-r ;
-
 C: %inc-r make-vop ;
-
 : %inc-r ( n -- ) src-vop <%inc-r> ;
-
 M: %inc-r basic-block? drop t ;
 
 TUPLE: %immediate ;
 C: %immediate make-vop ;
 
-: %immediate ( vreg obj -- vop )
-    swap <vreg> src/dest-vop <%immediate> ;
+: %immediate ( obj vreg -- vop )
+    src/dest-vop <%immediate> ;
 
 M: %immediate basic-block? drop t ;
 
 ! indirect load of a literal through a table
 TUPLE: %indirect ;
 C: %indirect make-vop ;
-: %indirect ( vreg obj -- )
-    swap <vreg> src/dest-vop <%indirect> ;
+: %indirect ( obj vreg -- )
+    src/dest-vop <%indirect> ;
 M: %indirect basic-block? drop t ;
 
 ! object slot accessors

From 0ff2dbc4e0b69c08def273d7a93a2e10b9c0eacc Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sun, 2 Apr 2006 00:48:17 +0000
Subject: [PATCH 005/112] Cocoa fixes

---
 Makefile                | 2 ++
 library/cocoa/ui.factor | 8 +++++---
 2 files changed, 7 insertions(+), 3 deletions(-)

diff --git a/Makefile b/Makefile
index ad1f392d9e..03706e3120 100644
--- a/Makefile
+++ b/Makefile
@@ -117,6 +117,8 @@ macosx.app:
 		-o -name '*.js' \) \
 		-exec ./cp_dir {} $(BUNDLE)/Contents/Resources/{} \;
 
+	cp version.factor $(BUNDLE)/Contents/Resources/
+
 	cp $(IMAGE) $(BUNDLE)/Contents/Resources/factor.image
 
 	install_name_tool \
diff --git a/library/cocoa/ui.factor b/library/cocoa/ui.factor
index 0dc64f8d63..85360b424b 100644
--- a/library/cocoa/ui.factor
+++ b/library/cocoa/ui.factor
@@ -18,8 +18,10 @@ SYMBOL: views
 
 H{ } clone views set-global
 
-: purge-expired ( hash -- hash )
-    [ drop expired? not ] hash-subset ;
+: purge-views ( hash -- hash )
+    global [
+        views [ [ drop expired? not ] hash-subset ] change
+    ] bind ;
 
 : view ( handle -- world ) views get hash ;
 
@@ -192,7 +194,7 @@ IN: shells
     [
         [
             init-ui
-            purge-expired
+            purge-views
             launchpad-window
             listener-window
             finish-launching

From cfdefab51824333c00644b42db3f7c92cfcd12a8 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sun, 2 Apr 2006 00:50:33 +0000
Subject: [PATCH 006/112] vreg usage cleanups

---
 library/compiler/intrinsics.factor  | 150 +++++++++++-----------------
 library/compiler/linearizer.factor  |  60 ++++++++---
 library/compiler/stack.factor       |  14 +--
 library/compiler/vops.factor        |  31 +++---
 library/freetype/freetype-gl.factor |   2 +-
 5 files changed, 118 insertions(+), 139 deletions(-)

diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index 156e13f85a..fd64cd59cb 100644
--- a/library/compiler/intrinsics.factor
+++ b/library/compiler/intrinsics.factor
@@ -1,5 +1,5 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 IN: compiler-frontend
 USING: arrays assembler compiler-backend generic hashtables
 inference kernel kernel-internals lists math math-internals
@@ -32,111 +32,92 @@ namespaces sequences words ;
 \ slot [
     dup slot@ [
         -1 %inc-d ,
-        in-1
-        0 swap slot@ %fast-slot ,
+        dup in-1 >r slot@ r> %fast-slot ,
     ] [
-        drop
-        in-2
+        in-2 swap
         -1 %inc-d ,
-        0 %untag ,
-        1 0 %slot ,
-    ] if  out-1
+        dup %untag ,
+        %slot ,
+    ] if  T{ vreg f 0 } out-1
 ] "intrinsic" set-word-prop
 
 \ set-slot [
     dup slot@ [
         -1 %inc-d ,
-        in-2
+        dup in-2
         -2 %inc-d ,
-        slot@ >r 0 1 r> %fast-set-slot ,
+        rot slot@ %fast-set-slot ,
     ] [
-        drop
         in-3
         -3 %inc-d ,
-        1 %untag ,
-        0 1 2 %set-slot ,
+        over %untag ,
+        %set-slot ,
     ] if
-    1 %write-barrier ,
+    T{ vreg f 1 } %write-barrier ,
 ] "intrinsic" set-word-prop
 
 \ char-slot [
-    drop
     in-2
     -1 %inc-d ,
-    0 1 %char-slot ,
-    T{ vreg f 1 } T{ ds-loc f 0 } %replace ,
+    [ %char-slot , ] keep
+    out-1
 ] "intrinsic" set-word-prop
 
 \ set-char-slot [
-    drop
     in-3
     -3 %inc-d ,
-    0 2 1 %set-char-slot ,
+    swap %set-char-slot ,
 ] "intrinsic" set-word-prop
 
 \ type [
-    drop
-    in-1
-    0 %type ,
-    out-1
+    in-1 [ %type , ] keep out-1
 ] "intrinsic" set-word-prop
 
 \ tag [
-    drop
-    in-1
-    0 %tag ,
-    out-1
+    in-1 [ %tag , ] keep out-1
 ] "intrinsic" set-word-prop
 
 \ getenv [
-    -1 %inc-d ,
-    node-peek value-literal 0 <vreg> swap %getenv ,
-    1 %inc-d ,
-    out-1
+    T{ vreg f 0 } [
+        -1 %inc-d ,
+        swap node-peek value-literal %getenv ,
+        1 %inc-d ,
+    ] keep out-1
 ] "intrinsic" set-word-prop
 
-\ setenv [
-    -1 %inc-d ,
-    in-1
-    node-peek value-literal 0 <vreg> swap %setenv ,
-    -1 %inc-d ,
-] "intrinsic" set-word-prop
-
-GENERIC: load-value ( vreg loc value -- )
-
-M: object load-value ( vreg loc value -- )
-    drop %peek , ;
-
-M: value load-value ( vreg loc value -- )
-    nip value-literal swap load-literal ;
-
-: binary-inputs ( node -- in1 in2 )
-    node-in-d
-    T{ vreg f 0 } T{ ds-loc f 1 } pick first load-value
-    T{ vreg f 1 } T{ ds-loc f 0 } rot second load-value
-    T{ vreg f 1 } T{ vreg f 0 } ;
-
-: binary-op-reg ( node op -- )
-    >r binary-inputs dup -1 %inc-d , r> execute , out-1 ; inline
-
 : binary-imm ( node -- in1 in2 )
-    -1 %inc-d ,
-    T{ vreg f 0 } T{ ds-loc f 1 } pick node-peek load-value
-    node-peek value-literal T{ vreg f 0 } ;
+    node-in-d { T{ vreg f 0 } f } intrinsic-inputs first2 swap
+    -2 %inc-d , ;
 
-: binary-op-imm ( node op -- )
-    >r binary-imm dup r> execute , out-1 ; inline
+\ setenv [
+    binary-imm
+    %setenv ,
+] "intrinsic" set-word-prop
+
+: binary-reg ( node -- in1 in2 )
+    node-in-d { T{ vreg f 0 } T{ vreg f 1 } } intrinsic-inputs
+    first2 swap -2 %inc-d , ;
 
 : literal-immediate? ( value -- ? )
     dup value? [ value-literal immediate? ] [ drop f ] if ;
 
-: binary-op-imm? ( node -- ? )
-    fixnum-imm? >r node-peek literal-immediate? r> and ;
+: (binary-op) ( node -- in1 in2 )
+    fixnum-imm? [
+        dup node-peek literal-immediate?
+        [ binary-imm ] [ binary-reg ] if
+    ] [
+        binary-reg
+    ] if ;
 
 : binary-op ( node op -- )
-    #! out is a vreg where the vop stores the result.
-    over binary-op-imm?
-    [ binary-op-imm ] [ binary-op-reg ] if ;
+    >r (binary-op) dup r> execute ,
+    1 %inc-d ,
+    T{ vreg f 0 } out-1 ; inline
+
+: binary-op-reg ( node op -- )
+    >r binary-reg dup r> execute ,
+    1 %inc-d ,
+    T{ vreg f 0 } out-1 ; inline
 
 {
     { fixnum+       %fixnum+       }
@@ -148,15 +129,8 @@ M: value load-value ( vreg loc value -- )
     first2 [ binary-op ] curry "intrinsic" set-word-prop
 ] each
 
-: binary-jump-reg ( node label op -- )
-    >r >r binary-inputs -2 %inc-d , r> r> execute , ; inline
-
-: binary-jump-imm ( node label op -- )
-    >r >r binary-imm -1 %inc-d , r> r> execute , ; inline
-
 : binary-jump ( node label op -- )
-    pick binary-op-imm?
-    [ binary-jump-imm ] [ binary-jump-reg ] if ;
+    >r >r (binary-op) r> r> execute , ; inline
 
 {
     { fixnum<= %jump-fixnum<= }
@@ -176,29 +150,21 @@ M: value load-value ( vreg loc value -- )
     ! This is not clever. Because of x86, %fixnum-mod is
     ! hard-coded to put its output in vreg 2, which happends to
     ! be EDX there.
-    drop
-    in-2
+    in-2 swap
     -1 %inc-d ,
-    1 <vreg> 0 <vreg> 2 <vreg> %fixnum-mod ,
-    T{ vreg f 2 } T{ ds-loc f 0 } %replace ,
+    [ dup %fixnum-mod , ] keep out-1
 ] "intrinsic" set-word-prop
 
 \ fixnum/mod [
     ! See the remark on fixnum-mod for vreg usage
-    drop
-    in-2
-    { T{ vreg f 1 } T{ vreg f 0 } }
+    in-2 swap 2array
     { T{ vreg f 2 } T{ vreg f 0 } }
     %fixnum/mod ,
-    T{ vreg f 2 } T{ ds-loc f 0 } %replace ,
-    T{ vreg f 0 } T{ ds-loc f 1 } %replace ,
+    { T{ vreg f 0 } T{ vreg f 2 } } out-n
 ] "intrinsic" set-word-prop
 
 \ fixnum-bitnot [
-    drop
-    in-1
-    0 <vreg> 0 <vreg> %fixnum-bitnot ,
-    out-1
+    in-1 [ dup %fixnum-bitnot , ] keep out-1
 ] "intrinsic" set-word-prop
 
 \ fixnum* [
@@ -209,13 +175,13 @@ M: value load-value ( vreg loc value -- )
 
 : negative-shift ( n -- )
     -1 %inc-d ,
-    in-1
+    { f } { T{ vreg f 0 } } intrinsic-inputs drop
     dup cell-bits neg <= [
-        drop 0 <vreg> 2 <vreg> %fixnum-sgn ,
-        T{ vreg f 2 } T{ ds-loc f 0 } %replace ,
+        drop T{ vreg f 0 } T{ vreg f 2 } %fixnum-sgn ,
+        T{ vreg f 2 } out-1
     ] [
-        neg 0 <vreg> 0 <vreg> %fixnum>> ,
-        out-1
+        neg T{ vreg f 0 } T{ vreg f 0 } %fixnum>> ,
+        T{ vreg f 0 } out-1
     ] if ;
 
 : fast-shift ( n -- )
diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index 6bd2443d43..620b31068e 100644
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -81,20 +81,45 @@ M: #label linearize* ( node -- next )
     renamed-label swap node-child linearize-1
     r> ;
 
-: in-1
-    T{ vreg f 0 } T{ ds-loc f 0 } %peek , ;
+: immediate? ( obj -- ? )
+    #! fixnums and f have a pointerless representation, and
+    #! are compiled immediately. Everything else can be moved
+    #! by GC, and is indexed through a table.
+    dup fixnum? swap f eq? or ;
 
-: in-2
-    T{ vreg f 0 } T{ ds-loc f 1 } %peek ,
-    T{ vreg f 1 } T{ ds-loc f 0 } %peek , ;
+: load-literal ( obj vreg -- )
+    over immediate? [ %immediate ] [ %indirect ] if , ;
 
-: in-3
-    T{ vreg f 0 } T{ ds-loc f 2 } %peek ,
-    T{ vreg f 1 } T{ ds-loc f 1 } %peek ,
-    T{ vreg f 2 } T{ ds-loc f 0 } %peek , ;
+GENERIC: load-value ( vreg loc value -- operand )
 
-: out-1
-    T{ vreg f 0 } T{ ds-loc f 0 } %replace , ;
+M: object load-value ( vreg loc value -- operand )
+    drop dupd %peek , ;
+
+M: value load-value ( vreg loc value -- operand )
+    nip value-literal swap [ [ load-literal ] keep ] when* ;
+
+: intrinsic-inputs ( seq template -- inputs )
+    dup length reverse-slice [ <ds-loc> ] map rot 3array flip
+    [ first3 load-value ] map ;
+
+: in-1 ( node -- operand )
+    node-in-d { T{ vreg f 0 } } intrinsic-inputs first ;
+
+: in-2 ( node -- operand operand )
+    node-in-d { T{ vreg f 0 } T{ vreg f 1 } }
+    intrinsic-inputs first2 ;
+
+: in-3 ( node -- operand operand operand )
+    node-in-d { T{ vreg f 0 } T{ vreg f 1 } T{ vreg f 2 } }
+    intrinsic-inputs first3 ;
+
+: stacks<>vregs ( values quot quot -- )
+    >r >r dup reverse-slice swap length r> map r> 2each ; inline
+
+: out-n ( vregs -- )
+    [ <ds-loc> ] [ %replace , ] stacks<>vregs ;
+
+: out-1 ( vreg -- ) 1array out-n ;
 
 : intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
 
@@ -128,14 +153,17 @@ M: #if linearize* ( node -- next )
         -1 %inc-d ,
         swap node-children nth linearize-child iterate-next
     ] [
-        in-1 -1 %inc-d , <label> dup 0 %jump-t , linearize-if
+        dup in-1 -1 %inc-d , >r <label> dup r> %jump-t ,
+        linearize-if
     ] if* ;
 
-: dispatch-head ( vtable -- label/node )
+: dispatch-head ( node -- label/node )
     #! Output the jump table insn and return a list of
     #! label/branch pairs.
-    in-1 -1 %inc-d , 0 %dispatch ,
-    [ <label> dup %target-label ,  2array ] map ;
+    dup in-1
+    -1 %inc-d ,
+    %dispatch ,
+    node-children [ <label> dup %target-label ,  2array ] map ;
 
 : dispatch-body ( label/node -- )
     <label> swap [
@@ -145,6 +173,6 @@ M: #if linearize* ( node -- next )
 M: #dispatch linearize* ( node -- next )
     #! The parameter is a list of nodes, each one is a branch to
     #! take in case the top of stack has that type.
-    node-children dispatch-head dispatch-body iterate-next ;
+    dispatch-head dispatch-body iterate-next ;
 
 M: #return linearize* drop %return , f ;
diff --git a/library/compiler/stack.factor b/library/compiler/stack.factor
index 6301a81d57..0d69a760d3 100644
--- a/library/compiler/stack.factor
+++ b/library/compiler/stack.factor
@@ -4,15 +4,6 @@ IN: compiler-frontend
 USING: compiler-backend generic inference kernel math namespaces
 sequences vectors words ;
 
-: immediate? ( obj -- ? )
-    #! fixnums and f have a pointerless representation, and
-    #! are compiled immediately. Everything else can be moved
-    #! by GC, and is indexed through a table.
-    dup fixnum? swap f eq? or ;
-
-: load-literal ( obj vreg -- )
-    over immediate? [ %immediate ] [ %indirect ] if , ;
-
 SYMBOL: vreg-allocator
 SYMBOL: live-d
 SYMBOL: live-r
@@ -28,9 +19,6 @@ SYMBOL: live-r
     over value-dropped? [ 2drop ] [ >r get r> %peek , ] if
     vreg-allocator inc ;
 
-: stacks<>vregs ( values quot quot -- )
-    >r >r dup reverse-slice swap length r> map r> 2each ; inline
-
 : stacks>vregs ( #shuffle -- )
     dup
     node-in-d [ <ds-loc> ] [ stack>vreg ] stacks<>vregs
@@ -65,7 +53,7 @@ SYMBOL: live-r
     #! stack slot actually clobbers a vreg.
     live-d get literals/computed
     live-r get literals/computed
-    swapd vregs>stacks vregs>stacks ;
+    swapd (vregs>stacks) (vregs>stacks) ;
 
 : live-stores ( instack outstack -- stack )
     #! Avoid storing a value into its former position.
diff --git a/library/compiler/vops.factor b/library/compiler/vops.factor
index 291f7cda0c..22efffcaac 100644
--- a/library/compiler/vops.factor
+++ b/library/compiler/vops.factor
@@ -1,5 +1,5 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! Copyright (C) 2004, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 IN: compiler-backend
 USING: arrays errors generic hashtables kernel kernel-internals
 lists math memory namespaces parser sequences words ;
@@ -139,12 +139,12 @@ C: %call make-vop ;
 
 TUPLE: %jump-t ;
 C: %jump-t make-vop ;
-: %jump-t <vreg> label/src-vop <%jump-t> ;
+: %jump-t label/src-vop <%jump-t> ;
 
 ! dispatch tables
 TUPLE: %dispatch ;
 C: %dispatch make-vop ;
-: %dispatch <vreg> src-vop <%dispatch> ;
+: %dispatch src-vop <%dispatch> ;
 
 TUPLE: %target-label ;
 C: %target-label make-vop ;
@@ -189,18 +189,16 @@ M: %indirect basic-block? drop t ;
 ! object slot accessors
 TUPLE: %untag ;
 C: %untag make-vop ;
-: %untag <vreg> dest-vop <%untag> ;
+: %untag dest-vop <%untag> ;
 M: %untag basic-block? drop t ;
 
-: slot-vop [ <vreg> ] 2apply 2-vop ;
-
 TUPLE: %slot ;
 C: %slot make-vop ;
-: %slot ( n vreg ) slot-vop <%slot> ;
+: %slot ( n vreg ) 2-vop <%slot> ;
 M: %slot basic-block? drop t ;
 
 : set-slot-vop
-    rot <vreg> rot <vreg> rot <vreg> dup >r 3array r> 1array f ;
+    [ 3array ] keep 1array f ;
 
 TUPLE: %set-slot ;
 C: %set-slot make-vop ;
@@ -215,22 +213,21 @@ M: %set-slot basic-block? drop t ;
 ! known at compile time, so these become a single instruction
 TUPLE: %fast-slot ;
 C: %fast-slot make-vop ;
-: %fast-slot ( vreg n )
-    swap <vreg> 2-vop <%fast-slot> ;
+: %fast-slot ( n vreg )
+    2-vop <%fast-slot> ;
 M: %fast-slot basic-block? drop t ;
 
 TUPLE: %fast-set-slot ;
 C: %fast-set-slot make-vop ;
 : %fast-set-slot ( value obj n )
     #! %fast-set-slot writes to vreg obj.
-    >r >r <vreg> r> <vreg> r> over >r 3array r> 1array f
-    <%fast-set-slot> ;
+    over >r 3array r> 1array f <%fast-set-slot> ;
 M: %fast-set-slot basic-block? drop t ;
 
 ! Char readers and writers
 TUPLE: %char-slot ;
 C: %char-slot make-vop ;
-: %char-slot ( n vreg ) slot-vop <%char-slot> ;
+: %char-slot ( n vreg ) 2-vop <%char-slot> ;
 M: %char-slot basic-block? drop t ;
 
 TUPLE: %set-char-slot ;
@@ -244,7 +241,7 @@ M: %set-char-slot basic-block? drop t ;
 
 TUPLE: %write-barrier ;
 C: %write-barrier make-vop ;
-: %write-barrier ( ptr ) <vreg> dest-vop <%write-barrier> ;
+: %write-barrier ( ptr ) dest-vop <%write-barrier> ;
 
 ! fixnum intrinsics
 TUPLE: %fixnum+ ;
@@ -318,11 +315,11 @@ C: %jump-eq? make-vop ;
 ! some slightly optimized inline assembly
 TUPLE: %type ;
 C: %type make-vop ;
-: %type ( vreg ) <vreg> dest-vop <%type> ;
+: %type ( vreg ) dest-vop <%type> ;
 
 TUPLE: %tag ;
 C: %tag make-vop ;
-: %tag ( vreg ) <vreg> dest-vop <%tag> ;
+: %tag ( vreg ) dest-vop <%tag> ;
 M: %tag basic-block? drop t ;
 
 TUPLE: %getenv ;
diff --git a/library/freetype/freetype-gl.factor b/library/freetype/freetype-gl.factor
index 8c593cd6e5..a229f829ff 100644
--- a/library/freetype/freetype-gl.factor
+++ b/library/freetype/freetype-gl.factor
@@ -168,7 +168,7 @@ C: font ( handle -- font )
     #! glyph.
     [ dupd <char-sprite> ] cache-nth nip ;
 
-: draw-string ( open-font sprites string -- )
+: (draw-string) ( open-font sprites string -- )
     GL_TEXTURE_2D [
         GL_MODELVIEW [
             [

From 717cba001ca7717f5622abfe51def9f66e868f1e Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sun, 2 Apr 2006 00:51:48 +0000
Subject: [PATCH 007/112] UI tweaks

---
 library/ui/labels.factor | 3 +--
 library/ui/world.factor  | 3 +++
 2 files changed, 4 insertions(+), 2 deletions(-)

diff --git a/library/ui/labels.factor b/library/ui/labels.factor
index 366eed992a..5aeac166a2 100644
--- a/library/ui/labels.factor
+++ b/library/ui/labels.factor
@@ -27,7 +27,6 @@ M: label pref-dim* ( label -- dim ) label-size ;
 
 : draw-label ( label -- )
     dup label-color gl-color
-    dup label-font* dup world get font-sprites rot
-    label-text draw-string ;
+    dup label-font* swap label-text draw-string ;
 
 M: label draw-gadget* ( label -- ) draw-label ;
diff --git a/library/ui/world.factor b/library/ui/world.factor
index 62d4e45f80..3e0f3edcac 100644
--- a/library/ui/world.factor
+++ b/library/ui/world.factor
@@ -45,3 +45,6 @@ M: world pref-dim* ( world -- dim )
 
 : focused-ancestors ( world -- seq )
     world-focus parents reverse-slice ;
+
+: draw-string ( open-fonts string -- )
+    >r dup world get font-sprites r> (draw-string) ;

From ded9d3d11bba079bf7334acb0b5bf899480d6b92 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sun, 2 Apr 2006 04:42:14 +0000
Subject: [PATCH 008/112] Bootstrap images stored under resource path now

---
 library/bootstrap/boot-stage2.factor | 2 +-
 library/bootstrap/image.factor       | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor
index 1cd2362d80..df2814acba 100644
--- a/library/bootstrap/boot-stage2.factor
+++ b/library/bootstrap/boot-stage2.factor
@@ -78,5 +78,5 @@ number>string write " ms" print
 "Bootstrapping is complete." print
 "Now, you can run ./f factor.image" print flush
 
-"factor.image" save-image
+"factor.image" resource-path save-image
 0 exit
diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor
index 06387cf3fc..dabb7de804 100644
--- a/library/bootstrap/image.factor
+++ b/library/bootstrap/image.factor
@@ -337,7 +337,7 @@ M: hashtable ' ( hashtable -- pointer )
     ] if ;
 
 : image-name
-    "boot.image." architecture get append ;
+    "boot.image." architecture get append resource-path ;
 
 : write-image ( image -- )
     "Writing image to " write dup write "..." print flush

From 839080c225c01186d16d71440769fbe5457aa223 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sun, 2 Apr 2006 04:42:36 +0000
Subject: [PATCH 009/112] Further compiler refactoring, implemented "templates"

---
 library/compiler/intrinsics.factor | 158 ++++++++++++++---------------
 library/compiler/linearizer.factor |  38 +++----
 2 files changed, 95 insertions(+), 101 deletions(-)

diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index fd64cd59cb..4b33371349 100644
--- a/library/compiler/intrinsics.factor
+++ b/library/compiler/intrinsics.factor
@@ -5,8 +5,6 @@ USING: arrays assembler compiler-backend generic hashtables
 inference kernel kernel-internals lists math math-internals
 namespaces sequences words ;
 
-: node-peek ( node -- value ) node-in-d peek ;
-
 : type-tag ( type -- tag )
     #! Given a type number, return the tag number.
     dup 6 > [ drop 3 ] when ;
@@ -31,93 +29,82 @@ namespaces sequences words ;
 
 \ slot [
     dup slot@ [
-        -1 %inc-d ,
-        dup in-1 >r slot@ r> %fast-slot ,
+        { { 0 "obj" } { f "slot" } } { "obj" } [
+            node get slot@ "obj" get %fast-slot ,
+        ] with-template
     ] [
-        in-2 swap
-        -1 %inc-d ,
-        dup %untag ,
-        %slot ,
-    ] if  T{ vreg f 0 } out-1
+        { { 0 "obj" } { 1 "n" } } { "obj" } [
+            "obj" get %untag ,
+            "n" get "obj" get %slot ,
+        ] with-template
+    ] if
 ] "intrinsic" set-word-prop
 
 \ set-slot [
     dup slot@ [
-        -1 %inc-d ,
-        dup in-2
-        -2 %inc-d ,
-        rot slot@ %fast-set-slot ,
+        { { 0 "val" } { 1 "obj" } { f "slot" } } { } [
+            "val" get "obj" get node get slot@ %fast-set-slot ,
+        ] with-template
     ] [
-        in-3
-        -3 %inc-d ,
-        over %untag ,
-        %set-slot ,
+        { { 0 "val" } { 1 "obj" } { 2 "slot" } } { } [
+            "obj" get %untag ,
+            "val" get "obj" get "slot" get %set-slot ,
+        ] with-template
     ] if
     T{ vreg f 1 } %write-barrier ,
 ] "intrinsic" set-word-prop
 
 \ char-slot [
-    in-2
-    -1 %inc-d ,
-    [ %char-slot , ] keep
-    out-1
+    { { 0 "n" } { 1 "str" } } { "str" } [
+        "n" get "str" get %char-slot ,
+    ] with-template
 ] "intrinsic" set-word-prop
 
 \ set-char-slot [
-    in-3
-    -3 %inc-d ,
-    swap %set-char-slot ,
+    { { 0 "ch" } { 1 "n" } { 2 "str" } } { } [
+        "ch" get "str" get "n" get %set-char-slot ,
+    ] with-template
 ] "intrinsic" set-word-prop
 
 \ type [
-    in-1 [ %type , ] keep out-1
+    { { 0 "in" } } { "in" } [ "in" get %type , ] with-template
 ] "intrinsic" set-word-prop
 
 \ tag [
-    in-1 [ %tag , ] keep out-1
+    { { 0 "in" } } { "in" } [ "in" get %tag , ] with-template
 ] "intrinsic" set-word-prop
 
 \ getenv [
-    T{ vreg f 0 } [
-        -1 %inc-d ,
-        swap node-peek value-literal %getenv ,
-        1 %inc-d ,
-    ] keep out-1
+    { { f "env" } } { "out" } [
+        T{ vreg f 0 } "out" set
+        "out" get "env" get %getenv ,
+    ] with-template
 ] "intrinsic" set-word-prop
 
-: binary-imm ( node -- in1 in2 )
-    node-in-d { T{ vreg f 0 } f } intrinsic-inputs first2 swap
-    -2 %inc-d , ;
-
 \ setenv [
-    binary-imm
-    %setenv ,
+    { { 0 "value" } { f "env" } } { } [
+        "env" get "value" get %setenv ,
+    ] with-template
 ] "intrinsic" set-word-prop
 
-: binary-reg ( node -- in1 in2 )
-    node-in-d { T{ vreg f 0 } T{ vreg f 1 } } intrinsic-inputs
-    first2 swap -2 %inc-d , ;
+: literal-immediate? ( node -- ? )
+    node-in-d peek dup value?
+    [ value-literal immediate? ] [ drop f ] if ;
 
-: literal-immediate? ( value -- ? )
-    dup value? [ value-literal immediate? ] [ drop f ] if ;
+: binary-in ( node -- in )
+    literal-immediate? fixnum-imm? and
+    { { 0 "x" } { f "y" } } { { 0 "x" } { 1 "y" } } ? ;
 
-: (binary-op) ( node -- in1 in2 )
-    fixnum-imm? [
-        dup node-peek literal-immediate?
-        [ binary-imm ] [ binary-reg ] if
-    ] [
-        binary-reg
-    ] if ;
+: (binary-op) ( node in -- )
+    { "x" } [
+        >r "y" get "x" get dup r> execute ,
+    ] with-template ; inline
 
 : binary-op ( node op -- )
-    >r (binary-op) dup r> execute ,
-    1 %inc-d ,
-    T{ vreg f 0 } out-1 ; inline
+    swap dup binary-in (binary-op) ; inline
 
 : binary-op-reg ( node op -- )
-    >r binary-reg dup r> execute ,
-    1 %inc-d ,
-    T{ vreg f 0 } out-1 ; inline
+    swap { { 0 "x" } { 1 "y" } } (binary-op) ; inline
 
 {
     { fixnum+       %fixnum+       }
@@ -130,7 +117,9 @@ namespaces sequences words ;
 ] each
 
 : binary-jump ( node label op -- )
-    >r >r (binary-op) r> r> execute , ; inline
+    rot dup binary-in { } [
+        >r >r "y" get "x" get r> r> execute ,
+    ] with-template ; inline
 
 {
     { fixnum<= %jump-fixnum<= }
@@ -150,21 +139,26 @@ namespaces sequences words ;
     ! This is not clever. Because of x86, %fixnum-mod is
     ! hard-coded to put its output in vreg 2, which happends to
     ! be EDX there.
-    in-2 swap
-    -1 %inc-d ,
-    [ dup %fixnum-mod , ] keep out-1
+    { { 0 "x" } { 1 "y" } } { "out" } [
+        T{ vreg f 2 } "out" set
+        "y" get "x" get "out" get %fixnum-mod ,
+    ] with-template
 ] "intrinsic" set-word-prop
 
 \ fixnum/mod [
     ! See the remark on fixnum-mod for vreg usage
-    in-2 swap 2array
-    { T{ vreg f 2 } T{ vreg f 0 } }
-    %fixnum/mod ,
-    { T{ vreg f 0 } T{ vreg f 2 } } out-n
+    { { 0 "x" } { 1 "y" } } { "quo" "rem" } [
+        T{ vreg f 0 } "quo" set
+        T{ vreg f 2 } "rem" set
+        "y" get "x" get 2array
+        "rem" get "quo" get 2array %fixnum/mod ,
+    ] with-template
 ] "intrinsic" set-word-prop
 
 \ fixnum-bitnot [
-    in-1 [ dup %fixnum-bitnot , ] keep out-1
+    { { 0 "x" } } { "x" } [
+        "x" get dup %fixnum-bitnot ,
+    ] with-template
 ] "intrinsic" set-word-prop
 
 \ fixnum* [
@@ -173,32 +167,32 @@ namespaces sequences words ;
 
 : slow-shift ( -- ) \ fixnum-shift %call , ;
 
-: negative-shift ( n -- )
-    -1 %inc-d ,
-    { f } { T{ vreg f 0 } } intrinsic-inputs drop
-    dup cell-bits neg <= [
-        drop T{ vreg f 0 } T{ vreg f 2 } %fixnum-sgn ,
-        T{ vreg f 2 } out-1
-    ] [
-        neg T{ vreg f 0 } T{ vreg f 0 } %fixnum>> ,
-        T{ vreg f 0 } out-1
-    ] if ;
+: negative-shift ( n node -- )
+    { { 0 "x" } { f "n" } } { "out" } [
+        dup cell-bits neg <= [
+            drop
+            T{ vreg f 2 } "out" set
+            "x" get "out" get %fixnum-sgn ,
+        ] [
+            "x" get "out" set
+            neg "x" get "out" get %fixnum>> ,
+        ] if
+    ] with-template ;
 
-: fast-shift ( n -- )
-    dup zero? [
-        -1 %inc-d ,
-        drop
+: fast-shift ( n node -- )
+    over zero? [
+        -1 %inc-d , 2drop
     ] [
-        dup 0 < [
+        over 0 < [
             negative-shift
         ] [
-            drop slow-shift
+            2drop slow-shift
         ] if
     ] if ;
 
 \ fixnum-shift [
-    node-peek dup value? [
-        value-literal fast-shift
+    dup literal-immediate? [
+        [ node-in-d peek value-literal ] keep fast-shift
     ] [
         drop slow-shift
     ] if
diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index 620b31068e..c97ff52e4d 100644
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -98,28 +98,29 @@ M: object load-value ( vreg loc value -- operand )
 M: value load-value ( vreg loc value -- operand )
     nip value-literal swap [ [ load-literal ] keep ] when* ;
 
-: intrinsic-inputs ( seq template -- inputs )
+: (template-inputs) ( seq template -- inputs )
     dup length reverse-slice [ <ds-loc> ] map rot 3array flip
     [ first3 load-value ] map ;
 
-: in-1 ( node -- operand )
-    node-in-d { T{ vreg f 0 } } intrinsic-inputs first ;
-
-: in-2 ( node -- operand operand )
-    node-in-d { T{ vreg f 0 } T{ vreg f 1 } }
-    intrinsic-inputs first2 ;
-
-: in-3 ( node -- operand operand operand )
-    node-in-d { T{ vreg f 0 } T{ vreg f 1 } T{ vreg f 2 } }
-    intrinsic-inputs first3 ;
+: template-inputs ( node template -- )
+    flip first2 >r [ dup [ <vreg> ] when ] map
+    >r node-in-d r> (template-inputs)
+    r> [ set ] 2each ;
 
 : stacks<>vregs ( values quot quot -- )
     >r >r dup reverse-slice swap length r> map r> 2each ; inline
 
-: out-n ( vregs -- )
-    [ <ds-loc> ] [ %replace , ] stacks<>vregs ;
+: template-outputs ( template -- )
+    [ get ] map [ <ds-loc> ] [ %replace , ] stacks<>vregs ;
 
-: out-1 ( vreg -- ) 1array out-n ;
+: with-template ( node in out quot -- )
+    [
+        >r
+        pick pick template-inputs
+        dup rot [ length ] 2apply - %inc-d ,
+        swap node set
+        r> swap slip template-outputs
+    ] with-scope ; inline
 
 : intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
 
@@ -153,16 +154,15 @@ M: #if linearize* ( node -- next )
         -1 %inc-d ,
         swap node-children nth linearize-child iterate-next
     ] [
-        dup in-1 -1 %inc-d , >r <label> dup r> %jump-t ,
-        linearize-if
+        dup { { 0 "flag" } } { } [
+            <label> dup "flag" get %jump-t ,
+        ] with-template linearize-if
     ] if* ;
 
 : dispatch-head ( node -- label/node )
     #! Output the jump table insn and return a list of
     #! label/branch pairs.
-    dup in-1
-    -1 %inc-d ,
-    %dispatch ,
+    dup { { 0 "n" } } { } [ "n" get %dispatch , ] with-template
     node-children [ <label> dup %target-label ,  2array ] map ;
 
 : dispatch-body ( label/node -- )

From a26c93ff4565451dc07e640cd0b0de8d749f494d Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Mon, 3 Apr 2006 05:33:52 +0000
Subject: [PATCH 010/112] Cleanup compiler and some minor library code

---
 doc/handbook/collections.facts          |   1 -
 library/alien/alien-invoke.factor       |   3 +-
 library/bootstrap/boot-stage1.factor    |   2 +-
 library/bootstrap/boot-stage2.factor    |   4 +-
 library/collections/hashtables.factor   |   3 -
 library/collections/hashtables.facts    |   5 --
 library/collections/slicing.factor      |   3 +-
 library/compiler/intrinsics.factor      |   4 +-
 library/compiler/linearizer.factor      |  87 +++++++++-----------
 library/compiler/stack.factor           |  68 ----------------
 library/compiler/templates.factor       | 103 ++++++++++++++++++++++++
 library/compiler/vops.factor            |   2 +-
 library/help/crossref.factor            |   1 -
 library/io/null-stream.factor           |   2 +-
 library/test/compiler/intrinsics.factor |   3 +
 library/test/io/io.factor               |   2 +
 library/test/test.factor                |   8 +-
 library/words.factor                    |   5 +-
 18 files changed, 164 insertions(+), 142 deletions(-)
 delete mode 100644 library/compiler/stack.factor
 create mode 100644 library/compiler/templates.factor

diff --git a/doc/handbook/collections.facts b/doc/handbook/collections.facts
index b16c7b504e..bb35ca060a 100644
--- a/doc/handbook/collections.facts
+++ b/doc/handbook/collections.facts
@@ -52,7 +52,6 @@ ARTICLE: "hashtables-lookup" "Looking up keys in hashtables"
 
 ARTICLE: "hashtables-mutation" "Storing keys in hashtables"
 { $subsection set-hash }
-{ $subsection ?set-hash }
 { $subsection remove-hash }
 { $subsection clear-hash } ;
 
diff --git a/library/alien/alien-invoke.factor b/library/alien/alien-invoke.factor
index 64500b44fa..98bd4067a0 100644
--- a/library/alien/alien-invoke.factor
+++ b/library/alien/alien-invoke.factor
@@ -74,7 +74,8 @@ M: alien-invoke stack-reserve*
     alien-invoke-parameters stack-space ;
 
 : parse-arglist ( return seq -- types stack-effect )
-    unpair rot dup "void" = [ drop { } ] [ 1array ] if 2array
+    2 swap group unpair
+    rot dup "void" = [ drop { } ] [ 1array ] if 2array
     effect>string ;
 
 : (define-c-word) ( type lib func types stack-effect -- )
diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor
index 4446b4029d..0fd7a1e16e 100644
--- a/library/bootstrap/boot-stage1.factor
+++ b/library/bootstrap/boot-stage1.factor
@@ -127,9 +127,9 @@ vectors words ;
 
         "/library/compiler/assembler.factor"
         "/library/compiler/vops.factor"
+        "/library/compiler/templates.factor"
         "/library/compiler/linearizer.factor"
         "/library/compiler/xt.factor"
-        "/library/compiler/stack.factor"
         "/library/compiler/intrinsics.factor"
         "/library/compiler/generator.factor"
         "/library/compiler/basic-blocks.factor"
diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor
index df2814acba..0bc45c89da 100644
--- a/library/bootstrap/boot-stage2.factor
+++ b/library/bootstrap/boot-stage2.factor
@@ -5,8 +5,8 @@ kernel-internals lists math memory namespaces optimizer parser
 sequences sequences-internals words ;
 
 "Cross-referencing..." print
-xref-words
-xref-articles
+H{ } clone crossref set-global xref-words
+H{ } clone help-graph set-global xref-articles
 
 "compile" get [
     "native-io" get [
diff --git a/library/collections/hashtables.factor b/library/collections/hashtables.factor
index 85519d0d30..bd3e027fe7 100644
--- a/library/collections/hashtables.factor
+++ b/library/collections/hashtables.factor
@@ -235,9 +235,6 @@ M: hashtable hashcode ( hash -- n )
 : ?hash* ( key hash/f -- value/f )
     dup [ hash* ] [ 2drop f f ] if ; flushable
 
-: ?set-hash ( value key hash/f -- hash )
-    [ [ set-hash ] keep ] [ associate ] if ;
-
 : hash-stack ( key seq -- value )
     [ dupd hash-member? ] find-last nip ?hash ; flushable
 
diff --git a/library/collections/hashtables.facts b/library/collections/hashtables.facts
index c27f9b1bce..d39ed9c04a 100644
--- a/library/collections/hashtables.facts
+++ b/library/collections/hashtables.facts
@@ -146,11 +146,6 @@ HELP: set-hash "( value key hash -- )"
 { $description "Stores an entry into the hashtable." }
 { $see-also hash remove-hash } ;
 
-HELP: ?set-hash "( value key hash/f -- hash )"
-{ $values { "value" "a value" } { "key" "a key" } { "hash/f" "a hashtable or " { $link f } } }
-{ $description "If the mapping is " { $link f } ", constructs a new hashtable storing the given key/value pair. Otherwise, stores the key/value pair into the hashtable." }
-{ $see-also hash remove-hash } ;
-
 HELP: hash-keys "( hash -- keys )"
 { $values { "hash" "a hashtable" } { "keys" "an array of keys" } }
 { $description "Outputs an array of all keys in the hashtable." }
diff --git a/library/collections/slicing.factor b/library/collections/slicing.factor
index 7099e80d7e..3784cab3c6 100644
--- a/library/collections/slicing.factor
+++ b/library/collections/slicing.factor
@@ -104,8 +104,7 @@ strings vectors ;
     tuck swap tail-slice >r swap tail-slice r> ;
 
 : unpair ( seq -- firsts seconds )
-    2 swap group flip
-    dup empty? [ drop { } { } ] [ first2 ] if ;
+    flip dup empty? [ drop { } { } ] [ first2 ] if ;
 
 : concat ( seq -- seq )
     dup empty? [ [ [ % ] each ] over first make ] unless ;
diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index 4b33371349..50fec8c080 100644
--- a/library/compiler/intrinsics.factor
+++ b/library/compiler/intrinsics.factor
@@ -77,13 +77,13 @@ namespaces sequences words ;
 \ getenv [
     { { f "env" } } { "out" } [
         T{ vreg f 0 } "out" set
-        "out" get "env" get %getenv ,
+        "env" get "out" get %getenv ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ setenv [
     { { 0 "value" } { f "env" } } { } [
-        "env" get "value" get %setenv ,
+        "value" get "env" get %setenv ,
     ] with-template
 ] "intrinsic" set-word-prop
 
diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index c97ff52e4d..7a7c98e9ef 100644
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -58,11 +58,7 @@ SYMBOL: renamed-labels
 M: node linearize* ( node -- next ) drop iterate-next ;
 
 : linearize-call ( label -- next )
-    tail-call? [
-        %jump , f
-    ] [
-        %call , iterate-next
-    ] if ;
+    tail-call? [ %jump , f ] [ %call , iterate-next ] if ;
 
 : rename-label ( label -- label )
     <label> dup rot renamed-labels get set-hash ;
@@ -78,49 +74,7 @@ M: #label linearize* ( node -- next )
     #! to avoid problems with two IR #label nodes having the
     #! same label in different lexical scopes.
     dup node-param dup linearize-call-label >r
-    renamed-label swap node-child linearize-1
-    r> ;
-
-: immediate? ( obj -- ? )
-    #! fixnums and f have a pointerless representation, and
-    #! are compiled immediately. Everything else can be moved
-    #! by GC, and is indexed through a table.
-    dup fixnum? swap f eq? or ;
-
-: load-literal ( obj vreg -- )
-    over immediate? [ %immediate ] [ %indirect ] if , ;
-
-GENERIC: load-value ( vreg loc value -- operand )
-
-M: object load-value ( vreg loc value -- operand )
-    drop dupd %peek , ;
-
-M: value load-value ( vreg loc value -- operand )
-    nip value-literal swap [ [ load-literal ] keep ] when* ;
-
-: (template-inputs) ( seq template -- inputs )
-    dup length reverse-slice [ <ds-loc> ] map rot 3array flip
-    [ first3 load-value ] map ;
-
-: template-inputs ( node template -- )
-    flip first2 >r [ dup [ <vreg> ] when ] map
-    >r node-in-d r> (template-inputs)
-    r> [ set ] 2each ;
-
-: stacks<>vregs ( values quot quot -- )
-    >r >r dup reverse-slice swap length r> map r> 2each ; inline
-
-: template-outputs ( template -- )
-    [ get ] map [ <ds-loc> ] [ %replace , ] stacks<>vregs ;
-
-: with-template ( node in out quot -- )
-    [
-        >r
-        pick pick template-inputs
-        dup rot [ length ] 2apply - %inc-d ,
-        swap node set
-        r> swap slip template-outputs
-    ] with-scope ; inline
+    renamed-label swap node-child linearize-1 r> ;
 
 : intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
 
@@ -145,6 +99,43 @@ M: #call linearize* ( node -- next )
 M: #call-label linearize* ( node -- next )
     node-param renamed-label linearize-call ;
 
+SYMBOL: live-d
+SYMBOL: live-r
+
+: value-dropped? ( value -- ? )
+    dup value?
+    over live-d get member? not
+    rot live-r get member? not and
+    or ;
+
+: filter-dropped ( seq -- seq )
+    [ dup value-dropped? [ drop f ] when ] map ;
+
+: prepare-inputs ( values -- values templates )
+    filter-dropped dup [ any-reg swap 2array ] map ;
+
+: do-inputs ( node -- )
+    dup node-in-d prepare-inputs rot node-in-r prepare-inputs
+    template-inputs ;
+
+: live-stores ( instack outstack -- stack )
+    #! Avoid storing a value into its former position.
+    dup length [ pick ?nth dupd eq? [ drop f ] when ] 2map nip ;
+
+: shuffle-height ( node -- )
+    dup node-out-d length over node-in-d length - %inc-d ,
+    dup node-out-r length swap node-in-r length - %inc-r , ;
+
+M: #shuffle linearize* ( #shuffle -- )
+    [
+        0 vreg-allocator set
+        dup node-in-d over node-out-d live-stores live-d set
+        dup node-in-r over node-out-r live-stores live-r set
+        dup do-inputs
+        shuffle-height
+        live-d get live-r get template-outputs
+    ] with-scope iterate-next ;
+
 : ?static-branch ( node -- n )
     node-in-d first dup value?
     [ value-literal 0 1 ? ] [ drop f ] if ;
diff --git a/library/compiler/stack.factor b/library/compiler/stack.factor
deleted file mode 100644
index 0d69a760d3..0000000000
--- a/library/compiler/stack.factor
+++ /dev/null
@@ -1,68 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler-frontend
-USING: compiler-backend generic inference kernel math namespaces
-sequences vectors words ;
-
-SYMBOL: vreg-allocator
-SYMBOL: live-d
-SYMBOL: live-r
-
-: value-dropped? ( value -- ? )
-    dup value?
-    over live-d get member? not
-    rot live-r get member? not and
-    or ;
-
-: stack>vreg ( value stack-pos -- )
-    vreg-allocator get <vreg> pick set
-    over value-dropped? [ 2drop ] [ >r get r> %peek , ] if
-    vreg-allocator inc ;
-
-: stacks>vregs ( #shuffle -- )
-    dup
-    node-in-d [ <ds-loc> ] [ stack>vreg ] stacks<>vregs
-    node-in-r [ <cs-loc> ] [ stack>vreg ] stacks<>vregs ;
-
-: shuffle-height ( #shuffle -- )
-    dup node-out-d length over node-in-d length - %inc-d ,
-    dup node-out-r length swap node-in-r length - %inc-r , ;
-
-: literal>stack ( value stack-pos -- )
-    swap value-literal fixnum-imm? over immediate? and
-    [ T{ vreg f 0 } load-literal T{ vreg f 0 } ] unless
-    swap %replace , ; inline
-
-: vreg>stack ( value stack-pos -- )
-    {
-        { [ over not ] [ 2drop ] }
-        { [ over value? ] [ literal>stack ] }
-        { [ t ] [ >r get r> %replace , ] }
-    } cond ;
-
-: (vregs>stacks) ( stack stack -- )
-    [ <cs-loc> ] [ vreg>stack ] stacks<>vregs
-    [ <ds-loc> ] [ vreg>stack ] stacks<>vregs ;
-
-: literals/computed ( stack -- literals computed )
-    dup [ dup value? [ drop f ] unless ] map
-    swap [ dup value? [ drop f ] when ] map ;
-
-: vregs>stacks ( -- )
-    #! We store literals last because storing a literal to a
-    #! stack slot actually clobbers a vreg.
-    live-d get literals/computed
-    live-r get literals/computed
-    swapd (vregs>stacks) (vregs>stacks) ;
-
-: live-stores ( instack outstack -- stack )
-    #! Avoid storing a value into its former position.
-    dup length [ pick ?nth dupd eq? [ drop f ] when ] 2map nip ;
-
-M: #shuffle linearize* ( #shuffle -- )
-    [
-        0 vreg-allocator set
-        dup node-in-d over node-out-d live-stores live-d set
-        dup node-in-r over node-out-r live-stores live-r set
-        dup stacks>vregs shuffle-height vregs>stacks
-    ] with-scope iterate-next ;
diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
new file mode 100644
index 0000000000..34f8260799
--- /dev/null
+++ b/library/compiler/templates.factor
@@ -0,0 +1,103 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler-frontend
+USING: arrays compiler-backend generic inference kernel math
+namespaces sequences vectors words ;
+
+! SYMBOL: d-height
+! SYMBOL: r-height
+! 
+! : adjust-stacks ( inc-d inc-r -- )
+!     r-height [ + ] change d-height [ + ] change ;
+! 
+! : finalize-stack ( quot symbol -- )
+!     [
+!         get dup zero? [ 2drop ] [ swap execute , ] if 0
+!     ] keep set ; inline
+! 
+! : end-basic-block ( -- )
+!     \ %inc-r r-height finalize-stack
+!     \ %inc-d d-height finalize-stack ;
+
+: immediate? ( obj -- ? )
+    #! fixnums and f have a pointerless representation, and
+    #! are compiled immediately. Everything else can be moved
+    #! by GC, and is indexed through a table.
+    dup fixnum? swap f eq? or ;
+
+: load-literal ( obj vreg -- )
+    over immediate? [ %immediate ] [ %indirect ] if , ;
+
+GENERIC: stack>vreg* ( vreg loc value -- operand )
+
+M: object stack>vreg* ( vreg loc value -- operand )
+    drop >r <vreg> dup r> %peek , ;
+
+M: value stack>vreg* ( vreg loc value -- operand )
+    nip value-literal swap <vreg> [ load-literal ] keep ;
+
+SYMBOL: vreg-allocator
+
+SYMBOL: any-reg
+
+: alloc-value ( loc value -- operand )
+    vreg-allocator [ inc ] keep get -rot stack>vreg* ;
+
+: stack>vreg ( vreg loc value -- operand )
+    {
+        { [ dup not ] [ 3drop f ] }
+        { [ pick any-reg eq? ] [ alloc-value nip ] }
+        { [ pick not ] [ 2nip value-literal ] }
+        { [ t ] [ stack>vreg* ] }
+    } cond ;
+
+: (stack>vregs) ( names values template quot -- inputs )
+    >r dup length reverse r> map 3array flip
+    [ first3 rot stack>vreg ] map swap [ set ] 2each ; inline
+
+: stack>vregs ( stack template quot -- )
+    >r unpair -rot r> (stack>vregs) ; inline
+
+: template-inputs ( stack template stack template -- )
+    [ <cs-loc> ] stack>vregs [ <ds-loc> ] stack>vregs ;
+
+: literal>stack ( value stack-pos -- )
+    swap value-literal fixnum-imm? over immediate? and
+    [ T{ vreg f 0 } load-literal T{ vreg f 0 } ] unless
+    swap %replace , ; inline
+
+: vreg>stack ( value stack-pos -- )
+    {
+        { [ over not ] [ 2drop ] }
+        { [ over value? ] [ literal>stack ] }
+        { [ t ] [ >r get r> %replace , ] }
+    } cond ;
+
+: vregs>stack ( values quot -- )
+    >r dup reverse-slice swap length r> map
+    [ vreg>stack ] 2each ; inline
+
+: template-outputs ( stack stack -- )
+    [ <cs-loc> ] vregs>stack [ <ds-loc> ] vregs>stack ;
+
+SYMBOL: template-height
+
+: with-template ( node in out quot -- )
+    [
+        0 vreg-allocator set
+        pick length pick length swap - template-height set
+        swap >r >r
+        >r dup node-in-d r> { } { } template-inputs
+        template-height get %inc-d ,
+         node set r> call r> { } template-outputs
+    ] with-scope ; inline
+
+: literals/computed ( stack -- literals computed )
+    dup [ dup value? [ drop f ] unless ] map
+    swap [ dup value? [ drop f ] when ] map ;
+
+: vregs>stacks ( ds cs -- )
+    #! We store literals last because storing a literal to a
+    #! stack slot actually clobbers a vreg.
+    >r literals/computed r> literals/computed swapd
+    template-outputs template-outputs ;
diff --git a/library/compiler/vops.factor b/library/compiler/vops.factor
index 22efffcaac..34bd14c051 100644
--- a/library/compiler/vops.factor
+++ b/library/compiler/vops.factor
@@ -324,7 +324,7 @@ M: %tag basic-block? drop t ;
 
 TUPLE: %getenv ;
 C: %getenv make-vop ;
-: %getenv swap src/dest-vop <%getenv> ;
+: %getenv src/dest-vop <%getenv> ;
 M: %getenv basic-block? drop t ;
 
 TUPLE: %setenv ;
diff --git a/library/help/crossref.factor b/library/help/crossref.factor
index 38983c71cc..2061c42ed5 100644
--- a/library/help/crossref.factor
+++ b/library/help/crossref.factor
@@ -52,7 +52,6 @@ SYMBOL: help-graph
     [ links-out ] help-graph get remove-vertex ;
 
 : xref-articles ( -- )
-    H{ } clone help-graph set
     all-articles [ links-out ] help-graph get add-vertices ;
 
 : help-outliner ( seq quot -- | quot: obj -- )
diff --git a/library/io/null-stream.factor b/library/io/null-stream.factor
index c710d23816..8410485c25 100644
--- a/library/io/null-stream.factor
+++ b/library/io/null-stream.factor
@@ -3,7 +3,7 @@ USING: kernel ;
 
 ! Think '/dev/null'.
 M: f stream-close drop ;
-M: f set-timeout drop ;
+M: f set-timeout 2drop ;
 
 M: f stream-readln drop f ;
 M: f stream-read1 drop f ;
diff --git a/library/test/compiler/intrinsics.factor b/library/test/compiler/intrinsics.factor
index bd35d2f89d..78e686f35b 100644
--- a/library/test/compiler/intrinsics.factor
+++ b/library/test/compiler/intrinsics.factor
@@ -27,6 +27,9 @@ math-internals sequences strings test words ;
 [ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep dup rehash-string ] compile-1 ] unit-test
 [ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep dup rehash-string ] compile-1 ] unit-test
 
+[ ] [ [ 0 getenv ] compile-1 drop ] unit-test
+[ ] [ 1 getenv [ 1 setenv ] compile-1 ] unit-test
+
 [ ] [ 1 [ drop ] compile-1 ] unit-test
 [ ] [ [ 1 drop ] compile-1 ] unit-test
 [ ] [ [ 1 2 2drop ] compile-1 ] unit-test
diff --git a/library/test/io/io.factor b/library/test/io/io.factor
index 2bcef4f739..ca90ba83b7 100644
--- a/library/test/io/io.factor
+++ b/library/test/io/io.factor
@@ -60,3 +60,5 @@ unit-test
 [ f ]
 [ "" <string-reader> stream-readln ]
 unit-test
+
+[ ] [ 10000 f set-timeout ] unit-test
diff --git a/library/test/test.factor b/library/test/test.factor
index 157030f388..e3fb9d955a 100644
--- a/library/test/test.factor
+++ b/library/test/test.factor
@@ -1,8 +1,8 @@
 ! Factor test suite.
 
 IN: test
-USING: arrays errors inspector io kernel lists math memory
-namespaces parser prettyprint sequences strings words ;
+USING: arrays errors hashtables inspector io kernel lists math
+memory namespaces parser prettyprint sequences strings words ;
 
 TUPLE: assert got expect ;
 
@@ -54,9 +54,7 @@ SYMBOL: failures
         ] assert-depth drop
     ] test-handler ;
 
-: prepare-tests ( -- )
-    failures off
-    vocabularies get [ "temporary" off ] bind ;
+: prepare-tests ( -- ) failures off "temporary" forget-vocab ;
 
 : passed.
     "Tests passed:" print . ;
diff --git a/library/words.factor b/library/words.factor
index b19cf032da..e5efc33d03 100644
--- a/library/words.factor
+++ b/library/words.factor
@@ -116,7 +116,7 @@ SYMBOL: vocabularies
     all-words swap subset-with ; inline
 
 : xref-words ( -- )
-    H{ } clone crossref set
+    crossref get clear-hash
     all-words [ uses ] crossref get add-vertices ;
 
 : lookup ( name vocab -- word ) vocab ?hash ;
@@ -141,6 +141,9 @@ SYMBOL: vocabularies
     dup unxref-word
     dup word-name swap word-vocabulary vocab remove-hash ;
 
+: forget-vocab ( vocab -- )
+    vocabularies get remove-hash xref-words ;
+
 : target-word ( word -- word )
     dup word-name swap word-vocabulary lookup ;
 

From 12fd5294daf869a4bb812b8436ded8a2c3d69845 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Mon, 3 Apr 2006 06:18:56 +0000
Subject: [PATCH 011/112] Fix clear-hash bug, merge
 compiler/compiler-backend/compiler-frontend vocabs

---
 library/alien/alien-callback.factor        |  5 +--
 library/alien/alien-invoke.factor          |  4 +-
 library/alien/c-types.factor               |  2 +-
 library/alien/compiler.factor              |  2 +-
 library/alien/primitive-types.factor       |  3 +-
 library/alien/structs.factor               |  2 +-
 library/bootstrap/boot-stage1.factor       |  1 -
 library/bootstrap/boot-stage2.factor       |  2 +-
 library/collections/graphs.factor          |  3 +-
 library/collections/hashtables.factor      |  8 ++--
 library/compiler/amd64/alien.factor        |  2 +-
 library/compiler/amd64/architecture.factor |  4 +-
 library/compiler/amd64/generator.factor    |  4 +-
 library/compiler/amd64/slots.factor        |  4 +-
 library/compiler/architecture.factor       |  2 +-
 library/compiler/basic-blocks.factor       |  2 +-
 library/compiler/compiler.factor           |  7 ++--
 library/compiler/generator.factor          |  6 +--
 library/compiler/intrinsics.factor         |  6 +--
 library/compiler/linearizer.factor         | 16 +++++---
 library/compiler/ppc/alien.factor          |  2 +-
 library/compiler/ppc/architecture.factor   |  4 +-
 library/compiler/ppc/fixnum.factor         |  4 +-
 library/compiler/ppc/generator.factor      |  6 +--
 library/compiler/ppc/slots.factor          |  4 +-
 library/compiler/ppc/stack.factor          |  4 +-
 library/compiler/templates.factor          | 46 ++++++++++++++--------
 library/compiler/vops.factor               |  8 +---
 library/compiler/x86/alien.factor          |  4 +-
 library/compiler/x86/architecture.factor   |  6 +--
 library/compiler/x86/fixnum.factor         |  4 +-
 library/compiler/x86/generator.factor      |  4 +-
 library/compiler/x86/slots.factor          |  4 +-
 library/compiler/x86/stack.factor          |  4 +-
 library/compiler/xt.factor                 |  6 +--
 library/inference/optimizer.factor         |  2 +-
 library/test/collections/hashtables.factor |  4 ++
 library/test/compiler/linearizer.factor    |  1 -
 library/test/compiler/optimizer.factor     |  2 +-
 library/words.factor                       |  1 -
 40 files changed, 107 insertions(+), 98 deletions(-)

diff --git a/library/alien/alien-callback.factor b/library/alien/alien-callback.factor
index bf80103403..41c2fe8878 100644
--- a/library/alien/alien-callback.factor
+++ b/library/alien/alien-callback.factor
@@ -1,9 +1,8 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: alien
-USING: compiler-backend compiler-frontend errors generic
-hashtables inference inspector kernel lists namespaces sequences
-strings words ;
+USING: compiler errors generic hashtables inference inspector
+kernel lists namespaces sequences strings words ;
 
 TUPLE: alien-callback return parameters quot xt ;
 C: alien-callback make-node ;
diff --git a/library/alien/alien-invoke.factor b/library/alien/alien-invoke.factor
index 98bd4067a0..5b5fa66851 100644
--- a/library/alien/alien-invoke.factor
+++ b/library/alien/alien-invoke.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: alien
-USING: arrays assembler compiler compiler-backend
-compiler-frontend errors generic hashtables inference inspector
+USING: arrays assembler compiler compiler
+errors generic hashtables inference inspector
 io kernel kernel-internals lists math namespaces parser
 prettyprint sequences strings words ;
 
diff --git a/library/alien/c-types.factor b/library/alien/c-types.factor
index 4224bb431f..b6f88d41cb 100644
--- a/library/alien/c-types.factor
+++ b/library/alien/c-types.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: alien
-USING: arrays compiler compiler-backend errors generic
+USING: arrays compiler errors generic
 hashtables kernel kernel-internals libc lists math namespaces
 parser sequences strings words ;
 
diff --git a/library/alien/compiler.factor b/library/alien/compiler.factor
index a9a7ce7672..9deb4f3a2b 100644
--- a/library/alien/compiler.factor
+++ b/library/alien/compiler.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: alien
-USING: arrays compiler-backend generic hashtables kernel
+USING: arrays compiler generic hashtables kernel
 kernel-internals math namespaces sequences words ;
 
 : parameter-size c-size cell align ;
diff --git a/library/alien/primitive-types.factor b/library/alien/primitive-types.factor
index dffe561967..f2415f36d7 100644
--- a/library/alien/primitive-types.factor
+++ b/library/alien/primitive-types.factor
@@ -1,5 +1,4 @@
-USING: alien compiler-backend kernel kernel-internals
-math namespaces ;
+USING: alien compiler kernel kernel-internals math namespaces ;
 
 [
     [ alien-unsigned-cell <alien> ] "getter" set
diff --git a/library/alien/structs.factor b/library/alien/structs.factor
index 65a86504e6..c2253d1a98 100644
--- a/library/alien/structs.factor
+++ b/library/alien/structs.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: alien
-USING: assembler compiler compiler-backend errors generic
+USING: assembler compiler errors generic
 hashtables kernel kernel-internals lists math namespaces parser
 sequences strings words ;
 
diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor
index 0fd7a1e16e..3fe721874d 100644
--- a/library/bootstrap/boot-stage1.factor
+++ b/library/bootstrap/boot-stage1.factor
@@ -132,7 +132,6 @@ vectors words ;
         "/library/compiler/xt.factor"
         "/library/compiler/intrinsics.factor"
         "/library/compiler/generator.factor"
-        "/library/compiler/basic-blocks.factor"
         "/library/compiler/compiler.factor"
 
         "/library/alien/malloc.factor"
diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor
index 0bc45c89da..d13befd2b4 100644
--- a/library/bootstrap/boot-stage2.factor
+++ b/library/bootstrap/boot-stage2.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler compiler-backend help io io-internals kernel
+USING: compiler help io io-internals kernel
 kernel-internals lists math memory namespaces optimizer parser
 sequences sequences-internals words ;
 
diff --git a/library/collections/graphs.factor b/library/collections/graphs.factor
index 5b4175a198..fe909eb504 100644
--- a/library/collections/graphs.factor
+++ b/library/collections/graphs.factor
@@ -17,8 +17,7 @@ USING: hashtables kernel namespaces sequences ;
         swap [ swap (add-vertex) ] each-with
     ] if-graph ;
 
-: (remove-vertex) ( vertex graph -- )
-    nest remove-hash ;
+: (remove-vertex) ( vertex graph -- ) nest remove-hash ;
 
 : remove-vertex ( vertex edges graph -- )
     [
diff --git a/library/collections/hashtables.factor b/library/collections/hashtables.factor
index bd3e027fe7..f8b6c1bdf1 100644
--- a/library/collections/hashtables.factor
+++ b/library/collections/hashtables.factor
@@ -28,10 +28,12 @@ TUPLE: tombstone ;
 
 : <hash-array> ( n -- array ) 1+ 4 * ((empty)) <array> ;
 
-: reset-hash ( n hash -- )
-    swap <hash-array> over set-hash-array
+: init-hash ( hash -- )
     0 over set-hash-count 0 swap set-hash-deleted ;
 
+: reset-hash ( n hash -- )
+    swap <hash-array> over set-hash-array init-hash ;
+
 : (new-key@) ( key keys i -- n )
     3dup swap nth-unsafe dup tombstone? [
         2drop 2nip
@@ -124,7 +126,7 @@ IN: hashtables
     dup [ hash ] [ 2drop f ] if ;
 
 : clear-hash ( hash -- )
-    [ hash-array length ] keep reset-hash ;
+    dup init-hash hash-array [ drop ((empty)) ] inject ;
 
 : remove-hash ( key hash -- )
     [
diff --git a/library/compiler/amd64/alien.factor b/library/compiler/amd64/alien.factor
index 657be36d3b..f84ff9dc6d 100644
--- a/library/compiler/amd64/alien.factor
+++ b/library/compiler/amd64/alien.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: compiler-backend
+IN: compiler
 USING: alien arrays assembler kernel kernel-internals math
 sequences ;
 
diff --git a/library/compiler/amd64/architecture.factor b/library/compiler/amd64/architecture.factor
index 2c11013128..6950d4dec3 100644
--- a/library/compiler/amd64/architecture.factor
+++ b/library/compiler/amd64/architecture.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: compiler-backend
-USING: alien arrays assembler compiler compiler-frontend kernel
+IN: compiler
+USING: alien arrays assembler kernel
 kernel-internals math namespaces sequences ;
 
 ! AMD64 register assignments
diff --git a/library/compiler/amd64/generator.factor b/library/compiler/amd64/generator.factor
index 986a0c3819..99a2d26628 100644
--- a/library/compiler/amd64/generator.factor
+++ b/library/compiler/amd64/generator.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: compiler-backend
-USING: assembler compiler-frontend kernel math namespaces ;
+IN: compiler
+USING: assembler kernel math namespaces ;
 
 M: %prologue generate-node ( vop -- )
     drop
diff --git a/library/compiler/amd64/slots.factor b/library/compiler/amd64/slots.factor
index 66697924f5..7f2ab2eb4c 100644
--- a/library/compiler/amd64/slots.factor
+++ b/library/compiler/amd64/slots.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: compiler-backend
-USING: alien arrays assembler compiler inference kernel
+IN: compiler
+USING: alien arrays assembler inference kernel
 kernel-internals lists math memory namespaces sequences words ;
 
 M: %write-barrier generate-node ( vop -- )
diff --git a/library/compiler/architecture.factor b/library/compiler/architecture.factor
index 1acecc89b5..2325bd7299 100644
--- a/library/compiler/architecture.factor
+++ b/library/compiler/architecture.factor
@@ -1,4 +1,4 @@
-IN: compiler-backend
+IN: compiler
 
 ! A few things the front-end needs to know about the back-end.
 
diff --git a/library/compiler/basic-blocks.factor b/library/compiler/basic-blocks.factor
index 9fcab8a9d6..2510c32880 100644
--- a/library/compiler/basic-blocks.factor
+++ b/library/compiler/basic-blocks.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler-backend
+IN: compiler
 USING: arrays hashtables kernel lists math namespaces sequences ;
 
 ! Optimizations performed here:
diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor
index e1c356abaf..e3f5d2885a 100644
--- a/library/compiler/compiler.factor
+++ b/library/compiler/compiler.factor
@@ -1,14 +1,13 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: compiler
-USING: compiler-backend compiler-frontend errors hashtables
-inference io kernel lists math namespaces optimizer prettyprint
-sequences test words ;
+USING: errors hashtables inference io kernel lists math
+namespaces optimizer prettyprint sequences test words ;
 
 : (compile) ( word -- )
     #! Should be called inside the with-compiler scope.
     dup word-def dataflow optimize linearize
-    [ split-blocks simplify generate ] hash-each ;
+    [ generate ] hash-each ;
 
 : benchmark-compile
     [ [ (compile) ] keep ] benchmark nip
diff --git a/library/compiler/generator.factor b/library/compiler/generator.factor
index 05d4b6e1f9..78c6e40fe1 100644
--- a/library/compiler/generator.factor
+++ b/library/compiler/generator.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler-backend
-USING: alien assembler compiler errors inference kernel
+IN: compiler
+USING: alien assembler errors inference kernel
 kernel-internals lists math memory namespaces sequences strings
 vectors words ;
 
@@ -12,7 +12,7 @@ GENERIC: generate-node ( vop -- )
     compiled-offset >r
     compile-aligned
     swap save-xt
-    [ [ dup [ generate-node ] with-vop ] each ] each
+    [ dup [ generate-node ] with-vop ] each
     compile-aligned
     compiled-offset r> - ;
 
diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index 50fec8c080..ea06bf04aa 100644
--- a/library/compiler/intrinsics.factor
+++ b/library/compiler/intrinsics.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: compiler-frontend
-USING: arrays assembler compiler-backend generic hashtables
+IN: compiler
+USING: arrays assembler generic hashtables
 inference kernel kernel-internals lists math math-internals
 namespaces sequences words ;
 
@@ -181,7 +181,7 @@ namespaces sequences words ;
 
 : fast-shift ( n node -- )
     over zero? [
-        -1 %inc-d , 2drop
+        -1 0 adjust-stacks end-basic-block 2drop
     ] [
         over 0 < [
             negative-shift
diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index 7a7c98e9ef..07342de807 100644
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays compiler-backend generic hashtables inference
+IN: compiler
+USING: arrays generic hashtables inference
 kernel math namespaces sequences words ;
-IN: compiler-frontend
 
 ! On PowerPC and AMD64, we use a stack discipline whereby
 ! stack frames are used to hold parameters. We need to compute
@@ -38,12 +38,15 @@ SYMBOL: renamed-labels
 
 : make-linear ( word quot -- )
     [
+        0 { d-height r-height } [ set ] each-with
         swap >r { } make r> linearized get set-hash
     ] with-node-iterator ; inline
 
 : linearize-1 ( word node -- )
     swap [
-        dup stack-reserve %prologue , linearize-child
+        dup stack-reserve %prologue ,
+        linearize-child
+        end-basic-block
     ] make-linear ;
 
 : init-linearizer ( -- )
@@ -123,8 +126,9 @@ SYMBOL: live-r
     dup length [ pick ?nth dupd eq? [ drop f ] when ] 2map nip ;
 
 : shuffle-height ( node -- )
-    dup node-out-d length over node-in-d length - %inc-d ,
-    dup node-out-r length swap node-in-r length - %inc-r , ;
+    [ dup node-out-d length swap node-in-d length - ] keep
+    dup node-out-r length swap node-in-r length -
+    adjust-stacks end-basic-block ;
 
 M: #shuffle linearize* ( #shuffle -- )
     [
@@ -142,7 +146,7 @@ M: #shuffle linearize* ( #shuffle -- )
 
 M: #if linearize* ( node -- next )
     dup ?static-branch [
-        -1 %inc-d ,
+        -1 0 adjust-stacks end-basic-block
         swap node-children nth linearize-child iterate-next
     ] [
         dup { { 0 "flag" } } { } [
diff --git a/library/compiler/ppc/alien.factor b/library/compiler/ppc/alien.factor
index e63628370e..dd7120cdad 100644
--- a/library/compiler/ppc/alien.factor
+++ b/library/compiler/ppc/alien.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: compiler-backend
+IN: compiler
 USING: alien assembler kernel kernel-internals math sequences ;
 
 GENERIC: freg>stack ( stack reg reg-class -- )
diff --git a/library/compiler/ppc/architecture.factor b/library/compiler/ppc/architecture.factor
index 1cc3ecd964..f37c35fcbf 100644
--- a/library/compiler/ppc/architecture.factor
+++ b/library/compiler/ppc/architecture.factor
@@ -1,5 +1,5 @@
-IN: compiler-backend
-USING: assembler compiler-backend kernel kernel-internals math ;
+IN: compiler
+USING: assembler kernel kernel-internals math ;
 
 ! PowerPC register assignments
 ! r3-r10 vregs
diff --git a/library/compiler/ppc/fixnum.factor b/library/compiler/ppc/fixnum.factor
index 0aeadb66ba..29941ab182 100644
--- a/library/compiler/ppc/fixnum.factor
+++ b/library/compiler/ppc/fixnum.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler-backend
-USING: assembler compiler kernel kernel-internals math
+IN: compiler
+USING: assembler kernel kernel-internals math
 math-internals memory namespaces words ;
 
 : >3-vop< ( -- out1 in1 in2 )
diff --git a/library/compiler/ppc/generator.factor b/library/compiler/ppc/generator.factor
index 2b9b391646..3c9fc49463 100644
--- a/library/compiler/ppc/generator.factor
+++ b/library/compiler/ppc/generator.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 200 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: compiler-backend
-USING: alien assembler compiler compiler-frontend inference
-kernel kernel-internals lists math memory namespaces words ;
+IN: compiler
+USING: alien assembler inference kernel kernel-internals lists
+math memory namespaces words ;
 
 : compile-dlsym ( symbol dll register -- )
     >r 2dup dlsym  r> LOAD32 rel-2/2 rel-dlsym ;
diff --git a/library/compiler/ppc/slots.factor b/library/compiler/ppc/slots.factor
index b6e385ea41..6209357695 100644
--- a/library/compiler/ppc/slots.factor
+++ b/library/compiler/ppc/slots.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler-backend
-USING: alien assembler compiler inference kernel
+IN: compiler
+USING: alien assembler inference kernel
 kernel-internals lists math memory namespaces sequences words ;
 
 : generate-slot ( size quot -- )
diff --git a/library/compiler/ppc/stack.factor b/library/compiler/ppc/stack.factor
index 167b617740..3e81215eeb 100644
--- a/library/compiler/ppc/stack.factor
+++ b/library/compiler/ppc/stack.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler-backend
-USING: assembler compiler errors kernel kernel-internals math
+IN: compiler
+USING: assembler errors kernel kernel-internals math
 memory namespaces words ;
 
 GENERIC: loc>operand
diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index 34f8260799..d1b1207311 100644
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -1,23 +1,35 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: compiler-frontend
-USING: arrays compiler-backend generic inference kernel math
+IN: compiler
+USING: arrays generic inference kernel math
 namespaces sequences vectors words ;
 
-! SYMBOL: d-height
-! SYMBOL: r-height
-! 
-! : adjust-stacks ( inc-d inc-r -- )
-!     r-height [ + ] change d-height [ + ] change ;
-! 
-! : finalize-stack ( quot symbol -- )
-!     [
-!         get dup zero? [ 2drop ] [ swap execute , ] if 0
-!     ] keep set ; inline
-! 
-! : end-basic-block ( -- )
-!     \ %inc-r r-height finalize-stack
-!     \ %inc-d d-height finalize-stack ;
+SYMBOL: d-height
+SYMBOL: r-height
+
+! A data stack location.
+TUPLE: ds-loc n ;
+
+C: ds-loc ( n -- ds-loc ) 
+    [ >r d-height get + r> set-ds-loc-n ] keep ;
+
+! A call stack location.
+TUPLE: cs-loc n ;
+
+C: cs-loc ( n -- ds-loc ) 
+    [ >r r-height get + r> set-cs-loc-n ] keep ;
+
+: adjust-stacks ( inc-d inc-r -- )
+    r-height [ + ] change d-height [ + ] change ;
+
+: finalize-stack ( quot symbol -- )
+    [
+        get dup zero? [ 2drop ] [ swap execute , ] if 0
+    ] keep set ; inline
+
+: end-basic-block ( -- )
+    \ %inc-r r-height finalize-stack
+    \ %inc-d d-height finalize-stack ;
 
 : immediate? ( obj -- ? )
     #! fixnums and f have a pointerless representation, and
@@ -88,7 +100,7 @@ SYMBOL: template-height
         pick length pick length swap - template-height set
         swap >r >r
         >r dup node-in-d r> { } { } template-inputs
-        template-height get %inc-d ,
+        template-height get 0 adjust-stacks end-basic-block
          node set r> call r> { } template-outputs
     ] with-scope ; inline
 
diff --git a/library/compiler/vops.factor b/library/compiler/vops.factor
index 34bd14c051..707d313b90 100644
--- a/library/compiler/vops.factor
+++ b/library/compiler/vops.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: compiler-backend
+IN: compiler
 USING: arrays errors generic hashtables kernel kernel-internals
 lists math memory namespaces parser sequences words ;
 
@@ -53,12 +53,6 @@ M: float-regs inc-reg-class
     dup (inc-reg-class)
     macosx? [ reg-size 4 / int-regs +@ ] [ drop ] if ;
 
-! A data stack location.
-TUPLE: ds-loc n ;
-
-! A call stack location.
-TUPLE: cs-loc n ;
-
 GENERIC: v>operand
 
 M: integer v>operand tag-bits shift ;
diff --git a/library/compiler/x86/alien.factor b/library/compiler/x86/alien.factor
index 183106dba0..e57785d625 100644
--- a/library/compiler/x86/alien.factor
+++ b/library/compiler/x86/alien.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler-backend
-USING: alien arrays assembler compiler inference kernel
+IN: compiler
+USING: alien arrays assembler inference kernel
 kernel-internals lists math memory namespaces words ;
 
 GENERIC: push-return-reg ( reg-class -- )
diff --git a/library/compiler/x86/architecture.factor b/library/compiler/x86/architecture.factor
index 20db81c388..a3eb4024f9 100644
--- a/library/compiler/x86/architecture.factor
+++ b/library/compiler/x86/architecture.factor
@@ -1,6 +1,6 @@
-IN: compiler-backend
-USING: alien arrays assembler compiler compiler-backend generic
-kernel kernel-internals sequences words ;
+IN: compiler
+USING: alien arrays assembler generic kernel kernel-internals
+sequences words ;
 
 ! x86 register assignments
 ! EAX, ECX, EDX vregs
diff --git a/library/compiler/x86/fixnum.factor b/library/compiler/x86/fixnum.factor
index 05a61362c0..0c365fad43 100644
--- a/library/compiler/x86/fixnum.factor
+++ b/library/compiler/x86/fixnum.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler-backend
-USING: arrays assembler compiler errors kernel kernel-internals
+IN: compiler
+USING: arrays assembler errors kernel kernel-internals
 math math-internals memory namespaces words ;
 
 : literal-overflow ( -- dest src )
diff --git a/library/compiler/x86/generator.factor b/library/compiler/x86/generator.factor
index 1bb2db22a8..317aa8d5d8 100644
--- a/library/compiler/x86/generator.factor
+++ b/library/compiler/x86/generator.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler-backend
-USING: alien arrays assembler compiler inference kernel
+IN: compiler
+USING: alien arrays assembler inference kernel
 kernel-internals lists math memory namespaces sequences words ;
 
 ! Not used on x86
diff --git a/library/compiler/x86/slots.factor b/library/compiler/x86/slots.factor
index a2fae93bcd..d1527bce42 100644
--- a/library/compiler/x86/slots.factor
+++ b/library/compiler/x86/slots.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: compiler-backend
-USING: alien arrays assembler compiler inference kernel
+IN: compiler
+USING: alien arrays assembler inference kernel
 kernel-internals lists math memory namespaces sequences words ;
 
 M: %slot generate-node ( vop -- )
diff --git a/library/compiler/x86/stack.factor b/library/compiler/x86/stack.factor
index 230719914e..f40786e3b7 100644
--- a/library/compiler/x86/stack.factor
+++ b/library/compiler/x86/stack.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler-backend
-USING: alien arrays assembler compiler inference kernel
+IN: compiler
+USING: alien arrays assembler inference kernel
 kernel-internals lists math memory sequences words ;
 
 : reg-stack ( n reg -- op ) swap cells neg [+] ;
diff --git a/library/compiler/xt.factor b/library/compiler/xt.factor
index e1f51c8f01..f6b92b144e 100644
--- a/library/compiler/xt.factor
+++ b/library/compiler/xt.factor
@@ -1,9 +1,9 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: compiler
-USING: assembler compiler-backend compiler-frontend errors
-generic hashtables kernel kernel-internals lists math namespaces
-prettyprint sequences strings vectors words ;
+USING: assembler errors generic hashtables kernel
+kernel-internals lists math namespaces prettyprint sequences
+strings vectors words ;
 
 ! We use a hashtable "compiled-xts" that maps words to
 ! xt's that are currently being compiled. The commit-xt's word
diff --git a/library/inference/optimizer.factor b/library/inference/optimizer.factor
index 6e00fa5b0c..31801dc77f 100644
--- a/library/inference/optimizer.factor
+++ b/library/inference/optimizer.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: optimizer
-USING: compiler-backend generic hashtables inference io kernel
+USING: compiler generic hashtables inference io kernel
 lists math namespaces sequences vectors ;
 
 SYMBOL: optimizer-changed
diff --git a/library/test/collections/hashtables.factor b/library/test/collections/hashtables.factor
index 0c54434b8d..9e21211f81 100644
--- a/library/test/collections/hashtables.factor
+++ b/library/test/collections/hashtables.factor
@@ -197,3 +197,7 @@ H{ } clone "cache-test" set
 [ H{ } ] [ { H{ } } hash-concat ] unit-test
 [ H{ { 1 2 } } ] [ { H{ { 1 2 } } } hash-concat ] unit-test
 [ H{ { 1 2 } { 3 4 } } ] [ { H{ { 1 2 } } H{ { 3 4 } } } hash-concat ] unit-test
+
+! Resource leak...
+H{ } "x" set
+100 [ drop "x" get clear-hash ] each
diff --git a/library/test/compiler/linearizer.factor b/library/test/compiler/linearizer.factor
index 3155134d4c..42cdaf0d4a 100644
--- a/library/test/compiler/linearizer.factor
+++ b/library/test/compiler/linearizer.factor
@@ -2,7 +2,6 @@ IN: temporary
 USE: test
 USE: kernel
 USE: compiler
-USE: compiler-frontend
 USE: inference
 USE: words
 USE: sequences
diff --git a/library/test/compiler/optimizer.factor b/library/test/compiler/optimizer.factor
index e6650c1bf8..0fa16b2012 100644
--- a/library/test/compiler/optimizer.factor
+++ b/library/test/compiler/optimizer.factor
@@ -1,5 +1,5 @@
 IN: temporary
-USING: arrays assembler compiler compiler-backend generic
+USING: arrays assembler compiler generic
 hashtables inference kernel kernel-internals lists math
 optimizer prettyprint sequences strings test vectors words
 sequences-internals ;
diff --git a/library/words.factor b/library/words.factor
index e5efc33d03..33c3002c0a 100644
--- a/library/words.factor
+++ b/library/words.factor
@@ -116,7 +116,6 @@ SYMBOL: vocabularies
     all-words swap subset-with ; inline
 
 : xref-words ( -- )
-    crossref get clear-hash
     all-words [ uses ] crossref get add-vertices ;
 
 : lookup ( name vocab -- word ) vocab ?hash ;

From d65a7480428ce618cc9d1f8461e0441c31bbc27f Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Mon, 3 Apr 2006 07:22:33 +0000
Subject: [PATCH 012/112] Phasing out basic block optimizer; moved %inc-d/r
 merge optimization to templates

---
 library/alien/alien-callback.factor |  2 +-
 library/alien/alien-invoke.factor   |  2 +-
 library/compiler/intrinsics.factor  | 11 +++++---
 library/compiler/linearizer.factor  | 42 +++++++++++++++--------------
 library/compiler/templates.factor   | 17 +++++-------
 library/compiler/vops.factor        | 30 ---------------------
 6 files changed, 39 insertions(+), 65 deletions(-)

diff --git a/library/alien/alien-callback.factor b/library/alien/alien-callback.factor
index 41c2fe8878..fef4d10f6c 100644
--- a/library/alien/alien-callback.factor
+++ b/library/alien/alien-callback.factor
@@ -60,7 +60,7 @@ M: alien-callback-error summary ( error -- )
     ] make-linear ;
 
 M: alien-callback linearize* ( node -- )
-    compile-gc linearize-callback iterate-next ;
+    end-basic-block compile-gc linearize-callback iterate-next ;
 
 M: alien-callback stack-reserve*
     alien-callback-parameters stack-space ;
diff --git a/library/alien/alien-invoke.factor b/library/alien/alien-invoke.factor
index 5b5fa66851..853939cc47 100644
--- a/library/alien/alien-invoke.factor
+++ b/library/alien/alien-invoke.factor
@@ -64,7 +64,7 @@ M: alien-invoke-error summary ( error -- )
     ] if ;
 
 M: alien-invoke linearize* ( node -- )
-    compile-gc
+    end-basic-block compile-gc
     dup alien-invoke-parameters objects>registers
     dup alien-invoke-dlsym %alien-invoke ,
     dup linearize-cleanup box-return
diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index ea06bf04aa..80180fabb2 100644
--- a/library/compiler/intrinsics.factor
+++ b/library/compiler/intrinsics.factor
@@ -51,6 +51,7 @@ namespaces sequences words ;
             "val" get "obj" get "slot" get %set-slot ,
         ] with-template
     ] if
+    end-basic-block
     T{ vreg f 1 } %write-barrier ,
 ] "intrinsic" set-word-prop
 
@@ -67,7 +68,8 @@ namespaces sequences words ;
 ] "intrinsic" set-word-prop
 
 \ type [
-    { { 0 "in" } } { "in" } [ "in" get %type , ] with-template
+    { { 0 "in" } } { "in" }
+    [ end-basic-block "in" get %type , ] with-template
 ] "intrinsic" set-word-prop
 
 \ tag [
@@ -97,7 +99,7 @@ namespaces sequences words ;
 
 : (binary-op) ( node in -- )
     { "x" } [
-        >r "y" get "x" get dup r> execute ,
+        end-basic-block >r "y" get "x" get dup r> execute ,
     ] with-template ; inline
 
 : binary-op ( node op -- )
@@ -118,7 +120,7 @@ namespaces sequences words ;
 
 : binary-jump ( node label op -- )
     rot dup binary-in { } [
-        >r >r "y" get "x" get r> r> execute ,
+        end-basic-block >r >r "y" get "x" get r> r> execute ,
     ] with-template ; inline
 
 {
@@ -140,6 +142,7 @@ namespaces sequences words ;
     ! hard-coded to put its output in vreg 2, which happends to
     ! be EDX there.
     { { 0 "x" } { 1 "y" } } { "out" } [
+        end-basic-block
         T{ vreg f 2 } "out" set
         "y" get "x" get "out" get %fixnum-mod ,
     ] with-template
@@ -148,6 +151,7 @@ namespaces sequences words ;
 \ fixnum/mod [
     ! See the remark on fixnum-mod for vreg usage
     { { 0 "x" } { 1 "y" } } { "quo" "rem" } [
+        end-basic-block
         T{ vreg f 0 } "quo" set
         T{ vreg f 2 } "rem" set
         "y" get "x" get 2array
@@ -191,6 +195,7 @@ namespaces sequences words ;
     ] if ;
 
 \ fixnum-shift [
+    end-basic-block
     dup literal-immediate? [
         [ node-in-d peek value-literal ] keep fast-shift
     ] [
diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index 07342de807..3a8ff3d7a5 100644
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -27,7 +27,7 @@ UNION: #terminal POSTPONE: f #return #values #terminal-merge ;
 GENERIC: linearize* ( node -- next )
 
 : linearize-child ( node -- )
-    [ node@ linearize* ] iterate-nodes ;
+    [ node@ linearize* ] iterate-nodes end-basic-block ;
 
 ! A map from words to linear IR.
 SYMBOL: linearized
@@ -44,9 +44,7 @@ SYMBOL: renamed-labels
 
 : linearize-1 ( word node -- )
     swap [
-        dup stack-reserve %prologue ,
-        linearize-child
-        end-basic-block
+        dup stack-reserve %prologue , linearize-child
     ] make-linear ;
 
 : init-linearizer ( -- )
@@ -61,6 +59,7 @@ SYMBOL: renamed-labels
 M: node linearize* ( node -- next ) drop iterate-next ;
 
 : linearize-call ( label -- next )
+    end-basic-block
     tail-call? [ %jump , f ] [ %call , iterate-next ] if ;
 
 : rename-label ( label -- label )
@@ -86,9 +85,10 @@ M: #label linearize* ( node -- next )
     [ node-param "if-intrinsic" word-prop ] [ drop f ] if ;
 
 : linearize-if ( node label -- next )
-    <label> dup >r >r >r node-children first2 linearize-child
-    r> r> %jump-label , %label , linearize-child r> %label ,
-    iterate-next ;
+    <label> [
+        >r >r node-children first2 linearize-child
+        r> r> %jump-label , %label , linearize-child
+    ] keep %label , iterate-next ;
 
 M: #call linearize* ( node -- next )
     dup if-intrinsic [
@@ -128,17 +128,16 @@ SYMBOL: live-r
 : shuffle-height ( node -- )
     [ dup node-out-d length swap node-in-d length - ] keep
     dup node-out-r length swap node-in-r length -
-    adjust-stacks end-basic-block ;
+    adjust-stacks ;
 
 M: #shuffle linearize* ( #shuffle -- )
-    [
-        0 vreg-allocator set
-        dup node-in-d over node-out-d live-stores live-d set
-        dup node-in-r over node-out-r live-stores live-r set
-        dup do-inputs
-        shuffle-height
-        live-d get live-r get template-outputs
-    ] with-scope iterate-next ;
+    0 vreg-allocator set
+    dup node-in-d over node-out-d live-stores live-d set
+    dup node-in-r over node-out-r live-stores live-r set
+    dup do-inputs
+    shuffle-height
+    live-d get live-r get template-outputs
+    iterate-next ;
 
 : ?static-branch ( node -- n )
     node-in-d first dup value?
@@ -146,10 +145,11 @@ M: #shuffle linearize* ( #shuffle -- )
 
 M: #if linearize* ( node -- next )
     dup ?static-branch [
-        -1 0 adjust-stacks end-basic-block
+        -1 0 adjust-stacks
         swap node-children nth linearize-child iterate-next
     ] [
         dup { { 0 "flag" } } { } [
+            end-basic-block
             <label> dup "flag" get %jump-t ,
         ] with-template linearize-if
     ] if* ;
@@ -157,12 +157,14 @@ M: #if linearize* ( node -- next )
 : dispatch-head ( node -- label/node )
     #! Output the jump table insn and return a list of
     #! label/branch pairs.
-    dup { { 0 "n" } } { } [ "n" get %dispatch , ] with-template
+    dup { { 0 "n" } } { }
+    [ end-basic-block "n" get %dispatch , ] with-template
     node-children [ <label> dup %target-label ,  2array ] map ;
 
 : dispatch-body ( label/node -- )
     <label> swap [
-        first2 %label , linearize-child dup %jump-label ,
+        first2 %label , linearize-child end-basic-block
+        dup %jump-label ,
     ] each %label , ;
 
 M: #dispatch linearize* ( node -- next )
@@ -170,4 +172,4 @@ M: #dispatch linearize* ( node -- next )
     #! take in case the top of stack has that type.
     dispatch-head dispatch-body iterate-next ;
 
-M: #return linearize* drop %return , f ;
+M: #return linearize* drop end-basic-block %return , f ;
diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index d1b1207311..19326f2e6c 100644
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -11,13 +11,13 @@ SYMBOL: r-height
 TUPLE: ds-loc n ;
 
 C: ds-loc ( n -- ds-loc ) 
-    [ >r d-height get + r> set-ds-loc-n ] keep ;
+    [ >r d-height get - r> set-ds-loc-n ] keep ;
 
 ! A call stack location.
 TUPLE: cs-loc n ;
 
 C: cs-loc ( n -- ds-loc ) 
-    [ >r r-height get + r> set-cs-loc-n ] keep ;
+    [ >r r-height get - r> set-cs-loc-n ] keep ;
 
 : adjust-stacks ( inc-d inc-r -- )
     r-height [ + ] change d-height [ + ] change ;
@@ -95,14 +95,11 @@ SYMBOL: any-reg
 SYMBOL: template-height
 
 : with-template ( node in out quot -- )
-    [
-        0 vreg-allocator set
-        pick length pick length swap - template-height set
-        swap >r >r
-        >r dup node-in-d r> { } { } template-inputs
-        template-height get 0 adjust-stacks end-basic-block
-         node set r> call r> { } template-outputs
-    ] with-scope ; inline
+    pick length pick length swap - template-height set
+    swap >r >r
+    >r dup node-in-d r> { } { } template-inputs
+    template-height get 0 adjust-stacks
+    node set r> call r> { } template-outputs ; inline
 
 : literals/computed ( stack -- literals computed )
     dup [ dup value? [ drop f ] unless ] map
diff --git a/library/compiler/vops.factor b/library/compiler/vops.factor
index 707d313b90..83a77e36fd 100644
--- a/library/compiler/vops.factor
+++ b/library/compiler/vops.factor
@@ -82,12 +82,6 @@ TUPLE: vop inputs outputs label ;
 : output-operand ( n -- n ) output v>operand ;
 : label ( -- label ) vop get vop-label ;
 
-GENERIC: basic-block? ( vop -- ? )
-M: vop basic-block? drop f ;
-
-! simplifies some code
-M: f basic-block? drop f ;
-
 : make-vop ( inputs outputs label vop -- vop )
     [ >r <vop> r> set-delegate ] keep ;
 
@@ -148,22 +142,18 @@ C: %target-label make-vop ;
 TUPLE: %peek ;
 C: %peek make-vop ;
 : %peek swap src/dest-vop <%peek> ;
-M: %peek basic-block? drop t ;
 
 TUPLE: %replace ;
 C: %replace make-vop ;
 : %replace ( vreg loc -- vop ) src/dest-vop <%replace> ;
-M: %replace basic-block? drop t ;
 
 TUPLE: %inc-d ;
 C: %inc-d make-vop ;
 : %inc-d ( n -- node ) src-vop <%inc-d> ;
-M: %inc-d basic-block? drop t ;
 
 TUPLE: %inc-r ;
 C: %inc-r make-vop ;
 : %inc-r ( n -- ) src-vop <%inc-r> ;
-M: %inc-r basic-block? drop t ;
 
 TUPLE: %immediate ;
 C: %immediate make-vop ;
@@ -171,25 +161,20 @@ C: %immediate make-vop ;
 : %immediate ( obj vreg -- vop )
     src/dest-vop <%immediate> ;
 
-M: %immediate basic-block? drop t ;
-
 ! indirect load of a literal through a table
 TUPLE: %indirect ;
 C: %indirect make-vop ;
 : %indirect ( obj vreg -- )
     src/dest-vop <%indirect> ;
-M: %indirect basic-block? drop t ;
 
 ! object slot accessors
 TUPLE: %untag ;
 C: %untag make-vop ;
 : %untag dest-vop <%untag> ;
-M: %untag basic-block? drop t ;
 
 TUPLE: %slot ;
 C: %slot make-vop ;
 : %slot ( n vreg ) 2-vop <%slot> ;
-M: %slot basic-block? drop t ;
 
 : set-slot-vop
     [ 3array ] keep 1array f ;
@@ -201,28 +186,23 @@ C: %set-slot make-vop ;
     #! %set-slot writes to vreg obj.
     set-slot-vop <%set-slot> ;
 
-M: %set-slot basic-block? drop t ;
-
 ! in the 'fast' versions, the object's type and slot number is
 ! known at compile time, so these become a single instruction
 TUPLE: %fast-slot ;
 C: %fast-slot make-vop ;
 : %fast-slot ( n vreg )
     2-vop <%fast-slot> ;
-M: %fast-slot basic-block? drop t ;
 
 TUPLE: %fast-set-slot ;
 C: %fast-set-slot make-vop ;
 : %fast-set-slot ( value obj n )
     #! %fast-set-slot writes to vreg obj.
     over >r 3array r> 1array f <%fast-set-slot> ;
-M: %fast-set-slot basic-block? drop t ;
 
 ! Char readers and writers
 TUPLE: %char-slot ;
 C: %char-slot make-vop ;
 : %char-slot ( n vreg ) 2-vop <%char-slot> ;
-M: %char-slot basic-block? drop t ;
 
 TUPLE: %set-char-slot ;
 C: %set-char-slot make-vop ;
@@ -231,8 +211,6 @@ C: %set-char-slot make-vop ;
     #! %set-char-slot writes to vreg obj.
     set-slot-vop <%set-char-slot> ;
 
-M: %set-char-slot basic-block? drop t ;
-
 TUPLE: %write-barrier ;
 C: %write-barrier make-vop ;
 : %write-barrier ( ptr ) dest-vop <%write-barrier> ;
@@ -253,19 +231,15 @@ C: %fixnum/mod make-vop ;    : %fixnum/mod f <%fixnum/mod> ;
 
 TUPLE: %fixnum-bitand ;
 C: %fixnum-bitand make-vop ; : %fixnum-bitand 3-vop <%fixnum-bitand> ;
-M: %fixnum-bitand basic-block? drop t ;
 
 TUPLE: %fixnum-bitor ;
 C: %fixnum-bitor make-vop ;  : %fixnum-bitor 3-vop <%fixnum-bitor> ;
-M: %fixnum-bitor basic-block? drop t ;
 
 TUPLE: %fixnum-bitxor ;
 C: %fixnum-bitxor make-vop ; : %fixnum-bitxor 3-vop <%fixnum-bitxor> ;
-M: %fixnum-bitxor basic-block? drop t ;
 
 TUPLE: %fixnum-bitnot ;
 C: %fixnum-bitnot make-vop ; : %fixnum-bitnot 2-vop <%fixnum-bitnot> ;
-M: %fixnum-bitnot basic-block? drop t ;
 
 ! At the VOP level, the 'shift' operation is split into four
 ! distinct operations:
@@ -276,13 +250,11 @@ M: %fixnum-bitnot basic-block? drop t ;
 ! - shifts with a large negative count: %fixnum-sgn
 TUPLE: %fixnum>> ;
 C: %fixnum>> make-vop ;   : %fixnum>>   3-vop <%fixnum>>> ;
-M: %fixnum>> basic-block? drop t ;
 
 ! due to x86 limitations the destination of this VOP must be
 ! vreg 2 (EDX), and the source must be vreg 0 (EAX).
 TUPLE: %fixnum-sgn ;
 C: %fixnum-sgn make-vop ; : %fixnum-sgn src/dest-vop <%fixnum-sgn> ;
-M: %fixnum-sgn basic-block? drop t ;
 
 ! Integer comparison followed by a conditional branch is
 ! optimized
@@ -314,12 +286,10 @@ C: %type make-vop ;
 TUPLE: %tag ;
 C: %tag make-vop ;
 : %tag ( vreg ) dest-vop <%tag> ;
-M: %tag basic-block? drop t ;
 
 TUPLE: %getenv ;
 C: %getenv make-vop ;
 : %getenv src/dest-vop <%getenv> ;
-M: %getenv basic-block? drop t ;
 
 TUPLE: %setenv ;
 C: %setenv make-vop ;

From 2479ef1d5dff7cc3e14906e39b016b994a2fdeb4 Mon Sep 17 00:00:00 2001
From: "wayo.cavazos" <wayo.cavazos@gmail.com>
Date: Sat, 25 Feb 2006 06:01:51 +0000
Subject: [PATCH 013/112] set-error-handler in x.factor

---
 contrib/x11/x.factor | 13 ++++++++++++-
 1 file changed, 12 insertions(+), 1 deletion(-)

diff --git a/contrib/x11/x.factor b/contrib/x11/x.factor
index 9e63f83281..1396cdd149 100644
--- a/contrib/x11/x.factor
+++ b/contrib/x11/x.factor
@@ -1,5 +1,6 @@
+USING: namespaces kernel compiler math arrays strings alien sequences
+xlib rectangle ;
 
-USING: namespaces kernel math arrays strings alien sequences xlib rectangle ;
 IN: x 
 
 SYMBOL: dpy
@@ -238,6 +239,16 @@ dpy get "XEvent" <c-object> dup >r XNextEvent drop r> ;
 
 : events-queued ( mode -- n ) >r dpy get r> XEventsQueued ;
 
+! 11.8 - Handling Protocol Errors
+
+SYMBOL: error-handler-quot
+
+: error-handler-callback ( -- xt ) "void" { "Display*" "XErrorEvent*" }
+[ error-handler-quot get call ] alien-callback ; compiled
+
+: set-error-handler ( quot -- )
+error-handler-quot set error-handler-callback XSetErrorHandler drop ;
+
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! 12 - Input Device Functions
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

From b3cda2a3c91ffe0f942c64ee85e0e8863e93c50d Mon Sep 17 00:00:00 2001
From: "wayo.cavazos" <wayo.cavazos@gmail.com>
Date: Sat, 25 Feb 2006 06:05:41 +0000
Subject: [PATCH 014/112] Use set-error-handler

---
 contrib/factory/factory.factor | 9 +--------
 1 file changed, 1 insertion(+), 8 deletions(-)

diff --git a/contrib/factory/factory.factor b/contrib/factory/factory.factor
index fe0b6a34fd..b1fb504511 100644
--- a/contrib/factory/factory.factor
+++ b/contrib/factory/factory.factor
@@ -591,16 +591,9 @@ SYMBOL: window-list
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: xlib-error-handler ( -- xt ) "void" { "Display*" "XErrorEvent*" }
-[ "X11 : error-handler called" print flush ] alien-callback ; compiled
-
-: install-error-handler ( -- ) xlib-error-handler XSetErrorHandler drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 : start-factory ( dpy-string -- )
   initialize-x
-  install-error-handler
+  [ "X11 : error-handler called" print flush ] set-error-handler
   root get [ make-drag-gc ] with-win drag-gc set
   root get [ black-pixel get set-window-background clear-window ] with-win
   root get create-wm-root

From f8b688220dae0f9af144fcb8cbfe4c75ba743570 Mon Sep 17 00:00:00 2001
From: "wayo.cavazos" <wayo.cavazos@gmail.com>
Date: Sat, 25 Feb 2006 06:06:30 +0000
Subject: [PATCH 015/112] Minor formatting fix in Factory

---
 contrib/factory/factory.factor | 16 ++++++++--------
 1 file changed, 8 insertions(+), 8 deletions(-)

diff --git a/contrib/factory/factory.factor b/contrib/factory/factory.factor
index b1fb504511..b6c48d2ebb 100644
--- a/contrib/factory/factory.factor
+++ b/contrib/factory/factory.factor
@@ -558,15 +558,15 @@ SYMBOL: window-list
 : not-transient? ( frame -- ? ) wm-frame-child get-transient-for-hint% not ;
 
 : add-window-to-list ( window-list frame -- window-list )
-  dup					! window-list frame frame
-  wm-frame-child			! window-list frame child
-  fetch-name%				! window-list frame name-or-f
-  dup					! window-list frame name-or-f name-or-f
+  dup				! window-list frame frame
+  wm-frame-child		! window-list frame child
+  fetch-name%			! window-list frame name-or-f
+  dup				! window-list frame name-or-f name-or-f
   [ ] [ drop "*untitled*" ] if	! window-list frame name
-  swap					! window-list name frame
-  [ map-window% ]			! window-list name frame [ map-window% ]
-  cons					! window-list name action
-  pick					! window-list name action window-list
+  swap				! window-list name frame
+  [ map-window% ]		! window-list name frame [ map-window% ]
+  cons				! window-list name action
+  pick				! window-list name action window-list
   add-popup-menu-item ;
 
 : refresh-window-list ( window-list -- )

From bef109fda5fb59bff6fefa94610d542f9d65c35a Mon Sep 17 00:00:00 2001
From: "wayo.cavazos" <wayo.cavazos@gmail.com>
Date: Thu, 16 Mar 2006 07:49:39 +0000
Subject: [PATCH 016/112] Minor formatting in concurrent-widgets.factor

---
 contrib/x11/concurrent-widgets.factor | 30 +++++++++++++--------------
 1 file changed, 15 insertions(+), 15 deletions(-)

diff --git a/contrib/x11/concurrent-widgets.factor b/contrib/x11/concurrent-widgets.factor
index 81fb535354..4593787067 100644
--- a/contrib/x11/concurrent-widgets.factor
+++ b/contrib/x11/concurrent-widgets.factor
@@ -58,21 +58,21 @@ GENERIC: handle-property-event
 
 : handle-event ( event obj -- )
   over XAnyEvent-type
-  { { [ dup Expose = ]			[ drop handle-expose-event ] }
-    { [ dup KeyPress = ]		[ drop handle-key-press-event ] }
-    { [ dup KeyRelease = ]		[ drop handle-key-release-event ] }
-    { [ dup ButtonPress = ]		[ drop handle-button-press-event ] }
-    { [ dup ButtonRelease = ]		[ drop handle-button-release-event ] }
-    { [ dup ConfigureNotify = ]		[ drop handle-configure-event ] }
-    { [ dup EnterNotify = ]		[ drop handle-enter-window-event ] }
-    { [ dup LeaveNotify = ]		[ drop handle-leave-window-event ] }
-    { [ dup DestroyNotify = ]		[ drop handle-destroy-window-event ] }
-    { [ dup MapRequest = ]		[ drop handle-map-request-event ] }
-    { [ dup MapNotify = ]		[ drop handle-map-event ] }
-    { [ dup ConfigureRequest = ]	[ drop handle-configure-request-event ] }
-    { [ dup UnmapNotify = ]		[ drop handle-unmap-event ] }
-    { [ dup PropertyNotify = ]		[ drop handle-property-event ] }
-    { [ t ]                [ "handle-event ignoring event" print flush 3drop ] } }
+  { { [ dup Expose = ]		 [ drop handle-expose-event ] }
+    { [ dup KeyPress = ]	 [ drop handle-key-press-event ] }
+    { [ dup KeyRelease = ]	 [ drop handle-key-release-event ] }
+    { [ dup ButtonPress = ]	 [ drop handle-button-press-event ] }
+    { [ dup ButtonRelease = ]	 [ drop handle-button-release-event ] }
+    { [ dup ConfigureNotify = ]	 [ drop handle-configure-event ] }
+    { [ dup EnterNotify = ]	 [ drop handle-enter-window-event ] }
+    { [ dup LeaveNotify = ]	 [ drop handle-leave-window-event ] }
+    { [ dup DestroyNotify = ]	 [ drop handle-destroy-window-event ] }
+    { [ dup MapRequest = ]	 [ drop handle-map-request-event ] }
+    { [ dup MapNotify = ]	 [ drop handle-map-event ] }
+    { [ dup ConfigureRequest = ] [ drop handle-configure-request-event ] }
+    { [ dup UnmapNotify = ]      [ drop handle-unmap-event ] }
+    { [ dup PropertyNotify = ]   [ drop handle-property-event ] }
+    { [ t ] [ "handle-event ignoring event" print flush 3drop ] } }
   cond ;
 
 M: window handle-configure-event ( event obj -- )

From 4f79e3286e28e335757f4160264ee5756430c06e Mon Sep 17 00:00:00 2001
From: "wayo.cavazos" <wayo.cavazos@gmail.com>
Date: Thu, 16 Mar 2006 07:53:43 +0000
Subject: [PATCH 017/112] Minor formatting in xlib.factor

---
 contrib/x11/xlib.factor | 20 +++++++++-----------
 1 file changed, 9 insertions(+), 11 deletions(-)

diff --git a/contrib/x11/xlib.factor b/contrib/x11/xlib.factor
index 0033cab2d6..cee2494505 100644
--- a/contrib/x11/xlib.factor
+++ b/contrib/x11/xlib.factor
@@ -475,8 +475,8 @@ FUNCTION: Status XKillClient ( Display* display, XID resource ) ;
 : FocusIn			9 ;
 : FocusOut		10 ;
 : KeymapNotify		11 ;
-: Expose			12 ;
-: GraphicsExpose		13 ;
+: Expose		12 ;
+: GraphicsExpose	13 ;
 : NoExpose		14 ;
 : VisibilityNotify	15 ;
 : CreateNotify		16 ;
@@ -484,24 +484,22 @@ FUNCTION: Status XKillClient ( Display* display, XID resource ) ;
 : UnmapNotify		18 ;
 : MapNotify		19 ;
 : MapRequest		20 ;
-: ReparentNotify		21 ;
-: ConfigureNotify		22 ;
+: ReparentNotify	21 ;
+: ConfigureNotify	22 ;
 : ConfigureRequest	23 ;
 : GravityNotify		24 ;
 : ResizeRequest		25 ;
-: CirculateNotify		26 ;
+: CirculateNotify	26 ;
 : CirculateRequest	27 ;
-: PropertyNotify		28 ;
-: SelectionClear		29 ;
+: PropertyNotify	28 ;
+: SelectionClear	29 ;
 : SelectionRequest	30 ;
-: SelectionNotify		31 ;
-: ColormapNotify		32 ;
+: SelectionNotify	31 ;
+: ColormapNotify	32 ;
 : ClientMessage		33 ;
 : MappingNotify		34 ;
 : LASTEvent		35 ;
 
-
-
 BEGIN-STRUCT: XAnyEvent
 	FIELD: int type
 	FIELD: ulong serial

From abdee3dbb371b29f0c637a09fae6a7a81d8f753c Mon Sep 17 00:00:00 2001
From: "wayo.cavazos" <wayo.cavazos@gmail.com>
Date: Fri, 31 Mar 2006 00:50:04 +0000
Subject: [PATCH 018/112] documentation fixes

---
 doc/handbook/streams.facts | 4 +---
 1 file changed, 1 insertion(+), 3 deletions(-)

diff --git a/doc/handbook/streams.facts b/doc/handbook/streams.facts
index 16bf07225a..bb66229cba 100644
--- a/doc/handbook/streams.facts
+++ b/doc/handbook/streams.facts
@@ -24,7 +24,7 @@ GLOSSARY: "output stream" "an object responding to the output words of the " { $
 GLOSSARY: "bidirectional stream" "an object that is both an input and output stream" ;
 
 ARTICLE: "stream-protocol" "Stream protocol"
-"The stream protocol consits of a large number of generic words, many of which are optional."
+"The stream protocol consists of a large number of generic words, many of which are optional."
 $terpri
 "A word required to be implemented for all streams:"
 { $subsection stream-close }
@@ -86,8 +86,6 @@ ARTICLE: "character-styles" "Character styles"
 "Character styles for " { $link stream-format } ":"
 { $subsection foreground }
 { $subsection background }
-{ $subsection foreground }
-{ $subsection background }
 { $subsection font }
 { $subsection font-size }
 { $subsection font-style }

From 05ddc35d5c78e517ab1112a7de50fc9eba7a069a Mon Sep 17 00:00:00 2001
From: "wayo.cavazos" <wayo.cavazos@gmail.com>
Date: Fri, 31 Mar 2006 00:53:36 +0000
Subject: [PATCH 019/112] Minor Factory changes

---
 contrib/factory/factory.factor | 13 +++++++++++--
 1 file changed, 11 insertions(+), 2 deletions(-)

diff --git a/contrib/factory/factory.factor b/contrib/factory/factory.factor
index b6c48d2ebb..5568fdf700 100644
--- a/contrib/factory/factory.factor
+++ b/contrib/factory/factory.factor
@@ -151,6 +151,7 @@ TUPLE: wm-root ;
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 M: wm-root handle-map-request-event ( event <wm-root> -- )
+"handle-map-request-event called on wm-root" print flush
   drop XMapRequestEvent-window id>obj				! obj
 
   { { [ dup wm-frame? ]
@@ -164,6 +165,9 @@ M: wm-root handle-map-request-event ( event <wm-root> -- )
         "new window has override_redirect attribute set." print flush
         drop ] }
 
+    { [ dup window-id window-parent+ id>obj wm-frame? ]
+      [ "Window is already managed" print flush drop ] }
+
     { [ t ] [ window-id manage-window ] } }
 
   cond ;
@@ -332,7 +336,9 @@ TUPLE: wm-frame child ;
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : manage-window ( window -- )
+  flush-dpy
   grab-server
+  flush-dpy
 
   create-wm-child				! child
   create-wm-frame				! frame
@@ -360,8 +366,11 @@ TUPLE: wm-frame child ;
   dup map-subwindows%
 
   dup wm-frame-child PropertyChangeMask swap select-input%
-  
-  flush-dpy 0 sync-dpy ungrab-server ;
+
+  flush-dpy
+  0 sync-dpy
+  ungrab-server
+  flush-dpy ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

From d28fd90d4c2e0606f310ec4d8a54aa2e863cb094 Mon Sep 17 00:00:00 2001
From: "wayo.cavazos" <wayo.cavazos@gmail.com>
Date: Fri, 31 Mar 2006 00:54:20 +0000
Subject: [PATCH 020/112] .win word and minor changes

---
 contrib/x11/x.factor    | 103 +++++++++++++++++++++++++++++++++++++---
 contrib/x11/xlib.factor |   2 +-
 2 files changed, 97 insertions(+), 8 deletions(-)

diff --git a/contrib/x11/x.factor b/contrib/x11/x.factor
index 1396cdd149..4242058b4c 100644
--- a/contrib/x11/x.factor
+++ b/contrib/x11/x.factor
@@ -1,5 +1,5 @@
-USING: namespaces kernel compiler math arrays strings alien sequences
-xlib rectangle ;
+USING: namespaces kernel compiler math arrays strings alien sequences io
+prettyprint xlib rectangle ;
 
 IN: x 
 
@@ -134,12 +134,99 @@ DEFER: with-win
 : get-window-attributes ( -- <XWindowAttributes> )
   dpy get win get "XWindowAttributes" <c-object> dup >r XGetWindowAttributes drop r> ;
 
+: window-root get-window-attributes XWindowAttributes-root ;
+
 : window-map-state
   get-window-attributes XWindowAttributes-map_state ;
 
+: window-event-mask
+get-window-attributes XWindowAttributes-your_event_mask ;
+
+: window-all-event-masks
+get-window-attributes XWindowAttributes-all_event_masks ;
+
 : window-override-redirect
   get-window-attributes XWindowAttributes-override_redirect ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: event-masks
+
+{ { "NoEventMask" 0 }
+  { "KeyPressMask" 1 }
+  { "KeyReleaseMask" 2 }
+  { "ButtonPressMask" 4 }
+  { "ButtonReleaseMask" 8 }
+  { "EnterWindowMask" 16 }
+  { "LeaveWindowMask" 32 }
+  { "PointerMotionMask" 64 }
+  { "PointerMotionHintMask" 128 }
+  { "Button1MotionMask" 256 }
+  { "Button2MotionMask" 512 }
+  { "Button3MotionMask" 1024 }
+  { "Button4MotionMask" 2048 }
+  { "Button5MotionMask" 4096 }
+  { "ButtonMotionMask" 8192 }
+  { "KeymapStateMask" 16384 }
+  { "ExposureMask" 32768 }
+  { "VisibilityChangeMask" 65536 }
+  { "StructureNotifyMask" 131072 }
+  { "ResizeRedirectMask" 262144 }
+  { "SubstructureNotifyMask" 524288 }
+  { "SubstructureRedirectMask" 1048576 }
+  { "FocusChangeMask" 2097152 }
+  { "PropertyChangeMask" 4194304 }
+  { "ColormapChangeMask" 8388608 }
+  { "OwnerGrabButtonMask" 16777216 }
+} event-masks set-global
+
+: bit-test ( a b -- t-or-f ) bitand 0 = not ;
+  
+: name>event-mask ( str -- i )
+event-masks get [ first over = ] find 2nip second ;
+
+: event-mask>name ( i -- str )
+event-masks get [ second over = ] find 2nip first ;
+
+: event-mask-names ( -- seq ) event-masks get [ first ] map ;
+
+: event-mask>names ( mask -- seq )
+event-mask-names [ name>event-mask bit-test ] subset-with ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Pretty printing window information
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: print-field ( name value -- ) swap "=" append write pprint ;
+
+: spc ( -- ) " " write ;
+
+: print-window-geometry ( -- )
+window-width pprint "x" write window-height pprint "+" write
+window-x pprint "+" write window-y pprint ;
+
+: print-map-state ( -- )
+"map-state=" write
+window-map-state
+{ { [ dup 0 = ] [ drop "IsUnmapped" write ] }
+  { [ dup 1 = ] [ drop "IsUnviewable" write ] }
+  { [ dup 2 = ] [ drop "IsViewable" write ] }
+} cond ;
+
+: print-window-info ( -- )
+"id" win get print-field spc
+"parent" window-parent print-field spc
+"root" window-root print-field spc
+print-window-geometry terpri
+"children" window-children print-field terpri
+"override-redirect" window-override-redirect print-field spc
+print-map-state terpri
+"event-mask" window-event-mask event-mask>names print-field terpri
+"all-event-masks" window-all-event-masks event-mask>names print-field
+terpri ;
+
+: .win print-window-info ;
+
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! 6 - Color Management Functions
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -206,14 +293,15 @@ dup length 1 - [ swap 2nth draw-line ] each-with ;
 
 ! 8.6 - Drawing Text
 
-: draw-string ( { x y } string -- )
-  >r >r dpy get win get gcontext get r> [ ] each r> dup length XDrawString drop ;
+: draw-string ( { x y } string -- ) >r >r
+dpy get win get gcontext get r> [ ] each r> dup length XDrawString drop ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! 9 - Window and Session Manager Functions
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: reparent-window ( parent -- ) >r dpy get win get r> 0 0 XReparentWindow drop ;
+: reparent-window ( parent -- ) >r
+dpy get win get r> 0 0 XReparentWindow drop ;
 
 : add-to-save-set ( -- ) dpy get win get XAddToSaveSet drop ;
 
@@ -257,8 +345,8 @@ error-handler-quot set error-handler-callback XSetErrorHandler drop ;
   >r >r dpy get win get r> r> XSetInputFocus drop ;
 
 : grab-pointer ( mask -- )
-  >r dpy get win get False r> GrabModeAsync GrabModeAsync None None CurrentTime
-  XGrabPointer drop ;
+>r dpy get win get False r> GrabModeAsync GrabModeAsync None None CurrentTime
+XGrabPointer drop ;
 
 : ungrab-pointer ( time -- )
   >r dpy get r> XUngrabPointer drop ;
@@ -295,6 +383,7 @@ error-handler-quot set error-handler-callback XSetErrorHandler drop ;
 : destroy-window+		[ destroy-window ] with-win ;
 : map-window+			[ map-window ] with-win ;
 : unmap-window+			[ unmap-window ] with-win ;
+: window-parent+		[ window-parent ] with-win ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
diff --git a/contrib/x11/xlib.factor b/contrib/x11/xlib.factor
index cee2494505..4bba879a5f 100644
--- a/contrib/x11/xlib.factor
+++ b/contrib/x11/xlib.factor
@@ -472,7 +472,7 @@ FUNCTION: Status XKillClient ( Display* display, XID resource ) ;
 : MotionNotify		6 ;
 : EnterNotify		7 ;
 : LeaveNotify		8 ;
-: FocusIn			9 ;
+: FocusIn		9 ;
 : FocusOut		10 ;
 : KeymapNotify		11 ;
 : Expose		12 ;

From 8eb75c89e4e7fb17d18f1284f6ef2561c09c0ec3 Mon Sep 17 00:00:00 2001
From: "wayo.cavazos" <wayo.cavazos@gmail.com>
Date: Fri, 31 Mar 2006 01:01:26 +0000
Subject: [PATCH 021/112] Remove duplicate of next-event word

---
 library/x11/events.factor | 3 ---
 1 file changed, 3 deletions(-)

diff --git a/library/x11/events.factor b/library/x11/events.factor
index c9ff273430..59519fc681 100644
--- a/library/x11/events.factor
+++ b/library/x11/events.factor
@@ -30,9 +30,6 @@ GENERIC: client-event ( event window -- )
 
 : events-queued ( mode -- n ) >r dpy get r> XEventsQueued ;
 
-: next-event ( -- event )
-    dpy get "XEvent" <c-object> dup >r XNextEvent drop r> ;
-
 : wait-event ( -- event )
     QueuedAfterFlush events-queued 0 >
     [ next-event ] [ ui-step wait-event ] if ;

From 940d3307f5b138044051bbc3ba236c308ad68072 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Wed, 5 Apr 2006 06:43:37 +0000
Subject: [PATCH 022/112] Changes to templating system, re-enabled shuffle
 optimizations

---
 library/compiler/intrinsics.factor      |  14 +--
 library/compiler/linearizer.factor      |  12 +-
 library/compiler/templates.factor       | 140 +++++++++++++-----------
 library/test/compiler/intrinsics.factor |   2 +
 4 files changed, 86 insertions(+), 82 deletions(-)

diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index 80180fabb2..c7cec72b3f 100644
--- a/library/compiler/intrinsics.factor
+++ b/library/compiler/intrinsics.factor
@@ -29,7 +29,7 @@ namespaces sequences words ;
 
 \ slot [
     dup slot@ [
-        { { 0 "obj" } { f "slot" } } { "obj" } [
+        { { 0 "obj" } { value "slot" } } { "obj" } [
             node get slot@ "obj" get %fast-slot ,
         ] with-template
     ] [
@@ -42,7 +42,7 @@ namespaces sequences words ;
 
 \ set-slot [
     dup slot@ [
-        { { 0 "val" } { 1 "obj" } { f "slot" } } { } [
+        { { 0 "val" } { 1 "obj" } { value "slot" } } { } [
             "val" get "obj" get node get slot@ %fast-set-slot ,
         ] with-template
     ] [
@@ -77,14 +77,14 @@ namespaces sequences words ;
 ] "intrinsic" set-word-prop
 
 \ getenv [
-    { { f "env" } } { "out" } [
+    { { value "env" } } { "out" } [
         T{ vreg f 0 } "out" set
         "env" get "out" get %getenv ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ setenv [
-    { { 0 "value" } { f "env" } } { } [
+    { { 0 "value" } { value "env" } } { } [
         "value" get "env" get %setenv ,
     ] with-template
 ] "intrinsic" set-word-prop
@@ -95,7 +95,7 @@ namespaces sequences words ;
 
 : binary-in ( node -- in )
     literal-immediate? fixnum-imm? and
-    { { 0 "x" } { f "y" } } { { 0 "x" } { 1 "y" } } ? ;
+    { { 0 "x" } { value "y" } } { { 0 "x" } { 1 "y" } } ? ;
 
 : (binary-op) ( node in -- )
     { "x" } [
@@ -172,7 +172,7 @@ namespaces sequences words ;
 : slow-shift ( -- ) \ fixnum-shift %call , ;
 
 : negative-shift ( n node -- )
-    { { 0 "x" } { f "n" } } { "out" } [
+    { { 0 "x" } { value "n" } } { "out" } [
         dup cell-bits neg <= [
             drop
             T{ vreg f 2 } "out" set
@@ -185,7 +185,7 @@ namespaces sequences words ;
 
 : fast-shift ( n node -- )
     over zero? [
-        -1 0 adjust-stacks end-basic-block 2drop
+        end-basic-block -1 0 adjust-stacks 2drop
     ] [
         over 0 < [
             negative-shift
diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index 3a8ff3d7a5..ee807e866c 100644
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -38,7 +38,7 @@ SYMBOL: renamed-labels
 
 : make-linear ( word quot -- )
     [
-        0 { d-height r-height } [ set ] each-with
+        init-templates
         swap >r { } make r> linearized get set-hash
     ] with-node-iterator ; inline
 
@@ -125,17 +125,11 @@ SYMBOL: live-r
     #! Avoid storing a value into its former position.
     dup length [ pick ?nth dupd eq? [ drop f ] when ] 2map nip ;
 
-: shuffle-height ( node -- )
-    [ dup node-out-d length swap node-in-d length - ] keep
-    dup node-out-r length swap node-in-r length -
-    adjust-stacks ;
-
 M: #shuffle linearize* ( #shuffle -- )
     0 vreg-allocator set
     dup node-in-d over node-out-d live-stores live-d set
     dup node-in-r over node-out-r live-stores live-r set
-    dup do-inputs
-    shuffle-height
+    do-inputs
     live-d get live-r get template-outputs
     iterate-next ;
 
@@ -145,7 +139,7 @@ M: #shuffle linearize* ( #shuffle -- )
 
 M: #if linearize* ( node -- next )
     dup ?static-branch [
-        -1 0 adjust-stacks
+        end-basic-block -1 0 adjust-stacks
         swap node-children nth linearize-child iterate-next
     ] [
         dup { { 0 "flag" } } { } [
diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index 19326f2e6c..f4c064914e 100644
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -7,30 +7,25 @@ namespaces sequences vectors words ;
 SYMBOL: d-height
 SYMBOL: r-height
 
+! Uncomitted values
+SYMBOL: phantom-d
+SYMBOL: phantom-r
+
+: init-templates
+    0 d-height set 0 r-height set
+    V{ } clone phantom-d set V{ } clone phantom-r set ;
+
 ! A data stack location.
 TUPLE: ds-loc n ;
-
-C: ds-loc ( n -- ds-loc ) 
-    [ >r d-height get - r> set-ds-loc-n ] keep ;
+C: ds-loc [ >r d-height get - r> set-ds-loc-n ] keep ;
 
 ! A call stack location.
 TUPLE: cs-loc n ;
-
-C: cs-loc ( n -- ds-loc ) 
-    [ >r r-height get - r> set-cs-loc-n ] keep ;
+C: cs-loc [ >r r-height get - r> set-cs-loc-n ] keep ;
 
 : adjust-stacks ( inc-d inc-r -- )
     r-height [ + ] change d-height [ + ] change ;
 
-: finalize-stack ( quot symbol -- )
-    [
-        get dup zero? [ 2drop ] [ swap execute , ] if 0
-    ] keep set ; inline
-
-: end-basic-block ( -- )
-    \ %inc-r r-height finalize-stack
-    \ %inc-d d-height finalize-stack ;
-
 : immediate? ( obj -- ? )
     #! fixnums and f have a pointerless representation, and
     #! are compiled immediately. Everything else can be moved
@@ -40,73 +35,86 @@ C: cs-loc ( n -- ds-loc )
 : load-literal ( obj vreg -- )
     over immediate? [ %immediate ] [ %indirect ] if , ;
 
-GENERIC: stack>vreg* ( vreg loc value -- operand )
+: literal>stack ( value loc -- )
+    swap value-literal fixnum-imm? over immediate? and
+    [ T{ vreg f 0 } load-literal T{ vreg f 0 } ] unless
+    swap %replace , ; inline
 
-M: object stack>vreg* ( vreg loc value -- operand )
-    drop >r <vreg> dup r> %peek , ;
+G: vreg>stack ( value loc -- ) 1 standard-combination ;
 
-M: value stack>vreg* ( vreg loc value -- operand )
-    nip value-literal swap <vreg> [ load-literal ] keep ;
+M: f vreg>stack ( value loc -- ) 2drop ;
+
+M: value vreg>stack ( value loc -- )
+    swap value-literal fixnum-imm? over immediate? and
+    [ T{ vreg f 0 } load-literal T{ vreg f 0 } ] unless
+    swap %replace , ;
+
+M: object vreg>stack ( value loc -- )
+    %replace , ;
+
+: vregs>stack ( values quot literals -- )
+    -rot >r [ dup value? rot eq? [ drop f ] unless ] map-with
+    dup reverse-slice swap length r> map
+    [ vreg>stack ] 2each ; inline
+
+: finalize-height ( word symbol -- )
+    [ dup zero? [ 2drop ] [ swap execute , ] if 0 ] change ;
+    inline
+
+: end-basic-block ( -- )
+    \ %inc-d d-height finalize-height
+    \ %inc-r r-height finalize-height
+    phantom-d get [ <ds-loc> ] f vregs>stack
+    phantom-r get [ <cs-loc> ] f vregs>stack
+    phantom-d get [ <ds-loc> ] t vregs>stack
+    phantom-r get [ <cs-loc> ] t vregs>stack
+    0 phantom-d get set-length
+    0 phantom-r get set-length ;
+
+G: stack>vreg ( value vreg loc -- operand )
+    2 standard-combination ;
+
+M: f stack>vreg ( value vreg loc -- operand ) 2drop ;
+
+M: object stack>vreg ( value vreg loc -- operand )
+    >r <vreg> dup r> %peek , nip ;
+
+M: value stack>vreg ( value vreg loc -- operand )
+    drop >r value-literal r> dup value eq?
+    [ drop ] [ <vreg> [ load-literal ] keep ] if ;
 
 SYMBOL: vreg-allocator
 
 SYMBOL: any-reg
 
-: alloc-value ( loc value -- operand )
-    vreg-allocator [ inc ] keep get -rot stack>vreg* ;
+: alloc-reg ( template -- template )
+    dup any-reg eq? [
+        drop vreg-allocator dup get swap inc
+    ] when ;
 
-: stack>vreg ( vreg loc value -- operand )
-    {
-        { [ dup not ] [ 3drop f ] }
-        { [ pick any-reg eq? ] [ alloc-value nip ] }
-        { [ pick not ] [ 2nip value-literal ] }
-        { [ t ] [ stack>vreg* ] }
-    } cond ;
+: alloc-regs ( template -- template ) [ alloc-reg ] map ;
 
-: (stack>vregs) ( names values template quot -- inputs )
-    >r dup length reverse r> map 3array flip
-    [ first3 rot stack>vreg ] map swap [ set ] 2each ; inline
+: (stack>vregs) ( values template locs -- inputs )
+    3array flip
+    [ first3 over [ stack>vreg ] [ 3drop f ] if ] map ;
 
 : stack>vregs ( stack template quot -- )
-    >r unpair -rot r> (stack>vregs) ; inline
+    >r unpair -rot alloc-regs dup length reverse r> map
+    (stack>vregs) swap [ set ] 2each ; inline
 
 : template-inputs ( stack template stack template -- )
-    [ <cs-loc> ] stack>vregs [ <ds-loc> ] stack>vregs ;
+    end-basic-block
+    over >r [ <cs-loc> ] stack>vregs
+    over >r [ <ds-loc> ] stack>vregs
+    r> r> [ length neg ] 2apply adjust-stacks ;
 
-: literal>stack ( value stack-pos -- )
-    swap value-literal fixnum-imm? over immediate? and
-    [ T{ vreg f 0 } load-literal T{ vreg f 0 } ] unless
-    swap %replace , ; inline
-
-: vreg>stack ( value stack-pos -- )
-    {
-        { [ over not ] [ 2drop ] }
-        { [ over value? ] [ literal>stack ] }
-        { [ t ] [ >r get r> %replace , ] }
-    } cond ;
-
-: vregs>stack ( values quot -- )
-    >r dup reverse-slice swap length r> map
-    [ vreg>stack ] 2each ; inline
+: >phantom ( seq stack -- )
+    get swap [ dup value? [ get ] unless ] map nappend ;
 
 : template-outputs ( stack stack -- )
-    [ <cs-loc> ] vregs>stack [ <ds-loc> ] vregs>stack ;
-
-SYMBOL: template-height
+    2dup [ length ] 2apply adjust-stacks
+    phantom-r >phantom phantom-d >phantom ;
 
 : with-template ( node in out quot -- )
-    pick length pick length swap - template-height set
-    swap >r >r
-    >r dup node-in-d r> { } { } template-inputs
-    template-height get 0 adjust-stacks
+    swap >r >r >r dup node-in-d r> { } { } template-inputs
     node set r> call r> { } template-outputs ; inline
-
-: literals/computed ( stack -- literals computed )
-    dup [ dup value? [ drop f ] unless ] map
-    swap [ dup value? [ drop f ] when ] map ;
-
-: vregs>stacks ( ds cs -- )
-    #! We store literals last because storing a literal to a
-    #! stack slot actually clobbers a vreg.
-    >r literals/computed r> literals/computed swapd
-    template-outputs template-outputs ;
diff --git a/library/test/compiler/intrinsics.factor b/library/test/compiler/intrinsics.factor
index 78e686f35b..3bdc393f75 100644
--- a/library/test/compiler/intrinsics.factor
+++ b/library/test/compiler/intrinsics.factor
@@ -54,6 +54,8 @@ math-internals sequences strings test words ;
 [ 2 ] [ 1 [ 2 nip ] compile-1 ] unit-test
 [ 2 ] [ 1 2 [ nip ] compile-1 ] unit-test
 
+[ 2 1 "hi" ] [ 1 2 [ swap "hi" ] compile-1 ] unit-test
+
 [ 4 ] [ 12 7 [ fixnum-bitand ] compile-1 ] unit-test
 [ 4 ] [ 12 [ 7 fixnum-bitand ] compile-1 ] unit-test
 [ 4 ] [ [ 12 7 fixnum-bitand ] compile-1 ] unit-test

From ec1890b2b36ad58eaaa1bf0cbdbc36f57b7cb603 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Fri, 7 Apr 2006 00:46:31 +0000
Subject: [PATCH 023/112] Small shuffle optimization cleanup

---
 library/compiler/linearizer.factor | 29 ++++++-----------------------
 library/inference/shuffle.factor   | 25 +++++++++++++++++++++++--
 2 files changed, 29 insertions(+), 25 deletions(-)

diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index ee807e866c..81bfc41ae0 100644
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -102,35 +102,18 @@ M: #call linearize* ( node -- next )
 M: #call-label linearize* ( node -- next )
     node-param renamed-label linearize-call ;
 
-SYMBOL: live-d
-SYMBOL: live-r
-
-: value-dropped? ( value -- ? )
-    dup value?
-    over live-d get member? not
-    rot live-r get member? not and
-    or ;
-
-: filter-dropped ( seq -- seq )
-    [ dup value-dropped? [ drop f ] when ] map ;
-
 : prepare-inputs ( values -- values templates )
-    filter-dropped dup [ any-reg swap 2array ] map ;
+    dup [ any-reg swap 2array ] map ;
 
-: do-inputs ( node -- )
-    dup node-in-d prepare-inputs rot node-in-r prepare-inputs
+: do-inputs ( shuffle -- )
+    dup shuffle-in-d prepare-inputs
+    rot shuffle-in-r prepare-inputs
     template-inputs ;
 
-: live-stores ( instack outstack -- stack )
-    #! Avoid storing a value into its former position.
-    dup length [ pick ?nth dupd eq? [ drop f ] when ] 2map nip ;
-
 M: #shuffle linearize* ( #shuffle -- )
     0 vreg-allocator set
-    dup node-in-d over node-out-d live-stores live-d set
-    dup node-in-r over node-out-r live-stores live-r set
-    do-inputs
-    live-d get live-r get template-outputs
+    node-shuffle dup do-inputs
+    dup shuffle-out-d swap shuffle-out-r template-outputs
     iterate-next ;
 
 : ?static-branch ( node -- n )
diff --git a/library/inference/shuffle.factor b/library/inference/shuffle.factor
index d54267abcc..54f29336e7 100644
--- a/library/inference/shuffle.factor
+++ b/library/inference/shuffle.factor
@@ -3,8 +3,6 @@ USING: hashtables kernel math namespaces sequences ;
 
 TUPLE: shuffle in-d in-r out-d out-r ;
 
-: empty-shuffle { } { } { } { } <shuffle> ;
-
 : load-shuffle ( d r shuffle -- )
     tuck shuffle-in-r [ set ] 2each shuffle-in-d [ set ] 2each ;
 
@@ -59,3 +57,26 @@ M: shuffle clone ( shuffle -- shuffle )
     [ shuffle-out-d clone ] keep
     shuffle-out-r clone
     <shuffle> ;
+
+SYMBOL: live-d
+SYMBOL: live-r
+
+: value-dropped? ( value -- ? )
+    dup value?
+    over live-d get member? not
+    rot live-r get member? not and
+    or ;
+
+: filter-dropped ( seq -- seq )
+    [ dup value-dropped? [ drop f ] when ] map ;
+
+: live-stores ( instack outstack -- stack )
+    #! Avoid storing a value into its former position.
+    dup length [ pick ?nth dupd eq? [ drop f ] when ] 2map nip ;
+
+: trim-shuffle ( shuffle -- shuffle )
+    dup shuffle-in-d over shuffle-out-d live-stores live-d set
+    dup shuffle-in-r over shuffle-out-r live-stores live-r set
+    dup shuffle-in-d filter-dropped
+    swap shuffle-in-r filter-dropped
+    live-d get live-r get <shuffle> ;

From 7f5e240e98f2375bffeef76c5df4d16fd58ea2fb Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sat, 8 Apr 2006 07:13:01 +0000
Subject: [PATCH 024/112] More powerful templating

---
 library/compiler/basic-blocks.factor | 178 ---------------------------
 library/compiler/templates.factor    |  44 +++++--
 2 files changed, 37 insertions(+), 185 deletions(-)
 delete mode 100644 library/compiler/basic-blocks.factor

diff --git a/library/compiler/basic-blocks.factor b/library/compiler/basic-blocks.factor
deleted file mode 100644
index 2510c32880..0000000000
--- a/library/compiler/basic-blocks.factor
+++ /dev/null
@@ -1,178 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
-USING: arrays hashtables kernel lists math namespaces sequences ;
-
-! Optimizations performed here:
-! - combining %inc-d/%inc-r within a single basic block
-! - if a literal is loaded into a vreg but the vreg is
-!   overwritten before being read, the literal load is deleted
-! - if a %replace is writing a vreg to a stack location already
-!   holding that vreg, or a stack location that is not read
-!   before being popped, the %replace is deleted
-! - if a %peek is reading a stack location into a vreg that
-!   already holds that vreg, or if the vreg is overwritten
-!   before being read, the %peek is deleted
-! - removing dead loads of stack locations into vregs
-! - removing dead stores of vregs into stack locations
-
-: vop-in ( vop n -- input ) swap vop-inputs nth ;
-: set-vop-in ( input vop n -- ) swap vop-inputs set-nth ;
-: vop-out ( vop n -- input ) swap vop-outputs nth ;
-: set-vop-out ( output vop n -- ) swap vop-outputs set-nth ;
-
-: (split-blocks) ( n linear -- )
-    2dup length = [
-        dup like , drop
-    ] [
-        2dup nth basic-block? [
-            >r 1+ r> (split-blocks)
-        ] [
-            (cut) >r , 1 r> (cut) >r , 0 r> (split-blocks)
-        ] if
-    ] if ;
-
-: split-blocks ( linear -- blocks )
-    [ 0 swap (split-blocks) ] { } make ;
-
-SYMBOL: d-height
-SYMBOL: r-height
-
-! combining %inc-d/%inc-r
-GENERIC: simplify-stack* ( vop -- )
-
-M: tuple simplify-stack* ( vop -- ) drop ;
-
-: accum-height ( vop var -- )
-    >r dup 0 vop-in r> [ + ] change 0 swap 0 set-vop-in ;
-
-M: %inc-d simplify-stack* ( vop -- ) d-height accum-height ;
-
-M: %inc-r simplify-stack* ( vop -- ) r-height accum-height ;
-
-GENERIC: update-loc ( loc -- loc )
-
-M: ds-loc update-loc ds-loc-n d-height get - <ds-loc> ;
-
-M: cs-loc update-loc cs-loc-n r-height get - <cs-loc> ;
-
-M: %peek simplify-stack* ( vop -- )
-    0 [ vop-in update-loc ] 2keep set-vop-in ;
-
-M: %replace simplify-stack* ( vop -- )
-    0 [ vop-out update-loc ] 2keep set-vop-out ;
-
-: simplify-stack ( block -- )
-    #! Combine all %inc-d/%inc-r into two final ones.
-    #! Destructively modifies the VOPs in the block.
-    [ simplify-stack* ] each ;
-
-: each-tail ( seq quot -- | quot: tail -- )
-    >r dup length [ swap tail-slice ] map-with r> each ; inline
-
-! removing dead loads/stores
-: preserves-location? ( exitcc location vop -- ? )
-    #! If the VOP writes the register, call the loop exit
-    #! continuation with 'f'.
-    {
-        { [ 2dup vop-inputs member? ] [ 3drop t ] }
-        { [ 2dup vop-outputs member? ] [ 2drop f swap continue-with ] }
-        { [ t ] [ 3drop f ] }
-    } cond ;
-
-GENERIC: live@end? ( location -- ? )
-
-M: tuple live@end? drop t ;
-
-M: ds-loc live@end? ds-loc-n d-height get + 0 >= ;
-
-M: cs-loc live@end? cs-loc-n r-height get + 0 >= ;
-
-: location-live? ( location tail -- ? )
-    #! A location is not live if and only if it is overwritten
-    #! before the end of the basic block.
-    [
-        -rot [ >r 2dup r> preserves-location? ] contains?
-        [ dup live@end? ] unless*
-    ] callcc1 2nip ;
-
-! Used for elimination of dead loads from the stack:
-! we keep a map of vregs to ds-loc/cs-loc/f.
-SYMBOL: vreg-contents
-
-GENERIC: trim-dead* ( tail vop -- )
-
-: forget-vregs ( vop -- )
-    vop-outputs [ vreg-contents get remove-hash ] each ;
-
-M: tuple trim-dead* ( tail vop -- ) dup forget-vregs , drop ;
-
-: ?, [ , ] [ drop ] if ;
-
-: simplify-inc ( vop -- ) dup 0 vop-in zero? not ?, ;
-
-M: %inc-d trim-dead* ( tail vop -- ) simplify-inc drop ;
-
-M: %inc-r trim-dead* ( tail vop -- ) simplify-inc drop ;
-
-: live-load? ( tail vop -- ? )
-    #! If the VOP's output location is overwritten before being
-    #! read again, kill the VOP.
-    0 vop-out swap location-live? ;
-
-: remember-peek ( vop -- )
-    dup 0 vop-in swap 0 vop-out vreg-contents get set-hash ;
-
-: redundant-peek? ( vop -- ? )
-    dup 0 vop-in swap 0 vop-out vreg-contents get hash = ;
-
-M: %peek trim-dead* ( tail vop -- )
-    dup redundant-peek? >r tuck live-load? not r> or
-    [ dup remember-peek dup , ] unless drop ;
-
-: redundant-replace? ( vop -- ? )
-    dup 0 vop-out swap 0 vop-in vreg-contents get hash = ;
-
-: forget-stack-loc ( loc -- )
-    #! Forget that any vregs hold this stack location.
-    vreg-contents [ [ nip swap = not ] hash-subset-with ] change ;
-
-: remember-replace ( vop -- )
-    #! If a vreg claims to hold the stack location we are
-    #! writing to, we must forget this fact, since that stack
-    #! location no longer holds this value!
-    dup 0 vop-out forget-stack-loc
-    dup 0 vop-out swap 0 vop-in vreg-contents get set-hash ;
-
-M: %replace trim-dead* ( tail vop -- )
-    dup redundant-replace? >r tuck live-load? not r> or
-    [ dup remember-replace dup , ] unless drop ;
-
-: ?dead-literal dup forget-vregs tuck live-load? ?, ;
-
-M: %immediate trim-dead* ( tail vop -- ) ?dead-literal ;
-
-M: %indirect trim-dead* ( tail vop -- ) ?dead-literal ;
-
-: trim-dead ( block -- )
-    #! Remove dead loads and stores.
-    [ dup first >r 1 swap tail-slice r> trim-dead* ] each-tail ;
-
-: simplify-block ( block -- block )
-    #! Destructively modifies the VOPs in the block.
-    [
-        0 d-height set
-        0 r-height set
-        H{ } clone vreg-contents set
-        dup simplify-stack
-        d-height get %inc-d r-height get %inc-r 2array append
-        trim-dead
-    ] { } make ;
-
-: keep-simplifying ( block -- block )
-    dup length >r simplify-block dup length r> =
-    [ keep-simplifying ] unless ;
-
-: simplify ( blocks -- blocks )
-    #! Simplify basic block IR.
-    [ keep-simplifying ] map ;
diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index f4c064914e..1abc111a1f 100644
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -61,6 +61,9 @@ M: object vreg>stack ( value loc -- )
     [ dup zero? [ 2drop ] [ swap execute , ] if 0 ] change ;
     inline
 
+: reset-stack ( vector -- )
+    0 swap set-length ;
+
 : end-basic-block ( -- )
     \ %inc-d d-height finalize-height
     \ %inc-r r-height finalize-height
@@ -68,8 +71,8 @@ M: object vreg>stack ( value loc -- )
     phantom-r get [ <cs-loc> ] f vregs>stack
     phantom-d get [ <ds-loc> ] t vregs>stack
     phantom-r get [ <cs-loc> ] t vregs>stack
-    0 phantom-d get set-length
-    0 phantom-r get set-length ;
+    phantom-d get reset-stack
+    phantom-r get reset-stack ;
 
 G: stack>vreg ( value vreg loc -- operand )
     2 standard-combination ;
@@ -98,14 +101,41 @@ SYMBOL: any-reg
     3array flip
     [ first3 over [ stack>vreg ] [ 3drop f ] if ] map ;
 
+: phantom-vregs ( phantom template -- )
+    [ second ] map [ set ] 2each ;
+
 : stack>vregs ( stack template quot -- )
-    >r unpair -rot alloc-regs dup length reverse r> map
-    (stack>vregs) swap [ set ] 2each ; inline
+    >r dup [ first ] map swapd alloc-regs
+    dup length reverse r> map
+    (stack>vregs) swap phantom-vregs ; inline
+
+: compatible-vreg?
+    swap dup value? [ 2drop t ] [ vreg-n = ] if ;
+
+: compatible-values? ( value template -- ? )
+    {
+        { [ dup any-reg eq? ] [ 2drop t ] }
+        { [ dup integer? ] [ compatible-vreg? ] }
+        { [ dup value eq? ] [ drop value? ] }
+    } cond ;
+
+: template-match? ( phantom template -- ? )
+    2dup [ length ] 2apply = [
+        f [ first compatible-values? and ] 2reduce
+    ] [
+        2drop f
+    ] if ;
+
+: template-input ( values template phantom quot -- )
+    >r swap [ template-match? ] 2keep rot [
+        rot r> 2drop over >r phantom-vregs r> reset-stack
+    ] [
+        nip end-basic-block r> stack>vregs
+    ] if ; inline
 
 : template-inputs ( stack template stack template -- )
-    end-basic-block
-    over >r [ <cs-loc> ] stack>vregs
-    over >r [ <ds-loc> ] stack>vregs
+    over >r phantom-r get [ <cs-loc> ] template-input
+    over >r phantom-d get [ <ds-loc> ] template-input
     r> r> [ length neg ] 2apply adjust-stacks ;
 
 : >phantom ( seq stack -- )

From 5279cd99bcdc47df817461ec4b802c739a81f917 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sat, 8 Apr 2006 20:46:47 +0000
Subject: [PATCH 025/112] Debugging compiler

---
 library/compiler/templates.factor | 39 ++++++++++++++++++++++---------
 library/inference/dataflow.factor | 20 ----------------
 library/inference/shuffle.factor  | 22 +++++++++++++++++
 3 files changed, 50 insertions(+), 31 deletions(-)

diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index 1abc111a1f..c5ee0fcf4b 100644
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -4,6 +4,22 @@ IN: compiler
 USING: arrays generic inference kernel math
 namespaces sequences vectors words ;
 
+! TUPLE: phantom-stack height elements ;
+! 
+! GENERIC: <loc> ( n stack -- loc )
+! 
+! TUPLE: phantom-datastack ;
+! 
+! C: phantom-datastack [ >r <phantom-stack> r> ] set-delegate ;
+! 
+! M: phantom-datastack <loc> drop <ds-loc> ;
+! 
+! TUPLE: phantom-callstack ;
+! 
+! C: phantom-callstack [ >r <phantom-stack> r> ] set-delegate ;
+! 
+! M: phantom-callstack <loc> drop <cs-loc> ;
+
 SYMBOL: d-height
 SYMBOL: r-height
 
@@ -35,11 +51,6 @@ C: cs-loc [ >r r-height get - r> set-cs-loc-n ] keep ;
 : load-literal ( obj vreg -- )
     over immediate? [ %immediate ] [ %indirect ] if , ;
 
-: literal>stack ( value loc -- )
-    swap value-literal fixnum-imm? over immediate? and
-    [ T{ vreg f 0 } load-literal T{ vreg f 0 } ] unless
-    swap %replace , ; inline
-
 G: vreg>stack ( value loc -- ) 1 standard-combination ;
 
 M: f vreg>stack ( value loc -- ) 2drop ;
@@ -83,8 +94,11 @@ M: object stack>vreg ( value vreg loc -- operand )
     >r <vreg> dup r> %peek , nip ;
 
 M: value stack>vreg ( value vreg loc -- operand )
-    drop >r value-literal r> dup value eq?
-    [ drop ] [ <vreg> [ load-literal ] keep ] if ;
+    drop dup value eq? [
+        drop
+    ] [
+        >r value-literal r> <vreg> [ load-literal ] keep
+    ] if ;
 
 SYMBOL: vreg-allocator
 
@@ -102,7 +116,9 @@ SYMBOL: any-reg
     [ first3 over [ stack>vreg ] [ 3drop f ] if ] map ;
 
 : phantom-vregs ( phantom template -- )
-    [ second ] map [ set ] 2each ;
+    >r [ dup value? [ value-literal ] when ] map r>
+    [ second ] map
+    [ set ] 2each ;
 
 : stack>vregs ( stack template quot -- )
     >r dup [ first ] map swapd alloc-regs
@@ -110,18 +126,19 @@ SYMBOL: any-reg
     (stack>vregs) swap phantom-vregs ; inline
 
 : compatible-vreg?
-    swap dup value? [ 2drop t ] [ vreg-n = ] if ;
+    swap dup value? [ 2drop f ] [ vreg-n = ] if ;
 
 : compatible-values? ( value template -- ? )
     {
-        { [ dup any-reg eq? ] [ 2drop t ] }
+        { [ dup any-reg eq? ] [ drop vreg? ] }
         { [ dup integer? ] [ compatible-vreg? ] }
         { [ dup value eq? ] [ drop value? ] }
+        { [ dup not ] [ 2drop t ] }
     } cond ;
 
 : template-match? ( phantom template -- ? )
     2dup [ length ] 2apply = [
-        f [ first compatible-values? and ] 2reduce
+        t [ first compatible-values? and ] 2reduce
     ] [
         2drop f
     ] if ;
diff --git a/library/inference/dataflow.factor b/library/inference/dataflow.factor
index 263be79353..b5b3dbb34e 100644
--- a/library/inference/dataflow.factor
+++ b/library/inference/dataflow.factor
@@ -4,26 +4,6 @@ IN: inference
 USING: arrays generic hashtables interpreter kernel lists math
 namespaces parser sequences words ;
 
-! Recursive state. An alist, mapping words to labels.
-SYMBOL: recursive-state
-
-: <computed> \ <computed> counter ;
-
-TUPLE: value uid literal recursion ;
-
-C: value ( obj -- value )
-    <computed> over set-value-uid
-    recursive-state get over set-value-recursion
-    [ set-value-literal ] keep ;
-
-M: value hashcode value-uid ;
-
-M: value = eq? ;
-
-M: integer value-uid ;
-
-M: integer value-recursion drop f ;
-
 ! The dataflow IR is the first of the two intermediate
 ! representations used by Factor. It annotates concatenative
 ! code with stack flow information and types.
diff --git a/library/inference/shuffle.factor b/library/inference/shuffle.factor
index 54f29336e7..d65af168ab 100644
--- a/library/inference/shuffle.factor
+++ b/library/inference/shuffle.factor
@@ -1,6 +1,28 @@
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 IN: inference
 USING: hashtables kernel math namespaces sequences ;
 
+! Recursive state. An alist, mapping words to labels.
+SYMBOL: recursive-state
+
+: <computed> \ <computed> counter ;
+
+TUPLE: value uid literal recursion ;
+
+C: value ( obj -- value )
+    <computed> over set-value-uid
+    recursive-state get over set-value-recursion
+    [ set-value-literal ] keep ;
+
+M: value hashcode value-uid ;
+
+M: value = eq? ;
+
+M: integer value-uid ;
+
+M: integer value-recursion drop f ;
+
 TUPLE: shuffle in-d in-r out-d out-r ;
 
 : load-shuffle ( d r shuffle -- )

From 0989004dd2d2bd592ae9c67eac28a9dbd1c5c29a Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sun, 9 Apr 2006 23:14:30 +0000
Subject: [PATCH 026/112] Minor launcher fixes

---
 TODO.FACTOR.txt     | 1 +
 native/factor.c     | 6 +++++-
 native/macosx/run.m | 3 +--
 3 files changed, 7 insertions(+), 3 deletions(-)

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 6930251b8f..16af9a48d9 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -6,6 +6,7 @@ should fix in 0.82:
 - when generating a 32-bit image on a 64-bit system, large numbers which should
   be bignums become fixnums
 - httpd fep
+- SBUF" " i/o bug
 - clicks sent twice
 - speed up ideas:
   - only do clipping for certain gadgets
diff --git a/native/factor.c b/native/factor.c
index 6e4f31389b..4ddac15031 100644
--- a/native/factor.c
+++ b/native/factor.c
@@ -64,6 +64,7 @@ int main(int argc, char** argv)
 	CELL literal_size = 128;
 	CELL args;
 	CELL i;
+	bool image_given = true;
 
 	early_init();
 
@@ -88,7 +89,10 @@ int main(int argc, char** argv)
 	}
 
 	if(image == NULL)
+	{
+		image_given = false;
 		image = default_image_path();
+	}
 
 	init_factor(image,
 		ds_size * 1024,
@@ -100,7 +104,7 @@ int main(int argc, char** argv)
 		literal_size * 1024);
 
 	args = F;
-	while(--argc > 1)
+	while(--argc > (image_given ? 1 : 0))
 	{
 		args = cons(tag_object(from_c_string(argv[argc])),args);
 	}
diff --git a/native/macosx/run.m b/native/macosx/run.m
index 5545dac8ae..6e4d69ce2e 100644
--- a/native/macosx/run.m
+++ b/native/macosx/run.m
@@ -42,7 +42,6 @@ void early_init(void)
 const char *default_image_path(void)
 {
 	NSBundle *bundle = [NSBundle mainBundle];
-	NSString *path = [bundle bundlePath];
-	NSString *image = [path stringByAppendingString:@"/Contents/Resources/factor.image"];
+	NSString *image = [[bundle resourcePath] stringByAppendingString:@"/factor.image"];
 	return [image cString];
 }

From 4b9d87f85f513677bc2a65dc4eebd39cdcac964c Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Mon, 10 Apr 2006 02:23:00 +0000
Subject: [PATCH 027/112] New phantom stack abstraction

---
 library/compiler/templates.factor | 165 +++++++++++++++++++-----------
 1 file changed, 104 insertions(+), 61 deletions(-)

diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index c5ee0fcf4b..dc57e1f493 100644
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -4,43 +4,87 @@ IN: compiler
 USING: arrays generic inference kernel math
 namespaces sequences vectors words ;
 
-! TUPLE: phantom-stack height elements ;
-! 
-! GENERIC: <loc> ( n stack -- loc )
-! 
-! TUPLE: phantom-datastack ;
-! 
-! C: phantom-datastack [ >r <phantom-stack> r> ] set-delegate ;
-! 
-! M: phantom-datastack <loc> drop <ds-loc> ;
-! 
-! TUPLE: phantom-callstack ;
-! 
-! C: phantom-callstack [ >r <phantom-stack> r> ] set-delegate ;
-! 
-! M: phantom-callstack <loc> drop <cs-loc> ;
+TUPLE: phantom-stack height elements ;
 
-SYMBOL: d-height
-SYMBOL: r-height
+C: phantom-stack ( -- stack )
+    0 over set-phantom-stack-height
+    V{ } clone over set-phantom-stack-elements ;
+
+: phantom-length ( phantom -- n )
+    phantom-stack-elements length ;
+
+GENERIC: finalize-height ( n stack -- )
+
+GENERIC: <loc> ( n stack -- loc )
+
+: (loc) phantom-stack-height - ;
+
+: (finalize-height) ( stack word -- )
+    swap [
+        phantom-stack-height
+        dup zero? [ 2drop ] [ swap execute , ] if
+        0
+    ] keep set-phantom-stack-height ; inline
+
+TUPLE: phantom-datastack ;
+
+C: phantom-datastack
+    [ >r <phantom-stack> r> set-delegate ] keep ;
+
+M: phantom-datastack <loc> (loc) <ds-loc> ;
+
+M: phantom-datastack finalize-height
+    \ %inc-d (finalize-height) ;
+
+TUPLE: phantom-callstack ;
+
+C: phantom-callstack
+    [ >r <phantom-stack> r> set-delegate ] keep ;
+
+M: phantom-callstack <loc> (loc) <cs-loc> ;
+
+M: phantom-callstack finalize-height
+    \ %inc-r (finalize-height) ;
+
+: >phantom ( elt phantom -- ) phantom-stack-elements push ;
+
+: phantom> ( phantom -- elt ) phantom-stack-elements pop ;
+
+: phantom-append ( seq phantom -- )
+    phantom-stack-elements swap nappend ;
+
+: phantom-cut ( n phantom -- stuff )
+    [ phantom-stack-elements cut* swap ] keep
+    set-phantom-stack-elements ;
+
+: phantom-locs ( n phantom -- locs )
+    swap reverse-slice [ <loc> ] map-with ;
+
+: phantom-locs* ( phantom -- locs )
+    dup phantom-length swap phantom-locs ;
+
+: adjust-phantom ( n phantom -- )
+    [ phantom-stack-height + ] keep set-phantom-stack-height ;
+
+: reset-phantom ( phantom -- )
+    0 swap phantom-stack-elements set-length ;
 
-! Uncomitted values
 SYMBOL: phantom-d
 SYMBOL: phantom-r
 
-: init-templates
-    0 d-height set 0 r-height set
-    V{ } clone phantom-d set V{ } clone phantom-r set ;
+: init-templates ( -- )
+    <phantom-datastack> phantom-d set
+    <phantom-callstack> phantom-r set ;
 
 ! A data stack location.
 TUPLE: ds-loc n ;
-C: ds-loc [ >r d-height get - r> set-ds-loc-n ] keep ;
 
 ! A call stack location.
 TUPLE: cs-loc n ;
-C: cs-loc [ >r r-height get - r> set-cs-loc-n ] keep ;
 
 : adjust-stacks ( inc-d inc-r -- )
-    r-height [ + ] change d-height [ + ] change ;
+    phantom-d get adjust-phantom
+    phantom-r get adjust-phantom ;
 
 : immediate? ( obj -- ? )
     #! fixnums and f have a pointerless representation, and
@@ -63,27 +107,21 @@ M: value vreg>stack ( value loc -- )
 M: object vreg>stack ( value loc -- )
     %replace , ;
 
-: vregs>stack ( values quot literals -- )
-    -rot >r [ dup value? rot eq? [ drop f ] unless ] map-with
-    dup reverse-slice swap length r> map
-    [ vreg>stack ] 2each ; inline
-
-: finalize-height ( word symbol -- )
-    [ dup zero? [ 2drop ] [ swap execute , ] if 0 ] change ;
-    inline
-
-: reset-stack ( vector -- )
-    0 swap set-length ;
+: vregs>stack ( values? phantom -- )
+    [
+        phantom-stack-elements
+        [ dup value? rot eq? [ drop f ] unless ] map-with
+    ] keep phantom-locs* [ vreg>stack ] 2each ;
 
 : end-basic-block ( -- )
-    \ %inc-d d-height finalize-height
-    \ %inc-r r-height finalize-height
-    phantom-d get [ <ds-loc> ] f vregs>stack
-    phantom-r get [ <cs-loc> ] f vregs>stack
-    phantom-d get [ <ds-loc> ] t vregs>stack
-    phantom-r get [ <cs-loc> ] t vregs>stack
-    phantom-d get reset-stack
-    phantom-r get reset-stack ;
+    phantom-d get finalize-height
+    phantom-r get finalize-height
+    f phantom-d get vregs>stack
+    f phantom-r get vregs>stack
+    t phantom-d get vregs>stack
+    t phantom-r get vregs>stack
+    phantom-d get reset-phantom
+    phantom-r get reset-phantom ;
 
 G: stack>vreg ( value vreg loc -- operand )
     2 standard-combination ;
@@ -117,15 +155,16 @@ SYMBOL: any-reg
 
 : phantom-vregs ( phantom template -- )
     >r [ dup value? [ value-literal ] when ] map r>
-    [ second ] map
-    [ set ] 2each ;
+    [ second ] map [ set ] 2each ;
 
-: stack>vregs ( stack template quot -- )
-    >r dup [ first ] map swapd alloc-regs
-    dup length reverse r> map
-    (stack>vregs) swap phantom-vregs ; inline
+: stack>vregs ( stack template -- )
+    [
+        [ first ] map alloc-regs
+        dup length pick phantom-locs
+        (stack>vregs) 
+    ] keep phantom-vregs ;
 
-: compatible-vreg?
+: compatible-vreg? ( value vreg -- ? )
     swap dup value? [ 2drop f ] [ vreg-n = ] if ;
 
 : compatible-values? ( value template -- ? )
@@ -143,24 +182,28 @@ SYMBOL: any-reg
         2drop f
     ] if ;
 
-: template-input ( values template phantom quot -- )
-    >r swap [ template-match? ] 2keep rot [
-        rot r> 2drop over >r phantom-vregs r> reset-stack
+: optimized-input ( phantom template -- )
+    over >r phantom-vregs r> reset-phantom ;
+
+: template-input ( values template phantom -- )
+    swap 2dup >r phantom-stack-elements r> template-match? [
+        rot drop optimized-input
     ] [
-        nip end-basic-block r> stack>vregs
+        nip end-basic-block stack>vregs
     ] if ; inline
 
 : template-inputs ( stack template stack template -- )
-    over >r phantom-r get [ <cs-loc> ] template-input
-    over >r phantom-d get [ <ds-loc> ] template-input
-    r> r> [ length neg ] 2apply adjust-stacks ;
+    over >r phantom-r get template-input
+    over >r phantom-d get template-input
+    r> r> [ phantom-length neg ] 2apply adjust-stacks ;
 
-: >phantom ( seq stack -- )
-    get swap [ dup value? [ get ] unless ] map nappend ;
+: (template-outputs) ( seq stack -- )
+    >r [ dup value? [ get ] unless ] map r> phantom-append ;
 
 : template-outputs ( stack stack -- )
-    2dup [ length ] 2apply adjust-stacks
-    phantom-r >phantom phantom-d >phantom ;
+    [ [ length ] 2apply adjust-stacks ] 2keep
+    phantom-r get >phantom
+    phantom-d get >phantom ;
 
 : with-template ( node in out quot -- )
     swap >r >r >r dup node-in-d r> { } { } template-inputs

From cd9f3b72a0af23e26f62174b736858ad87d6e095 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Mon, 10 Apr 2006 02:23:24 +0000
Subject: [PATCH 028/112] Slightly better error reporting in the UI

---
 library/tools/listener.factor | 10 +++++++++-
 library/ui/listener.factor    | 12 +++++++++---
 2 files changed, 18 insertions(+), 4 deletions(-)

diff --git a/library/tools/listener.factor b/library/tools/listener.factor
index 10a94dd78a..d37d1b0c40 100644
--- a/library/tools/listener.factor
+++ b/library/tools/listener.factor
@@ -9,8 +9,10 @@ SYMBOL: quit-flag
 
 SYMBOL: listener-hook
 SYMBOL: datastack-hook
+SYMBOL: error-hook
 
 "  " listener-prompt set-global
+[ drop terpri debug-help ] error-hook set-global
 
 : bye ( -- ) quit-flag on ;
 
@@ -28,10 +30,16 @@ SYMBOL: datastack-hook
 : read-multiline ( -- quot ? )
     [ f depth (read-multiline) >r reverse r> ] with-parser ;
 
+: listen-try
+    [
+        print-error error-continuation get error-hook get call
+    ] recover ;
+
 : listen ( -- )
     listener-hook get call
     listener-prompt get write flush
-    [ read-multiline [ call ] [ bye ] if ] try ;
+    [ read-multiline [ call ] [ bye ] if ]
+    listen-try ;
 
 : (listener) ( -- )
     quit-flag get [ quit-flag off ] [ listen (listener) ] if ;
diff --git a/library/ui/listener.factor b/library/ui/listener.factor
index 052946f3c6..248a491db3 100644
--- a/library/ui/listener.factor
+++ b/library/ui/listener.factor
@@ -3,9 +3,9 @@
 IN: gadgets-listener
 USING: arrays gadgets gadgets-editors gadgets-labels
 gadgets-layouts gadgets-panes gadgets-scrolling
-gadgets-splitters gadgets-theme generic hashtables
-io jedit kernel listener lists math
-namespaces parser prettyprint sequences threads words ;
+gadgets-splitters gadgets-theme generic hashtables io jedit
+kernel listener lists math namespaces parser prettyprint
+sequences styles threads words ;
 
 TUPLE: listener-gadget pane stack ;
 
@@ -32,9 +32,15 @@ TUPLE: listener-gadget pane stack ;
     ] keep
     listener-gadget-pane word-completion ;
 
+: ui-error-hook ( error -- )
+    terpri H{ { font-style bold } } [
+        "Debug this error" swap simple-object terpri
+    ] with-style ;
+
 : listener-thread ( listener -- )
     dup listener-gadget-pane [
         [ ui-listener-hook ] curry listener-hook set
+        [ ui-error-hook ] error-hook set
         print-banner listener
     ] with-stream* ;
 

From 36d10212680a1397768e0b24ef1d82e521efda20 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Mon, 10 Apr 2006 03:11:19 +0000
Subject: [PATCH 029/112] Compiler fixes

---
 library/compiler/templates.factor | 68 +++++++++++++------------------
 1 file changed, 28 insertions(+), 40 deletions(-)

diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index dc57e1f493..1dd68fd9e5 100644
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -4,14 +4,17 @@ IN: compiler
 USING: arrays generic inference kernel math
 namespaces sequences vectors words ;
 
-TUPLE: phantom-stack height elements ;
+! A data stack location.
+TUPLE: ds-loc n ;
+
+! A call stack location.
+TUPLE: cs-loc n ;
+
+TUPLE: phantom-stack height ;
 
 C: phantom-stack ( -- stack )
     0 over set-phantom-stack-height
-    V{ } clone over set-phantom-stack-elements ;
-
-: phantom-length ( phantom -- n )
-    phantom-stack-elements length ;
+    V{ } clone over set-delegate ;
 
 GENERIC: finalize-height ( n stack -- )
 
@@ -46,28 +49,20 @@ M: phantom-callstack <loc> (loc) <cs-loc> ;
 M: phantom-callstack finalize-height
     \ %inc-r (finalize-height) ;
 
-: >phantom ( elt phantom -- ) phantom-stack-elements push ;
-
-: phantom> ( phantom -- elt ) phantom-stack-elements pop ;
-
 : phantom-append ( seq phantom -- )
     phantom-stack-elements swap nappend ;
 
-: phantom-cut ( n phantom -- stuff )
-    [ phantom-stack-elements cut* swap ] keep
-    set-phantom-stack-elements ;
-
 : phantom-locs ( n phantom -- locs )
-    swap reverse-slice [ <loc> ] map-with ;
+    swap reverse-slice [ swap <loc> ] map-with ;
 
 : phantom-locs* ( phantom -- locs )
-    dup phantom-length swap phantom-locs ;
+    dup length swap phantom-locs ;
 
 : adjust-phantom ( n phantom -- )
     [ phantom-stack-height + ] keep set-phantom-stack-height ;
 
 : reset-phantom ( phantom -- )
-    0 swap phantom-stack-elements set-length ;
+    0 swap set-length ;
 
 SYMBOL: phantom-d
 SYMBOL: phantom-r
@@ -76,15 +71,9 @@ SYMBOL: phantom-r
     <phantom-datastack> phantom-d set
     <phantom-callstack> phantom-r set ;
 
-! A data stack location.
-TUPLE: ds-loc n ;
-
-! A call stack location.
-TUPLE: cs-loc n ;
-
 : adjust-stacks ( inc-d inc-r -- )
-    phantom-d get adjust-phantom
-    phantom-r get adjust-phantom ;
+    phantom-r get adjust-phantom
+    phantom-d get adjust-phantom ;
 
 : immediate? ( obj -- ? )
     #! fixnums and f have a pointerless representation, and
@@ -109,7 +98,6 @@ M: object vreg>stack ( value loc -- )
 
 : vregs>stack ( values? phantom -- )
     [
-        phantom-stack-elements
         [ dup value? rot eq? [ drop f ] unless ] map-with
     ] keep phantom-locs* [ vreg>stack ] 2each ;
 
@@ -153,15 +141,15 @@ SYMBOL: any-reg
     3array flip
     [ first3 over [ stack>vreg ] [ 3drop f ] if ] map ;
 
-: phantom-vregs ( phantom template -- )
-    >r [ dup value? [ value-literal ] when ] map r>
-    [ second ] map [ set ] 2each ;
+: phantom-vregs ( values template -- )
+    >r [ dup value? [ value-literal ] when ] map
+    r> [ second set ] 2each ;
 
-: stack>vregs ( stack template -- )
+: stack>vregs ( values phantom template -- )
     [
         [ first ] map alloc-regs
-        dup length pick phantom-locs
-        (stack>vregs) 
+        pick length rot phantom-locs
+        (stack>vregs)
     ] keep phantom-vregs ;
 
 : compatible-vreg? ( value vreg -- ? )
@@ -177,7 +165,7 @@ SYMBOL: any-reg
 
 : template-match? ( phantom template -- ? )
     2dup [ length ] 2apply = [
-        t [ first compatible-values? and ] 2reduce
+        f [ first compatible-values? and ] 2reduce
     ] [
         2drop f
     ] if ;
@@ -186,24 +174,24 @@ SYMBOL: any-reg
     over >r phantom-vregs r> reset-phantom ;
 
 : template-input ( values template phantom -- )
-    swap 2dup >r phantom-stack-elements r> template-match? [
-        rot drop optimized-input
+    swap 2dup template-match? [
+        optimized-input drop
     ] [
-        nip end-basic-block stack>vregs
+        end-basic-block stack>vregs
     ] if ; inline
 
-: template-inputs ( stack template stack template -- )
+: template-inputs ( values template values template -- )
     over >r phantom-r get template-input
     over >r phantom-d get template-input
-    r> r> [ phantom-length neg ] 2apply adjust-stacks ;
+    r> r> [ length neg ] 2apply adjust-stacks ;
 
 : (template-outputs) ( seq stack -- )
-    >r [ dup value? [ get ] unless ] map r> phantom-append ;
+    swap [ dup value? [ get ] unless ] map nappend ;
 
 : template-outputs ( stack stack -- )
     [ [ length ] 2apply adjust-stacks ] 2keep
-    phantom-r get >phantom
-    phantom-d get >phantom ;
+    phantom-r get (template-outputs)
+    phantom-d get (template-outputs) ;
 
 : with-template ( node in out quot -- )
     swap >r >r >r dup node-in-d r> { } { } template-inputs

From b003d46647fed38be744017a4b691d325f0efa35 Mon Sep 17 00:00:00 2001
From: Kevin Reid <kpreid@mac.com>
Date: Mon, 10 Apr 2006 19:03:41 +0000
Subject: [PATCH 030/112] Cocoa window zooming based on gadget's preferred
 dimensions

---
 library/cocoa/types.factor | 11 ++++++++++-
 library/cocoa/ui.factor    | 33 ++++++++++++++++++++++++++++++++-
 2 files changed, 42 insertions(+), 2 deletions(-)

diff --git a/library/cocoa/types.factor b/library/cocoa/types.factor
index d1dbcedf5c..54ef1635e4 100644
--- a/library/cocoa/types.factor
+++ b/library/cocoa/types.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2006 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 IN: cocoa
-USING: alien kernel ;
+USING: alien kernel math ;
 
 BEGIN-STRUCT: NSRect
     FIELD: float x
@@ -20,6 +20,15 @@ TYPEDEF: NSRect CGRect
     [ set-NSRect-y ] keep
     [ set-NSRect-x ] keep ;
 
+: NSRect-x-y ( rect -- origin-x origin-y )
+    [ NSRect-x ] keep NSRect-y ;
+
+: NSRect-x-far-y ( rect -- origin-x far-y )
+    [ NSRect-x-y ] keep NSRect-h + ;
+  
+: <far-y-NSRect> ( x y w h -- rect )
+    rot dupd swap - -rot <NSRect> ;
+
 BEGIN-STRUCT: NSPoint
     FIELD: float x
     FIELD: float y
diff --git a/library/cocoa/ui.factor b/library/cocoa/ui.factor
index 85360b424b..ac4d56245b 100644
--- a/library/cocoa/ui.factor
+++ b/library/cocoa/ui.factor
@@ -2,6 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: objc-FactorView
 DEFER: FactorView
+IN: objc-FactorUIWindowDelegate
+DEFER: FactorUIWindowDelegate
 
 USING: alien arrays cocoa errors freetype gadgets
 gadgets-launchpad gadgets-layouts gadgets-listener gadgets-panes
@@ -171,13 +173,42 @@ H{ } clone views set-global
     FactorView over rect-dim <GLView>
     [ over set-world-handle dup add-notify register-view ] keep ;
 
+
+: window-root-gadget-pref-dim  [contentView] view pref-dim ;
+
+: frame-rect-for-window-content-rect ( window rect -- rect )
+    swap [styleMask] NSWindow -rot [frameRectForContentRect:styleMask:] ;
+
+: content-rect-for-window-frame-rect ( window rect -- rect )
+    swap [styleMask] NSWindow -rot [contentRectForFrameRect:styleMask:] ;
+
+: window-content-rect ( window -- rect )
+    dup [frame] content-rect-for-window-frame-rect ;
+
+"NSObject" "FactorUIWindowDelegate" {
+    { "windowWillUseStandardFrame:defaultFrame:" "NSRect" { "id" "SEL" "id" "NSRect" }
+        [
+            drop 2nip ( self sel window default-frame -- window )
+            dup window-content-rect NSRect-x-far-y ( window -- window x y )
+            pick window-root-gadget-pref-dim first2 ( window x y -- window x y w h )
+            <far-y-NSRect>
+            frame-rect-for-window-content-rect
+        ]
+    }
+} { } define-objc-class
+
+: install-window-delegate ( window -- )
+    FactorUIWindowDelegate [alloc] [init] [setDelegate:] ;
+
 IN: gadgets
 
 : redraw-world ( handle -- )
     world-handle 1 [setNeedsDisplay:] ;
 
 : open-window* ( world title -- )
-    >r <FactorView> r> <ViewWindow> [contentView] [release] ;
+    >r <FactorView> r> <ViewWindow> 
+    dup install-window-delegate
+    [contentView] [release] ;
 
 : select-gl-context ( handle -- )
     [openGLContext] [makeCurrentContext] ;

From 4646552254015e42d93360f14f6a6f2a4786599a Mon Sep 17 00:00:00 2001
From: Kevin Reid <kpreid@mac.com>
Date: Mon, 10 Apr 2006 22:21:01 +0000
Subject: [PATCH 031/112] Standard Mac OS X menu bar, and FactorCallback class
 for target-action callbacks.

---
 library/cocoa/callback.factor |  27 +++++++
 library/cocoa/load.factor     |   2 +
 library/cocoa/menu-bar.factor | 142 ++++++++++++++++++++++++++++++++++
 library/cocoa/ui.factor       |   2 +-
 4 files changed, 172 insertions(+), 1 deletion(-)
 create mode 100644 library/cocoa/callback.factor
 create mode 100644 library/cocoa/menu-bar.factor

diff --git a/library/cocoa/callback.factor b/library/cocoa/callback.factor
new file mode 100644
index 0000000000..0343f3e967
--- /dev/null
+++ b/library/cocoa/callback.factor
@@ -0,0 +1,27 @@
+IN: objc-FactorCallback
+DEFER: FactorCallback
+
+IN: cocoa
+USING: hashtables kernel namespaces objc objc-NSObject ;
+
+SYMBOL: callbacks
+
+H{ } clone callbacks set
+
+"NSObject" "FactorCallback" {
+    { "perform:" "void" { "id" "SEL" "id" }
+        [ nip swap callbacks get hash call ]
+    }
+    
+    { "dealloc" "void" { "id" "SEL" }
+        [
+            drop
+            dup callbacks get remove-hash
+            SUPER-> [dealloc]
+        ]
+    }
+} { } define-objc-class
+
+: <FactorCallback> ( quot -- id | quot: id -- )
+    FactorCallback [alloc] [init]
+    [ callbacks get set-hash ] keep ;
\ No newline at end of file
diff --git a/library/cocoa/load.factor b/library/cocoa/load.factor
index 5896c419a4..b97e0434c7 100644
--- a/library/cocoa/load.factor
+++ b/library/cocoa/load.factor
@@ -7,9 +7,11 @@ USING: compiler io parser sequences words ;
     "/library/cocoa/core-foundation.factor"
     "/library/cocoa/types.factor"
     "/library/cocoa/init-cocoa.factor"
+    "/library/cocoa/callback.factor"
     "/library/cocoa/application-utils.factor"
     "/library/cocoa/window-utils.factor"
     "/library/cocoa/view-utils.factor"
+    "/library/cocoa/menu-bar.factor"
     "/library/cocoa/ui.factor"
 } [
     run-resource
diff --git a/library/cocoa/menu-bar.factor b/library/cocoa/menu-bar.factor
new file mode 100644
index 0000000000..0f18221105
--- /dev/null
+++ b/library/cocoa/menu-bar.factor
@@ -0,0 +1,142 @@
+USING: kernel sequences objc cocoa objc-NSObject objc-NSApplication objc-NSWindow objc-NSMenu objc-NSMenuItem objc-FactorCallback gadgets gadgets-layouts gadgets-listener words compiler strings lists ;
+
+! for words used by menu bar actions (copied from launchpad.factor)
+USING: gadgets gadgets-browser gadgets-listener help inspector io kernel memory namespaces sequences gadgets-launchpad ; 
+
+IN: cocoa
+
+: NSApp NSApplication [sharedApplication] ;
+
+! -------------------------------------------------------------------------
+
+GENERIC: to-target-and-action ( selector-string-or-quotation -- target action )
+
+M: string to-target-and-action sel_registerName f swap ;
+M: f to-target-and-action f ;
+M: list to-target-and-action \ drop swons <FactorCallback> "perform:" sel_registerName ;
+
+
+: <NSMenu> NSMenu [alloc] swap <NSString> [initWithTitle:] [autorelease] ;
+
+: set-main-menu NSApp swap [setMainMenu:] ;
+
+: <NSMenuItem> ( title action equivalent -- item )
+    >r >r >r
+    NSMenuItem [alloc]
+    r> <NSString>
+    r> dup [ sel_registerName ] when
+    r> <NSString>
+    [initWithTitle:action:keyEquivalent:] [autorelease] ;
+
+: make-menu-item-2 ( title selector-string-or-quotation equivalent -- item )
+    swap to-target-and-action swap >r swap <NSMenuItem> dup r> [setTarget:] ;
+
+: submenu-to-item ( menu -- item )
+    dup [title] CF>string f "" <NSMenuItem> dup rot [setSubmenu:] ;
+
+: add-submenu ( menu submenu -- )
+    submenu-to-item [addItem:] ;
+
+: and-modifiers ( item key-equivalent-modifier-mask -- item )
+    dupd [setKeyEquivalentModifierMask:] ;
+: and-alternate ( item -- item )
+    dup 1 [setAlternate:] ;
+: and-option-equivalent-modifier 1572864 and-modifiers ;
+
+! -------------------------------------------------------------------------
+
+DEFER: described-menu
+
+! { } => separator
+
+! { { ... } } or
+! { { ... } modify-quotation } => submenu as described in inner sequence
+
+! { title action equivalent } or
+! { title action equivalent modify-quotation } => item
+
+! this is a mess
+: described-item ( desc -- menu-item )
+    dup length 0 = [
+        drop NSMenuItem [separatorItem]
+    ] [
+        dup first string? [
+            [ first3 make-menu-item-2 ] keep
+            dup length 4 = [ fourth call ] [ drop ] if
+        ] [
+            [ first described-menu ] keep
+            dup length 2 = [ second call ] [ drop ] if
+            submenu-to-item
+        ] if
+    ] if ;
+
+: and-described-item ( menu desc -- same-menu )
+    described-item dupd [addItem:] ;
+
+: described-menu ( { title items* } -- menu )
+    [ first <NSMenu> ] keep
+    1 swap tail [ and-described-item ] each ;
+
+: and-described-submenu ( menu { title items* } -- menu )
+    described-menu dupd add-submenu ;
+
+! -------------------------------------------------------------------------
+
+
+: default-main-menu 
+    {
+        "<top>"
+        { {
+            "Factor"
+            ! About goes here
+            ! Preferences goes here
+            { {
+                "Services"
+            } [ dup NSApp swap [setServicesMenu:] ] }
+            { }
+            { "Hide Factor" "hide:" "h" }
+            { "Hide Others" "hideOtherApplications:" "h" [ and-option-equivalent-modifier ] }
+            { "Show All" "unhideAllApplications:" "" }
+            { }
+            { "Save Image" [ save ] "s" }
+            { }
+            { "Quit" "terminate:" "q" }
+        } [ dup NSApp swap [setAppleMenu:] ] }
+        { {
+            ! Tools is standing in for the File menu
+            "Tools"
+            { "Listener" [ listener-window ] "n" }
+            { "Vocabulary List" [ [ vocabs. ] "Vocabularies" pane-window ] "y" }
+            { "Globals" [ global browser-window ] "u" }
+            { "Memory" [ [ heap-stats. terpri room. ] "Memory" pane-window ] "u" }
+        } }
+        { {
+            "Edit"
+            { "Undo" "undo:" "z" }
+            { "Redo" "redo:" "Z" }
+            { }
+            { "Cut" "cut:" "x" }
+            { "Copy" "copy:" "c" }
+            { "Paste" "paste:" "v" }
+            { "Paste and Match Style" "pasteAsPlainText:" "V" [ and-option-equivalent-modifier ] }
+            { "Delete" "delete:" "" }
+            { "Select All" "selectAll:" "a" }
+            ! { }
+            ! Find, Spelling, and Speech submenus go here
+        } }
+        { {
+            "Window"
+            { "Close" "performClose:" "w" }
+            { "Zoom" "performZoom:" "" }
+            { "Minimize" "performMiniaturize:" "m" }
+            { "Minimize All" "miniaturizeAll:" "m"  [ and-alternate and-option-equivalent-modifier ] }
+            { }
+            { "Bring All to Front" "arrangeInFront:" "" }
+        } [ dup NSApp swap [setWindowsMenu:] ] }
+        { {
+            "Help"
+            { "Factor Documentation" [ handbook-window ] "?" }
+            { "Help Index" [ [ articles. ] "Help index" pane-window ] "" }
+            { "Vocabularies" [ [ vocabs. ] "Vocabularies" pane-window ] "" }
+        } }
+    } described-menu set-main-menu ;
diff --git a/library/cocoa/ui.factor b/library/cocoa/ui.factor
index ac4d56245b..e098ed011e 100644
--- a/library/cocoa/ui.factor
+++ b/library/cocoa/ui.factor
@@ -226,7 +226,7 @@ IN: shells
         [
             init-ui
             purge-views
-            launchpad-window
+            default-main-menu
             listener-window
             finish-launching
             event-loop

From daa1837df7b2f38c4f891ef734414f05a70bc5cb Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Tue, 11 Apr 2006 06:45:24 +0000
Subject: [PATCH 032/112] Register allocator fixes

---
 library/compiler/intrinsics.factor      |  10 +-
 library/compiler/linearizer.factor      |   4 +-
 library/compiler/ppc/stack.factor       |  12 ++-
 library/compiler/templates.factor       | 124 ++++++++++++++----------
 library/test/compiler/intrinsics.factor |   4 -
 library/test/compiler/stack.factor      |   3 -
 library/test/compiler/templates.factor  |  19 ++++
 library/test/test.factor                |   2 +-
 8 files changed, 109 insertions(+), 69 deletions(-)
 create mode 100644 library/test/compiler/templates.factor

diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index c7cec72b3f..5826084f08 100644
--- a/library/compiler/intrinsics.factor
+++ b/library/compiler/intrinsics.factor
@@ -68,12 +68,12 @@ namespaces sequences words ;
 ] "intrinsic" set-word-prop
 
 \ type [
-    { { 0 "in" } } { "in" }
+    { { any-reg "in" } } { "in" }
     [ end-basic-block "in" get %type , ] with-template
 ] "intrinsic" set-word-prop
 
 \ tag [
-    { { 0 "in" } } { "in" } [ "in" get %tag , ] with-template
+    { { any-reg "in" } } { "in" } [ "in" get %tag , ] with-template
 ] "intrinsic" set-word-prop
 
 \ getenv [
@@ -84,7 +84,7 @@ namespaces sequences words ;
 ] "intrinsic" set-word-prop
 
 \ setenv [
-    { { 0 "value" } { value "env" } } { } [
+    { { any-reg "value" } { value "env" } } { } [
         "value" get "env" get %setenv ,
     ] with-template
 ] "intrinsic" set-word-prop
@@ -119,7 +119,7 @@ namespaces sequences words ;
 ] each
 
 : binary-jump ( node label op -- )
-    rot dup binary-in { } [
+    rot { { any-reg "x" } { any-reg "y" } } { } [
         end-basic-block >r >r "y" get "x" get r> r> execute ,
     ] with-template ; inline
 
@@ -185,7 +185,7 @@ namespaces sequences words ;
 
 : fast-shift ( n node -- )
     over zero? [
-        end-basic-block -1 0 adjust-stacks 2drop
+        drop-phantom 2drop
     ] [
         over 0 < [
             negative-shift
diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index 81bfc41ae0..6a47323dfa 100644
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -111,7 +111,7 @@ M: #call-label linearize* ( node -- next )
     template-inputs ;
 
 M: #shuffle linearize* ( #shuffle -- )
-    0 vreg-allocator set
+    compute-free-vregs
     node-shuffle dup do-inputs
     dup shuffle-out-d swap shuffle-out-r template-outputs
     iterate-next ;
@@ -122,7 +122,7 @@ M: #shuffle linearize* ( #shuffle -- )
 
 M: #if linearize* ( node -- next )
     dup ?static-branch [
-        end-basic-block -1 0 adjust-stacks
+        end-basic-block drop-phantom
         swap node-children nth linearize-child iterate-next
     ] [
         dup { { 0 "flag" } } { } [
diff --git a/library/compiler/ppc/stack.factor b/library/compiler/ppc/stack.factor
index 3e81215eeb..abba554663 100644
--- a/library/compiler/ppc/stack.factor
+++ b/library/compiler/ppc/stack.factor
@@ -9,14 +9,22 @@ GENERIC: loc>operand
 M: ds-loc loc>operand ds-loc-n cells neg 14 swap ;
 M: cs-loc loc>operand cs-loc-n cells neg 15 swap ;
 
+: %literal ( quot -- )
+    0 output vreg? [
+        0 input 0 output-operand rot call
+    ] [
+        0 input 11 rot call
+        11 0 output loc>operand STW
+    ] if ; inline
+
 M: %immediate generate-node ( vop -- )
-    drop 0 input address 0 output-operand LOAD ;
+    drop [ >r address r> LOAD ] %literal ;
 
 : load-indirect ( dest literal -- )
     add-literal over LOAD32 rel-2/2 rel-address dup 0 LWZ ;
 
 M: %indirect generate-node ( vop -- )
-    drop 0 output-operand 0 input load-indirect ;
+    drop [ swap load-indirect ] %literal ;
 
 M: %peek generate-node ( vop -- )
     drop 0 output-operand 0 input loc>operand LWZ ;
diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index 1dd68fd9e5..27aa2bc08d 100644
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -49,9 +49,6 @@ M: phantom-callstack <loc> (loc) <cs-loc> ;
 M: phantom-callstack finalize-height
     \ %inc-r (finalize-height) ;
 
-: phantom-append ( seq phantom -- )
-    phantom-stack-elements swap nappend ;
-
 : phantom-locs ( n phantom -- locs )
     swap reverse-slice [ swap <loc> ] map-with ;
 
@@ -61,8 +58,10 @@ M: phantom-callstack finalize-height
 : adjust-phantom ( n phantom -- )
     [ phantom-stack-height + ] keep set-phantom-stack-height ;
 
-: reset-phantom ( phantom -- )
-    0 swap set-length ;
+GENERIC: cut-phantom ( n phantom -- seq )
+
+M: phantom-stack cut-phantom ( n phantom -- seq )
+    [ delegate cut* swap ] keep set-delegate ;
 
 SYMBOL: phantom-d
 SYMBOL: phantom-r
@@ -71,17 +70,13 @@ SYMBOL: phantom-r
     <phantom-datastack> phantom-d set
     <phantom-callstack> phantom-r set ;
 
-: adjust-stacks ( inc-d inc-r -- )
-    phantom-r get adjust-phantom
-    phantom-d get adjust-phantom ;
-
 : immediate? ( obj -- ? )
     #! fixnums and f have a pointerless representation, and
     #! are compiled immediately. Everything else can be moved
     #! by GC, and is indexed through a table.
     dup fixnum? swap f eq? or ;
 
-: load-literal ( obj vreg -- )
+: load-literal ( obj dest -- )
     over immediate? [ %immediate ] [ %indirect ] if , ;
 
 G: vreg>stack ( value loc -- ) 1 standard-combination ;
@@ -89,27 +84,25 @@ G: vreg>stack ( value loc -- ) 1 standard-combination ;
 M: f vreg>stack ( value loc -- ) 2drop ;
 
 M: value vreg>stack ( value loc -- )
-    swap value-literal fixnum-imm? over immediate? and
-    [ T{ vreg f 0 } load-literal T{ vreg f 0 } ] unless
-    swap %replace , ;
+    >r value-literal r> load-literal ;
 
 M: object vreg>stack ( value loc -- )
     %replace , ;
 
-: vregs>stack ( values? phantom -- )
-    [
-        [ dup value? rot eq? [ drop f ] unless ] map-with
-    ] keep phantom-locs* [ vreg>stack ] 2each ;
+: vregs>stack ( phantom -- )
+    dup dup phantom-locs* [ vreg>stack ] 2each
+    0 swap set-length ;
+
+: finalize-phantom ( phantom -- )
+    dup finalize-height vregs>stack ;
 
 : end-basic-block ( -- )
-    phantom-d get finalize-height
-    phantom-r get finalize-height
-    f phantom-d get vregs>stack
-    f phantom-r get vregs>stack
-    t phantom-d get vregs>stack
-    t phantom-r get vregs>stack
-    phantom-d get reset-phantom
-    phantom-r get reset-phantom ;
+    phantom-d get finalize-phantom
+    phantom-r get finalize-phantom ;
+
+: end-basic-block* ( -- )
+    phantom-d get vregs>stack
+    phantom-r get vregs>stack ;
 
 G: stack>vreg ( value vreg loc -- operand )
     2 standard-combination ;
@@ -126,16 +119,26 @@ M: value stack>vreg ( value vreg loc -- operand )
         >r value-literal r> <vreg> [ load-literal ] keep
     ] if ;
 
-SYMBOL: vreg-allocator
-
 SYMBOL: any-reg
 
-: alloc-reg ( template -- template )
-    dup any-reg eq? [
-        drop vreg-allocator dup get swap inc
-    ] when ;
+SYMBOL: free-vregs
 
-: alloc-regs ( template -- template ) [ alloc-reg ] map ;
+: compute-free-vregs ( -- )
+    phantom-d get [ vreg? ] subset
+    phantom-r get [ vreg? ] subset append
+    [ vreg-n ] map vregs length reverse diff
+    >vector free-vregs set ;
+
+: requested-vregs ( template -- n )
+    [ any-reg eq? ] subset length ;
+
+: sufficient-vregs? ( template template -- ? )
+    [ requested-vregs ] 2apply + free-vregs get length <= ;
+
+: alloc-regs ( template -- template )
+    free-vregs get swap [
+        dup any-reg eq? [ drop pop ] [ nip ] if
+    ] map-with ;
 
 : (stack>vregs) ( values template locs -- inputs )
     3array flip
@@ -145,54 +148,71 @@ SYMBOL: any-reg
     >r [ dup value? [ value-literal ] when ] map
     r> [ second set ] 2each ;
 
-: stack>vregs ( values phantom template -- )
+: stack>vregs ( values phantom template -- values )
     [
         [ first ] map alloc-regs
         pick length rot phantom-locs
         (stack>vregs)
-    ] keep phantom-vregs ;
+    ] 2keep length neg swap adjust-phantom ;
 
 : compatible-vreg? ( value vreg -- ? )
     swap dup value? [ 2drop f ] [ vreg-n = ] if ;
 
 : compatible-values? ( value template -- ? )
     {
+        { [ dup not ] [ 2drop t ] }
+        { [ over not ] [ 2drop f ] }
         { [ dup any-reg eq? ] [ drop vreg? ] }
         { [ dup integer? ] [ compatible-vreg? ] }
         { [ dup value eq? ] [ drop value? ] }
-        { [ dup not ] [ 2drop t ] }
     } cond ;
 
-: template-match? ( phantom template -- ? )
-    2dup [ length ] 2apply = [
-        f [ first compatible-values? and ] 2reduce
+: template-match? ( template phantom -- ? )
+    2dup [ length ] 2apply <= [
+        >r dup length r> tail-slice*
+        t [ swap first compatible-values? and ] 2reduce
     ] [
         2drop f
     ] if ;
 
-: optimized-input ( phantom template -- )
-    over >r phantom-vregs r> reset-phantom ;
+: templates-match? ( template template -- ? )
+    2dup sufficient-vregs? [
+        phantom-r get template-match?
+        >r phantom-d get template-match? r> and
+    ] [
+        2drop f
+    ] if ;
+
+: optimized-input ( template phantom -- )
+    over length neg over adjust-phantom
+    over length over cut-phantom
+    >r dup empty? [ drop ] [ vregs>stack ] if r>
+    swap phantom-vregs ;
 
 : template-input ( values template phantom -- )
-    swap 2dup template-match? [
-        optimized-input drop
-    ] [
-        end-basic-block stack>vregs
-    ] if ; inline
+    dup vregs>stack swap [ stack>vregs ] keep phantom-vregs ;
 
 : template-inputs ( values template values template -- )
-    over >r phantom-r get template-input
-    over >r phantom-d get template-input
-    r> r> [ length neg ] 2apply adjust-stacks ;
+    pick over templates-match? [
+        phantom-r get optimized-input drop
+        phantom-d get optimized-input drop
+    ] [
+        phantom-r get template-input
+        phantom-d get template-input
+    ] if ;
 
-: (template-outputs) ( seq stack -- )
+: drop-phantom ( -- )
+    end-basic-block -1 phantom-d get adjust-phantom ;
+
+: template-output ( seq stack -- )
+    over length over adjust-phantom
     swap [ dup value? [ get ] unless ] map nappend ;
 
 : template-outputs ( stack stack -- )
-    [ [ length ] 2apply adjust-stacks ] 2keep
-    phantom-r get (template-outputs)
-    phantom-d get (template-outputs) ;
+    phantom-r get template-output
+    phantom-d get template-output ;
 
 : with-template ( node in out quot -- )
+    compute-free-vregs
     swap >r >r >r dup node-in-d r> { } { } template-inputs
     node set r> call r> { } template-outputs ; inline
diff --git a/library/test/compiler/intrinsics.factor b/library/test/compiler/intrinsics.factor
index 3bdc393f75..a24d9bc4a4 100644
--- a/library/test/compiler/intrinsics.factor
+++ b/library/test/compiler/intrinsics.factor
@@ -2,10 +2,6 @@ IN: temporary
 USING: arrays compiler kernel kernel-internals lists math
 math-internals sequences strings test words ;
 
-! Oops!
-[ 5000 ] [ [ 5000 ] compile-1 ] unit-test
-[ "hi" ] [ [ "hi" ] compile-1 ] unit-test
-
 ! Make sure that intrinsic ops compile to correct code.
 [ 1 ] [ [[ 1 2 ]] [ 0 slot ] compile-1 ] unit-test
 [ 1 ] [ [ [[ 1 2 ]] 0 slot ] compile-1 ] unit-test
diff --git a/library/test/compiler/stack.factor b/library/test/compiler/stack.factor
index 463515b022..ed3d27bf2b 100644
--- a/library/test/compiler/stack.factor
+++ b/library/test/compiler/stack.factor
@@ -18,6 +18,3 @@ USING: compiler kernel math-internals test ;
 [ 1 2 1 ] [ 1 2 [ over ] compile-1 ] unit-test
 [ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-1 ] unit-test
 [ 2 1 ] [ 1 2 [ swap ] compile-1 ] unit-test
-
-! Test literals in either side of a shuffle
-[ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-1 ] unit-test
diff --git a/library/test/compiler/templates.factor b/library/test/compiler/templates.factor
new file mode 100644
index 0000000000..068c2df2e7
--- /dev/null
+++ b/library/test/compiler/templates.factor
@@ -0,0 +1,19 @@
+! Black box testing of templater optimization
+
+IN: temporary
+USING: compiler kernel kernel-internals math-internals test ;
+
+! Oops!
+[ 5000 ] [ [ 5000 ] compile-1 ] unit-test
+[ "hi" ] [ [ "hi" ] compile-1 ] unit-test
+
+[ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test
+[ 0 ] [ 3 [ tag ] compile-1 ] unit-test
+[ 0 3 ] [ 3 [ [ tag ] keep ] compile-1 ] unit-test
+
+[ { 1 2 3 } { 1 4 3 } 8 8 ]
+[ { 1 2 3 } { 1 4 3 } [ over type over type ] compile-1 ]
+unit-test
+
+! Test literals in either side of a shuffle
+[ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-1 ] unit-test
diff --git a/library/test/test.factor b/library/test/test.factor
index e3fb9d955a..9e6c67657e 100644
--- a/library/test/test.factor
+++ b/library/test/test.factor
@@ -101,7 +101,7 @@ SYMBOL: failures
 : compiler-tests
     {
         "io/buffer"
-        "compiler/simple"
+        "compiler/simple" "compiler/templates"
         "compiler/stack" "compiler/ifte"
         "compiler/generic" "compiler/bail-out"
         "compiler/linearizer" "compiler/intrinsics"

From 2c780d6ee2895ddcfa9787926a5b4b1d2ff3e80e Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Tue, 11 Apr 2006 06:54:10 +0000
Subject: [PATCH 033/112] Re-enable shuffle optimization, remove dead code

---
 library/compiler/linearizer.factor | 2 +-
 library/compiler/templates.factor  | 4 ----
 2 files changed, 1 insertion(+), 5 deletions(-)

diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index 6a47323dfa..0724f2873a 100644
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -112,7 +112,7 @@ M: #call-label linearize* ( node -- next )
 
 M: #shuffle linearize* ( #shuffle -- )
     compute-free-vregs
-    node-shuffle dup do-inputs
+    node-shuffle trim-shuffle dup do-inputs
     dup shuffle-out-d swap shuffle-out-r template-outputs
     iterate-next ;
 
diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index 27aa2bc08d..a068eee8f4 100644
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -100,10 +100,6 @@ M: object vreg>stack ( value loc -- )
     phantom-d get finalize-phantom
     phantom-r get finalize-phantom ;
 
-: end-basic-block* ( -- )
-    phantom-d get vregs>stack
-    phantom-r get vregs>stack ;
-
 G: stack>vreg ( value vreg loc -- operand )
     2 standard-combination ;
 

From c6bd0b4aac13cddbf6999413df79e22564ae2d7d Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Fri, 14 Apr 2006 07:53:45 +0000
Subject: [PATCH 034/112] Fix dead store elimination

---
 TODO.FACTOR.txt                        |  1 +
 library/compiler/intrinsics.factor     | 43 +++++++++++++-------------
 library/compiler/linearizer.factor     | 43 +++++++++++++++++---------
 library/compiler/templates.factor      | 35 ++++++++++++++++-----
 library/inference/shuffle.factor       | 23 --------------
 library/test/compiler/templates.factor | 10 ++++++
 library/tools/describe.factor          |  7 +++--
 7 files changed, 94 insertions(+), 68 deletions(-)

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 16af9a48d9..c26624ce0a 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -74,6 +74,7 @@ should fix in 0.82:
 - the invalid recursion form case needs to be fixed, for inlines too
 - code gc
 - compiled gc check slows things down
+- fix branch folding
 
 + misc:
 
diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index 5826084f08..41fda1eee0 100644
--- a/library/compiler/intrinsics.factor
+++ b/library/compiler/intrinsics.factor
@@ -30,12 +30,12 @@ namespaces sequences words ;
 \ slot [
     dup slot@ [
         { { 0 "obj" } { value "slot" } } { "obj" } [
-            node get slot@ "obj" get %fast-slot ,
+            node %get slot@ "obj" %get %fast-slot ,
         ] with-template
     ] [
         { { 0 "obj" } { 1 "n" } } { "obj" } [
-            "obj" get %untag ,
-            "n" get "obj" get %slot ,
+            "obj" %get %untag ,
+            "n" %get "obj" %get %slot ,
         ] with-template
     ] if
 ] "intrinsic" set-word-prop
@@ -43,12 +43,13 @@ namespaces sequences words ;
 \ set-slot [
     dup slot@ [
         { { 0 "val" } { 1 "obj" } { value "slot" } } { } [
-            "val" get "obj" get node get slot@ %fast-set-slot ,
+            "val" %get "obj" %get node %get slot@
+            %fast-set-slot ,
         ] with-template
     ] [
         { { 0 "val" } { 1 "obj" } { 2 "slot" } } { } [
-            "obj" get %untag ,
-            "val" get "obj" get "slot" get %set-slot ,
+            "obj" %get %untag ,
+            "val" %get "obj" %get "slot" %get %set-slot ,
         ] with-template
     ] if
     end-basic-block
@@ -57,35 +58,35 @@ namespaces sequences words ;
 
 \ char-slot [
     { { 0 "n" } { 1 "str" } } { "str" } [
-        "n" get "str" get %char-slot ,
+        "n" %get "str" %get %char-slot ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ set-char-slot [
     { { 0 "ch" } { 1 "n" } { 2 "str" } } { } [
-        "ch" get "str" get "n" get %set-char-slot ,
+        "ch" %get "str" %get "n" %get %set-char-slot ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ type [
     { { any-reg "in" } } { "in" }
-    [ end-basic-block "in" get %type , ] with-template
+    [ end-basic-block "in" %get %type , ] with-template
 ] "intrinsic" set-word-prop
 
 \ tag [
-    { { any-reg "in" } } { "in" } [ "in" get %tag , ] with-template
+    { { any-reg "in" } } { "in" } [ "in" %get %tag , ] with-template
 ] "intrinsic" set-word-prop
 
 \ getenv [
     { { value "env" } } { "out" } [
         T{ vreg f 0 } "out" set
-        "env" get "out" get %getenv ,
+        "env" %get "out" %get %getenv ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ setenv [
     { { any-reg "value" } { value "env" } } { } [
-        "value" get "env" get %setenv ,
+        "value" %get "env" %get %setenv ,
     ] with-template
 ] "intrinsic" set-word-prop
 
@@ -99,7 +100,7 @@ namespaces sequences words ;
 
 : (binary-op) ( node in -- )
     { "x" } [
-        end-basic-block >r "y" get "x" get dup r> execute ,
+        end-basic-block >r "y" %get "x" %get dup r> execute ,
     ] with-template ; inline
 
 : binary-op ( node op -- )
@@ -120,7 +121,7 @@ namespaces sequences words ;
 
 : binary-jump ( node label op -- )
     rot { { any-reg "x" } { any-reg "y" } } { } [
-        end-basic-block >r >r "y" get "x" get r> r> execute ,
+        end-basic-block >r >r "y" %get "x" %get r> r> execute ,
     ] with-template ; inline
 
 {
@@ -144,7 +145,7 @@ namespaces sequences words ;
     { { 0 "x" } { 1 "y" } } { "out" } [
         end-basic-block
         T{ vreg f 2 } "out" set
-        "y" get "x" get "out" get %fixnum-mod ,
+        "y" %get "x" %get "out" %get %fixnum-mod ,
     ] with-template
 ] "intrinsic" set-word-prop
 
@@ -154,14 +155,14 @@ namespaces sequences words ;
         end-basic-block
         T{ vreg f 0 } "quo" set
         T{ vreg f 2 } "rem" set
-        "y" get "x" get 2array
-        "rem" get "quo" get 2array %fixnum/mod ,
+        "y" %get "x" %get 2array
+        "rem" %get "quo" %get 2array %fixnum/mod ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ fixnum-bitnot [
     { { 0 "x" } } { "x" } [
-        "x" get dup %fixnum-bitnot ,
+        "x" %get dup %fixnum-bitnot ,
     ] with-template
 ] "intrinsic" set-word-prop
 
@@ -176,10 +177,10 @@ namespaces sequences words ;
         dup cell-bits neg <= [
             drop
             T{ vreg f 2 } "out" set
-            "x" get "out" get %fixnum-sgn ,
+            "x" %get "out" %get %fixnum-sgn ,
         ] [
-            "x" get "out" set
-            neg "x" get "out" get %fixnum>> ,
+            "x" %get "out" set
+            neg "x" %get "out" %get %fixnum>> ,
         ] if
     ] with-template ;
 
diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index 0724f2873a..0c48587588 100644
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -1,13 +1,9 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: compiler
 USING: arrays generic hashtables inference
 kernel math namespaces sequences words ;
+IN: compiler
 
-! On PowerPC and AMD64, we use a stack discipline whereby
-! stack frames are used to hold parameters. We need to compute
-! the stack frame size to compile the prologue on entry to a
-! word.
 GENERIC: stack-reserve*
 
 M: object stack-reserve* drop 0 ;
@@ -102,18 +98,37 @@ M: #call linearize* ( node -- next )
 M: #call-label linearize* ( node -- next )
     node-param renamed-label linearize-call ;
 
-: prepare-inputs ( values -- values templates )
+SYMBOL: live-d
+SYMBOL: live-r
+
+: value-dropped? ( value -- ? )
+    dup value?
+    over live-d get member? not
+    rot live-r get member? not and
+    or ;
+
+: shuffle-in-template ( values -- value template )
+    [ dup value-dropped? [ drop f ] when ] map
     dup [ any-reg swap 2array ] map ;
 
-: do-inputs ( shuffle -- )
-    dup shuffle-in-d prepare-inputs
-    rot shuffle-in-r prepare-inputs
-    template-inputs ;
+: shuffle-out-template ( instack outstack -- stack )
+    #! Avoid storing a value into its former position.
+    dup length [
+        pick ?nth dupd eq? [ <clean> ] when
+    ] 2map nip ;
+
+: linearize-shuffle ( shuffle -- )
+    dup shuffle-in-d over shuffle-out-d
+    shuffle-out-template live-d set
+    dup shuffle-in-r over shuffle-out-r
+    shuffle-out-template live-r set
+    dup shuffle-in-d shuffle-in-template
+    rot shuffle-in-r shuffle-in-template template-inputs
+    live-d get live-r get template-outputs ;
 
 M: #shuffle linearize* ( #shuffle -- )
     compute-free-vregs
-    node-shuffle trim-shuffle dup do-inputs
-    dup shuffle-out-d swap shuffle-out-r template-outputs
+    node-shuffle linearize-shuffle
     iterate-next ;
 
 : ?static-branch ( node -- n )
@@ -127,7 +142,7 @@ M: #if linearize* ( node -- next )
     ] [
         dup { { 0 "flag" } } { } [
             end-basic-block
-            <label> dup "flag" get %jump-t ,
+            <label> dup "flag" %get %jump-t ,
         ] with-template linearize-if
     ] if* ;
 
@@ -135,7 +150,7 @@ M: #if linearize* ( node -- next )
     #! Output the jump table insn and return a list of
     #! label/branch pairs.
     dup { { 0 "n" } } { }
-    [ end-basic-block "n" get %dispatch , ] with-template
+    [ end-basic-block "n" %get %dispatch , ] with-template
     node-children [ <label> dup %target-label ,  2array ] map ;
 
 : dispatch-body ( label/node -- )
diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index a068eee8f4..cf5725b382 100644
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -10,6 +10,11 @@ TUPLE: ds-loc n ;
 ! A call stack location.
 TUPLE: cs-loc n ;
 
+! A marker for values which are already stored in this location
+TUPLE: clean ;
+
+C: clean [ set-delegate ] keep ;
+
 TUPLE: phantom-stack height ;
 
 C: phantom-stack ( -- stack )
@@ -89,6 +94,8 @@ M: value vreg>stack ( value loc -- )
 M: object vreg>stack ( value loc -- )
     %replace , ;
 
+M: clean vreg>stack ( value loc -- ) 2drop ;
+
 : vregs>stack ( phantom -- )
     dup dup phantom-locs* [ vreg>stack ] 2each
     0 swap set-length ;
@@ -120,9 +127,9 @@ SYMBOL: any-reg
 SYMBOL: free-vregs
 
 : compute-free-vregs ( -- )
-    phantom-d get [ vreg? ] subset
-    phantom-r get [ vreg? ] subset append
-    [ vreg-n ] map vregs length reverse diff
+    phantom-d get phantom-r get append
+    [ vreg? ] subset [ vreg-n ] map
+    vregs length reverse diff
     >vector free-vregs set ;
 
 : requested-vregs ( template -- n )
@@ -138,11 +145,16 @@ SYMBOL: free-vregs
 
 : (stack>vregs) ( values template locs -- inputs )
     3array flip
-    [ first3 over [ stack>vreg ] [ 3drop f ] if ] map ;
+    [ first3 over [ stack>vreg <clean> ] [ 3drop f ] if ] map ;
+
+: ?clean ( obj -- obj )
+    dup clean? [ delegate ] when ;
+
+: %get ( obj -- value )
+    get ?clean dup value? [ value-literal ] when ;
 
 : phantom-vregs ( values template -- )
-    >r [ dup value? [ value-literal ] when ] map
-    r> [ second set ] 2each ;
+    [ second set ] 2each ;
 
 : stack>vregs ( values phantom template -- values )
     [
@@ -155,7 +167,7 @@ SYMBOL: free-vregs
     swap dup value? [ 2drop f ] [ vreg-n = ] if ;
 
 : compatible-values? ( value template -- ? )
-    {
+    >r ?clean r> {
         { [ dup not ] [ 2drop t ] }
         { [ over not ] [ 2drop f ] }
         { [ dup any-reg eq? ] [ drop vreg? ] }
@@ -200,9 +212,16 @@ SYMBOL: free-vregs
 : drop-phantom ( -- )
     end-basic-block -1 phantom-d get adjust-phantom ;
 
+: prep-output ( value -- value )
+    {
+        { [ dup value? ] [ ] }
+        { [ dup clean? ] [ delegate dup value? [ get ] unless ] }
+        { [ t ] [ get ?clean ] }
+    } cond ;
+
 : template-output ( seq stack -- )
     over length over adjust-phantom
-    swap [ dup value? [ get ] unless ] map nappend ;
+    swap [ prep-output ] map nappend ;
 
 : template-outputs ( stack stack -- )
     phantom-r get template-output
diff --git a/library/inference/shuffle.factor b/library/inference/shuffle.factor
index d65af168ab..5baa5f21b9 100644
--- a/library/inference/shuffle.factor
+++ b/library/inference/shuffle.factor
@@ -79,26 +79,3 @@ M: shuffle clone ( shuffle -- shuffle )
     [ shuffle-out-d clone ] keep
     shuffle-out-r clone
     <shuffle> ;
-
-SYMBOL: live-d
-SYMBOL: live-r
-
-: value-dropped? ( value -- ? )
-    dup value?
-    over live-d get member? not
-    rot live-r get member? not and
-    or ;
-
-: filter-dropped ( seq -- seq )
-    [ dup value-dropped? [ drop f ] when ] map ;
-
-: live-stores ( instack outstack -- stack )
-    #! Avoid storing a value into its former position.
-    dup length [ pick ?nth dupd eq? [ drop f ] when ] 2map nip ;
-
-: trim-shuffle ( shuffle -- shuffle )
-    dup shuffle-in-d over shuffle-out-d live-stores live-d set
-    dup shuffle-in-r over shuffle-out-r live-stores live-r set
-    dup shuffle-in-d filter-dropped
-    swap shuffle-in-r filter-dropped
-    live-d get live-r get <shuffle> ;
diff --git a/library/test/compiler/templates.factor b/library/test/compiler/templates.factor
index 068c2df2e7..3f678d83a4 100644
--- a/library/test/compiler/templates.factor
+++ b/library/test/compiler/templates.factor
@@ -17,3 +17,13 @@ unit-test
 
 ! Test literals in either side of a shuffle
 [ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-1 ] unit-test
+
+: foo ;
+
+[ 4 4 ]
+[ 1/2 [ tag [ foo ] keep ] compile-1 ]
+unit-test
+
+[ 1 2 2 ]
+[ 1/2 [ dup 0 slot swap 1 slot [ foo ] keep ] compile-1 ]
+unit-test
diff --git a/library/tools/describe.factor b/library/tools/describe.factor
index a27b209d06..5bceede23e 100644
--- a/library/tools/describe.factor
+++ b/library/tools/describe.factor
@@ -10,8 +10,11 @@ GENERIC: summary ( object -- string )
     0 > "a positive " "a negative " ? ;
 
 M: integer summary
-    dup sign-string over 2 mod zero? "even " "odd " ?
-    rot class word-name append3 ;
+    dup zero? [
+        "a " "zero "
+    ] [
+        dup sign-string over 2 mod zero? "even " "odd " ?
+    ] if rot class word-name append3 ;
 
 M: real summary
     dup sign-string swap class word-name append ;

From 25edc7de306578574bb1d6dc830eb6b462e72aea Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Mon, 17 Apr 2006 21:17:34 +0000
Subject: [PATCH 035/112] Stripping out old compiler code

---
 library/collections/namespaces.factor   |   5 +-
 library/compiler/intrinsics.factor      | 145 +++++-------------------
 library/compiler/linearizer.factor      |  50 ++++----
 library/compiler/templates.factor       |  93 ++++++---------
 library/inference/branches.factor       |   3 +-
 library/inference/class-infer.factor    |   4 +-
 library/inference/dataflow.factor       |   6 +-
 library/inference/kill-literals.factor  |   9 +-
 library/inference/optimizer.factor      |   4 +
 library/inference/print-dataflow.factor |   2 +
 library/test/compiler/templates.factor  |  41 ++++++-
 library/test/inference.factor           |   8 ++
 12 files changed, 159 insertions(+), 211 deletions(-)

diff --git a/library/collections/namespaces.factor b/library/collections/namespaces.factor
index 856e64d33f..6f7cd3cfd7 100644
--- a/library/collections/namespaces.factor
+++ b/library/collections/namespaces.factor
@@ -10,6 +10,7 @@ sequences strings vectors words ;
 : namespace ( -- namespace ) namestack* peek ; inline
 : >n ( namespace -- n:namespace ) namestack* push ; inline
 : n> ( n:namespace -- namespace ) namestack* pop ; inline
+: ndrop ( n:namespace -- ) namestack* pop* ; inline
 : global ( -- g ) 4 getenv ; inline
 : get ( variable -- value ) namestack* hash-stack ; flushable
 : set ( value variable -- ) namespace set-hash ;
@@ -30,13 +31,13 @@ sequences strings vectors words ;
 
 : dec ( var -- ) -1 swap +@ ; inline
 
-: bind ( namespace quot -- ) swap >n call n> drop ; inline
+: bind ( namespace quot -- ) swap >n call ndrop ; inline
 
 : counter ( var -- n ) global [ dup inc get ] bind ;
 
 : make-hash ( quot -- hash ) H{ } clone >n call n> ; inline
 
-: with-scope ( quot -- ) make-hash drop ; inline
+: with-scope ( quot -- ) H{ } clone >n call ndrop ; inline
 
 ! Building sequences
 SYMBOL: building
diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index 41fda1eee0..0fe2437d62 100644
--- a/library/compiler/intrinsics.factor
+++ b/library/compiler/intrinsics.factor
@@ -5,122 +5,69 @@ USING: arrays assembler generic hashtables
 inference kernel kernel-internals lists math math-internals
 namespaces sequences words ;
 
-: type-tag ( type -- tag )
-    #! Given a type number, return the tag number.
-    dup 6 > [ drop 3 ] when ;
-
-: value-tag ( value node -- n/f )
-    #! If the tag is known, output it, otherwise f.
-    node-classes ?hash dup [
-        types [ type-tag ] map dup all-equal?
-        [ first ] [ drop f ] if
-    ] [
-        drop f
-    ] if ;
-
-: slot@ ( node -- n/f )
-    #! Compute slot offset.
-    dup node-in-d reverse-slice dup first dup value? [
-        value-literal cells swap second
-        rot value-tag dup [ - ] [ 2drop f ] if
-    ] [
-        3drop f
-    ] if ;
-
 \ slot [
-    dup slot@ [
-        { { 0 "obj" } { value "slot" } } { "obj" } [
-            node %get slot@ "obj" %get %fast-slot ,
-        ] with-template
-    ] [
-        { { 0 "obj" } { 1 "n" } } { "obj" } [
-            "obj" %get %untag ,
-            "n" %get "obj" %get %slot ,
-        ] with-template
-    ] if
+    drop
+    { { 0 "obj" } { 1 "n" } } { "obj" } [
+        "obj" %get %untag ,
+        "n" %get "obj" %get %slot ,
+    ] with-template
 ] "intrinsic" set-word-prop
 
 \ set-slot [
-    dup slot@ [
-        { { 0 "val" } { 1 "obj" } { value "slot" } } { } [
-            "val" %get "obj" %get node %get slot@
-            %fast-set-slot ,
-        ] with-template
-    ] [
-        { { 0 "val" } { 1 "obj" } { 2 "slot" } } { } [
-            "obj" %get %untag ,
-            "val" %get "obj" %get "slot" %get %set-slot ,
-        ] with-template
-    ] if
+    drop
+    { { 0 "val" } { 1 "obj" } { 2 "slot" } } { } [
+        "obj" %get %untag ,
+        "val" %get "obj" %get "slot" %get %set-slot ,
+    ] with-template
     end-basic-block
     T{ vreg f 1 } %write-barrier ,
 ] "intrinsic" set-word-prop
 
 \ char-slot [
+    drop
     { { 0 "n" } { 1 "str" } } { "str" } [
         "n" %get "str" %get %char-slot ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ set-char-slot [
+    drop
     { { 0 "ch" } { 1 "n" } { 2 "str" } } { } [
         "ch" %get "str" %get "n" %get %set-char-slot ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ type [
+    drop
     { { any-reg "in" } } { "in" }
     [ end-basic-block "in" %get %type , ] with-template
 ] "intrinsic" set-word-prop
 
 \ tag [
+    drop
     { { any-reg "in" } } { "in" } [ "in" %get %tag , ] with-template
 ] "intrinsic" set-word-prop
 
-\ getenv [
-    { { value "env" } } { "out" } [
-        T{ vreg f 0 } "out" set
-        "env" %get "out" %get %getenv ,
-    ] with-template
-] "intrinsic" set-word-prop
-
-\ setenv [
-    { { any-reg "value" } { value "env" } } { } [
-        "value" %get "env" %get %setenv ,
-    ] with-template
-] "intrinsic" set-word-prop
-
-: literal-immediate? ( node -- ? )
-    node-in-d peek dup value?
-    [ value-literal immediate? ] [ drop f ] if ;
-
-: binary-in ( node -- in )
-    literal-immediate? fixnum-imm? and
-    { { 0 "x" } { value "y" } } { { 0 "x" } { 1 "y" } } ? ;
-
-: (binary-op) ( node in -- )
-    { "x" } [
+: binary-op ( op -- )
+    { { 0 "x" } { 1 "y" } } { "x" } [
         end-basic-block >r "y" %get "x" %get dup r> execute ,
     ] with-template ; inline
 
-: binary-op ( node op -- )
-    swap dup binary-in (binary-op) ; inline
-
-: binary-op-reg ( node op -- )
-    swap { { 0 "x" } { 1 "y" } } (binary-op) ; inline
-
 {
     { fixnum+       %fixnum+       }
     { fixnum-       %fixnum-       }
     { fixnum-bitand %fixnum-bitand }
     { fixnum-bitor  %fixnum-bitor  }
     { fixnum-bitxor %fixnum-bitxor }
+    { fixnum/i      %fixnum/i      }
+    { fixnum*       %fixnum*       }
 } [
-    first2 [ binary-op ] curry "intrinsic" set-word-prop
+    first2 [ binary-op drop ] curry
+    "intrinsic" set-word-prop
 ] each
 
-: binary-jump ( node label op -- )
-    rot { { any-reg "x" } { any-reg "y" } } { } [
+: binary-jump ( label op -- )
+    { { any-reg "x" } { any-reg "y" } } { } [
         end-basic-block >r >r "y" %get "x" %get r> r> execute ,
     ] with-template ; inline
 
@@ -131,14 +78,12 @@ namespaces sequences words ;
     { fixnum>  %jump-fixnum>  }
     { eq?      %jump-eq?      }
 } [
-    first2 [ binary-jump ] curry "if-intrinsic" set-word-prop
+    first2 [ binary-jump drop ] curry
+    "if-intrinsic" set-word-prop
 ] each
 
-\ fixnum/i [
-    \ %fixnum/i binary-op-reg
-] "intrinsic" set-word-prop
-
 \ fixnum-mod [
+    drop
     ! This is not clever. Because of x86, %fixnum-mod is
     ! hard-coded to put its output in vreg 2, which happends to
     ! be EDX there.
@@ -150,6 +95,7 @@ namespaces sequences words ;
 ] "intrinsic" set-word-prop
 
 \ fixnum/mod [
+    drop
     ! See the remark on fixnum-mod for vreg usage
     { { 0 "x" } { 1 "y" } } { "quo" "rem" } [
         end-basic-block
@@ -161,45 +107,8 @@ namespaces sequences words ;
 ] "intrinsic" set-word-prop
 
 \ fixnum-bitnot [
+    drop
     { { 0 "x" } } { "x" } [
         "x" %get dup %fixnum-bitnot ,
     ] with-template
 ] "intrinsic" set-word-prop
-
-\ fixnum* [
-    \ %fixnum* binary-op-reg
-] "intrinsic" set-word-prop
-
-: slow-shift ( -- ) \ fixnum-shift %call , ;
-
-: negative-shift ( n node -- )
-    { { 0 "x" } { value "n" } } { "out" } [
-        dup cell-bits neg <= [
-            drop
-            T{ vreg f 2 } "out" set
-            "x" %get "out" %get %fixnum-sgn ,
-        ] [
-            "x" %get "out" set
-            neg "x" %get "out" %get %fixnum>> ,
-        ] if
-    ] with-template ;
-
-: fast-shift ( n node -- )
-    over zero? [
-        drop-phantom 2drop
-    ] [
-        over 0 < [
-            negative-shift
-        ] [
-            2drop slow-shift
-        ] if
-    ] if ;
-
-\ fixnum-shift [
-    end-basic-block
-    dup literal-immediate? [
-        [ node-in-d peek value-literal ] keep fast-shift
-    ] [
-        drop slow-shift
-    ] if
-] "intrinsic" set-word-prop
diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index 0c48587588..faaac788d0 100644
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -102,54 +102,52 @@ SYMBOL: live-d
 SYMBOL: live-r
 
 : value-dropped? ( value -- ? )
-    dup value?
-    over live-d get member? not
-    rot live-r get member? not and
-    or ;
+    dup live-d get member? not
+    swap live-r get member? not and ;
 
-: shuffle-in-template ( values -- value template )
-    [ dup value-dropped? [ drop f ] when ] map
-    dup [ any-reg swap 2array ] map ;
+: shuffle-in-template ( values -- template )
+    [
+        dup value-dropped? [ drop f ] when any-reg swap 2array
+    ] map ;
 
 : shuffle-out-template ( instack outstack -- stack )
     #! Avoid storing a value into its former position.
     dup length [
-        pick ?nth dupd eq? [ <clean> ] when
+        pick ?nth dupd ( eq? ) 2drop f [ <clean> ] when
     ] 2map nip ;
 
-: linearize-shuffle ( shuffle -- )
+: linearize-shuffle ( node -- )
+    compute-free-vregs node-shuffle
     dup shuffle-in-d over shuffle-out-d
     shuffle-out-template live-d set
     dup shuffle-in-r over shuffle-out-r
     shuffle-out-template live-r set
     dup shuffle-in-d shuffle-in-template
-    rot shuffle-in-r shuffle-in-template template-inputs
+    swap shuffle-in-r shuffle-in-template template-inputs
     live-d get live-r get template-outputs ;
 
 M: #shuffle linearize* ( #shuffle -- )
-    compute-free-vregs
-    node-shuffle linearize-shuffle
-    iterate-next ;
+    linearize-shuffle iterate-next ;
 
-: ?static-branch ( node -- n )
-    node-in-d first dup value?
-    [ value-literal 0 1 ? ] [ drop f ] if ;
+: linearize-push ( node -- )
+    compute-free-vregs
+    >#push< dup length alloc-reg# [ <vreg> ] map
+    [ [ load-literal ] 2each ] keep
+    phantom-d get phantom-append ;
+
+M: #push linearize* ( #push -- )
+    linearize-push iterate-next ;
 
 M: #if linearize* ( node -- next )
-    dup ?static-branch [
-        end-basic-block drop-phantom
-        swap node-children nth linearize-child iterate-next
-    ] [
-        dup { { 0 "flag" } } { } [
-            end-basic-block
-            <label> dup "flag" %get %jump-t ,
-        ] with-template linearize-if
-    ] if* ;
+    { { 0 "flag" } } { } [
+        end-basic-block
+        <label> dup "flag" %get %jump-t ,
+    ] with-template linearize-if ;
 
 : dispatch-head ( node -- label/node )
     #! Output the jump table insn and return a list of
     #! label/branch pairs.
-    dup { { 0 "n" } } { }
+    { { 0 "n" } } { }
     [ end-basic-block "n" %get %dispatch , ] with-template
     node-children [ <label> dup %target-label ,  2array ] map ;
 
diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index cf5725b382..0cf8216efc 100644
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: compiler
-USING: arrays generic inference kernel math
-namespaces sequences vectors words ;
+USING: arrays generic inference io kernel math
+namespaces prettyprint sequences vectors words ;
 
 ! A data stack location.
 TUPLE: ds-loc n ;
@@ -84,17 +84,12 @@ SYMBOL: phantom-r
 : load-literal ( obj dest -- )
     over immediate? [ %immediate ] [ %indirect ] if , ;
 
-G: vreg>stack ( value loc -- ) 1 standard-combination ;
-
-M: f vreg>stack ( value loc -- ) 2drop ;
-
-M: value vreg>stack ( value loc -- )
-    >r value-literal r> load-literal ;
-
-M: object vreg>stack ( value loc -- )
-    %replace , ;
-
-M: clean vreg>stack ( value loc -- ) 2drop ;
+: vreg>stack ( value loc -- )
+    {
+        { [ over not ] [ 2drop ] }
+        { [ over clean? ] [ 2drop ] }
+        { [ t ] [ %replace , ] }
+    } cond ;
 
 : vregs>stack ( phantom -- )
     dup dup phantom-locs* [ vreg>stack ] 2each
@@ -107,20 +102,8 @@ M: clean vreg>stack ( value loc -- ) 2drop ;
     phantom-d get finalize-phantom
     phantom-r get finalize-phantom ;
 
-G: stack>vreg ( value vreg loc -- operand )
-    2 standard-combination ;
-
-M: f stack>vreg ( value vreg loc -- operand ) 2drop ;
-
-M: object stack>vreg ( value vreg loc -- operand )
-    >r <vreg> dup r> %peek , nip ;
-
-M: value stack>vreg ( value vreg loc -- operand )
-    drop dup value eq? [
-        drop
-    ] [
-        >r value-literal r> <vreg> [ load-literal ] keep
-    ] if ;
+: stack>vreg ( vreg loc -- operand )
+    over [ >r <vreg> dup r> %peek , ] [ 2drop f ] if ;
 
 SYMBOL: any-reg
 
@@ -143,9 +126,8 @@ SYMBOL: free-vregs
         dup any-reg eq? [ drop pop ] [ nip ] if
     ] map-with ;
 
-: (stack>vregs) ( values template locs -- inputs )
-    3array flip
-    [ first3 over [ stack>vreg <clean> ] [ 3drop f ] if ] map ;
+: alloc-reg# ( n -- regs )
+    free-vregs [ cut ] change ;
 
 : ?clean ( obj -- obj )
     dup clean? [ delegate ] when ;
@@ -153,26 +135,21 @@ SYMBOL: free-vregs
 : %get ( obj -- value )
     get ?clean dup value? [ value-literal ] when ;
 
-: phantom-vregs ( values template -- )
-    [ second set ] 2each ;
+: phantom-vregs ( values template -- ) [ second set ] 2each ;
 
-: stack>vregs ( values phantom template -- values )
+: stack>vregs ( phantom template -- values )
     [
         [ first ] map alloc-regs
-        pick length rot phantom-locs
-        (stack>vregs)
+        dup length rot phantom-locs
+        [ stack>vreg ] 2map
     ] 2keep length neg swap adjust-phantom ;
 
-: compatible-vreg? ( value vreg -- ? )
-    swap dup value? [ 2drop f ] [ vreg-n = ] if ;
-
 : compatible-values? ( value template -- ? )
     >r ?clean r> {
         { [ dup not ] [ 2drop t ] }
         { [ over not ] [ 2drop f ] }
-        { [ dup any-reg eq? ] [ drop vreg? ] }
-        { [ dup integer? ] [ compatible-vreg? ] }
-        { [ dup value eq? ] [ drop value? ] }
+        { [ dup any-reg eq? ] [ 2drop t ] }
+        { [ dup integer? ] [ swap vreg-n = ] }
     } cond ;
 
 : template-match? ( template phantom -- ? )
@@ -197,13 +174,13 @@ SYMBOL: free-vregs
     >r dup empty? [ drop ] [ vregs>stack ] if r>
     swap phantom-vregs ;
 
-: template-input ( values template phantom -- )
+: template-input ( template phantom -- )
     dup vregs>stack swap [ stack>vregs ] keep phantom-vregs ;
 
-: template-inputs ( values template values template -- )
-    pick over templates-match? [
-        phantom-r get optimized-input drop
-        phantom-d get optimized-input drop
+: template-inputs ( template template -- )
+    2dup templates-match? [
+        phantom-r get optimized-input
+        phantom-d get optimized-input
     ] [
         phantom-r get template-input
         phantom-d get template-input
@@ -213,21 +190,23 @@ SYMBOL: free-vregs
     end-basic-block -1 phantom-d get adjust-phantom ;
 
 : prep-output ( value -- value )
-    {
-        { [ dup value? ] [ ] }
-        { [ dup clean? ] [ delegate dup value? [ get ] unless ] }
-        { [ t ] [ get ?clean ] }
-    } cond ;
+    dup clean? [ delegate ] [ get ?clean ] if ;
+
+: phantom-append ( seq stack -- )
+    over length over adjust-phantom swap nappend ;
 
 : template-output ( seq stack -- )
-    over length over adjust-phantom
-    swap [ prep-output ] map nappend ;
+    >r [ prep-output ] map r> phantom-append ;
+
+: trace-outputs ( stack stack -- )
+    "==== Template output:" print [ . ] 2apply ;
 
 : template-outputs ( stack stack -- )
+   !  2dup trace-outputs
     phantom-r get template-output
     phantom-d get template-output ;
 
-: with-template ( node in out quot -- )
-    compute-free-vregs
-    swap >r >r >r dup node-in-d r> { } { } template-inputs
-    node set r> call r> { } template-outputs ; inline
+: with-template ( in out quot -- )
+    compute-free-vregs swap >r
+    >r { } template-inputs r> call r> { } template-outputs ;
+    inline
diff --git a/library/inference/branches.factor b/library/inference/branches.factor
index 94535a898d..e8d9f3b080 100644
--- a/library/inference/branches.factor
+++ b/library/inference/branches.factor
@@ -31,8 +31,7 @@ namespaces parser prettyprint sequences strings vectors words ;
 
 : unbalanced-branches ( in out -- )
     { "Unbalanced branches:" } -rot [
-        swap number>string " " rot length number>string
-        append3
+        swap unparse " " rot length unparse append3
     ] 2map append "\n" join inference-error ;
 
 : unify-effect ( in out -- in out )
diff --git a/library/inference/class-infer.factor b/library/inference/class-infer.factor
index 5ffc3aa8a6..51f93e63dc 100644
--- a/library/inference/class-infer.factor
+++ b/library/inference/class-infer.factor
@@ -122,8 +122,8 @@ M: #call infer-classes* ( node -- )
         [ over node-out-d intersect-classes ] when*
     ] when drop ;
 
-M: #shuffle infer-classes* ( node -- )
-    node-out-d [ value? ] subset
+M: #push infer-classes* ( node -- )
+    node-out-d
     [ [ value-literal ] keep set-value-literal* ] each ;
 
 M: #if child-ties ( node -- seq )
diff --git a/library/inference/dataflow.factor b/library/inference/dataflow.factor
index b5b3dbb34e..49ab412be5 100644
--- a/library/inference/dataflow.factor
+++ b/library/inference/dataflow.factor
@@ -53,10 +53,14 @@ TUPLE: #call-label ;
 C: #call-label make-node ;
 : #call-label ( label -- node ) param-node <#call-label> ;
 
+TUPLE: #push ;
+C: #push make-node ;
+: #push ( outputs -- node ) d-tail out-node <#push> ;
+: >#push< ( node -- seq ) node-out-d [ value-literal ] map ;
+
 TUPLE: #shuffle ;
 C: #shuffle make-node ;
 : #shuffle ( -- node ) empty-node <#shuffle> ;
-: #push ( outputs -- node ) d-tail out-node <#shuffle> ;
 
 TUPLE: #values ;
 C: #values make-node ;
diff --git a/library/inference/kill-literals.factor b/library/inference/kill-literals.factor
index 24ac75b227..15aa355990 100644
--- a/library/inference/kill-literals.factor
+++ b/library/inference/kill-literals.factor
@@ -53,6 +53,10 @@ M: #shuffle literals* ( node -- seq )
     dup node-out-d swap node-out-r
     [ [ value? ] subset ] 2apply append ;
 
+! #push
+M: #push literals* ( node -- seq )
+    node-values ;
+
 ! #call
 ! M: #call flushable-values* ( node -- )
 !     dup node-param "flushable" word-prop
@@ -63,8 +67,9 @@ M: #return live-values* ( node -- seq )
     #! Values returned by local labels can be killed.
     dup node-param [ drop { } ] [ delegate live-values* ] if ;
 
-! nodes that don't use their input values directly
-UNION: #killable #shuffle #call-label #merge #values #entry ;
+! nodes that don't use their values directly
+UNION: #killable
+    #push #shuffle #call-label #merge #values #entry ;
 
 M: #killable live-values* ( node -- seq ) drop { } ;
 
diff --git a/library/inference/optimizer.factor b/library/inference/optimizer.factor
index 31801dc77f..02b51c3aa7 100644
--- a/library/inference/optimizer.factor
+++ b/library/inference/optimizer.factor
@@ -53,6 +53,10 @@ M: #shuffle optimize-node*  ( node -- node/t )
         ] prune-if
     ] if ;
 
+! #push
+M: #push optimize-node*  ( node -- node/t )
+    [ node-out-d empty? ] prune-if ;
+
 ! #return
 M: #return optimize-node* ( node -- node/t )
     node-successor [ node-successor ] [ t ] if* ;
diff --git a/library/inference/print-dataflow.factor b/library/inference/print-dataflow.factor
index 7e683e8ae8..6dc50e55c7 100644
--- a/library/inference/print-dataflow.factor
+++ b/library/inference/print-dataflow.factor
@@ -38,6 +38,8 @@ M: comment pprint* ( ann -- )
 M: #shuffle node>quot ( ? node -- )
     >r drop t r> dup effect-str "#shuffle: " swap append comment, ;
 
+M: #push node>quot ( ? node -- ) nip >#push< % ;
+
 DEFER: dataflow>quot
 
 : #call>quot ( ? node -- )
diff --git a/library/test/compiler/templates.factor b/library/test/compiler/templates.factor
index 3f678d83a4..bd0235de4d 100644
--- a/library/test/compiler/templates.factor
+++ b/library/test/compiler/templates.factor
@@ -1,7 +1,8 @@
 ! Black box testing of templater optimization
 
 IN: temporary
-USING: compiler kernel kernel-internals math-internals test ;
+USING: arrays compiler kernel kernel-internals math
+math-internals namespaces test ;
 
 ! Oops!
 [ 5000 ] [ [ 5000 ] compile-1 ] unit-test
@@ -27,3 +28,41 @@ unit-test
 [ 1 2 2 ]
 [ 1/2 [ dup 0 slot swap 1 slot [ foo ] keep ] compile-1 ]
 unit-test
+
+: jxyz
+    over bignum? [
+        dup ratio? [
+            [ >fraction ] 2apply swapd
+            >r 2array swap r> 2array swap
+        ] when
+    ] when ;
+
+\ jxyz compile
+
+[ { 1 2 } { 1 1 } ] [ 1 >bignum 1/2 jxyz ] unit-test
+
+[ 3 ]
+[
+    global [ 3 \ foo set ] bind
+    \ foo [ global >n get n> drop ] compile-1
+] unit-test
+
+: blech drop ;
+
+[ 3 ]
+[
+    global [ 3 \ foo set ] bind
+    \ foo [ global [ get ] swap blech call ] compile-1
+] unit-test
+
+[ 3 ]
+[
+    global [ 3 \ foo set ] bind
+    \ foo [ global [ get ] swap >n call n> drop ] compile-1
+] unit-test
+
+[ 3 ]
+[
+    global [ 3 \ foo set ] bind
+    \ foo [ global [ get ] bind ] compile-1
+] unit-test
diff --git a/library/test/inference.factor b/library/test/inference.factor
index f52be71686..3c5570d09b 100644
--- a/library/test/inference.factor
+++ b/library/test/inference.factor
@@ -225,6 +225,14 @@ DEFER: do-crap
 : do-crap dup [ do-crap ] [ more-crap ] if ;
 [ [ do-crap ] infer ] unit-test-fails
 
+! Error reporting is wrong
+G: xyz math-combination ;
+M: fixnum xyz 2array ;
+M: ratio xyz 
+    [ >fraction ] 2apply swapd >r 2array swap r> 2array swap ;
+
+[ t ] [ [ [ xyz ] infer ] catch inference-error? ] unit-test
+
 [ { 2 1 } ] [ [ swons ] infer ] unit-test
 [ { 1 2 } ] [ [ uncons ] infer ] unit-test
 [ { 1 1 } ] [ [ unit ] infer ] unit-test

From 5b02250d949838ab1461cfd50cc9f88b0eef6e5c Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Mon, 17 Apr 2006 22:25:38 +0000
Subject: [PATCH 036/112] Intrinsics cleanups, x86 fixes

---
 library/compiler/intrinsics.factor     | 15 ++++++++-------
 library/compiler/linearizer.factor     | 12 ++++++++----
 library/compiler/templates.factor      | 19 ++++++++++++-------
 library/test/compiler/templates.factor |  2 ++
 4 files changed, 30 insertions(+), 18 deletions(-)

diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index 0fe2437d62..fdd72fadde 100644
--- a/library/compiler/intrinsics.factor
+++ b/library/compiler/intrinsics.factor
@@ -7,7 +7,7 @@ namespaces sequences words ;
 
 \ slot [
     drop
-    { { 0 "obj" } { 1 "n" } } { "obj" } [
+    { { any-reg "obj" } { any-reg "n" } } { "obj" } [
         "obj" %get %untag ,
         "n" %get "obj" %get %slot ,
     ] with-template
@@ -15,24 +15,25 @@ namespaces sequences words ;
 
 \ set-slot [
     drop
-    { { 0 "val" } { 1 "obj" } { 2 "slot" } } { } [
+    { { any-reg "val" } { any-reg "obj" } { any-reg "slot" } }
+    { } [
         "obj" %get %untag ,
         "val" %get "obj" %get "slot" %get %set-slot ,
+        end-basic-block
+        "obj" get %write-barrier ,
     ] with-template
-    end-basic-block
-    T{ vreg f 1 } %write-barrier ,
 ] "intrinsic" set-word-prop
 
 \ char-slot [
     drop
-    { { 0 "n" } { 1 "str" } } { "str" } [
+    { { any-reg "n" } { any-reg "str" } } { "str" } [
         "n" %get "str" %get %char-slot ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ set-char-slot [
     drop
-    { { 0 "ch" } { 1 "n" } { 2 "str" } } { } [
+    { { any-reg "ch" } { any-reg "n" } { any-reg "str" } } { } [
         "ch" %get "str" %get "n" %get %set-char-slot ,
     ] with-template
 ] "intrinsic" set-word-prop
@@ -108,7 +109,7 @@ namespaces sequences words ;
 
 \ fixnum-bitnot [
     drop
-    { { 0 "x" } } { "x" } [
+    { { any-reg "x" } } { "x" } [
         "x" %get dup %fixnum-bitnot ,
     ] with-template
 ] "intrinsic" set-word-prop
diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index faaac788d0..aaaa28257d 100644
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -116,8 +116,7 @@ SYMBOL: live-r
         pick ?nth dupd ( eq? ) 2drop f [ <clean> ] when
     ] 2map nip ;
 
-: linearize-shuffle ( node -- )
-    compute-free-vregs node-shuffle
+: linearize-shuffle ( shuffle -- )
     dup shuffle-in-d over shuffle-out-d
     shuffle-out-template live-d set
     dup shuffle-in-r over shuffle-out-r
@@ -127,11 +126,16 @@ SYMBOL: live-r
     live-d get live-r get template-outputs ;
 
 M: #shuffle linearize* ( #shuffle -- )
-    linearize-shuffle iterate-next ;
+    node-shuffle linearize-shuffle iterate-next ;
+
+: ensure-vregs ( n -- )
+    sufficient-vregs?
+    [ end-basic-block compute-free-vregs ] unless ;
 
 : linearize-push ( node -- )
     compute-free-vregs
-    >#push< dup length alloc-reg# [ <vreg> ] map
+    >#push< dup length dup ensure-vregs
+    alloc-reg# [ <vreg> ] map
     [ [ load-literal ] 2each ] keep
     phantom-d get phantom-append ;
 
diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index 0cf8216efc..6070e1f69c 100644
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -118,8 +118,10 @@ SYMBOL: free-vregs
 : requested-vregs ( template -- n )
     [ any-reg eq? ] subset length ;
 
-: sufficient-vregs? ( template template -- ? )
-    [ requested-vregs ] 2apply + free-vregs get length <= ;
+: sufficient-vregs? ( n -- ? ) free-vregs get length <= ;
+
+: template-vreg# ( template template -- n )
+    [ requested-vregs ] 2apply + ;
 
 : alloc-regs ( template -- template )
     free-vregs get swap [
@@ -161,7 +163,7 @@ SYMBOL: free-vregs
     ] if ;
 
 : templates-match? ( template template -- ? )
-    2dup sufficient-vregs? [
+    2dup template-vreg# sufficient-vregs? [
         phantom-r get template-match?
         >r phantom-d get template-match? r> and
     ] [
@@ -175,13 +177,17 @@ SYMBOL: free-vregs
     swap phantom-vregs ;
 
 : template-input ( template phantom -- )
-    dup vregs>stack swap [ stack>vregs ] keep phantom-vregs ;
+    swap [ stack>vregs ] keep phantom-vregs ;
 
 : template-inputs ( template template -- )
     2dup templates-match? [
         phantom-r get optimized-input
         phantom-d get optimized-input
+        compute-free-vregs
     ] [
+        phantom-r get vregs>stack
+        phantom-d get vregs>stack
+        compute-free-vregs
         phantom-r get template-input
         phantom-d get template-input
     ] if ;
@@ -207,6 +213,5 @@ SYMBOL: free-vregs
     phantom-d get template-output ;
 
 : with-template ( in out quot -- )
-    compute-free-vregs swap >r
-    >r { } template-inputs r> call r> { } template-outputs ;
-    inline
+    swap >r >r { } template-inputs
+    r> call r> { } template-outputs ; inline
diff --git a/library/test/compiler/templates.factor b/library/test/compiler/templates.factor
index bd0235de4d..5a1ddc5bbc 100644
--- a/library/test/compiler/templates.factor
+++ b/library/test/compiler/templates.factor
@@ -8,6 +8,8 @@ math-internals namespaces test ;
 [ 5000 ] [ [ 5000 ] compile-1 ] unit-test
 [ "hi" ] [ [ "hi" ] compile-1 ] unit-test
 
+[ 1 2 3 4 ] [ [ 1 2 3 4 ] compile-1 ] unit-test
+
 [ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test
 [ 0 ] [ 3 [ tag ] compile-1 ] unit-test
 [ 0 3 ] [ 3 [ [ tag ] keep ] compile-1 ] unit-test

From 4c5dcf4135bcdbed7f6909370f5e11ef5e244a30 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Wed, 19 Apr 2006 20:19:26 +0000
Subject: [PATCH 037/112] New approach to stack dead load/store elimination

---
 library/bootstrap/boot-stage1.factor |   1 +
 library/compiler/intrinsics.factor   |  42 ++++----
 library/compiler/linearizer.factor   |  38 +------
 library/compiler/stack.factor        |  37 +++++++
 library/compiler/templates.factor    | 145 ++++++++++++++-------------
 5 files changed, 134 insertions(+), 129 deletions(-)
 create mode 100644 library/compiler/stack.factor

diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor
index 3fe721874d..e063ee395e 100644
--- a/library/bootstrap/boot-stage1.factor
+++ b/library/bootstrap/boot-stage1.factor
@@ -129,6 +129,7 @@ vectors words ;
         "/library/compiler/vops.factor"
         "/library/compiler/templates.factor"
         "/library/compiler/linearizer.factor"
+        "/library/compiler/stack.factor"
         "/library/compiler/xt.factor"
         "/library/compiler/intrinsics.factor"
         "/library/compiler/generator.factor"
diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index fdd72fadde..a08fe2d53b 100644
--- a/library/compiler/intrinsics.factor
+++ b/library/compiler/intrinsics.factor
@@ -6,52 +6,47 @@ inference kernel kernel-internals lists math math-internals
 namespaces sequences words ;
 
 \ slot [
-    drop
     { { any-reg "obj" } { any-reg "n" } } { "obj" } [
-        "obj" %get %untag ,
-        "n" %get "obj" %get %slot ,
+        "obj" get %untag ,
+        "n" get "obj" get %slot ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ set-slot [
-    drop
     { { any-reg "val" } { any-reg "obj" } { any-reg "slot" } }
     { } [
-        "obj" %get %untag ,
-        "val" %get "obj" %get "slot" %get %set-slot ,
+        "obj" get %untag ,
+        "val" get "obj" get "slot" get %set-slot ,
         end-basic-block
         "obj" get %write-barrier ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ char-slot [
-    drop
     { { any-reg "n" } { any-reg "str" } } { "str" } [
-        "n" %get "str" %get %char-slot ,
+        "n" get "str" get %char-slot ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ set-char-slot [
-    drop
     { { any-reg "ch" } { any-reg "n" } { any-reg "str" } } { } [
-        "ch" %get "str" %get "n" %get %set-char-slot ,
+        "ch" get "str" get "n" get %set-char-slot ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ type [
-    drop
     { { any-reg "in" } } { "in" }
-    [ end-basic-block "in" %get %type , ] with-template
+    [ end-basic-block "in" get %type , ] with-template
 ] "intrinsic" set-word-prop
 
 \ tag [
-    drop
-    { { any-reg "in" } } { "in" } [ "in" %get %tag , ] with-template
+    { { any-reg "in" } } { "in" }
+    [ "in" get %tag , ] with-template
 ] "intrinsic" set-word-prop
 
 : binary-op ( op -- )
     { { 0 "x" } { 1 "y" } } { "x" } [
-        end-basic-block >r "y" %get "x" %get dup r> execute ,
+        end-basic-block >r "y" get "x" get dup r> execute ,
     ] with-template ; inline
 
 {
@@ -63,13 +58,13 @@ namespaces sequences words ;
     { fixnum/i      %fixnum/i      }
     { fixnum*       %fixnum*       }
 } [
-    first2 [ binary-op drop ] curry
+    first2 [ binary-op ] curry
     "intrinsic" set-word-prop
 ] each
 
 : binary-jump ( label op -- )
     { { any-reg "x" } { any-reg "y" } } { } [
-        end-basic-block >r >r "y" %get "x" %get r> r> execute ,
+        end-basic-block >r >r "y" get "x" get r> r> execute ,
     ] with-template ; inline
 
 {
@@ -79,37 +74,34 @@ namespaces sequences words ;
     { fixnum>  %jump-fixnum>  }
     { eq?      %jump-eq?      }
 } [
-    first2 [ binary-jump drop ] curry
+    first2 [ binary-jump ] curry
     "if-intrinsic" set-word-prop
 ] each
 
 \ fixnum-mod [
-    drop
     ! This is not clever. Because of x86, %fixnum-mod is
     ! hard-coded to put its output in vreg 2, which happends to
     ! be EDX there.
     { { 0 "x" } { 1 "y" } } { "out" } [
         end-basic-block
         T{ vreg f 2 } "out" set
-        "y" %get "x" %get "out" %get %fixnum-mod ,
+        "y" get "x" get "out" get %fixnum-mod ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ fixnum/mod [
-    drop
     ! See the remark on fixnum-mod for vreg usage
     { { 0 "x" } { 1 "y" } } { "quo" "rem" } [
         end-basic-block
         T{ vreg f 0 } "quo" set
         T{ vreg f 2 } "rem" set
-        "y" %get "x" %get 2array
-        "rem" %get "quo" %get 2array %fixnum/mod ,
+        "y" get "x" get 2array
+        "rem" get "quo" get 2array %fixnum/mod ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ fixnum-bitnot [
-    drop
     { { any-reg "x" } } { "x" } [
-        "x" %get dup %fixnum-bitnot ,
+        "x" get dup %fixnum-bitnot ,
     ] with-template
 ] "intrinsic" set-word-prop
diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index aaaa28257d..f87c778fe8 100644
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -88,46 +88,16 @@ M: #label linearize* ( node -- next )
 
 M: #call linearize* ( node -- next )
     dup if-intrinsic [
-        >r <label> 2dup r> call
+        >r <label> dup r> call
         >r node-successor r> linearize-if node-successor
     ] [
         dup intrinsic
-        [ call iterate-next ] [ node-param linearize-call ] if*
+        [ call iterate-next ] [ node-param linearize-call ] ?if
     ] if* ;
 
 M: #call-label linearize* ( node -- next )
     node-param renamed-label linearize-call ;
 
-SYMBOL: live-d
-SYMBOL: live-r
-
-: value-dropped? ( value -- ? )
-    dup live-d get member? not
-    swap live-r get member? not and ;
-
-: shuffle-in-template ( values -- template )
-    [
-        dup value-dropped? [ drop f ] when any-reg swap 2array
-    ] map ;
-
-: shuffle-out-template ( instack outstack -- stack )
-    #! Avoid storing a value into its former position.
-    dup length [
-        pick ?nth dupd ( eq? ) 2drop f [ <clean> ] when
-    ] 2map nip ;
-
-: linearize-shuffle ( shuffle -- )
-    dup shuffle-in-d over shuffle-out-d
-    shuffle-out-template live-d set
-    dup shuffle-in-r over shuffle-out-r
-    shuffle-out-template live-r set
-    dup shuffle-in-d shuffle-in-template
-    swap shuffle-in-r shuffle-in-template template-inputs
-    live-d get live-r get template-outputs ;
-
-M: #shuffle linearize* ( #shuffle -- )
-    node-shuffle linearize-shuffle iterate-next ;
-
 : ensure-vregs ( n -- )
     sufficient-vregs?
     [ end-basic-block compute-free-vregs ] unless ;
@@ -145,14 +115,14 @@ M: #push linearize* ( #push -- )
 M: #if linearize* ( node -- next )
     { { 0 "flag" } } { } [
         end-basic-block
-        <label> dup "flag" %get %jump-t ,
+        <label> dup "flag" get %jump-t ,
     ] with-template linearize-if ;
 
 : dispatch-head ( node -- label/node )
     #! Output the jump table insn and return a list of
     #! label/branch pairs.
     { { 0 "n" } } { }
-    [ end-basic-block "n" %get %dispatch , ] with-template
+    [ end-basic-block "n" get %dispatch , ] with-template
     node-children [ <label> dup %target-label ,  2array ] map ;
 
 : dispatch-body ( label/node -- )
diff --git a/library/compiler/stack.factor b/library/compiler/stack.factor
new file mode 100644
index 0000000000..4583328ad4
--- /dev/null
+++ b/library/compiler/stack.factor
@@ -0,0 +1,37 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler
+USING: arrays generic inference io kernel math
+namespaces prettyprint sequences vectors words ;
+
+: phantom-shuffle-input ( n phantom -- seq )
+    2dup length <= [
+        cut-phantom
+    ] [
+        [ phantom-locs ] keep [ length swap tail-slice ] keep
+        append
+    ] if ;
+
+: phantom-shuffle-inputs ( shuffle -- locs locs )
+    dup shuffle-in-d length phantom-d get phantom-shuffle-input
+    swap shuffle-in-r length phantom-r get phantom-shuffle-input ;
+
+: adjust-shuffle ( shuffle -- )
+    dup shuffle-in-d length neg phantom-d get adjust-phantom
+    shuffle-in-r length neg phantom-r get adjust-phantom ;
+
+: sufficient-shuffle-vregs? ( shuffle -- ? )
+    dup shuffle-in-d length phantom-d get length - 0 max
+    over shuffle-in-r length phantom-r get length - 0 max +
+    free-vregs get length <= ;
+
+: phantom-shuffle ( shuffle -- )
+    ! compute-free-vregs sufficient-shuffle-vregs? [
+        end-basic-block compute-free-vregs
+    ! ] unless
+    [ phantom-shuffle-inputs ] keep
+    [ shuffle* ] keep adjust-shuffle
+    (template-outputs) ;
+
+M: #shuffle linearize* ( #shuffle -- )
+    node-shuffle phantom-shuffle iterate-next ;
diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index 6070e1f69c..1126c4f8c9 100644
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -4,17 +4,14 @@ IN: compiler
 USING: arrays generic inference io kernel math
 namespaces prettyprint sequences vectors words ;
 
+SYMBOL: free-vregs
+
 ! A data stack location.
 TUPLE: ds-loc n ;
 
 ! A call stack location.
 TUPLE: cs-loc n ;
 
-! A marker for values which are already stored in this location
-TUPLE: clean ;
-
-C: clean [ set-delegate ] keep ;
-
 TUPLE: phantom-stack height ;
 
 C: phantom-stack ( -- stack )
@@ -84,35 +81,46 @@ SYMBOL: phantom-r
 : load-literal ( obj dest -- )
     over immediate? [ %immediate ] [ %indirect ] if , ;
 
-: vreg>stack ( value loc -- )
-    {
-        { [ over not ] [ 2drop ] }
-        { [ over clean? ] [ 2drop ] }
-        { [ t ] [ %replace , ] }
-    } cond ;
+: finalize-heights ( -- )
+    phantom-d get finalize-height
+    phantom-r get finalize-height ;
 
-: vregs>stack ( phantom -- )
-    dup dup phantom-locs* [ vreg>stack ] 2each
-    0 swap set-length ;
+: alloc-reg ( -- n ) free-vregs get pop ;
 
-: finalize-phantom ( phantom -- )
-    dup finalize-height vregs>stack ;
+: lazy-load ( value loc -- value )
+    over ds-loc? pick cs-loc? or [
+        dupd = [
+            drop f
+        ] [
+            >r alloc-reg <vreg> dup r> %peek ,
+        ] if
+    ] [
+        drop
+    ] if ;
+
+: vregs>stack ( values locs -- )
+    [ over [ %replace , ] [ 2drop ] if ] 2each ;
+
+: finalize-contents ( -- )
+    phantom-d get phantom-r get 2dup
+    [ dup phantom-locs* [ [ lazy-load ] 2map ] keep ] 2apply
+    vregs>stack vregs>stack
+    [ 0 swap set-length ] 2apply ;
 
 : end-basic-block ( -- )
-    phantom-d get finalize-phantom
-    phantom-r get finalize-phantom ;
+    finalize-contents finalize-heights ;
 
 : stack>vreg ( vreg loc -- operand )
-    over [ >r <vreg> dup r> %peek , ] [ 2drop f ] if ;
+    >r <vreg> dup r> %peek , ;
 
 SYMBOL: any-reg
 
-SYMBOL: free-vregs
+: used-vregs ( -- seq )
+    phantom-d get phantom-r get append
+    [ vreg? ] subset [ vreg-n ] map ;
 
 : compute-free-vregs ( -- )
-    phantom-d get phantom-r get append
-    [ vreg? ] subset [ vreg-n ] map
-    vregs length reverse diff
+    used-vregs vregs length reverse diff
     >vector free-vregs set ;
 
 : requested-vregs ( template -- n )
@@ -124,20 +132,13 @@ SYMBOL: free-vregs
     [ requested-vregs ] 2apply + ;
 
 : alloc-regs ( template -- template )
-    free-vregs get swap [
-        dup any-reg eq? [ drop pop ] [ nip ] if
-    ] map-with ;
+    [ dup any-reg eq? [ drop alloc-reg ] when ] map ;
 
 : alloc-reg# ( n -- regs )
     free-vregs [ cut ] change ;
 
-: ?clean ( obj -- obj )
-    dup clean? [ delegate ] when ;
-
-: %get ( obj -- value )
-    get ?clean dup value? [ value-literal ] when ;
-
-: phantom-vregs ( values template -- ) [ second set ] 2each ;
+: phantom-vregs ( values template -- )
+    [ >r f lazy-load r> second set ] 2each ;
 
 : stack>vregs ( phantom template -- values )
     [
@@ -147,7 +148,9 @@ SYMBOL: free-vregs
     ] 2keep length neg swap adjust-phantom ;
 
 : compatible-values? ( value template -- ? )
-    >r ?clean r> {
+    {
+        { [ over ds-loc? ] [ 2drop t ] }
+        { [ over cs-loc? ] [ 2drop t ] }
         { [ dup not ] [ 2drop t ] }
         { [ over not ] [ 2drop f ] }
         { [ dup any-reg eq? ] [ 2drop t ] }
@@ -155,62 +158,64 @@ SYMBOL: free-vregs
     } cond ;
 
 : template-match? ( template phantom -- ? )
-    2dup [ length ] 2apply <= [
-        >r dup length r> tail-slice*
-        t [ swap first compatible-values? and ] 2reduce
-    ] [
-        2drop f
-    ] if ;
+    [ reverse-slice ] 2apply
+    t [ swap first compatible-values? and ] 2reduce ;
 
 : templates-match? ( template template -- ? )
-    2dup template-vreg# sufficient-vregs? [
-        phantom-r get template-match?
-        >r phantom-d get template-match? r> and
+    phantom-r get template-match?
+    >r phantom-d get template-match? r> and ;
+
+: split-template ( template phantom -- slow fast )
+    over length over length <= [
+        drop { } swap
     ] [
-        2drop f
+        length swap cut*
     ] if ;
 
-: optimized-input ( template phantom -- )
+: split-templates ( template template -- slow slow fast fast )
+    >r phantom-d get split-template r>
+    phantom-r get split-template swapd ;
+
+: match-templates ( template template -- slow slow fast fast )
+    2dup templates-match? [ split-templates ] [ { } { } ] if ;
+
+: (fast-input) ( template phantom -- )
     over length neg over adjust-phantom
-    over length over cut-phantom
-    >r dup empty? [ drop ] [ vregs>stack ] if r>
+    over length swap cut-phantom
     swap phantom-vregs ;
 
-: template-input ( template phantom -- )
+: fast-input ( template template -- )
+    phantom-r get (fast-input)
+    phantom-d get (fast-input) ;
+
+: (slow-input) ( template phantom -- )
     swap [ stack>vregs ] keep phantom-vregs ;
 
+: slow-input ( template template -- )
+    phantom-r get (slow-input)
+    phantom-d get (slow-input) ;
+
+: adjust-free-vregs ( -- )
+    used-vregs free-vregs [ diff ] change ;
+
 : template-inputs ( template template -- )
-    2dup templates-match? [
-        phantom-r get optimized-input
-        phantom-d get optimized-input
-        compute-free-vregs
-    ] [
-        phantom-r get vregs>stack
-        phantom-d get vregs>stack
-        compute-free-vregs
-        phantom-r get template-input
-        phantom-d get template-input
-    ] if ;
+    compute-free-vregs
+    match-templates fast-input
+    adjust-free-vregs
+    finalize-contents
+    slow-input ;
 
 : drop-phantom ( -- )
     end-basic-block -1 phantom-d get adjust-phantom ;
 
-: prep-output ( value -- value )
-    dup clean? [ delegate ] [ get ?clean ] if ;
-
 : phantom-append ( seq stack -- )
     over length over adjust-phantom swap nappend ;
 
-: template-output ( seq stack -- )
-    >r [ prep-output ] map r> phantom-append ;
-
-: trace-outputs ( stack stack -- )
-    "==== Template output:" print [ . ] 2apply ;
+: (template-outputs) ( seq stack -- )
+    phantom-r get phantom-append phantom-d get phantom-append ;
 
 : template-outputs ( stack stack -- )
-   !  2dup trace-outputs
-    phantom-r get template-output
-    phantom-d get template-output ;
+    [ [ get ] map ] 2apply (template-outputs) ;
 
 : with-template ( in out quot -- )
     swap >r >r { } template-inputs

From 3ff72629765b5a80955536a7712be19c1242a75e Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Thu, 20 Apr 2006 20:28:08 +0000
Subject: [PATCH 038/112] Fix dead load/store elimination

---
 TODO.FACTOR.txt                        | 4 +++-
 library/compiler/stack.factor          | 8 ++++----
 library/compiler/templates.factor      | 9 +++------
 library/test/compiler/templates.factor | 4 ++++
 4 files changed, 14 insertions(+), 11 deletions(-)

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index c26624ce0a..f3862f6490 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,5 +1,7 @@
 should fix in 0.82:
 
+- constant branch folding
+- getenv, setenv, fast-slot stuff
 - 3 >n fep
 - amd64 %box-struct
 - get factor running on mac intel
@@ -27,6 +29,7 @@ should fix in 0.82:
 
 + ui/help:
 
+- polish OS X menu bar code
 - help search
 - reimplement clicking input
 - reimplement tab completion
@@ -74,7 +77,6 @@ should fix in 0.82:
 - the invalid recursion form case needs to be fixed, for inlines too
 - code gc
 - compiled gc check slows things down
-- fix branch folding
 
 + misc:
 
diff --git a/library/compiler/stack.factor b/library/compiler/stack.factor
index 4583328ad4..9666824bb7 100644
--- a/library/compiler/stack.factor
+++ b/library/compiler/stack.factor
@@ -8,8 +8,8 @@ namespaces prettyprint sequences vectors words ;
     2dup length <= [
         cut-phantom
     ] [
-        [ phantom-locs ] keep [ length swap tail-slice ] keep
-        append
+        [ phantom-locs ] keep [ length swap head-slice* ] keep
+        [ append 0 ] keep set-length
     ] if ;
 
 : phantom-shuffle-inputs ( shuffle -- locs locs )
@@ -26,9 +26,9 @@ namespaces prettyprint sequences vectors words ;
     free-vregs get length <= ;
 
 : phantom-shuffle ( shuffle -- )
-    ! compute-free-vregs sufficient-shuffle-vregs? [
+    compute-free-vregs sufficient-shuffle-vregs? [
         end-basic-block compute-free-vregs
-    ! ] unless
+    ] unless
     [ phantom-shuffle-inputs ] keep
     [ shuffle* ] keep adjust-shuffle
     (template-outputs) ;
diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index 1126c4f8c9..fa0093132c 100644
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -90,7 +90,7 @@ SYMBOL: phantom-r
 : lazy-load ( value loc -- value )
     over ds-loc? pick cs-loc? or [
         dupd = [
-            drop f
+            >r alloc-reg <vreg> dup r> %peek , ! drop f
         ] [
             >r alloc-reg <vreg> dup r> %peek ,
         ] if
@@ -166,11 +166,8 @@ SYMBOL: any-reg
     >r phantom-d get template-match? r> and ;
 
 : split-template ( template phantom -- slow fast )
-    over length over length <= [
-        drop { } swap
-    ] [
-        length swap cut*
-    ] if ;
+    over length over length <=
+    [ drop { } swap ] [ length swap cut* ] if ;
 
 : split-templates ( template template -- slow slow fast fast )
     >r phantom-d get split-template r>
diff --git a/library/test/compiler/templates.factor b/library/test/compiler/templates.factor
index 5a1ddc5bbc..54862ae6eb 100644
--- a/library/test/compiler/templates.factor
+++ b/library/test/compiler/templates.factor
@@ -14,6 +14,10 @@ math-internals namespaces test ;
 [ 0 ] [ 3 [ tag ] compile-1 ] unit-test
 [ 0 3 ] [ 3 [ [ tag ] keep ] compile-1 ] unit-test
 
+[ 2 3 ] [ 3 [ 2 swap ] compile-1 ] unit-test
+
+[ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-1 ] unit-test
+
 [ { 1 2 3 } { 1 4 3 } 8 8 ]
 [ { 1 2 3 } { 1 4 3 } [ over type over type ] compile-1 ]
 unit-test

From 750c0b86b768a22d21e3d935b3aef0c7b8c69ea3 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Fri, 21 Apr 2006 20:51:01 +0000
Subject: [PATCH 039/112] Remove debugging code, fix typo in x86 backend

---
 library/compiler/templates.factor      | 2 +-
 library/compiler/x86/generator.factor  | 2 +-
 library/test/compiler/templates.factor | 3 +++
 3 files changed, 5 insertions(+), 2 deletions(-)

diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index fa0093132c..ea018a4c7a 100644
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -90,7 +90,7 @@ SYMBOL: phantom-r
 : lazy-load ( value loc -- value )
     over ds-loc? pick cs-loc? or [
         dupd = [
-            >r alloc-reg <vreg> dup r> %peek , ! drop f
+            drop f
         ] [
             >r alloc-reg <vreg> dup r> %peek ,
         ] if
diff --git a/library/compiler/x86/generator.factor b/library/compiler/x86/generator.factor
index 317aa8d5d8..1d272a03be 100644
--- a/library/compiler/x86/generator.factor
+++ b/library/compiler/x86/generator.factor
@@ -73,7 +73,7 @@ M: %type generate-node ( vop -- )
     0 scratch object-tag CMP
     "f" get JE
     ! The pointer is not equal to 3. Load the object header.
-    0 output-operand ECX object-tag neg [+] MOV
+    0 output-operand 0 scratch object-tag neg [+] MOV
     ! Mask off header tag, making a fixnum.
     0 output-operand object-tag XOR
     "end" get JMP
diff --git a/library/test/compiler/templates.factor b/library/test/compiler/templates.factor
index 54862ae6eb..dadaf1650d 100644
--- a/library/test/compiler/templates.factor
+++ b/library/test/compiler/templates.factor
@@ -18,6 +18,9 @@ math-internals namespaces test ;
 
 [ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-1 ] unit-test
 
+[ { 1 2 3 } { 1 4 3 } 3 3 ]
+[ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-1 ]
+
 [ { 1 2 3 } { 1 4 3 } 8 8 ]
 [ { 1 2 3 } { 1 4 3 } [ over type over type ] compile-1 ]
 unit-test

From 0842bd6a01226b85358a29cd4d5d66da7e25238a Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sat, 22 Apr 2006 19:26:32 +0000
Subject: [PATCH 040/112] Multiple load elimination

---
 library/compiler/templates.factor      | 67 +++++++++++++++++++-------
 library/test/compiler/templates.factor |  1 +
 2 files changed, 50 insertions(+), 18 deletions(-)

diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index ea018a4c7a..513fcbb928 100644
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: compiler
-USING: arrays generic inference io kernel math
+USING: arrays generic hashtables inference io kernel math
 namespaces prettyprint sequences vectors words ;
 
 SYMBOL: free-vregs
@@ -87,32 +87,59 @@ SYMBOL: phantom-r
 
 : alloc-reg ( -- n ) free-vregs get pop ;
 
-: lazy-load ( value loc -- value )
-    over ds-loc? pick cs-loc? or [
-        dupd = [
-            drop f
-        ] [
-            >r alloc-reg <vreg> dup r> %peek ,
-        ] if
+: loc? ( obj -- ? ) dup ds-loc? swap cs-loc? or ;
+
+: stack>vreg ( vreg# loc -- operand )
+    >r <vreg> dup r> %peek , ;
+
+: stack>new-vreg ( loc -- vreg )
+    alloc-reg swap stack>vreg ;
+
+: vreg>stack ( value loc -- )
+    over loc? [
+        2drop
     ] [
-        drop
+        over [ %replace , ] [ 2drop ] if
     ] if ;
 
-: vregs>stack ( values locs -- )
-    [ over [ %replace , ] [ 2drop ] if ] 2each ;
+: vregs>stack ( phantom -- )
+    [
+        dup phantom-locs* [ vreg>stack ] 2each 0
+    ] keep set-length ;
+
+: (live-locs) ( seq -- seq )
+    dup phantom-locs* [ 2array ] 2map
+    [ first2 over loc? >r = not r> and ] subset
+    [ first ] map ;
+
+: live-locs ( phantom phantom -- hash )
+    [ (live-locs) ] 2apply append prune
+    [ dup stack>new-vreg ] map>hash ;
+
+: lazy-store ( value loc -- )
+    over loc? [
+        2dup = [
+            2drop
+        ] [
+            >r \ live-locs get hash r> vreg>stack 
+        ] if
+    ] [
+        2drop
+    ] if ;
+
+: flush-locs ( phantom phantom -- )
+    [
+        2dup live-locs \ live-locs set
+        [ dup phantom-locs* [ lazy-store ] 2each ] 2apply
+    ] with-scope ;
 
 : finalize-contents ( -- )
-    phantom-d get phantom-r get 2dup
-    [ dup phantom-locs* [ [ lazy-load ] 2map ] keep ] 2apply
-    vregs>stack vregs>stack
-    [ 0 swap set-length ] 2apply ;
+    phantom-d get phantom-r get
+    2dup flush-locs vregs>stack vregs>stack ;
 
 : end-basic-block ( -- )
     finalize-contents finalize-heights ;
 
-: stack>vreg ( vreg loc -- operand )
-    >r <vreg> dup r> %peek , ;
-
 SYMBOL: any-reg
 
 : used-vregs ( -- seq )
@@ -137,6 +164,10 @@ SYMBOL: any-reg
 : alloc-reg# ( n -- regs )
     free-vregs [ cut ] change ;
 
+: lazy-load ( value loc -- value )
+    over loc?
+    [ dupd = [ drop f ] [ stack>new-vreg ] if ] [ drop ] if ;
+
 : phantom-vregs ( values template -- )
     [ >r f lazy-load r> second set ] 2each ;
 
diff --git a/library/test/compiler/templates.factor b/library/test/compiler/templates.factor
index dadaf1650d..8a91d7f75b 100644
--- a/library/test/compiler/templates.factor
+++ b/library/test/compiler/templates.factor
@@ -20,6 +20,7 @@ math-internals namespaces test ;
 
 [ { 1 2 3 } { 1 4 3 } 3 3 ]
 [ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-1 ]
+unit-test
 
 [ { 1 2 3 } { 1 4 3 } 8 8 ]
 [ { 1 2 3 } { 1 4 3 } [ over type over type ] compile-1 ]

From ac678bceb09187b46cbef1d520119e6851b39a09 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sun, 23 Apr 2006 05:40:49 +0000
Subject: [PATCH 041/112] Register allocation fixes

---
 library/compiler/intrinsics.factor     | 10 +++++-----
 library/compiler/linearizer.factor     | 14 -------------
 library/compiler/stack.factor          | 20 ++++++++++++-------
 library/compiler/templates.factor      | 27 ++++++++++++++++----------
 library/test/compiler/templates.factor |  2 ++
 5 files changed, 37 insertions(+), 36 deletions(-)

diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index a08fe2d53b..4958718f81 100644
--- a/library/compiler/intrinsics.factor
+++ b/library/compiler/intrinsics.factor
@@ -17,7 +17,7 @@ namespaces sequences words ;
     { } [
         "obj" get %untag ,
         "val" get "obj" get "slot" get %set-slot ,
-        end-basic-block
+        finalize-contents
         "obj" get %write-barrier ,
     ] with-template
 ] "intrinsic" set-word-prop
@@ -36,7 +36,7 @@ namespaces sequences words ;
 
 \ type [
     { { any-reg "in" } } { "in" }
-    [ end-basic-block "in" get %type , ] with-template
+    [ finalize-contents "in" get %type , ] with-template
 ] "intrinsic" set-word-prop
 
 \ tag [
@@ -46,7 +46,7 @@ namespaces sequences words ;
 
 : binary-op ( op -- )
     { { 0 "x" } { 1 "y" } } { "x" } [
-        end-basic-block >r "y" get "x" get dup r> execute ,
+        finalize-contents >r "y" get "x" get dup r> execute ,
     ] with-template ; inline
 
 {
@@ -83,7 +83,7 @@ namespaces sequences words ;
     ! hard-coded to put its output in vreg 2, which happends to
     ! be EDX there.
     { { 0 "x" } { 1 "y" } } { "out" } [
-        end-basic-block
+        finalize-contents
         T{ vreg f 2 } "out" set
         "y" get "x" get "out" get %fixnum-mod ,
     ] with-template
@@ -92,7 +92,7 @@ namespaces sequences words ;
 \ fixnum/mod [
     ! See the remark on fixnum-mod for vreg usage
     { { 0 "x" } { 1 "y" } } { "quo" "rem" } [
-        end-basic-block
+        finalize-contents
         T{ vreg f 0 } "quo" set
         T{ vreg f 2 } "rem" set
         "y" get "x" get 2array
diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index f87c778fe8..5d80252c18 100644
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -98,20 +98,6 @@ M: #call linearize* ( node -- next )
 M: #call-label linearize* ( node -- next )
     node-param renamed-label linearize-call ;
 
-: ensure-vregs ( n -- )
-    sufficient-vregs?
-    [ end-basic-block compute-free-vregs ] unless ;
-
-: linearize-push ( node -- )
-    compute-free-vregs
-    >#push< dup length dup ensure-vregs
-    alloc-reg# [ <vreg> ] map
-    [ [ load-literal ] 2each ] keep
-    phantom-d get phantom-append ;
-
-M: #push linearize* ( #push -- )
-    linearize-push iterate-next ;
-
 M: #if linearize* ( node -- next )
     { { 0 "flag" } } { } [
         end-basic-block
diff --git a/library/compiler/stack.factor b/library/compiler/stack.factor
index 9666824bb7..4e250abbda 100644
--- a/library/compiler/stack.factor
+++ b/library/compiler/stack.factor
@@ -20,18 +20,24 @@ namespaces prettyprint sequences vectors words ;
     dup shuffle-in-d length neg phantom-d get adjust-phantom
     shuffle-in-r length neg phantom-r get adjust-phantom ;
 
-: sufficient-shuffle-vregs? ( shuffle -- ? )
-    dup shuffle-in-d length phantom-d get length - 0 max
-    over shuffle-in-r length phantom-r get length - 0 max +
-    free-vregs get length <= ;
+: shuffle-vregs# ( shuffle -- n )
+    dup shuffle-in-d swap shuffle-in-r additional-vregs# ;
 
 : phantom-shuffle ( shuffle -- )
-    compute-free-vregs sufficient-shuffle-vregs? [
-        end-basic-block compute-free-vregs
-    ] unless
+    dup shuffle-vregs# ensure-vregs
     [ phantom-shuffle-inputs ] keep
     [ shuffle* ] keep adjust-shuffle
     (template-outputs) ;
 
 M: #shuffle linearize* ( #shuffle -- )
     node-shuffle phantom-shuffle iterate-next ;
+
+: linearize-push ( node -- )
+    compute-free-vregs
+    >#push< dup length dup ensure-vregs
+    alloc-reg# [ <vreg> ] map
+    [ [ load-literal ] 2each ] keep
+    phantom-d get phantom-append ;
+
+M: #push linearize* ( #push -- )
+    linearize-push iterate-next ;
diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index 513fcbb928..6f6aff7c44 100644
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -127,6 +127,8 @@ SYMBOL: phantom-r
         2drop
     ] if ;
 
+: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
+
 : flush-locs ( phantom phantom -- )
     [
         2dup live-locs \ live-locs set
@@ -134,8 +136,7 @@ SYMBOL: phantom-r
     ] with-scope ;
 
 : finalize-contents ( -- )
-    phantom-d get phantom-r get
-    2dup flush-locs vregs>stack vregs>stack ;
+    phantoms 2dup flush-locs [ vregs>stack ] 2apply ;
 
 : end-basic-block ( -- )
     finalize-contents finalize-heights ;
@@ -143,8 +144,7 @@ SYMBOL: phantom-r
 SYMBOL: any-reg
 
 : used-vregs ( -- seq )
-    phantom-d get phantom-r get append
-    [ vreg? ] subset [ vreg-n ] map ;
+    phantoms append [ vreg? ] subset [ vreg-n ] map ;
 
 : compute-free-vregs ( -- )
     used-vregs vregs length reverse diff
@@ -153,8 +153,6 @@ SYMBOL: any-reg
 : requested-vregs ( template -- n )
     [ any-reg eq? ] subset length ;
 
-: sufficient-vregs? ( n -- ? ) free-vregs get length <= ;
-
 : template-vreg# ( template template -- n )
     [ requested-vregs ] 2apply + ;
 
@@ -164,6 +162,18 @@ SYMBOL: any-reg
 : alloc-reg# ( n -- regs )
     free-vregs [ cut ] change ;
 
+: additional-vregs# ( seq seq -- n )
+    2array phantoms 2array [ [ length ] map ] 2apply v-
+    0 [ 0 max + ] reduce ;
+
+: free-vregs* ( -- n )
+    free-vregs get length
+    phantoms [ [ loc? ] subset length ] 2apply + - ;
+
+: ensure-vregs ( n -- )
+    compute-free-vregs free-vregs* <=
+    [ finalize-contents compute-free-vregs ] unless ;
+
 : lazy-load ( value loc -- value )
     over loc?
     [ dupd = [ drop f ] [ stack>new-vreg ] if ] [ drop ] if ;
@@ -227,15 +237,12 @@ SYMBOL: any-reg
     used-vregs free-vregs [ diff ] change ;
 
 : template-inputs ( template template -- )
-    compute-free-vregs
+    2dup additional-vregs# ensure-vregs
     match-templates fast-input
     adjust-free-vregs
     finalize-contents
     slow-input ;
 
-: drop-phantom ( -- )
-    end-basic-block -1 phantom-d get adjust-phantom ;
-
 : phantom-append ( seq stack -- )
     over length over adjust-phantom swap nappend ;
 
diff --git a/library/test/compiler/templates.factor b/library/test/compiler/templates.factor
index 8a91d7f75b..b6e14e93b2 100644
--- a/library/test/compiler/templates.factor
+++ b/library/test/compiler/templates.factor
@@ -16,6 +16,8 @@ math-internals namespaces test ;
 
 [ 2 3 ] [ 3 [ 2 swap ] compile-1 ] unit-test
 
+[ 2 1 3 4 ] [ 1 2 [ swap 3 4 ] compile-1 ] unit-test
+
 [ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-1 ] unit-test
 
 [ { 1 2 3 } { 1 4 3 } 3 3 ]

From 54932adb21d24dc58359811b6c9d0be101558704 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sun, 23 Apr 2006 06:24:14 +0000
Subject: [PATCH 042/112] Benchmark fixes, remove some crusty old code

---
 library/inference/optimizer.factor        | 26 +----------------------
 library/inference/shuffle.factor          | 22 -------------------
 library/test/benchmark/fib.factor         |  2 +-
 library/test/benchmark/prettyprint.factor |  5 ++++-
 library/test/benchmark/sort.factor        |  2 +-
 5 files changed, 7 insertions(+), 50 deletions(-)

diff --git a/library/inference/optimizer.factor b/library/inference/optimizer.factor
index 02b51c3aa7..3984ae8fd1 100644
--- a/library/inference/optimizer.factor
+++ b/library/inference/optimizer.factor
@@ -24,38 +24,14 @@ GENERIC: optimize-node* ( node -- node/t )
         optimizer-changed get
     ] with-node-iterator [ optimize ] when ;
 
-: prune-if ( node quot -- successor/t )
-    over >r call [ r> node-successor ] [ r> drop t ] if ;
-    inline
-
 ! Generic nodes
 M: f optimize-node* drop t ;
 
 M: node optimize-node* ( node -- t ) drop t ;
 
-! #shuffle
-: can-compose? ( shuffle -- ? )
-    dup shuffle-in-d length swap shuffle-in-r length +
-    vregs length <= ;
-
-: compose-shuffle-nodes ( #shuffle #shuffle -- #shuffle/t )
-    [ [ node-shuffle ] 2apply compose-shuffle ] keep
-    over can-compose?
-    [ [ set-node-shuffle ] keep ] [ 2drop t ] if ;
-
-M: #shuffle optimize-node*  ( node -- node/t )
-    dup node-successor dup #shuffle? [
-        compose-shuffle-nodes
-    ] [
-        drop [
-            dup node-in-d over node-out-d sequence=
-            >r dup node-in-r swap node-out-r sequence= r> and
-        ] prune-if
-    ] if ;
-
 ! #push
 M: #push optimize-node*  ( node -- node/t )
-    [ node-out-d empty? ] prune-if ;
+    dup node-out-d empty? [ node-successor ] [ drop t ] if ;
 
 ! #return
 M: #return optimize-node* ( node -- node/t )
diff --git a/library/inference/shuffle.factor b/library/inference/shuffle.factor
index 5baa5f21b9..3f783845c6 100644
--- a/library/inference/shuffle.factor
+++ b/library/inference/shuffle.factor
@@ -51,28 +51,6 @@ TUPLE: shuffle in-d in-r out-d out-r ;
     #! the shuffle.
     [ split-shuffle ] keep shuffle* join-shuffle ;
 
-: fix-compose-d ( s1 s2 -- )
-    over shuffle-out-d over shuffle-in-d [ length ] 2apply < [
-        over shuffle-out-d length over shuffle-in-d head*
-        [ pick shuffle-in-d append pick set-shuffle-in-d ] keep
-        pick shuffle-out-d append pick set-shuffle-out-d
-    ] when 2drop ;
-
-: fix-compose-r ( s1 s2 -- )
-    over shuffle-out-r over shuffle-in-r [ length ] 2apply < [
-        over shuffle-out-r length over shuffle-in-r head*
-        [ pick shuffle-in-r append pick set-shuffle-in-r ] keep
-        pick shuffle-out-r append pick set-shuffle-out-r
-    ] when 2drop ;
-
-: compose-shuffle ( s1 s2 -- s1+s2 )
-    #! s1's d and r output lengths must be at least the required
-    #! length for the shuffle. If they are not, a special
-    #! behavior is used which is only valid for the optimizer.
-    [ clone ] 2apply 2dup fix-compose-d 2dup fix-compose-r
-    >r dup shuffle-out-d over shuffle-out-r r> shuffle
-    >r >r dup shuffle-in-d swap shuffle-in-r r> r> <shuffle> ;
-
 M: shuffle clone ( shuffle -- shuffle )
     [ shuffle-in-d clone ] keep
     [ shuffle-in-r clone ] keep
diff --git a/library/test/benchmark/fib.factor b/library/test/benchmark/fib.factor
index 0528391b57..df55485210 100644
--- a/library/test/benchmark/fib.factor
+++ b/library/test/benchmark/fib.factor
@@ -54,4 +54,4 @@ SYMBOL: n
         ] if
     ] with-scope ; compiled
 
-[ 9227465 ] [ 34 namespace-fib ] unit-test
+[ 1346269 ] [ 30 namespace-fib ] unit-test
diff --git a/library/test/benchmark/prettyprint.factor b/library/test/benchmark/prettyprint.factor
index fa2f583b01..fbda45ac91 100644
--- a/library/test/benchmark/prettyprint.factor
+++ b/library/test/benchmark/prettyprint.factor
@@ -5,5 +5,8 @@ USE: test
 USE: words
 USE: kernel
 USE: sequences
+USE: io
 
-[ ] [ vocabs [ words [ see ] each ] each ] unit-test
+[ ] [
+    [ vocabs [ words [ see ] each ] each ] string-out drop
+] unit-test
diff --git a/library/test/benchmark/sort.factor b/library/test/benchmark/sort.factor
index 806dd786e9..2fdde603e7 100644
--- a/library/test/benchmark/sort.factor
+++ b/library/test/benchmark/sort.factor
@@ -2,6 +2,6 @@ IN: temporary
 USING: compiler kernel math sequences test ;
 
 : sort-benchmark
-    100000 [ drop 100000 random-int ] map number-sort drop ; compiled
+    100000 [ drop 100000 random-int ] map natural-sort drop ; compiled
 
 [ ] [ sort-benchmark ] unit-test

From 3839e481c518caa5b86eb89772db54b637cc6d37 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sun, 23 Apr 2006 19:32:08 +0000
Subject: [PATCH 043/112] New, very hairy with-template specifier style

---
 library/compiler/intrinsics.factor | 58 +++++++++++++++------
 library/compiler/linearizer.factor |  9 ++--
 library/compiler/templates.factor  | 81 +++++++++++++++++++-----------
 library/compiler/vops.factor       |  3 --
 4 files changed, 100 insertions(+), 51 deletions(-)

diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index 4958718f81..606bd61669 100644
--- a/library/compiler/intrinsics.factor
+++ b/library/compiler/intrinsics.factor
@@ -6,15 +6,20 @@ inference kernel kernel-internals lists math math-internals
 namespaces sequences words ;
 
 \ slot [
-    { { any-reg "obj" } { any-reg "n" } } { "obj" } [
+    H{
+        { +input-d { { f "obj" } { f "n" } } }
+        { +output-d { "obj" } }
+    } [
         "obj" get %untag ,
         "n" get "obj" get %slot ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ set-slot [
-    { { any-reg "val" } { any-reg "obj" } { any-reg "slot" } }
-    { } [
+    H{
+        { +input-d { { f "val" } { f "obj" } { f "slot" } } }
+        { +clobber { "obj" } }
+    } [
         "obj" get %untag ,
         "val" get "obj" get "slot" get %set-slot ,
         finalize-contents
@@ -23,29 +28,41 @@ namespaces sequences words ;
 ] "intrinsic" set-word-prop
 
 \ char-slot [
-    { { any-reg "n" } { any-reg "str" } } { "str" } [
+    H{
+        { +input-d { { f "n" } { f "str" } } }
+        { +output-d { "str" } }
+    } [
         "n" get "str" get %char-slot ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ set-char-slot [
-    { { any-reg "ch" } { any-reg "n" } { any-reg "str" } } { } [
+    H{
+        { +input-d { { f "ch" } { f "n" } { f "str" } } }
+    } [
         "ch" get "str" get "n" get %set-char-slot ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ type [
-    { { any-reg "in" } } { "in" }
-    [ finalize-contents "in" get %type , ] with-template
+    H{
+        { +input-d { { f "in" } } }
+        { +output-d { "in" } }
+    } [ finalize-contents "in" get %type , ] with-template
 ] "intrinsic" set-word-prop
 
 \ tag [
-    { { any-reg "in" } } { "in" }
-    [ "in" get %tag , ] with-template
+    H{
+        { +input-d { { f "in" } } }
+        { +output-d { "in" } }
+    } [ "in" get %tag , ] with-template
 ] "intrinsic" set-word-prop
 
 : binary-op ( op -- )
-    { { 0 "x" } { 1 "y" } } { "x" } [
+    H{
+        { +input-d { { 0 "x" } { 1 "y" } } }
+        { +output-d { "x" } }
+    } [
         finalize-contents >r "y" get "x" get dup r> execute ,
     ] with-template ; inline
 
@@ -63,7 +80,9 @@ namespaces sequences words ;
 ] each
 
 : binary-jump ( label op -- )
-    { { any-reg "x" } { any-reg "y" } } { } [
+    H{
+        { +input-d { { f "x" } { f "y" } } }
+    } [
         end-basic-block >r >r "y" get "x" get r> r> execute ,
     ] with-template ; inline
 
@@ -82,7 +101,10 @@ namespaces sequences words ;
     ! This is not clever. Because of x86, %fixnum-mod is
     ! hard-coded to put its output in vreg 2, which happends to
     ! be EDX there.
-    { { 0 "x" } { 1 "y" } } { "out" } [
+    H{
+        { +input-d { { 0 "x" } { 1 "y" } } }
+        { +output-d { "out" } }
+    } [
         finalize-contents
         T{ vreg f 2 } "out" set
         "y" get "x" get "out" get %fixnum-mod ,
@@ -91,7 +113,10 @@ namespaces sequences words ;
 
 \ fixnum/mod [
     ! See the remark on fixnum-mod for vreg usage
-    { { 0 "x" } { 1 "y" } } { "quo" "rem" } [
+    H{
+        { +input-d { { 0 "x" } { 1 "y" } } }
+        { +output-d { "quo" "rem" } }
+    } [
         finalize-contents
         T{ vreg f 0 } "quo" set
         T{ vreg f 2 } "rem" set
@@ -101,7 +126,8 @@ namespaces sequences words ;
 ] "intrinsic" set-word-prop
 
 \ fixnum-bitnot [
-    { { any-reg "x" } } { "x" } [
-        "x" get dup %fixnum-bitnot ,
-    ] with-template
+    H{
+        { +input-d { { f "x" } } }
+        { +output-d { "x" } }
+    } [ "x" get dup %fixnum-bitnot , ] with-template
 ] "intrinsic" set-word-prop
diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index 5d80252c18..d7d2981b8b 100644
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -99,7 +99,9 @@ M: #call-label linearize* ( node -- next )
     node-param renamed-label linearize-call ;
 
 M: #if linearize* ( node -- next )
-    { { 0 "flag" } } { } [
+    H{
+        { +input-d { { 0 "flag" } } }
+    } [
         end-basic-block
         <label> dup "flag" get %jump-t ,
     ] with-template linearize-if ;
@@ -107,8 +109,9 @@ M: #if linearize* ( node -- next )
 : dispatch-head ( node -- label/node )
     #! Output the jump table insn and return a list of
     #! label/branch pairs.
-    { { 0 "n" } } { }
-    [ end-basic-block "n" get %dispatch , ] with-template
+    H{
+        { +input-d { { 0 "n" } } }
+    } [ end-basic-block "n" get %dispatch , ] with-template
     node-children [ <label> dup %target-label ,  2array ] map ;
 
 : dispatch-body ( label/node -- )
diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index 6f6aff7c44..3969dbd2ab 100644
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -141,8 +141,6 @@ SYMBOL: phantom-r
 : end-basic-block ( -- )
     finalize-contents finalize-heights ;
 
-SYMBOL: any-reg
-
 : used-vregs ( -- seq )
     phantoms append [ vreg? ] subset [ vreg-n ] map ;
 
@@ -151,13 +149,13 @@ SYMBOL: any-reg
     >vector free-vregs set ;
 
 : requested-vregs ( template -- n )
-    [ any-reg eq? ] subset length ;
+    0 [ [ 1+ ] unless ] reduce ;
 
 : template-vreg# ( template template -- n )
     [ requested-vregs ] 2apply + ;
 
 : alloc-regs ( template -- template )
-    [ dup any-reg eq? [ drop alloc-reg ] when ] map ;
+    [ [ alloc-reg ] unless* ] map ;
 
 : alloc-reg# ( n -- regs )
     free-vregs [ cut ] change ;
@@ -190,11 +188,9 @@ SYMBOL: any-reg
 
 : compatible-values? ( value template -- ? )
     {
-        { [ over ds-loc? ] [ 2drop t ] }
-        { [ over cs-loc? ] [ 2drop t ] }
+        { [ over loc? ] [ 2drop t ] }
         { [ dup not ] [ 2drop t ] }
         { [ over not ] [ 2drop f ] }
-        { [ dup any-reg eq? ] [ 2drop t ] }
         { [ dup integer? ] [ swap vreg-n = ] }
     } cond ;
 
@@ -223,35 +219,62 @@ SYMBOL: any-reg
     swap phantom-vregs ;
 
 : fast-input ( template template -- )
-    phantom-r get (fast-input)
-    phantom-d get (fast-input) ;
+    phantoms swapd (fast-input) (fast-input) ;
 
 : (slow-input) ( template phantom -- )
     swap [ stack>vregs ] keep phantom-vregs ;
 
-: slow-input ( template template -- )
-    phantom-r get (slow-input)
-    phantom-d get (slow-input) ;
-
-: adjust-free-vregs ( -- )
-    used-vregs free-vregs [ diff ] change ;
-
-: template-inputs ( template template -- )
-    2dup additional-vregs# ensure-vregs
-    match-templates fast-input
-    adjust-free-vregs
-    finalize-contents
-    slow-input ;
-
 : phantom-append ( seq stack -- )
     over length over adjust-phantom swap nappend ;
 
 : (template-outputs) ( seq stack -- )
-    phantom-r get phantom-append phantom-d get phantom-append ;
+    phantoms swapd phantom-append phantom-append ;
 
-: template-outputs ( stack stack -- )
-    [ [ get ] map ] 2apply (template-outputs) ;
+SYMBOL: +input-d
+SYMBOL: +input-r
+SYMBOL: +output-d
+SYMBOL: +output-r
+SYMBOL: +scratch
+SYMBOL: +clobber
 
-: with-template ( in out quot -- )
-    swap >r >r { } template-inputs
-    r> call r> { } template-outputs ; inline
+: fix-spec ( spec -- spec )
+    H{
+        { +input-d { } }
+        { +input-r { } }
+        { +output-d { } }
+        { +output-r { } }
+        { +scratch { } }
+        { +clobber { } }
+    } swap hash-union ;
+
+: adjust-free-vregs ( -- )
+    used-vregs free-vregs [ diff ] change ;
+
+: output-vregs ( -- seq )
+    { +output-d +output-r +clobber }
+    [ get [ get ] map ] map concat ;
+
+: finalize-contents? ( -- ? )
+    output-vregs phantoms append
+    [ swap member? ] contains-with? ;
+
+: slow-input ( template template -- )
+    2dup [ empty? not ] 2apply or finalize-contents? or
+    [ finalize-contents ] when
+    phantoms swapd (slow-input) (slow-input) ;
+
+: template-inputs ( -- )
+    +input-d get +input-r get
+    2dup additional-vregs# ensure-vregs
+    match-templates fast-input
+    adjust-free-vregs
+    slow-input ;
+
+: template-outputs ( -- )
+    +output-d get +output-r get [ [ get ] map ] 2apply
+    (template-outputs) ;
+
+: with-template ( spec quot -- )
+    swap fix-spec [
+        template-inputs call template-outputs
+    ] bind ; inline
diff --git a/library/compiler/vops.factor b/library/compiler/vops.factor
index 83a77e36fd..d65a85bb10 100644
--- a/library/compiler/vops.factor
+++ b/library/compiler/vops.factor
@@ -106,9 +106,6 @@ TUPLE: %label ;
 C: %label make-vop ;
 : %label label-vop <%label> ;
 
-! Return vops take a label that is ignored, to have the
-! same stack effect as jumps. This is needed for the
-! simplifier.
 TUPLE: %return ;
 C: %return make-vop ;
 : %return empty-vop <%return> ;

From 7542f5a026abaf1c19e6c778e67793358c1adb5d Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sun, 23 Apr 2006 21:29:42 +0000
Subject: [PATCH 044/112] Fix examples and contrib

---
 contrib/random-tester/random-tester.factor | 2 +-
 contrib/splay-trees.factor                 | 4 ++--
 examples/numbers-game.factor               | 2 +-
 examples/turing.factor                     | 2 +-
 4 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/contrib/random-tester/random-tester.factor b/contrib/random-tester/random-tester.factor
index 5c995d2b0e..20dca6fc48 100644
--- a/contrib/random-tester/random-tester.factor
+++ b/contrib/random-tester/random-tester.factor
@@ -241,7 +241,7 @@ SYMBOL: first-arg
     dup .
     [ last-quot set ] keep
     [ call ] keep
-    [ last car update-xt ] keep call
+    [ peek update-xt ] keep call
     2dup swap unparse write " " write unparse print
     = [ "update-xt problem" throw ] unless ;
 
diff --git a/contrib/splay-trees.factor b/contrib/splay-trees.factor
index fe9bfa33c7..7f8b7e20b8 100644
--- a/contrib/splay-trees.factor
+++ b/contrib/splay-trees.factor
@@ -111,5 +111,5 @@ DEFER: (splay)
 USING: namespaces words ;
 
 <splay-tree> "foo" set
-[ dup word-name "foo" get set-splay ] each-word
-[ dup word-name "foo" get get-splay drop ] each-word
+all-words [ dup word-name "foo" get set-splay ] each
+all-words [ dup word-name "foo" get get-splay drop ] each
diff --git a/examples/numbers-game.factor b/examples/numbers-game.factor
index ab99e51f5b..75e3b382db 100644
--- a/examples/numbers-game.factor
+++ b/examples/numbers-game.factor
@@ -1,5 +1,5 @@
 IN: numbers-game
-USING: kernel math parser random io ;
+USING: kernel math parser io ;
 
 : read-number ( -- n ) readln string>number ;
 
diff --git a/examples/turing.factor b/examples/turing.factor
index 945cab37de..72987a56fb 100644
--- a/examples/turing.factor
+++ b/examples/turing.factor
@@ -38,7 +38,7 @@ SYMBOL: position
 SYMBOL: tape
 
 ! Initial tape
-20 zero-array >vector tape set
+20 0 <array> >vector tape set
 
 : sym ( -- sym )
     #! Symbol at head position.

From ed39103cf89bd4716d19524e64c73f977e0be267 Mon Sep 17 00:00:00 2001
From: "chris.double" <chris.double@double.co.nz>
Date: Sun, 23 Apr 2006 21:30:35 +0000
Subject: [PATCH 045/112] fix coroutine code for abscence of tree-each

---
 contrib/coroutines.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/contrib/coroutines.factor b/contrib/coroutines.factor
index 8facf45139..2471c4ebed 100644
--- a/contrib/coroutines.factor
+++ b/contrib/coroutines.factor
@@ -56,8 +56,8 @@ TUPLE: coroutine resumecc exitcc ;
 USE: prettyprint
 USE: sequences
 
-: test1 ( -- co )
-  [ swap [ over coyield 2drop ] tree-each f swap coyield ] cocreate ; 
+: test1 ( list -- co )
+  [ swap [ over coyield 2drop ] each f swap coyield ] cocreate ; 
   
 : test2 ( -- co )
   [ 1 over coyield drop 2 over coyield drop 3 over coyield ] cocreate ;

From 8eca428594fbe6a76be43acfc5cb9108493994c6 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Mon, 24 Apr 2006 21:52:03 +0000
Subject: [PATCH 046/112] Huge compiler patch; two new fixnum-fast and
 fixnum+fast primitives which do not perform overflow checks

---
 library/bootstrap/primitives.factor           |  2 +
 .../collections/sequence-combinators.facts    |  2 +-
 library/compiler/intrinsics.factor            | 60 +++++++-----
 library/compiler/linearizer.factor            |  4 +-
 library/compiler/ppc/fixnum.factor            |  4 +
 library/compiler/stack.factor                 |  6 +-
 library/compiler/templates.factor             | 98 +++++++++----------
 library/compiler/vops.factor                  |  4 +
 library/compiler/x86/fixnum.factor            |  4 +
 library/inference/known-words.factor          |  8 ++
 library/inference/optimizer.factor            | 10 +-
 library/kernel.factor                         |  4 +-
 library/test/benchmark/empty-loop.factor      |  7 +-
 library/test/benchmark/fib.factor             | 13 ++-
 library/test/compiler/templates.factor        | 45 ++++++++-
 library/test/inference.factor                 | 16 ---
 native/fixnum.c                               | 14 +++
 native/fixnum.h                               |  2 +
 native/primitives.c                           |  7 +-
 native/primitives.h                           |  1 -
 20 files changed, 204 insertions(+), 107 deletions(-)

diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor
index ccad6ca33b..fee3cec058 100644
--- a/library/bootstrap/primitives.factor
+++ b/library/bootstrap/primitives.factor
@@ -59,7 +59,9 @@ call
     { "bits>double" "math"                  }
     { "<complex>" "math-internals"          }
     { "fixnum+" "math-internals"            }
+    { "fixnum+fast" "math-internals"        }
     { "fixnum-" "math-internals"            }
+    { "fixnum-fast" "math-internals"        }
     { "fixnum*" "math-internals"            }
     { "fixnum/i" "math-internals"           }
     { "fixnum/f" "math-internals"           }
diff --git a/library/collections/sequence-combinators.facts b/library/collections/sequence-combinators.facts
index fa38347f6c..0b21654f74 100644
--- a/library/collections/sequence-combinators.facts
+++ b/library/collections/sequence-combinators.facts
@@ -3,7 +3,7 @@ USING: help math sequences-internals ;
 
 HELP: collect "( n quot -- array )"
 { $values { "n" "a non-negative integer" } { "quot" "a quotation with stack effect " { $snippet "( n -- value )" } } { "array" "an array with " { $snippet "n" } " elements" } }
-{ $description "A primitive mapping operation that applies a quotation to all integers from 0 up to but not including " { $snippet "n" } ", and collects the results in a new array. Client code should use " { $snippet map } " instead." } ;
+{ $description "A primitive mapping operation that applies a quotation to all integers from 0 up to but not including " { $snippet "n" } ", and collects the results in a new array. Client code should use " { $link map } " instead." } ;
 
 HELP: each "( seq quot -- )"
 { $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index 606bd61669..f1c77dc471 100644
--- a/library/compiler/intrinsics.factor
+++ b/library/compiler/intrinsics.factor
@@ -7,8 +7,8 @@ namespaces sequences words ;
 
 \ slot [
     H{
-        { +input-d { { f "obj" } { f "n" } } }
-        { +output-d { "obj" } }
+        { +input { { f "obj" } { f "n" } } }
+        { +output { "obj" } }
     } [
         "obj" get %untag ,
         "n" get "obj" get %slot ,
@@ -17,7 +17,7 @@ namespaces sequences words ;
 
 \ set-slot [
     H{
-        { +input-d { { f "val" } { f "obj" } { f "slot" } } }
+        { +input { { f "val" } { f "obj" } { f "slot" } } }
         { +clobber { "obj" } }
     } [
         "obj" get %untag ,
@@ -29,8 +29,8 @@ namespaces sequences words ;
 
 \ char-slot [
     H{
-        { +input-d { { f "n" } { f "str" } } }
-        { +output-d { "str" } }
+        { +input { { f "n" } { f "str" } } }
+        { +output { "str" } }
     } [
         "n" get "str" get %char-slot ,
     ] with-template
@@ -38,7 +38,7 @@ namespaces sequences words ;
 
 \ set-char-slot [
     H{
-        { +input-d { { f "ch" } { f "n" } { f "str" } } }
+        { +input { { f "ch" } { f "n" } { f "str" } } }
     } [
         "ch" get "str" get "n" get %set-char-slot ,
     ] with-template
@@ -46,22 +46,22 @@ namespaces sequences words ;
 
 \ type [
     H{
-        { +input-d { { f "in" } } }
-        { +output-d { "in" } }
+        { +input { { f "in" } } }
+        { +output { "in" } }
     } [ finalize-contents "in" get %type , ] with-template
 ] "intrinsic" set-word-prop
 
 \ tag [
     H{
-        { +input-d { { f "in" } } }
-        { +output-d { "in" } }
+        { +input { { f "in" } } }
+        { +output { "in" } }
     } [ "in" get %tag , ] with-template
 ] "intrinsic" set-word-prop
 
 : binary-op ( op -- )
     H{
-        { +input-d { { 0 "x" } { 1 "y" } } }
-        { +output-d { "x" } }
+        { +input { { 0 "x" } { 1 "y" } } }
+        { +output { "x" } }
     } [
         finalize-contents >r "y" get "x" get dup r> execute ,
     ] with-template ; inline
@@ -69,9 +69,6 @@ namespaces sequences words ;
 {
     { fixnum+       %fixnum+       }
     { fixnum-       %fixnum-       }
-    { fixnum-bitand %fixnum-bitand }
-    { fixnum-bitor  %fixnum-bitor  }
-    { fixnum-bitxor %fixnum-bitxor }
     { fixnum/i      %fixnum/i      }
     { fixnum*       %fixnum*       }
 } [
@@ -79,9 +76,28 @@ namespaces sequences words ;
     "intrinsic" set-word-prop
 ] each
 
+: binary-op-fast ( op -- )
+    H{
+        { +input { { f "x" } { f "y" } } }
+        { +output { "x" } }
+    } [
+        >r "y" get "x" get dup r> execute ,
+    ] with-template ; inline
+
+{
+    { fixnum-bitand %fixnum-bitand }
+    { fixnum-bitor  %fixnum-bitor  }
+    { fixnum-bitxor %fixnum-bitxor }
+    { fixnum+fast   %fixnum+fast   }
+    { fixnum-fast   %fixnum-fast   }
+} [
+    first2 [ binary-op-fast ] curry
+    "intrinsic" set-word-prop
+] each
+
 : binary-jump ( label op -- )
     H{
-        { +input-d { { f "x" } { f "y" } } }
+        { +input { { f "x" } { f "y" } } }
     } [
         end-basic-block >r >r "y" get "x" get r> r> execute ,
     ] with-template ; inline
@@ -102,8 +118,8 @@ namespaces sequences words ;
     ! hard-coded to put its output in vreg 2, which happends to
     ! be EDX there.
     H{
-        { +input-d { { 0 "x" } { 1 "y" } } }
-        { +output-d { "out" } }
+        { +input { { 0 "x" } { 1 "y" } } }
+        { +output { "out" } }
     } [
         finalize-contents
         T{ vreg f 2 } "out" set
@@ -114,8 +130,8 @@ namespaces sequences words ;
 \ fixnum/mod [
     ! See the remark on fixnum-mod for vreg usage
     H{
-        { +input-d { { 0 "x" } { 1 "y" } } }
-        { +output-d { "quo" "rem" } }
+        { +input { { 0 "x" } { 1 "y" } } }
+        { +output { "quo" "rem" } }
     } [
         finalize-contents
         T{ vreg f 0 } "quo" set
@@ -127,7 +143,7 @@ namespaces sequences words ;
 
 \ fixnum-bitnot [
     H{
-        { +input-d { { f "x" } } }
-        { +output-d { "x" } }
+        { +input { { f "x" } } }
+        { +output { "x" } }
     } [ "x" get dup %fixnum-bitnot , ] with-template
 ] "intrinsic" set-word-prop
diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index d7d2981b8b..1913736b8f 100644
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -100,7 +100,7 @@ M: #call-label linearize* ( node -- next )
 
 M: #if linearize* ( node -- next )
     H{
-        { +input-d { { 0 "flag" } } }
+        { +input { { 0 "flag" } } }
     } [
         end-basic-block
         <label> dup "flag" get %jump-t ,
@@ -110,7 +110,7 @@ M: #if linearize* ( node -- next )
     #! Output the jump table insn and return a list of
     #! label/branch pairs.
     H{
-        { +input-d { { 0 "n" } } }
+        { +input { { 0 "n" } } }
     } [ end-basic-block "n" get %dispatch , ] with-template
     node-children [ <label> dup %target-label ,  2array ] map ;
 
diff --git a/library/compiler/ppc/fixnum.factor b/library/compiler/ppc/fixnum.factor
index 29941ab182..f5e6b762a8 100644
--- a/library/compiler/ppc/fixnum.factor
+++ b/library/compiler/ppc/fixnum.factor
@@ -23,6 +23,10 @@ math-internals memory namespaces words ;
 M: %fixnum+ generate-node ( vop -- )
     drop 0 MTXER >3-vop< ADDO. \ SUBF \ ADD simple-overflow ;
 
+M: %fixnum+fast generate-node ( vop -- ) drop >3-vop< ADD ;
+
+M: %fixnum-fast generate-node ( vop -- ) drop >3-vop< SUBF ;
+
 M: %fixnum- generate-node ( vop -- )
     drop 0 MTXER >3-vop< SUBFO. \ ADD \ SUBF simple-overflow ;
 
diff --git a/library/compiler/stack.factor b/library/compiler/stack.factor
index 4e250abbda..2cfc2e5e8d 100644
--- a/library/compiler/stack.factor
+++ b/library/compiler/stack.factor
@@ -4,6 +4,11 @@ IN: compiler
 USING: arrays generic inference io kernel math
 namespaces prettyprint sequences vectors words ;
 
+: immediate? ( obj -- ? ) dup fixnum? swap not or ;
+
+: load-literal ( obj dest -- )
+    over immediate? [ %immediate ] [ %indirect ] if , ;
+
 : phantom-shuffle-input ( n phantom -- seq )
     2dup length <= [
         cut-phantom
@@ -33,7 +38,6 @@ M: #shuffle linearize* ( #shuffle -- )
     node-shuffle phantom-shuffle iterate-next ;
 
 : linearize-push ( node -- )
-    compute-free-vregs
     >#push< dup length dup ensure-vregs
     alloc-reg# [ <vreg> ] map
     [ [ load-literal ] 2each ] keep
diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index 3969dbd2ab..d54ee36e9c 100644
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -22,9 +22,14 @@ GENERIC: finalize-height ( n stack -- )
 
 GENERIC: <loc> ( n stack -- loc )
 
-: (loc) phantom-stack-height - ;
+: (loc)
+    #! Utility for methods on <loc>
+    phantom-stack-height - ;
 
 : (finalize-height) ( stack word -- )
+    #! We consolidate multiple stack height changes until the
+    #! last moment, and we emit the final height changing
+    #! instruction here.
     swap [
         phantom-stack-height
         dup zero? [ 2drop ] [ swap execute , ] if
@@ -52,12 +57,14 @@ M: phantom-callstack finalize-height
     \ %inc-r (finalize-height) ;
 
 : phantom-locs ( n phantom -- locs )
+    #! A sequence of n ds-locs or cs-locs indexing the stack.
     swap reverse-slice [ swap <loc> ] map-with ;
 
 : phantom-locs* ( phantom -- locs )
     dup length swap phantom-locs ;
 
 : adjust-phantom ( n phantom -- )
+    #! Change stack heiht.
     [ phantom-stack-height + ] keep set-phantom-stack-height ;
 
 GENERIC: cut-phantom ( n phantom -- seq )
@@ -72,15 +79,6 @@ SYMBOL: phantom-r
     <phantom-datastack> phantom-d set
     <phantom-callstack> phantom-r set ;
 
-: immediate? ( obj -- ? )
-    #! fixnums and f have a pointerless representation, and
-    #! are compiled immediately. Everything else can be moved
-    #! by GC, and is indexed through a table.
-    dup fixnum? swap f eq? or ;
-
-: load-literal ( obj dest -- )
-    over immediate? [ %immediate ] [ %indirect ] if , ;
-
 : finalize-heights ( -- )
     phantom-d get finalize-height
     phantom-r get finalize-height ;
@@ -198,51 +196,36 @@ SYMBOL: phantom-r
     [ reverse-slice ] 2apply
     t [ swap first compatible-values? and ] 2reduce ;
 
-: templates-match? ( template template -- ? )
-    phantom-r get template-match?
-    >r phantom-d get template-match? r> and ;
-
 : split-template ( template phantom -- slow fast )
     over length over length <=
     [ drop { } swap ] [ length swap cut* ] if ;
 
-: split-templates ( template template -- slow slow fast fast )
-    >r phantom-d get split-template r>
-    phantom-r get split-template swapd ;
+: match-template ( template -- slow fast )
+    phantom-d get 2dup template-match?
+    [ split-template ] [ drop { } ] if ;
 
-: match-templates ( template template -- slow slow fast fast )
-    2dup templates-match? [ split-templates ] [ { } { } ] if ;
-
-: (fast-input) ( template phantom -- )
+: fast-input ( template -- )
+    phantom-d get
     over length neg over adjust-phantom
     over length swap cut-phantom
     swap phantom-vregs ;
 
-: fast-input ( template template -- )
-    phantoms swapd (fast-input) (fast-input) ;
-
-: (slow-input) ( template phantom -- )
-    swap [ stack>vregs ] keep phantom-vregs ;
-
 : phantom-append ( seq stack -- )
     over length over adjust-phantom swap nappend ;
 
 : (template-outputs) ( seq stack -- )
-    phantoms swapd phantom-append phantom-append ;
+    phantoms swapd phantom-append phantom-append
+    compute-free-vregs ;
 
-SYMBOL: +input-d
-SYMBOL: +input-r
-SYMBOL: +output-d
-SYMBOL: +output-r
+SYMBOL: +input
+SYMBOL: +output
 SYMBOL: +scratch
 SYMBOL: +clobber
 
 : fix-spec ( spec -- spec )
     H{
-        { +input-d { } }
-        { +input-r { } }
-        { +output-d { } }
-        { +output-r { } }
+        { +input { } }
+        { +output { } }
         { +scratch { } }
         { +clobber { } }
     } swap hash-union ;
@@ -250,31 +233,38 @@ SYMBOL: +clobber
 : adjust-free-vregs ( -- )
     used-vregs free-vregs [ diff ] change ;
 
-: output-vregs ( -- seq )
-    { +output-d +output-r +clobber }
-    [ get [ get ] map ] map concat ;
+: output-vregs ( -- seq seq )
+    +output get +clobber get [ [ get ] map ] 2apply ;
 
-: finalize-contents? ( -- ? )
-    output-vregs phantoms append
+: outputs-clash? ( -- ? )
+    output-vregs append phantoms append
     [ swap member? ] contains-with? ;
 
-: slow-input ( template template -- )
-    2dup [ empty? not ] 2apply or finalize-contents? or
+: finalize-carefully ( -- )
+    #! If the phantom callstack has datastack locations on it,
+    #! we cannot rearrange the datastack and expect meaningful
+    #! results.
+    phantom-r get [ ds-loc? ] contains? [
+        finalize-contents
+    ] [
+        phantom-d get dup { } flush-locs vregs>stack
+    ] if ;
+
+: slow-input ( template -- )
+    dup empty?
+    [ finalize-carefully ] unless
+    outputs-clash?
     [ finalize-contents ] when
-    phantoms swapd (slow-input) (slow-input) ;
+    phantom-d get swap [ stack>vregs ] keep phantom-vregs ;
 
 : template-inputs ( -- )
-    +input-d get +input-r get
-    2dup additional-vregs# ensure-vregs
-    match-templates fast-input
-    adjust-free-vregs
-    slow-input ;
+    +input get dup { } additional-vregs# ensure-vregs
+    match-template fast-input adjust-free-vregs slow-input ;
 
 : template-outputs ( -- )
-    +output-d get +output-r get [ [ get ] map ] 2apply
-    (template-outputs) ;
+    +output get [ get ] map { } (template-outputs) ;
 
 : with-template ( spec quot -- )
-    swap fix-spec [
-        template-inputs call template-outputs
-    ] bind ; inline
+    swap fix-spec
+    [ template-inputs call template-outputs ] bind
+    compute-free-vregs ; inline
diff --git a/library/compiler/vops.factor b/library/compiler/vops.factor
index d65a85bb10..129b90b096 100644
--- a/library/compiler/vops.factor
+++ b/library/compiler/vops.factor
@@ -215,8 +215,12 @@ C: %write-barrier make-vop ;
 ! fixnum intrinsics
 TUPLE: %fixnum+ ;
 C: %fixnum+ make-vop ;       : %fixnum+ 3-vop <%fixnum+> ;
+TUPLE: %fixnum+fast ;
+C: %fixnum+fast make-vop ;   : %fixnum+fast 3-vop <%fixnum+fast> ;
 TUPLE: %fixnum- ;
 C: %fixnum- make-vop ;       : %fixnum- 3-vop <%fixnum-> ;
+TUPLE: %fixnum-fast ;
+C: %fixnum-fast make-vop ;   : %fixnum-fast 3-vop <%fixnum-fast> ;
 TUPLE: %fixnum* ;
 C: %fixnum* make-vop ;       : %fixnum* 3-vop <%fixnum*> ;
 TUPLE: %fixnum-mod ;
diff --git a/library/compiler/x86/fixnum.factor b/library/compiler/x86/fixnum.factor
index 0c365fad43..8fee285fe6 100644
--- a/library/compiler/x86/fixnum.factor
+++ b/library/compiler/x86/fixnum.factor
@@ -34,9 +34,13 @@ math math-internals memory namespaces words ;
 M: %fixnum+ generate-node ( vop -- )
     drop dest/src ADD  \ SUB \ ADD simple-overflow ;
 
+M: %fixnum+fast generate-node ( vop -- ) drop dest/src ADD ;
+
 M: %fixnum- generate-node ( vop -- )
     drop dest/src SUB  \ ADD \ SUB simple-overflow ;
 
+M: %fixnum-fast generate-node ( vop -- ) drop dest/src SUB ;
+
 M: %fixnum* generate-node ( vop -- )
     drop
     ! both inputs are tagged, so one of them needs to have its
diff --git a/library/inference/known-words.factor b/library/inference/known-words.factor
index 1100ba8c18..553b22a991 100644
--- a/library/inference/known-words.factor
+++ b/library/inference/known-words.factor
@@ -139,10 +139,18 @@ sequences strings vectors words prettyprint ;
 \ fixnum+ t "flushable" set-word-prop
 \ fixnum+ t "foldable" set-word-prop
 
+\ fixnum+fast [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
+\ fixnum+fast t "flushable" set-word-prop
+\ fixnum+fast t "foldable" set-word-prop
+
 \ fixnum- [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
 \ fixnum- t "flushable" set-word-prop
 \ fixnum- t "foldable" set-word-prop
 
+\ fixnum-fast [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
+\ fixnum-fast t "flushable" set-word-prop
+\ fixnum-fast t "foldable" set-word-prop
+
 \ fixnum* [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
 \ fixnum* t "flushable" set-word-prop
 \ fixnum* t "foldable" set-word-prop
diff --git a/library/inference/optimizer.factor b/library/inference/optimizer.factor
index 3984ae8fd1..ae4cc58a82 100644
--- a/library/inference/optimizer.factor
+++ b/library/inference/optimizer.factor
@@ -24,14 +24,22 @@ GENERIC: optimize-node* ( node -- node/t )
         optimizer-changed get
     ] with-node-iterator [ optimize ] when ;
 
+: prune-if ( node quot -- successor/t )
+    over >r call [ r> node-successor ] [ r> drop t ] if ;
+    inline
+
 ! Generic nodes
 M: f optimize-node* drop t ;
 
 M: node optimize-node* ( node -- t ) drop t ;
 
+! #shuffle
+M: #shuffle optimize-node*  ( node -- node/t )
+    [ node-values empty? ] prune-if ;
+
 ! #push
 M: #push optimize-node*  ( node -- node/t )
-    dup node-out-d empty? [ node-successor ] [ drop t ] if ;
+    [ node-out-d empty? ] prune-if ;
 
 ! #return
 M: #return optimize-node* ( node -- node/t )
diff --git a/library/kernel.factor b/library/kernel.factor
index 0a79475942..aa0249b43b 100644
--- a/library/kernel.factor
+++ b/library/kernel.factor
@@ -81,8 +81,8 @@ IN: kernel-internals
 ! These words are unsafe. Don't use them.
 
 : array-capacity 1 slot ; inline
-: array-nth swap 2 fixnum+ slot ; inline
-: set-array-nth swap 2 fixnum+ set-slot ; inline
+: array-nth swap 2 fixnum+fast slot ; inline
+: set-array-nth swap 2 fixnum+fast set-slot ; inline
 
 : make-tuple <tuple> [ 2 set-slot ] keep ; flushable
 
diff --git a/library/test/benchmark/empty-loop.factor b/library/test/benchmark/empty-loop.factor
index b0de42a23b..8bdf3af9d1 100644
--- a/library/test/benchmark/empty-loop.factor
+++ b/library/test/benchmark/empty-loop.factor
@@ -1,5 +1,9 @@
 IN: temporary
-USING: compiler kernel math sequences test ;
+USING: compiler kernel math math-internals sequences test ;
+
+: empty-loop-0 ( n -- )
+    dup 0 fixnum< [ drop ] [ 1 fixnum-fast empty-loop-0 ] if ;
+    compiled
 
 : empty-loop-1 ( n -- )
     [ ] times ; compiled
@@ -10,6 +14,7 @@ USING: compiler kernel math sequences test ;
 : empty-loop-3 ( n -- )
     [ drop ] each ; compiled
 
+[ ] [ 5000000 empty-loop-0 ] unit-test
 [ ] [ 5000000 empty-loop-1 ] unit-test
 [ ] [ 5000000 empty-loop-2 ] unit-test
 [ ] [ 5000000 empty-loop-3 ] unit-test
diff --git a/library/test/benchmark/fib.factor b/library/test/benchmark/fib.factor
index df55485210..2b9e76e683 100644
--- a/library/test/benchmark/fib.factor
+++ b/library/test/benchmark/fib.factor
@@ -6,9 +6,20 @@ USE: test
 USE: math-internals
 USE: namespaces
 
-! Four fibonacci implementations, each one slower than the
+! Five fibonacci implementations, each one slower than the
 ! previous.
 
+: fast-fixnum-fib ( n -- nth fibonacci number )
+    dup 1 fixnum<= [
+        drop 1
+    ] [
+        1 fixnum-fast dup fast-fixnum-fib
+        swap 1 fixnum-fast fast-fixnum-fib fixnum+fast
+    ] if ;
+    compiled
+
+[ 9227465 ] [ 34 fast-fixnum-fib ] unit-test
+
 : fixnum-fib ( n -- nth fibonacci number )
     dup 1 fixnum<= [
         drop 1
diff --git a/library/test/compiler/templates.factor b/library/test/compiler/templates.factor
index b6e14e93b2..5dc1e92c37 100644
--- a/library/test/compiler/templates.factor
+++ b/library/test/compiler/templates.factor
@@ -2,7 +2,7 @@
 
 IN: temporary
 USING: arrays compiler kernel kernel-internals math
-math-internals namespaces test ;
+math-internals namespaces sequences sequences-internals test ;
 
 ! Oops!
 [ 5000 ] [ [ 5000 ] compile-1 ] unit-test
@@ -41,6 +41,21 @@ unit-test
 [ 1/2 [ dup 0 slot swap 1 slot [ foo ] keep ] compile-1 ]
 unit-test
 
+[ 41 5 4 ] [
+    5/4 4/5 [
+        dup ratio? [
+            over ratio? [
+                2dup 2>fraction >r * swap r> * swap
+                + -rot denominator swap denominator
+            ] [
+                2drop f f f
+            ] if
+        ] [
+            2drop f f f
+        ] if
+    ] compile-1
+] unit-test
+
 : jxyz
     over bignum? [
         dup ratio? [
@@ -78,3 +93,31 @@ unit-test
     global [ 3 \ foo set ] bind
     \ foo [ global [ get ] bind ] compile-1
 ] unit-test
+
+[ 12 13 ] [
+    -12 -13 [ [ 0 swap fixnum-fast ] 2apply ] compile-1
+] unit-test
+
+[ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-1 ] unit-test
+
+[ 12 13 ] [
+    -12 -13 [ [ 0 swap fixnum- ] 2apply ] compile-1
+] unit-test
+
+[ { t t } ] [
+    { t } { t } [
+        dup array-capacity [
+            2dup swap swap 2 fixnum+fast slot
+            >r pick swap 2 fixnum+fast slot r> 2array
+        ] collect 2nip
+    ] compile-1 first
+] unit-test
+
+[ { t t } ] [
+    { t } { t } [
+        dup array-capacity [
+            2dup swap swap 2 fixnum+ slot
+            >r pick swap 2 fixnum+ slot r> 2array
+        ] collect 2nip
+    ] compile-1 first
+] unit-test
diff --git a/library/test/inference.factor b/library/test/inference.factor
index 3c5570d09b..27527dee77 100644
--- a/library/test/inference.factor
+++ b/library/test/inference.factor
@@ -10,22 +10,6 @@ math-internals namespaces parser sequences test vectors ;
 
 [ t ] [ [ [ ] [ ] if ] dataflow dup [ [ ] map-nodes ] with-node-iterator = ] unit-test
 
-[
-    T{ shuffle f { "a" } { } { "a" } { "a" } }
-] [
-    T{ shuffle f { "a" } { } { "a" "a" } { } }
-    T{ shuffle f { "b" } { } { } { "b" } }
-    compose-shuffle
-] unit-test
-
-[
-    T{ shuffle f { "b" "a" } { } { "b" "b" } { } }
-] [
-    T{ shuffle f { "a" } { } { } { } }
-    T{ shuffle f { "b" } { } { "b" "b" } { } }
-    compose-shuffle
-] unit-test
-
 [ { 0 2 } ] [ [ 2 "Hello" ] infer ] unit-test
 [ { 1 2 } ] [ [ dup ] infer ] unit-test
 
diff --git a/native/fixnum.c b/native/fixnum.c
index b23db2b15f..ce90f4b233 100644
--- a/native/fixnum.c
+++ b/native/fixnum.c
@@ -42,6 +42,13 @@ void primitive_fixnum_add(void)
 	box_signed_cell(x + y);
 }
 
+void primitive_fixnum_add_fast(void)
+{
+	F_FIXNUM y = untag_fixnum_fast(dpop());
+	F_FIXNUM x = untag_fixnum_fast(dpop());
+	dpush(tag_fixnum(x + y));
+}
+
 void primitive_fixnum_subtract(void)
 {
 	F_FIXNUM y = untag_fixnum_fast(dpop());
@@ -49,6 +56,13 @@ void primitive_fixnum_subtract(void)
 	box_signed_cell(x - y);
 }
 
+void primitive_fixnum_subtract_fast(void)
+{
+	F_FIXNUM y = untag_fixnum_fast(dpop());
+	F_FIXNUM x = untag_fixnum_fast(dpop());
+	dpush(tag_fixnum(x - y));
+}
+
 /**
  * Multiply two integers, and trap overflow.
  * Thanks to David Blaikie (The_Vulture from freenode #java) for the hint.
diff --git a/native/fixnum.h b/native/fixnum.h
index df60e52a56..99b4e68676 100644
--- a/native/fixnum.h
+++ b/native/fixnum.h
@@ -13,6 +13,8 @@ void primitive_to_fixnum(void);
 
 void primitive_fixnum_add(void);
 void primitive_fixnum_subtract(void);
+void primitive_fixnum_add_fast(void);
+void primitive_fixnum_subtract_fast(void);
 void primitive_fixnum_multiply(void);
 void primitive_fixnum_divint(void);
 void primitive_fixnum_divfloat(void);
diff --git a/native/primitives.c b/native/primitives.c
index 610e31d892..bd2ea1226d 100644
--- a/native/primitives.c
+++ b/native/primitives.c
@@ -24,7 +24,9 @@ void* primitives[] = {
 	primitive_bits_double,
 	primitive_from_rect,
 	primitive_fixnum_add,
+	primitive_fixnum_add_fast,
 	primitive_fixnum_subtract,
+	primitive_fixnum_subtract_fast,
 	primitive_fixnum_multiply,
 	primitive_fixnum_divint,
 	primitive_fixnum_divfloat,
@@ -191,8 +193,5 @@ void* primitives[] = {
 
 CELL primitive_to_xt(CELL primitive)
 {
-	if(primitive < 0 || primitive >= PRIMITIVE_COUNT)
-		return (CELL)undefined;
-	else
-		return (CELL)primitives[primitive];
+	return (CELL)primitives[primitive];
 }
diff --git a/native/primitives.h b/native/primitives.h
index 809f0f05b5..2ed5cdc768 100644
--- a/native/primitives.h
+++ b/native/primitives.h
@@ -1,4 +1,3 @@
 extern void* primitives[];
-#define PRIMITIVE_COUNT 190
 
 CELL primitive_to_xt(CELL primitive);

From b458d58b91b7c15c31104e99f34967c1943fecf4 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Tue, 25 Apr 2006 22:25:39 +0000
Subject: [PATCH 047/112] Fixing some bugs, with-template argument order
 reversed

---
 library/compiler/intrinsics.factor | 92 +++++++++++++++---------------
 library/compiler/linearizer.factor | 13 ++---
 library/compiler/templates.factor  | 44 ++++++--------
 3 files changed, 69 insertions(+), 80 deletions(-)

diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index f1c77dc471..34a998abe1 100644
--- a/library/compiler/intrinsics.factor
+++ b/library/compiler/intrinsics.factor
@@ -6,65 +6,65 @@ inference kernel kernel-internals lists math math-internals
 namespaces sequences words ;
 
 \ slot [
-    H{
-        { +input { { f "obj" } { f "n" } } }
-        { +output { "obj" } }
-    } [
+    [
         "obj" get %untag ,
         "n" get "obj" get %slot ,
-    ] with-template
+    ] H{
+        { +input { { f "obj" } { f "n" } } }
+        { +output { "obj" } }
+    } with-template
 ] "intrinsic" set-word-prop
 
 \ set-slot [
-    H{
-        { +input { { f "val" } { f "obj" } { f "slot" } } }
-        { +clobber { "obj" } }
-    } [
+    [
         "obj" get %untag ,
         "val" get "obj" get "slot" get %set-slot ,
         finalize-contents
         "obj" get %write-barrier ,
-    ] with-template
+    ] H{
+        { +input { { f "val" } { f "obj" } { f "slot" } } }
+        { +clobber { "obj" } }
+    } with-template
 ] "intrinsic" set-word-prop
 
 \ char-slot [
-    H{
+    [
+        "n" get "str" get %char-slot ,
+    ] H{
         { +input { { f "n" } { f "str" } } }
         { +output { "str" } }
-    } [
-        "n" get "str" get %char-slot ,
-    ] with-template
+    } with-template
 ] "intrinsic" set-word-prop
 
 \ set-char-slot [
-    H{
-        { +input { { f "ch" } { f "n" } { f "str" } } }
-    } [
+    [
         "ch" get "str" get "n" get %set-char-slot ,
-    ] with-template
+    ] H{
+        { +input { { f "ch" } { f "n" } { f "str" } } }
+    } with-template
 ] "intrinsic" set-word-prop
 
 \ type [
-    H{
+    [ finalize-contents "in" get %type , ] H{
         { +input { { f "in" } } }
         { +output { "in" } }
-    } [ finalize-contents "in" get %type , ] with-template
+    } with-template
 ] "intrinsic" set-word-prop
 
 \ tag [
-    H{
+    [ "in" get %tag , ] H{
         { +input { { f "in" } } }
         { +output { "in" } }
-    } [ "in" get %tag , ] with-template
+    } with-template
 ] "intrinsic" set-word-prop
 
 : binary-op ( op -- )
-    H{
+    [
+        finalize-contents >r "y" get "x" get dup r> execute ,
+    ] H{
         { +input { { 0 "x" } { 1 "y" } } }
         { +output { "x" } }
-    } [
-        finalize-contents >r "y" get "x" get dup r> execute ,
-    ] with-template ; inline
+    } with-template ; inline
 
 {
     { fixnum+       %fixnum+       }
@@ -77,12 +77,12 @@ namespaces sequences words ;
 ] each
 
 : binary-op-fast ( op -- )
-    H{
+    [
+        >r "y" get "x" get dup r> execute ,
+    ] H{
         { +input { { f "x" } { f "y" } } }
         { +output { "x" } }
-    } [
-        >r "y" get "x" get dup r> execute ,
-    ] with-template ; inline
+    } with-template ; inline
 
 {
     { fixnum-bitand %fixnum-bitand }
@@ -96,11 +96,11 @@ namespaces sequences words ;
 ] each
 
 : binary-jump ( label op -- )
-    H{
-        { +input { { f "x" } { f "y" } } }
-    } [
+    [
         end-basic-block >r >r "y" get "x" get r> r> execute ,
-    ] with-template ; inline
+    ] H{
+        { +input { { f "x" } { f "y" } } }
+    } with-template ; inline
 
 {
     { fixnum<= %jump-fixnum<= }
@@ -117,33 +117,33 @@ namespaces sequences words ;
     ! This is not clever. Because of x86, %fixnum-mod is
     ! hard-coded to put its output in vreg 2, which happends to
     ! be EDX there.
-    H{
-        { +input { { 0 "x" } { 1 "y" } } }
-        { +output { "out" } }
-    } [
+    [
         finalize-contents
         T{ vreg f 2 } "out" set
         "y" get "x" get "out" get %fixnum-mod ,
-    ] with-template
+    ] H{
+        { +input { { 0 "x" } { 1 "y" } } }
+        { +output { "out" } }
+    } with-template
 ] "intrinsic" set-word-prop
 
 \ fixnum/mod [
     ! See the remark on fixnum-mod for vreg usage
-    H{
-        { +input { { 0 "x" } { 1 "y" } } }
-        { +output { "quo" "rem" } }
-    } [
+    [
         finalize-contents
         T{ vreg f 0 } "quo" set
         T{ vreg f 2 } "rem" set
         "y" get "x" get 2array
         "rem" get "quo" get 2array %fixnum/mod ,
-    ] with-template
+    ] H{
+        { +input { { 0 "x" } { 1 "y" } } }
+        { +output { "quo" "rem" } }
+    } with-template
 ] "intrinsic" set-word-prop
 
 \ fixnum-bitnot [
-    H{
+    [ "x" get dup %fixnum-bitnot , ] H{
         { +input { { f "x" } } }
         { +output { "x" } }
-    } [ "x" get dup %fixnum-bitnot , ] with-template
+    } with-template
 ] "intrinsic" set-word-prop
diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index 1913736b8f..d36e214473 100644
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -99,19 +99,18 @@ M: #call-label linearize* ( node -- next )
     node-param renamed-label linearize-call ;
 
 M: #if linearize* ( node -- next )
-    H{
-        { +input { { 0 "flag" } } }
-    } [
+    [
         end-basic-block
         <label> dup "flag" get %jump-t ,
-    ] with-template linearize-if ;
+    ] H{
+        { +input { { 0 "flag" } } }
+    } with-template linearize-if ;
 
 : dispatch-head ( node -- label/node )
     #! Output the jump table insn and return a list of
     #! label/branch pairs.
-    H{
-        { +input { { 0 "n" } } }
-    } [ end-basic-block "n" get %dispatch , ] with-template
+    [ end-basic-block "n" get %dispatch , ]
+    H{ { +input { { 0 "n" } } } } with-template
     node-children [ <label> dup %target-label ,  2array ] map ;
 
 : dispatch-body ( label/node -- )
diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index d54ee36e9c..fbfe8a9303 100644
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -128,10 +128,8 @@ SYMBOL: phantom-r
 : phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
 
 : flush-locs ( phantom phantom -- )
-    [
-        2dup live-locs \ live-locs set
-        [ dup phantom-locs* [ lazy-store ] 2each ] 2apply
-    ] with-scope ;
+    2dup live-locs \ live-locs set
+    [ dup phantom-locs* [ lazy-store ] 2each ] 2apply ;
 
 : finalize-contents ( -- )
     phantoms 2dup flush-locs [ vregs>stack ] 2apply ;
@@ -214,8 +212,7 @@ SYMBOL: phantom-r
     over length over adjust-phantom swap nappend ;
 
 : (template-outputs) ( seq stack -- )
-    phantoms swapd phantom-append phantom-append
-    compute-free-vregs ;
+    phantoms swapd phantom-append phantom-append ;
 
 SYMBOL: +input
 SYMBOL: +output
@@ -230,41 +227,34 @@ SYMBOL: +clobber
         { +clobber { } }
     } swap hash-union ;
 
-: adjust-free-vregs ( -- )
-    used-vregs free-vregs [ diff ] change ;
+: adjust-free-vregs ( seq -- ) free-vregs [ diff ] change ;
 
 : output-vregs ( -- seq seq )
-    +output get +clobber get [ [ get ] map ] 2apply ;
+    +output +clobber [ get [ get ] map ] 2apply ;
 
 : outputs-clash? ( -- ? )
     output-vregs append phantoms append
     [ swap member? ] contains-with? ;
 
-: finalize-carefully ( -- )
-    #! If the phantom callstack has datastack locations on it,
-    #! we cannot rearrange the datastack and expect meaningful
-    #! results.
-    phantom-r get [ ds-loc? ] contains? [
-        finalize-contents
-    ] [
-        phantom-d get dup { } flush-locs vregs>stack
-    ] if ;
-
 : slow-input ( template -- )
-    dup empty?
-    [ finalize-carefully ] unless
-    outputs-clash?
-    [ finalize-contents ] when
+    dup empty? [ finalize-contents ] unless
+    outputs-clash? [ finalize-contents ] when
     phantom-d get swap [ stack>vregs ] keep phantom-vregs ;
 
+: input-vregs ( -- seq )
+    +input +scratch [ get [ second get vreg-n ] map ] 2apply
+    append ;
+
 : template-inputs ( -- )
     +input get dup { } additional-vregs# ensure-vregs
-    match-template fast-input adjust-free-vregs slow-input ;
+    match-template fast-input
+    used-vregs adjust-free-vregs
+    slow-input
+    input-vregs adjust-free-vregs ;
 
 : template-outputs ( -- )
     +output get [ get ] map { } (template-outputs) ;
 
-: with-template ( spec quot -- )
-    swap fix-spec
-    [ template-inputs call template-outputs ] bind
+: with-template ( quot spec -- )
+    fix-spec [ template-inputs call template-outputs ] bind
     compute-free-vregs ; inline

From 973ed2c7ea41b317998b67b73a3d9e929aa93569 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Wed, 26 Apr 2006 07:05:38 +0000
Subject: [PATCH 048/112] Code cleanups, fix #if intrinsic linearization,
 faster repeat combinator

---
 library/compiler/intrinsics.factor |  7 ++++---
 library/compiler/linearizer.factor | 23 +++++++++++++++--------
 library/compiler/templates.factor  | 11 +++++------
 library/math/math.factor           | 23 ++++++++++++++++++-----
 4 files changed, 42 insertions(+), 22 deletions(-)

diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index 34a998abe1..1f53b6d535 100644
--- a/library/compiler/intrinsics.factor
+++ b/library/compiler/intrinsics.factor
@@ -123,6 +123,7 @@ namespaces sequences words ;
         "y" get "x" get "out" get %fixnum-mod ,
     ] H{
         { +input { { 0 "x" } { 1 "y" } } }
+        ! { +scratch { { 2 "out" } } }
         { +output { "out" } }
     } with-template
 ] "intrinsic" set-word-prop
@@ -131,13 +132,13 @@ namespaces sequences words ;
     ! See the remark on fixnum-mod for vreg usage
     [
         finalize-contents
-        T{ vreg f 0 } "quo" set
         T{ vreg f 2 } "rem" set
         "y" get "x" get 2array
-        "rem" get "quo" get 2array %fixnum/mod ,
+        "rem" get "x" get 2array %fixnum/mod ,
     ] H{
         { +input { { 0 "x" } { 1 "y" } } }
-        { +output { "quo" "rem" } }
+        ! { +scratch { { 2 "rem" } } }
+        { +output { "x" "rem" } }
     } with-template
 ] "intrinsic" set-word-prop
 
diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index d36e214473..f26a1506b4 100644
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -15,10 +15,23 @@ DEFER: #terminal?
 
 PREDICATE: #merge #terminal-merge node-successor #terminal? ;
 
-UNION: #terminal POSTPONE: f #return #values #terminal-merge ;
+: intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
+
+: if-intrinsic ( #call -- quot )
+    dup node-successor #if?
+    [ node-param "if-intrinsic" word-prop ] [ drop f ] if ;
+
+PREDICATE: #call #terminal-call
+    dup node-successor node-successor #terminal?
+    swap if-intrinsic and ;
+
+UNION: #terminal
+    POSTPONE: f #return #values #terminal-merge ;
 
 : tail-call? ( -- ? )
-    node-stack get [ node-successor ] map [ #terminal? ] all? ;
+    node-stack get [
+        dup #terminal-call? swap node-successor #terminal? or
+    ] all? ;
 
 GENERIC: linearize* ( node -- next )
 
@@ -74,12 +87,6 @@ M: #label linearize* ( node -- next )
     dup node-param dup linearize-call-label >r
     renamed-label swap node-child linearize-1 r> ;
 
-: intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
-
-: if-intrinsic ( #call -- quot )
-    dup node-successor #if?
-    [ node-param "if-intrinsic" word-prop ] [ drop f ] if ;
-
 : linearize-if ( node label -- next )
     <label> [
         >r >r node-children first2 linearize-child
diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index fbfe8a9303..7ce0b760dd 100644
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -12,6 +12,8 @@ TUPLE: ds-loc n ;
 ! A call stack location.
 TUPLE: cs-loc n ;
 
+UNION: loc ds-loc cs-loc ;
+
 TUPLE: phantom-stack height ;
 
 C: phantom-stack ( -- stack )
@@ -75,18 +77,17 @@ M: phantom-stack cut-phantom ( n phantom -- seq )
 SYMBOL: phantom-d
 SYMBOL: phantom-r
 
+: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
+
 : init-templates ( -- )
     <phantom-datastack> phantom-d set
     <phantom-callstack> phantom-r set ;
 
 : finalize-heights ( -- )
-    phantom-d get finalize-height
-    phantom-r get finalize-height ;
+    phantoms [ finalize-height ] 2apply ;
 
 : alloc-reg ( -- n ) free-vregs get pop ;
 
-: loc? ( obj -- ? ) dup ds-loc? swap cs-loc? or ;
-
 : stack>vreg ( vreg# loc -- operand )
     >r <vreg> dup r> %peek , ;
 
@@ -125,8 +126,6 @@ SYMBOL: phantom-r
         2drop
     ] if ;
 
-: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
-
 : flush-locs ( phantom phantom -- )
     2dup live-locs \ live-locs set
     [ dup phantom-locs* [ lazy-store ] 2each ] 2apply ;
diff --git a/library/math/math.factor b/library/math/math.factor
index 3ed833a28b..c517d6d32e 100644
--- a/library/math/math.factor
+++ b/library/math/math.factor
@@ -53,12 +53,25 @@ M: object zero? drop f ;
 
 : ceiling ( x -- y ) neg floor neg ; foldable
 
-: (repeat) ( i n quot -- )
-    pick pick >=
-    [ 3drop ] [ [ swap >r call 1+ r> ] keep (repeat) ] if ;
-    inline
+G: repeat 1 standard-combination ; inline
 
-: repeat ( n quot -- | quot: n -- n ) 0 -rot (repeat) ; inline
+: (repeat-fixnum) ( i n quot -- )
+    pick pick fixnum>= [
+        3drop
+    ] [
+        [ swap >r call 1 fixnum+fast r> ] keep (repeat-fixnum)
+    ] if ; inline
+
+M: fixnum repeat 0 -rot (repeat-fixnum) ;
+
+: (repeat-bignum) ( i n quot -- )
+    pick pick bignum>= [
+        3drop
+    ] [
+        [ swap >r call 1 bignum+ r> ] keep (repeat-bignum)
+    ] if ; inline
+
+M: bignum repeat 0 -rot (repeat-bignum) ;
 
 : times ( n quot -- | quot: -- )
     swap [ >r dup slip r> ] repeat drop ; inline

From f0ae853bcaf13cd771a8930e9db0559581e92e21 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Thu, 27 Apr 2006 04:44:50 +0000
Subject: [PATCH 049/112] Get rid of 'repeat' experiment

---
 library/math/math.factor | 19 ++++---------------
 1 file changed, 4 insertions(+), 15 deletions(-)

diff --git a/library/math/math.factor b/library/math/math.factor
index c517d6d32e..7a8afbfe32 100644
--- a/library/math/math.factor
+++ b/library/math/math.factor
@@ -53,25 +53,14 @@ M: object zero? drop f ;
 
 : ceiling ( x -- y ) neg floor neg ; foldable
 
-G: repeat 1 standard-combination ; inline
-
-: (repeat-fixnum) ( i n quot -- )
-    pick pick fixnum>= [
+: (repeat) ( i n quot -- )
+    pick pick >= [
         3drop
     ] [
-        [ swap >r call 1 fixnum+fast r> ] keep (repeat-fixnum)
+        [ swap >r call 1+ r> ] keep (repeat)
     ] if ; inline
 
-M: fixnum repeat 0 -rot (repeat-fixnum) ;
-
-: (repeat-bignum) ( i n quot -- )
-    pick pick bignum>= [
-        3drop
-    ] [
-        [ swap >r call 1 bignum+ r> ] keep (repeat-bignum)
-    ] if ; inline
-
-M: bignum repeat 0 -rot (repeat-bignum) ;
+: repeat 0 -rot (repeat) ; inline
 
 : times ( n quot -- | quot: -- )
     swap [ >r dup slip r> ] repeat drop ; inline

From 7f79de6d1f86bd5d7a2ff9327d62f1a1b18fcc25 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Thu, 27 Apr 2006 07:20:02 +0000
Subject: [PATCH 050/112] I/O fixes

---
 TODO.FACTOR.txt                     |  2 ++
 contrib/httpd/cont-responder.factor | 11 -----------
 library/unix/io.factor              | 11 ++++-------
 3 files changed, 6 insertions(+), 18 deletions(-)

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index f3862f6490..269f36bf87 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -2,6 +2,8 @@ should fix in 0.82:
 
 - constant branch folding
 - getenv, setenv, fast-slot stuff
+- more flexible fixnum intrinsics
+- compile if-intrinsic even if there is no #if there
 - 3 >n fep
 - amd64 %box-struct
 - get factor running on mac intel
diff --git a/contrib/httpd/cont-responder.factor b/contrib/httpd/cont-responder.factor
index d16486e7cd..908a20b7b7 100644
--- a/contrib/httpd/cont-responder.factor
+++ b/contrib/httpd/cont-responder.factor
@@ -136,17 +136,6 @@ TUPLE: resume value stdio ;
       </body>
     </html> flush  ;
 
-: (expired-page-handler) ( alist -- )
-  #! Display a page has expired message.
-  #! TODO: Need to handle this better to enable
-  #!       returning back to root continuation.
-    drop
-    <html>                
-      <body> 
-       <p> "This page has expired." write  </p> 
-      </body>
-    </html> flush  ;
-
 : expired-page-handler ( alist -- )
   [ (expired-page-handler) ] show-final ;
 
diff --git a/library/unix/io.factor b/library/unix/io.factor
index eb68bc3956..f1eeb6fa7a 100644
--- a/library/unix/io.factor
+++ b/library/unix/io.factor
@@ -66,7 +66,7 @@ C: port ( handle buffer -- port )
     80 <sbuf> over set-port-sbuf ;
 
 : touch-port ( port -- )
-    dup port-timeout dup 0 =
+    dup port-timeout dup zero?
     [ 2drop ] [ millis + swap set-port-cutoff ] if ;
 
 M: port set-timeout ( timeout port -- )
@@ -115,11 +115,8 @@ GENERIC: task-container ( task -- vector )
     queue-empty? [ remove-io-task ] [ drop ] if r> ;
 
 : handle-fd ( task -- )
-    dup do-io-task [
-        dup io-task-port touch-port pop-callback continue
-    ] [
-        drop
-    ] if ;
+    dup io-task-port touch-port dup do-io-task
+    [ pop-callback continue ] [ drop ] if ;
 
 : timeout? ( port -- ? )
     port-cutoff dup zero? not swap millis < and ;
@@ -145,7 +142,7 @@ GENERIC: task-container ( task -- vector )
     f ;
 
 : io-multiplex ( timeout -- )
-    >r FD_SETSIZE init-fdsets r> make-timeval select ( io-error ) drop
+    >r FD_SETSIZE init-fdsets r> make-timeval select io-error
     read-fdset get read-tasks get handle-fdset
     write-fdset get write-tasks get handle-fdset ;
 

From b64cb2cb759cb503ce077223f38f14ccabc52a67 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Fri, 28 Apr 2006 01:36:29 +0000
Subject: [PATCH 051/112] Fix scoping problem in cont-responder

---
 contrib/httpd/cont-responder.factor | 518 ++++++++++++++--------------
 library/unix/io.factor              |  16 +-
 2 files changed, 261 insertions(+), 273 deletions(-)

diff --git a/contrib/httpd/cont-responder.factor b/contrib/httpd/cont-responder.factor
index 908a20b7b7..cd4d70093c 100644
--- a/contrib/httpd/cont-responder.factor
+++ b/contrib/httpd/cont-responder.factor
@@ -1,29 +1,10 @@
 ! Copyright (C) 2004 Chris Double.
-! 
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-! 
-! 1. Redistributions of source code must retain the above copyright notice,
-!    this list of conditions and the following disclaimer.
-! 
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-!    this list of conditions and the following disclaimer in the documentation
-!    and/or other materials provided with the distribution.
-! 
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-IN: cont-responder
+! See http://factorcode.org/license.txt for BSD license.
+
 USING: http httpd math namespaces io
-       lists strings kernel html hashtables
-       parser generic sequences ;
+lists strings kernel html hashtables
+parser generic sequences ;
+IN: cont-responder
 
 #! Used inside the session state of responders to indicate whether the
 #! next request should use the post-refresh-get pattern. It is set to
@@ -31,95 +12,95 @@ USING: http httpd math namespaces io
 SYMBOL: post-refresh-get?
 
 : expiry-timeout ( -- timeout-seconds )
-  #! Number of seconds to timeout continuations in
-  #! continuation table. This value will need to be
-  #! tuned. I leave it at 24 hours but it can be
-  #! higher/lower as needed. Default to 15 minutes for
-  #! testing.
-  900 ;
+    #! Number of seconds to timeout continuations in
+    #! continuation table. This value will need to be
+    #! tuned. I leave it at 24 hours but it can be
+    #! higher/lower as needed. Default to 15 minutes for
+    #! testing.
+    900 ;
 
 : get-random-id ( -- id ) 
-  #! Generate a random id to use for continuation URL's
-  [ "ID" % 32 [ 9 random-int CHAR: 0 + , ] times ] "" make ;
+    #! Generate a random id to use for continuation URL's
+    [ "ID" % 32 [ 9 random-int CHAR: 0 + , ] times ] "" make ;
 
 SYMBOL: table
 
 : continuation-table ( -- <hashtable> ) 
-  #! Return the global table of continuations
-  table global hash ;
-    
-: reset-continuation-table ( -- ) 
-  #! Create the initial global table
-  continuation-table clear-hash ;
+    #! Return the global table of continuations
+    table get-global ;
 
-H{ } clone table global set-hash
+: reset-continuation-table ( -- ) 
+    #! Create the initial global table
+    continuation-table clear-hash ;
+
+H{ } clone table set-global
 
 #! Tuple for holding data related to a continuation.
 TUPLE: item expire? quot id time-added ;
 
 : continuation-item ( expire? quot id -- <item> )
-  #! A continuation item is the actual item stored
-  #! in the continuation table. It contains the id,
-  #! quotation/continuation, time added, etc. If
-  #! expire? is true then the continuation will
-  #! be expired after a certain amount of time.
-  millis <item> ;  
+    #! A continuation item is the actual item stored
+    #! in the continuation table. It contains the id,
+    #! quotation/continuation, time added, etc. If
+    #! expire? is true then the continuation will
+    #! be expired after a certain amount of time.
+    millis <item> ;  
 
 : seconds>millis ( seconds -- millis )
-  #! Convert a number of seconds to milliseconds
-  1000 * ;
+    #! Convert a number of seconds to milliseconds
+    1000 * ;
 
 : expired? ( timeout-seconds <item> -- bool )
-  #! Return true if the continuation item is expirable
-  #! and has expired (ie. was added to the table more than
-  #! timeout milliseconds ago).
-  [ item-time-added swap seconds>millis + millis - 0 < ] keep item-expire? and ;
+    #! Return true if the continuation item is expirable
+    #! and has expired (ie. was added to the table more than
+    #! timeout milliseconds ago).
+    [ item-time-added swap seconds>millis + millis - 0 < ] keep item-expire? and ;
 
 : expire-continuations ( timeout-seconds -- )
-  #! Expire all continuations in the continuation table
-  #! if they are 'timeout-seconds' old (ie. were added
-  #! more than 'timeout-seconds' ago.
-  continuation-table clone [ ( timeout-seconds [[ id item ]] -- )
-    swapd expired? [
-      continuation-table remove-hash
-    ] [
-      drop
-    ] if
-  ] hash-each-with ;
+    #! Expire all continuations in the continuation table
+    #! if they are 'timeout-seconds' old (ie. were added
+    #! more than 'timeout-seconds' ago.
+    continuation-table clone [
+        swapd expired? [
+            continuation-table remove-hash
+        ] [
+            drop
+        ] if
+    ] hash-each-with ;
 
 : expirable ( quot -- t quot )
-  #! Set the stack up for a register-continuation call 
-  #! so that the given quotation is registered that it can
-  #! be expired.
-  t swap ;
+    #! Set the stack up for a register-continuation call 
+    #! so that the given quotation is registered that it can
+    #! be expired.
+    t swap ;
 
 : permanent ( quot -- f quot )
-  #! Set the stack up for a register-continuation call
-  #! so that the given quotation is never expired after
-  #! registration.
-  f swap ;
+    #! Set the stack up for a register-continuation call
+    #! so that the given quotation is never expired after
+    #! registration.
+    f swap ;
 
 : register-continuation ( expire? quot -- id ) 
-  #! Store a continuation in the table and associate it with
-  #! a random id. That continuation will be expired after
-  #! a certain period of time if 'expire?' is true.  
-  get-random-id 
-  [ continuation-item ] keep ( item id -- )
-  [ continuation-table set-hash ] keep ;
-  
+    #! Store a continuation in the table and associate it with
+    #! a random id. That continuation will be expired after
+    #! a certain period of time if 'expire?' is true.  
+    get-random-id 
+    [ continuation-item ] keep ( item id -- )
+    [ continuation-table set-hash ] keep ;
+
 : register-continuation* ( expire? quots -- id ) 
-  #! Like register-continuation but registers a quotation 
-  #! that will call all quotations in the list, in the order given.
-  concat register-continuation ;
+    #! Like register-continuation but registers a quotation 
+    #! that will call all quotations in the list, in the order given.
+    concat register-continuation ;
 
 : get-continuation-item ( id -- <item> )
-  #! Get the continuation item associated with the id.
-  continuation-table hash ;
+    #! Get the continuation item associated with the id.
+    continuation-table hash ;
 
 : id>url ( id -- string )
-  #! Convert the continuation id to an URL suitable for
-  #! embedding in an HREF or other HTML.
-  url-encode "?id=" swap append ;
+    #! Convert the continuation id to an URL suitable for
+    #! embedding in an HREF or other HTML.
+    url-encode "?id=" swap append ;
 
 DEFER: show-final
 DEFER: show 
@@ -127,257 +108,262 @@ DEFER: show
 TUPLE: resume value stdio ;
 
 : (expired-page-handler) ( alist -- )
-  #! Display a page has expired message.
-  #! TODO: Need to handle this better to enable
-  #!       returning back to root continuation.
+    #! Display a page has expired message.
+    #! TODO: Need to handle this better to enable
+    #!       returning back to root continuation.
     <html>                
-      <body> 
-       <p> "This page has expired." write  </p> 
-      </body>
+        <body> 
+        <p> "This page has expired." write  </p> 
+        </body>
     </html> flush  ;
 
 : expired-page-handler ( alist -- )
-  [ (expired-page-handler) ] show-final ;
+    [ (expired-page-handler) ] show-final ;
 
 : >callable ( quot|interp|f -- interp )
-  dup continuation? [
-    [ continue-with ] cons
-  ] when ;
+    dup continuation? [
+        [ continue-with ] cons
+    ] when ;
 
 : get-registered-continuation ( id -- cont ) 
-  #! Return the continuation or quotation 
-  #! associated with the given id.  
-  #! TODO: handle expired pages better.
-  expiry-timeout expire-continuations
-  get-continuation-item [
-    item-quot
-  ] [
-    [ (expired-page-handler) ]
-  ] if* >callable ;
+    #! Return the continuation or quotation 
+    #! associated with the given id.  
+    #! TODO: handle expired pages better.
+    expiry-timeout expire-continuations
+    get-continuation-item [
+        item-quot
+    ] [
+        [ (expired-page-handler) ]
+    ] if* >callable ;
 
 : resume-continuation ( resumed-data id  -- ) 
-  #! Call the continuation associated with the given id,
-  #! with 'value' on the top of the stack.
-  get-registered-continuation call ;
+    #! Call the continuation associated with the given id,
+    #! with 'value' on the top of the stack.
+    get-registered-continuation call ;
 
 #! Name of the variable holding the continuation used to exit
 #! back to the httpd responder, returning any generated HTML.
 SYMBOL: exit-cc 
 
 : exit-continuation ( -- exit ) 
-  #! Get the current exit continuation
-  exit-cc get ;
+    #! Get the current exit continuation
+    exit-cc get ;
 
 : call-exit-continuation ( value -- ) 
-  #! Call the exit continuation, passing it the given value on the
-  #! top of the stack.
-  exit-cc get continue-with ;
+    #! Call the exit continuation, passing it the given value on the
+    #! top of the stack.
+    exit-cc get continue-with ;
 
 : with-exit-continuation ( quot -- ) 
-  #! Call the quotation with the variable exit-cc bound such that when
-  #! the exit continuation is called, computation will resume from the
-  #! end of this 'with-exit-continuation' call, with the value passed
-  #! to the exit continuation on the top of the stack.
-  [ exit-cc set call f call-exit-continuation ] callcc1 nip ;
+    #! Call the quotation with the variable exit-cc bound such that when
+    #! the exit continuation is called, computation will resume from the
+    #! end of this 'with-exit-continuation' call, with the value passed
+    #! to the exit continuation on the top of the stack.
+    [ exit-cc set call f call-exit-continuation ] callcc1 nip ;
 
 #! Name of variable holding the 'callback' continuation, used for
 #! returning back to previous 'show' calls.
 SYMBOL: callback-cc
 
 : store-callback-cc ( -- )
-  #! Store the current continuation in the variable 'callback-cc' 
-  #! so it can be returned to later by callbacks. Note that it
-  #! recalls itself when the continuation is called to ensure that
-  #! it resets its value back to the most recent show call.
-  [  ( 0 -- )
-    [ ( 0 1 -- )
-      callback-cc set ( 0 -- )
-      stdio get swap continue-with
-    ] callcc1 ( 0 [ ] == )
-    nip
-    dup resume-stdio stdio set resume-value
-    call
-    store-callback-cc stdio get 
-  ] callcc1 stdio set ;
+    #! Store the current continuation in the variable 'callback-cc' 
+    #! so it can be returned to later by callbacks. Note that it
+    #! recalls itself when the continuation is called to ensure that
+    #! it resets its value back to the most recent show call.
+    [  ( 0 -- )
+        [ ( 0 1 -- )
+            callback-cc set ( 0 -- )
+            stdio get swap continue-with
+        ] callcc1
+        nip
+        dup resume-stdio stdio set resume-value
+        call
+        store-callback-cc stdio get 
+    ] callcc1 stdio set ;
 
 : forward-to-url ( url -- )
-  #! When executed inside a 'show' call, this will force a
-  #! HTTP 302 to occur to instruct the browser to forward to
-  #! the request URL.
-  [ 
-    "HTTP/1.1 302 Document Moved\nLocation: " % %
-    "\nContent-Length: 0\nContent-Type: text/plain\n\n" %
-  ] "" make write "" call-exit-continuation ;
+    #! When executed inside a 'show' call, this will force a
+    #! HTTP 302 to occur to instruct the browser to forward to
+    #! the request URL.
+    [ 
+        "HTTP/1.1 302 Document Moved\nLocation: " % %
+        "\nContent-Length: 0\nContent-Type: text/plain\n\n" %
+    ] "" make write "" call-exit-continuation ;
 
 : forward-to-id ( id -- )
-  #! When executed inside a 'show' call, this will force a
-  #! HTTP 302 to occur to instruct the browser to forward to
-  #! the request URL.
-  >r "request" get r> id>url append forward-to-url ;
+    #! When executed inside a 'show' call, this will force a
+    #! HTTP 302 to occur to instruct the browser to forward to
+    #! the request URL.
+    >r "request" get r> id>url append forward-to-url ;
 
 : redirect-to-here ( -- )
-  #! Force a redirect to the client browser so that the browser
-  #! goes to the current point in the code. This forces an URL
-  #! change on the browser so that refreshing that URL will
-  #! immediately run from this code point. This prevents the 
-  #! "this request will issue a POST" warning from the browser
-  #! and prevents re-running the previous POST logic. This is
-  #! known as the 'post-refresh-get' pattern.
-  post-refresh-get? get [
-    [ 
-      expirable register-continuation forward-to-id
-    ] callcc1 resume-stdio stdio set
-  ] [
-    t post-refresh-get? set
-  ] if ;
+    #! Force a redirect to the client browser so that the browser
+    #! goes to the current point in the code. This forces an URL
+    #! change on the browser so that refreshing that URL will
+    #! immediately run from this code point. This prevents the 
+    #! "this request will issue a POST" warning from the browser
+    #! and prevents re-running the previous POST logic. This is
+    #! known as the 'post-refresh-get' pattern.
+    post-refresh-get? get [
+        [ 
+            expirable register-continuation forward-to-id
+        ] callcc1 resume-stdio stdio set
+    ] [
+        t post-refresh-get? set
+    ] if ;
 
 : (show) ( quot -- namespace )   
-  #! See comments for show. The difference is the 
-  #! quotation MUST set the content-type using 'serving-html'
-  #! or similar.
-  store-callback-cc  redirect-to-here 
-  [ 
-    expirable register-continuation id>url swap 
-    with-scope "" call-exit-continuation
-  ] callcc1 
-  nip dup resume-stdio stdio set resume-value ;
-  
+    #! See comments for show. The difference is the 
+    #! quotation MUST set the content-type using 'serving-html'
+    #! or similar.
+    store-callback-cc  redirect-to-here 
+    [ 
+        expirable register-continuation id>url swap 
+        with-scope "" call-exit-continuation
+    ] callcc1 
+    nip dup resume-stdio stdio set resume-value ;
+
 : show ( quot -- namespace )   
-  #! Call the quotation with the URL associated with the current
-  #! continuation. All output from the quotation goes to the client
-  #! browser. When the URL is later referenced then 
-  #! computation will resume from this 'show' call with a namespace on
-  #! the stack containing any query or post parameters.
-  #! NOTE: On return from 'show' the stack is exactly the same as
-  #! initial entry with 'quot' popped off an <namespace> put on. Even
-  #! if the quotation consumes items on the stack.
-  \ serving-html swons (show) ;
+    #! Call the quotation with the URL associated with the current
+    #! continuation. All output from the quotation goes to the client
+    #! browser. When the URL is later referenced then 
+    #! computation will resume from this 'show' call with a namespace on
+    #! the stack containing any query or post parameters.
+    #! NOTE: On return from 'show' the stack is exactly the same as
+    #! initial entry with 'quot' popped off an <namespace> put on. Even
+    #! if the quotation consumes items on the stack.
+    \ serving-html swons (show) ;
 
 : (show-final) ( quot -- namespace )
-  #! See comments for show-final. The difference is the 
-  #! quotation MUST set the content-type using 'serving-html'
-  #! or similar.
-  store-callback-cc  redirect-to-here 
-  with-scope "" call-exit-continuation ;
+    #! See comments for show-final. The difference is the 
+    #! quotation MUST set the content-type using 'serving-html'
+    #! or similar.
+    store-callback-cc  redirect-to-here 
+    with-scope "" call-exit-continuation ;
 
 : show-final ( quot -- namespace )
-  #! Similar to 'show', except the quotation does not receive the URL
-  #! to resume computation following 'show-final'. No continuation is
-  #! stored for this resumption. As a result, 'show-final' is for use
-  #! when a page is to be displayed with no further action to occur. Its
-  #! use is an optimisation to save having to generate and save a continuation
-  #! in that special case.
-  \ serving-html swons (show-final) ;
+    #! Similar to 'show', except the quotation does not receive the URL
+    #! to resume computation following 'show-final'. No continuation is
+    #! stored for this resumption. As a result, 'show-final' is for use
+    #! when a page is to be displayed with no further action to occur. Its
+    #! use is an optimisation to save having to generate and save a continuation
+    #! in that special case.
+    \ serving-html swons (show-final) ;
 
 #! Name of variable for holding initial continuation id that starts
 #! the responder.
 SYMBOL: root-continuation
 
 : id-or-root ( -- id )
-  #! Return the continuation id for the current requested continuation
-  #! or the root continuation if no id is supplied.
-  "id" "query" get hash [ root-continuation get ] unless* ;
+    #! Return the continuation id for the current requested continuation
+    #! or the root continuation if no id is supplied.
+    "id" "query" get hash [ root-continuation get ] unless* ;
 
 : cont-get/post-responder ( id-or-f -- ) 
-  #! httpd responder that retrieves a continuation and calls it.
-  #! The continuation id must be in a query parameter called 'id'.
-  #! If it does not exist the root continuation is called. If
-  #! no root continuation exists the expired continuation handler
-  #! should be called.
-  drop [
-    "response" get stdio get <resume>
-     id-or-root [
-      resume-continuation
-    ] [
-      (expired-page-handler) "" call-exit-continuation
-    ] if* 
-  ] with-exit-continuation drop ;
+    #! httpd responder that retrieves a continuation and calls it.
+    #! The continuation id must be in a query parameter called 'id'.
+    #! If it does not exist the root continuation is called. If
+    #! no root continuation exists the expired continuation handler
+    #! should be called.
+    [
+        drop [
+            "response" get stdio get <resume>
+            id-or-root [
+                resume-continuation
+            ] [
+                (expired-page-handler) "" call-exit-continuation
+            ] if* 
+        ] with-exit-continuation drop
+    ] with-scope ;
 
 : callback-quot ( quot -- quot )
-  #! Convert the given quotation so it works as a callback
-  #! by returning a quotation that will pass the original 
-  #! quotation to the callback continuation.
-  [ , \ stdio ,  \ get , \ <resume> , callback-cc get , \ continue-with , ] [ ] make ;
+    #! Convert the given quotation so it works as a callback
+    #! by returning a quotation that will pass the original 
+    #! quotation to the callback continuation.
+    [
+        , \ stdio ,  \ get , \ <resume> , callback-cc get ,
+        \ continue-with ,
+    ] [ ] make ;
 
 : quot-url ( quot -- url )
-  callback-quot expirable register-continuation id>url ;
+    callback-quot expirable register-continuation id>url ;
 
 : quot-href ( text quot -- )
-  #! Write to standard output an HTML HREF where the href,
-  #! when referenced, will call the quotation and then return
-  #! back to the most recent 'show' call (via the callback-cc).
-  #! The text of the link will be the 'text' argument on the 
-  #! stack.
-  <a quot-url =href a> write </a> ;
+    #! Write to standard output an HTML HREF where the href,
+    #! when referenced, will call the quotation and then return
+    #! back to the most recent 'show' call (via the callback-cc).
+    #! The text of the link will be the 'text' argument on the 
+    #! stack.
+    <a quot-url =href a> write </a> ;
 
 : init-session-namespace ( <resume> -- )
-  #! Setup the initial session namespace. Currently this only
-  #! sets the redirect flag so that the initial request of the
-  #! responder will not do a post-refresh-get style redirect.
-  #! This prevents the initial request to a responder from redirecting
-  #! to an URL with a continuation id. This word must be run from
-  #! within the session namespace.
-  f post-refresh-get? set dup resume-stdio stdio set ;
+    #! Setup the initial session namespace. Currently this only
+    #! sets the redirect flag so that the initial request of the
+    #! responder will not do a post-refresh-get style redirect.
+    #! This prevents the initial request to a responder from redirecting
+    #! to an URL with a continuation id. This word must be run from
+    #! within the session namespace.
+    f post-refresh-get? set dup resume-stdio stdio set ;
 
 : install-cont-responder ( name quot -- )
-  #! Install a cont-responder with the given name
-  #! that will initially run the given quotation.
-  #!
-  #! Convert the quotation so it is run within a session namespace
-  #! and that namespace is initialized first.
-  \ init-session-namespace swons [ , \ with-scope , ] [ ] make
-  [ 
-     [ cont-get/post-responder ] "get" set 
-     [ cont-get/post-responder ] "post" set 
-     swap "responder" set
-     permanent register-continuation root-continuation set 
-  ] make-responder ;
+    #! Install a cont-responder with the given name
+    #! that will initially run the given quotation.
+    #!
+    #! Convert the quotation so it is run within a session namespace
+    #! and that namespace is initialized first.
+    \ init-session-namespace swons [ , \ with-scope , ] [ ] make
+    [ 
+        [ cont-get/post-responder ] "get" set 
+        [ cont-get/post-responder ] "post" set 
+        swap "responder" set
+        permanent register-continuation root-continuation set 
+    ] make-responder ;
 
 : simple-page ( title quot -- )
-  #! Call the quotation, with all output going to the
-  #! body of an html page with the given title.
-  <html>  
-    <head> <title> swap write </title> </head> 
-    <body> call </body>
-  </html> ;
+    #! Call the quotation, with all output going to the
+    #! body of an html page with the given title.
+    <html>  
+        <head> <title> swap write </title> </head> 
+        <body> call </body>
+    </html> ;
 
 : styled-page ( title stylesheet-quot quot -- )
-  #! Call the quotation, with all output going to the
-  #! body of an html page with the given title. stylesheet-quot
-  #! is called to generate the required stylesheet.
-  <html>  
-    <head>  
-      <title> rot write </title> 
-      swap call 
-    </head> 
-    <body> call </body>
-  </html> ;
+    #! Call the quotation, with all output going to the
+    #! body of an html page with the given title. stylesheet-quot
+    #! is called to generate the required stylesheet.
+    <html>  
+        <head>  
+             <title> rot write </title> 
+             swap call 
+        </head> 
+        <body> call </body>
+    </html> ;
 
 : paragraph ( str -- )
-  #! Output the string as an html paragraph
-  <p> write </p> ;
+    #! Output the string as an html paragraph
+    <p> write </p> ;
 
 : show-message-page ( message -- )
-  #! Display the message in an HTML page with an OK button.
-  [
-    "Press OK to Continue" [
-       swap paragraph 
-       <a =href a> "OK" write </a>
-    ] simple-page 
-  ] show 2drop ;
+    #! Display the message in an HTML page with an OK button.
+    [
+        "Press OK to Continue" [
+            swap paragraph 
+            <a =href a> "OK" write </a>
+        ] simple-page 
+    ] show 2drop ;
 
 : vertical-layout ( list -- )
-  #! Given a list of HTML components, arrange them vertically.
-  <table> 
+    #! Given a list of HTML components, arrange them vertically.
+    <table> 
     [ <tr> <td> call </td> </tr> ] each
-  </table> ;
+    </table> ;
 
 : horizontal-layout ( list -- )
-  #! Given a list of HTML components, arrange them horizontally.
-  <table> 
-    <tr "top" =valign tr> [ <td> call </td> ] each </tr>
-  </table> ;
+    #! Given a list of HTML components, arrange them horizontally.
+    <table> 
+     <tr "top" =valign tr> [ <td> call </td> ] each </tr>
+    </table> ;
 
 : button ( label -- )
-  #! Output an HTML submit button with the given label.
-  <input "submit" =type =value input/> ;
+    #! Output an HTML submit button with the given label.
+    <input "submit" =type =value input/> ;
diff --git a/library/unix/io.factor b/library/unix/io.factor
index f1eeb6fa7a..a86fc78bd4 100644
--- a/library/unix/io.factor
+++ b/library/unix/io.factor
@@ -137,14 +137,16 @@ GENERIC: task-container ( task -- vector )
     [ drop t swap rot set-bit-nth ] hash-each-with ;
 
 : init-fdsets ( -- read write except )
-    read-fdset get [ read-tasks get init-fdset ] keep
-    write-fdset get [ write-tasks get init-fdset ] keep
+    read-fdset get-global
+    [ read-tasks get-global init-fdset ] keep
+    write-fdset get-global
+    [ write-tasks get-global init-fdset ] keep
     f ;
 
 : io-multiplex ( timeout -- )
     >r FD_SETSIZE init-fdsets r> make-timeval select io-error
-    read-fdset get read-tasks get handle-fdset
-    write-fdset get write-tasks get handle-fdset ;
+    read-fdset get-global read-tasks get-global handle-fdset
+    write-fdset get-global write-tasks get-global handle-fdset ;
 
 ! Readers
 
@@ -203,7 +205,7 @@ M: read-task do-io-task ( task -- ? )
         2drop f
     ] if ;
 
-M: read-task task-container drop read-tasks get ;
+M: read-task task-container drop read-tasks get-global ;
 
 : wait-to-read ( count port -- )
     2dup can-read-count? [
@@ -258,10 +260,10 @@ M: write-task do-io-task
         write-step f
     ] if ;
 
-M: write-task task-container drop write-tasks get ;
+M: write-task task-container drop write-tasks get-global ;
 
 : add-write-io-task ( callback task -- )
-    dup io-task-fd write-tasks get hash [
+    dup io-task-fd write-tasks get-global hash [
         dup write-task? [
             nip io-task-callbacks enque
         ] [

From 2fd9ea7fdacd14996429250e20c98f48543d77e9 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Fri, 28 Apr 2006 04:03:10 +0000
Subject: [PATCH 052/112] More robust duplex stream

---
 library/io/duplex-stream.factor | 48 +++++++++++++++++++++++----------
 1 file changed, 34 insertions(+), 14 deletions(-)

diff --git a/library/io/duplex-stream.factor b/library/io/duplex-stream.factor
index 9d296be3f7..58e2636cc3 100644
--- a/library/io/duplex-stream.factor
+++ b/library/io/duplex-stream.factor
@@ -1,44 +1,64 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: io
-USING: kernel ;
+USING: errors kernel ;
 
-TUPLE: duplex-stream in out ;
+! We ensure that the stream can only be closed once, to preserve
+! integrity of duplex I/O ports.
+
+TUPLE: duplex-stream in out closed? ;
+
+C: duplex-stream ( in out -- stream )
+    [ set-duplex-stream-out ] keep
+    [ set-duplex-stream-in ] keep ;
+
+: check-closed ( duplex -- )
+    duplex-stream-closed?
+    [ "Duplex stream closed" throw ] when ;
+
+: duplex-stream-in+ ( duplex -- stream )
+    dup check-closed duplex-stream-in ;
+
+: duplex-stream-out+ ( duplex -- stream )
+    dup check-closed duplex-stream-out ;
 
 M: duplex-stream stream-flush
-    duplex-stream-out stream-flush ;
+    duplex-stream-out+ stream-flush ;
 
 M: duplex-stream stream-readln
-    duplex-stream-in stream-readln ;
+    duplex-stream-in+ stream-readln ;
 
 M: duplex-stream stream-read1
-    duplex-stream-in stream-read1 ;
+    duplex-stream-in+ stream-read1 ;
 
 M: duplex-stream stream-read
-    duplex-stream-in stream-read ;
+    duplex-stream-in+ stream-read ;
 
 M: duplex-stream stream-write1
-    duplex-stream-out stream-write1 ;
+    duplex-stream-out+ stream-write1 ;
 
 M: duplex-stream stream-write
-    duplex-stream-out stream-write ;
+    duplex-stream-out+ stream-write ;
 
 M: duplex-stream stream-terpri
-    duplex-stream-out stream-terpri ;
+    duplex-stream-out+ stream-terpri ;
 
 M: duplex-stream stream-format
-    duplex-stream-out stream-format ;
+    duplex-stream-out+ stream-format ;
 
 M: duplex-stream with-nested-stream
-    duplex-stream-out with-nested-stream ;
+    duplex-stream-out+ with-nested-stream ;
 
 M: duplex-stream stream-close
     #! The output stream is closed first, in case both streams
     #! are attached to the same file descriptor, the output
     #! buffer needs to be flushed before we close the fd.
-    dup
-    duplex-stream-out stream-close
-    duplex-stream-in stream-close ;
+    dup duplex-stream-closed? [
+        t over set-duplex-stream-closed?
+        dup
+        duplex-stream-out stream-close
+        duplex-stream-in stream-close
+    ] unless ;
 
 M: duplex-stream set-timeout
     2dup

From 51a38d8ca5fec2b2606937d6312fcdad1339b2e2 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Fri, 28 Apr 2006 04:03:41 +0000
Subject: [PATCH 053/112] cont-responder cleanup

---
 contrib/httpd/cont-responder.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/contrib/httpd/cont-responder.factor b/contrib/httpd/cont-responder.factor
index cd4d70093c..65e7e78f92 100644
--- a/contrib/httpd/cont-responder.factor
+++ b/contrib/httpd/cont-responder.factor
@@ -176,8 +176,8 @@ SYMBOL: callback-cc
             stdio get swap continue-with
         ] callcc1
         nip
-        dup resume-stdio stdio set resume-value
-        call
+        dup resume-stdio stdio set
+        resume-value call
         store-callback-cc stdio get 
     ] callcc1 stdio set ;
 

From 5329b91aa8e56d382b6c0954fb7d223ab5df041b Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Fri, 28 Apr 2006 04:03:48 +0000
Subject: [PATCH 054/112] Unix I/O cleanup

---
 library/unix/io.factor | 19 ++++++-------------
 1 file changed, 6 insertions(+), 13 deletions(-)

diff --git a/library/unix/io.factor b/library/unix/io.factor
index a86fc78bd4..71ab7b83d1 100644
--- a/library/unix/io.factor
+++ b/library/unix/io.factor
@@ -254,21 +254,14 @@ C: write-task ( port -- task )
     [ >r <io-task> r> set-delegate ] keep ;
 
 M: write-task do-io-task
-    io-task-port dup buffer-length zero? over port-error or [
-        0 swap buffer-reset t
-    ] [
-        write-step f
-    ] if ;
+    io-task-port dup buffer-length zero? over port-error or
+    [ 0 swap buffer-reset t ] [ write-step f ] if ;
 
 M: write-task task-container drop write-tasks get-global ;
 
 : add-write-io-task ( callback task -- )
-    dup io-task-fd write-tasks get-global hash [
-        dup write-task? [
-            nip io-task-callbacks enque
-        ] [
-            drop add-io-task
-        ] if
+    write-tasks get-global hash [
+        [ io-task-callbacks enque ] [ add-io-task ] ?if
     ] [
         add-io-task
     ] if* ;
@@ -291,8 +284,8 @@ M: port stream-write ( string writer -- )
 
 M: port stream-close ( stream -- )
     dup port-type closed eq? [
-        dup port-type output eq? >r closed over set-port-type r>
-        [ dup port-flush ] when dup port-handle close
+        dup port-type >r closed over set-port-type r>
+        output eq? [ dup port-flush ] when dup port-handle close
         dup delegate [ buffer-free ] when* f over set-delegate
     ] unless drop ;
 

From 9e44e78d9c8586d293e974eaea37eb07a663879d Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Fri, 28 Apr 2006 04:19:58 +0000
Subject: [PATCH 055/112] Fix I/O typo

---
 library/unix/io.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/library/unix/io.factor b/library/unix/io.factor
index 71ab7b83d1..e66dd4c7ca 100644
--- a/library/unix/io.factor
+++ b/library/unix/io.factor
@@ -260,8 +260,8 @@ M: write-task do-io-task
 M: write-task task-container drop write-tasks get-global ;
 
 : add-write-io-task ( callback task -- )
-    write-tasks get-global hash [
-        [ io-task-callbacks enque ] [ add-io-task ] ?if
+    dup io-task-fd write-tasks get-global hash [
+        io-task-callbacks enque
     ] [
         add-io-task
     ] if* ;

From bf90db29149050b93dbc9c8b27af01003e249a0c Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sat, 29 Apr 2006 21:22:42 +0000
Subject: [PATCH 056/112] Fix typo

---
 library/unix/io.factor | 7 ++-----
 1 file changed, 2 insertions(+), 5 deletions(-)

diff --git a/library/unix/io.factor b/library/unix/io.factor
index e66dd4c7ca..a2eae41450 100644
--- a/library/unix/io.factor
+++ b/library/unix/io.factor
@@ -260,11 +260,8 @@ M: write-task do-io-task
 M: write-task task-container drop write-tasks get-global ;
 
 : add-write-io-task ( callback task -- )
-    dup io-task-fd write-tasks get-global hash [
-        io-task-callbacks enque
-    ] [
-        add-io-task
-    ] if* ;
+    dup io-task-fd write-tasks get-global hash
+    [ io-task-callbacks enque ] [ add-io-task ] ?if ;
 
 : port-flush ( port -- )
     [ swap <write-task> add-write-io-task stop ] callcc0 drop ;

From acb7a68b24604b4f3f092917c592206e1ad73ac3 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sat, 29 Apr 2006 21:23:16 +0000
Subject: [PATCH 057/112] Update copyright for changed file

---
 library/unix/io.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/library/unix/io.factor b/library/unix/io.factor
index a2eae41450..ae3a6ce90f 100644
--- a/library/unix/io.factor
+++ b/library/unix/io.factor
@@ -1,5 +1,5 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! Copyright (C) 2004, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 IN: io-internals
 USING: alien arrays errors generic hashtables io kernel
 kernel-internals lists math parser queues sequences strings

From 17d6efb543cb064a971bf8b7b7209d9f75df2abb Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Fri, 28 Apr 2006 22:38:48 +0000
Subject: [PATCH 058/112] Removing linear IR

---
 TODO.FACTOR.txt                            |   2 -
 library/alien/alien-callback.factor        |  25 +-
 library/alien/alien-invoke.factor          |  20 +-
 library/alien/compiler.factor              |  12 +-
 library/bootstrap/boot-stage1.factor       |  14 +-
 library/bootstrap/boot-stage2.factor       |   7 +-
 library/compiler/amd64/architecture.factor |   4 -
 library/compiler/architecture.factor       | 108 ++++++-
 library/compiler/compiler.factor           |  20 +-
 library/compiler/generator.factor          | 222 +++++++++++---
 library/compiler/linearizer.factor         | 134 --------
 library/compiler/ppc/alien.factor          |  89 ------
 library/compiler/ppc/architecture.factor   | 163 +++++++++-
 library/compiler/ppc/fixnum.factor         | 133 --------
 library/compiler/ppc/generator.factor      | 108 -------
 library/compiler/ppc/intrinsics.factor     | 225 ++++++++++++++
 library/compiler/ppc/slots.factor          |  64 ----
 library/compiler/ppc/stack.factor          |  39 ---
 library/compiler/stack.factor              |  47 ---
 library/compiler/templates.factor          |   8 +-
 library/compiler/vops.factor               | 340 ---------------------
 library/compiler/x86/architecture.factor   |   4 -
 library/compiler/xt.factor                 |   8 +-
 library/test/compiler/ifte.factor          |   1 +
 library/test/compiler/intrinsics.factor    |  74 ++---
 library/test/compiler/linearizer.factor    |  15 -
 library/test/compiler/simple.factor        |   5 +
 library/test/test.factor                   |   2 +-
 28 files changed, 775 insertions(+), 1118 deletions(-)
 delete mode 100644 library/compiler/linearizer.factor
 delete mode 100644 library/compiler/ppc/alien.factor
 delete mode 100644 library/compiler/ppc/fixnum.factor
 delete mode 100644 library/compiler/ppc/generator.factor
 create mode 100644 library/compiler/ppc/intrinsics.factor
 delete mode 100644 library/compiler/ppc/slots.factor
 delete mode 100644 library/compiler/ppc/stack.factor
 delete mode 100644 library/compiler/stack.factor
 delete mode 100644 library/compiler/vops.factor
 delete mode 100644 library/test/compiler/linearizer.factor

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 269f36bf87..6edf8eba78 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -9,8 +9,6 @@ should fix in 0.82:
 - get factor running on mac intel
 - when generating a 32-bit image on a 64-bit system, large numbers which should
   be bignums become fixnums
-- httpd fep
-- SBUF" " i/o bug
 - clicks sent twice
 - speed up ideas:
   - only do clipping for certain gadgets
diff --git a/library/alien/alien-callback.factor b/library/alien/alien-callback.factor
index fef4d10f6c..633b7a86ec 100644
--- a/library/alien/alien-callback.factor
+++ b/library/alien/alien-callback.factor
@@ -32,35 +32,34 @@ M: alien-callback-error summary ( error -- )
 ] "infer" set-word-prop
 
 : box-parameters ( parameters -- )
-    [ box-parameter ] map-parameters % ;
+    [ box-parameter ] each-parameter ;
 
 : registers>objects ( parameters -- )
-    dup \ %freg>stack move-parameters %
-    "nest_stacks" f %alien-invoke , box-parameters ;
+    dup \ %freg>stack move-parameters
+    "nest_stacks" f %alien-invoke box-parameters ;
 
 : unbox-return ( node -- )
     alien-callback-return [
-        "unnest_stacks" f %alien-invoke ,
+        "unnest_stacks" f %alien-invoke
     ] [
         c-type [
             "reg-class" get
             "unboxer-function" get
-            %callback-value ,
+            %callback-value
         ] bind
     ] if-void ;
 
-: linearize-callback ( node -- )
-    dup alien-callback-xt [
-        dup stack-reserve* %prologue ,
+: generate-callback ( node -- )
+    [ alien-callback-xt ] keep [
         dup alien-callback-parameters registers>objects
         dup alien-callback-quot \ init-error-handler swons
-        %alien-callback ,
+        %alien-callback
         unbox-return
-        %return ,
-    ] make-linear ;
+        %return
+    ] generate-block ;
 
-M: alien-callback linearize* ( node -- )
-    end-basic-block compile-gc linearize-callback iterate-next ;
+M: alien-callback generate-node ( node -- )
+    end-basic-block compile-gc generate-callback iterate-next ;
 
 M: alien-callback stack-reserve*
     alien-callback-parameters stack-space ;
diff --git a/library/alien/alien-invoke.factor b/library/alien/alien-invoke.factor
index 853939cc47..213ff16c67 100644
--- a/library/alien/alien-invoke.factor
+++ b/library/alien/alien-invoke.factor
@@ -39,35 +39,35 @@ M: alien-invoke-error summary ( error -- )
     node,
 ] "infer" set-word-prop
 
-: unbox-parameter ( stack# type -- node )
+: unbox-parameter ( stack# type -- )
     c-type [ "reg-class" get "unboxer" get call ] bind ;
 
 : unbox-parameters ( parameters -- )
-    [ unbox-parameter , ] reverse-each-parameter ;
+    [ unbox-parameter ] reverse-each-parameter ;
 
 : objects>registers ( parameters -- )
     #! Generate code for boxing a list of C types, then generate
     #! code for moving these parameters to register on
     #! architectures where parameters are passed in registers
     #! (PowerPC, AMD64).
-    dup unbox-parameters "save_stacks" f %alien-invoke ,
-    \ %stack>freg move-parameters % ;
+    dup unbox-parameters "save_stacks" f %alien-invoke
+    \ %stack>freg move-parameters ;
 
 : box-return ( node -- )
-    alien-invoke-return [ ] [ f swap box-parameter , ] if-void ;
+    alien-invoke-return [ ] [ f swap box-parameter ] if-void ;
 
-: linearize-cleanup ( node -- )
+: generate-cleanup ( node -- )
     dup alien-invoke-library library-abi "stdcall" = [
         drop
     ] [
-        alien-invoke-parameters stack-space %cleanup ,
+        alien-invoke-parameters stack-space %cleanup
     ] if ;
 
-M: alien-invoke linearize* ( node -- )
+M: alien-invoke generate-node ( node -- )
     end-basic-block compile-gc
     dup alien-invoke-parameters objects>registers
-    dup alien-invoke-dlsym %alien-invoke ,
-    dup linearize-cleanup box-return
+    dup alien-invoke-dlsym %alien-invoke
+    dup generate-cleanup box-return
     iterate-next ;
 
 M: alien-invoke stack-reserve*
diff --git a/library/alien/compiler.factor b/library/alien/compiler.factor
index 9deb4f3a2b..63df3cdd23 100644
--- a/library/alien/compiler.factor
+++ b/library/alien/compiler.factor
@@ -36,22 +36,22 @@ kernel-internals math namespaces sequences words ;
         [ c-size cell / "void*" <array> ] [ 1array ] if
     ] map concat ;
 
+: each-parameter ( parameters quot -- )
+    >r [ parameter-sizes ] keep r> 2each ; inline
+
 : reverse-each-parameter ( parameters quot -- )
     >r [ parameter-sizes ] keep
     [ reverse-slice ] 2apply r> 2each ; inline
 
-: map-parameters ( parameters quot -- seq )
-    >r [ parameter-sizes ] keep r> 2map ; inline
-
-: move-parameters ( params vop -- seq )
+: move-parameters ( params vop -- )
     #! Moves values from C stack to registers (if vop is
     #! %stack>freg) and registers to C stack (if vop is
     #! %freg>stack).
     swap [
         flatten-value-types
         0 { int-regs float-regs stack-params } [ set ] each-with
-        [ pick >r alloc-parameter r> execute ] map-parameters
-        nip
+        [ pick >r alloc-parameter r> execute ] each-parameter
+        drop
     ] with-scope ; inline
 
 : box-parameter ( stack# type -- node )
diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor
index e063ee395e..6a928e1e21 100644
--- a/library/bootstrap/boot-stage1.factor
+++ b/library/bootstrap/boot-stage1.factor
@@ -126,12 +126,8 @@ vectors words ;
         "/library/inference/print-dataflow.factor"
 
         "/library/compiler/assembler.factor"
-        "/library/compiler/vops.factor"
         "/library/compiler/templates.factor"
-        "/library/compiler/linearizer.factor"
-        "/library/compiler/stack.factor"
         "/library/compiler/xt.factor"
-        "/library/compiler/intrinsics.factor"
         "/library/compiler/generator.factor"
         "/library/compiler/compiler.factor"
 
@@ -297,11 +293,11 @@ vectors words ;
                 {
                     "/library/compiler/ppc/assembler.factor"
                     "/library/compiler/ppc/architecture.factor"
-                    "/library/compiler/ppc/generator.factor"
-                    "/library/compiler/ppc/slots.factor"
-                    "/library/compiler/ppc/stack.factor"
-                    "/library/compiler/ppc/fixnum.factor"
-                    "/library/compiler/ppc/alien.factor"
+                    ! "/library/compiler/ppc/generator.factor"
+                    ! "/library/compiler/ppc/slots.factor"
+                    ! "/library/compiler/ppc/stack.factor"
+                    ! "/library/compiler/ppc/fixnum.factor"
+                    ! "/library/compiler/ppc/alien.factor"
                 }
             ]
         } {
diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor
index d13befd2b4..ba1de70cb3 100644
--- a/library/bootstrap/boot-stage2.factor
+++ b/library/bootstrap/boot-stage2.factor
@@ -23,12 +23,7 @@ H{ } clone help-graph set-global xref-articles
 
     "Compiling base..." print flush
 
-    {
-        uncons 1+ 1- + <= > >= mod length
-        nth-unsafe set-nth-unsafe
-        = string>number number>string scan
-        kill-values (generate)
-    } [ compile ] each
+    { "kernel" "sequences" "assembler" } compile-vocabs
 
     "Compiling system..." print flush
     compile-all
diff --git a/library/compiler/amd64/architecture.factor b/library/compiler/amd64/architecture.factor
index 6950d4dec3..4922f704d5 100644
--- a/library/compiler/amd64/architecture.factor
+++ b/library/compiler/amd64/architecture.factor
@@ -10,10 +10,6 @@ kernel-internals math namespaces sequences ;
 ! R14 datastack
 ! R15 callstack
 
-: fixnum-imm? ( -- ? )
-    #! Can fixnum operations take immediate operands?
-    f ; inline
-
 : ds-reg R14 ; inline
 : cs-reg R15 ; inline
 : remainder-reg RDX ; inline
diff --git a/library/compiler/architecture.factor b/library/compiler/architecture.factor
index 2325bd7299..acc122ed6a 100644
--- a/library/compiler/architecture.factor
+++ b/library/compiler/architecture.factor
@@ -1,10 +1,110 @@
 IN: compiler
+USING: generic kernel kernel-internals math memory namespaces
+sequences ;
 
-! A few things the front-end needs to know about the back-end.
+! A scratch register for computations
+TUPLE: vreg n ;
 
-DEFER: fixnum-imm? ( -- ? )
-#! Can fixnum operations take immediate operands?
+! Register classes
+TUPLE: int-regs ;
+TUPLE: float-regs size ;
 
+! A pseudo-register class for parameters spilled on the stack
+TUPLE: stack-params ;
+
+! Return values of this class go here
+GENERIC: return-reg ( register-class -- reg )
+
+! Sequence of registers used for parameter passing in class
+GENERIC: fastcall-regs ( register-class -- regs )
+
+! Sequence mapping vreg-n to native assembler registers
 DEFER: vregs ( -- regs )
 
-DEFER: compile-c-call ( library function -- )
+! Load a literal (immediate or indirect)
+G: load-literal ( obj vreg -- ) 1 standard-combination ;
+
+! Set up caller stack frame (PowerPC and AMD64)
+DEFER: %prologue ( n -- )
+
+! Tail call another word
+DEFER: %jump ( label -- )
+
+! Call another word
+DEFER: %call ( label -- )
+
+! Local jump for branches or tail calls in nested #label
+DEFER: %jump-label ( label -- )
+
+! Test if vreg is 'f' or not
+DEFER: %jump-t ( label vreg -- )
+
+! Jump table of addresses (one cell each) is right after this
+DEFER: %dispatch ( vreg -- )
+
+! Return to caller
+DEFER: %return ( -- )
+
+! Change datastack height
+DEFER: %inc-d ( n -- )
+
+! Change callstack height
+DEFER: %inc-r ( n -- )
+
+! Load stack into vreg
+DEFER: %peek ( vreg loc -- )
+
+! Store vreg to stack
+DEFER: %replace ( vreg loc -- )
+
+! FFI stuff
+DEFER: %unbox ( n reg-class func -- )
+
+DEFER: %unbox-struct ( n reg-class size -- )
+
+DEFER: %box ( n reg-class func -- )
+
+DEFER: %box-struct ( n reg-class size -- )
+
+DEFER: %alien-invoke ( library function -- )
+
+DEFER: %alien-callback ( quot -- )
+
+DEFER: %callback-value ( reg-class func -- )
+
+! A few FFI operations have default implementations
+: %cleanup ( n -- ) drop ;
+
+: %stack>freg ( n reg reg-class -- ) 3drop ;
+
+: %freg>stack ( n reg reg-class -- ) 3drop ;
+
+! Some stuff probably not worth redefining in other backends
+M: stack-params fastcall-regs drop 0 ;
+
+GENERIC: reg-size ( register-class -- n )
+
+GENERIC: inc-reg-class ( register-class -- )
+
+M: int-regs reg-size drop cell ;
+
+: (inc-reg-class)
+    dup class inc
+    macosx? [ reg-size stack-params +@ ] [ drop ] if ;
+
+M: int-regs inc-reg-class
+    (inc-reg-class) ;
+
+M: float-regs reg-size float-regs-size ;
+
+M: float-regs inc-reg-class
+    dup (inc-reg-class)
+    macosx? [ reg-size 4 / int-regs +@ ] [ drop ] if ;
+
+GENERIC: v>operand
+
+M: integer v>operand tag-bits shift ;
+
+M: vreg v>operand vreg-n vregs nth ;
+
+M: f v>operand address ;
diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor
index e3f5d2885a..ec7681d4ef 100644
--- a/library/compiler/compiler.factor
+++ b/library/compiler/compiler.factor
@@ -5,23 +5,21 @@ USING: errors hashtables inference io kernel lists math
 namespaces optimizer prettyprint sequences test words ;
 
 : (compile) ( word -- )
-    #! Should be called inside the with-compiler scope.
-    dup word-def dataflow optimize linearize
-    [ generate ] hash-each ;
-
-: benchmark-compile
-    [ [ (compile) ] keep ] benchmark nip
+    [
+        [
+            dup word-def dataflow optimize generate
+        ] keep
+    ] benchmark nip
     "compile-time" set-word-prop ;
 
 : inform-compile ( word -- ) "Compiling " write . flush ;
 
 : compile-postponed ( -- )
     compile-words get dup empty? [
-        dup pop
-        dup inform-compile
-        benchmark-compile
-        compile-postponed
-    ] unless drop ;
+        drop
+    ] [
+        pop dup inform-compile (compile) compile-postponed
+    ] if ;
 
 : compile ( word -- )
     [ postpone-word compile-postponed ] with-compiler ;
diff --git a/library/compiler/generator.factor b/library/compiler/generator.factor
index 78c6e40fe1..0d3b2862a9 100644
--- a/library/compiler/generator.factor
+++ b/library/compiler/generator.factor
@@ -1,18 +1,39 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! Copyright (C) 2004, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 IN: compiler
-USING: alien assembler errors inference kernel
-kernel-internals lists math memory namespaces sequences strings
-vectors words ;
+USING: arrays assembler errors generic hashtables inference
+kernel kernel-internals lists math namespaces queues sequences
+words ;
 
-! Compile a VOP.
-GENERIC: generate-node ( vop -- )
+GENERIC: stack-reserve*
 
-: generate-code ( word linear -- length )
+M: object stack-reserve* drop 0 ;
+
+: stack-reserve ( node -- n )
+    0 swap [ stack-reserve* max ] each-node ;
+
+DEFER: #terminal?
+
+PREDICATE: #merge #terminal-merge node-successor #terminal? ;
+
+PREDICATE: #call #terminal-call
+    dup node-successor node-successor #terminal?
+    swap if-intrinsic and ;
+
+UNION: #terminal
+    POSTPONE: f #return #values #terminal-merge ;
+
+: tail-call? ( -- ? )
+    node-stack get [
+        dup #terminal-call? swap node-successor #terminal? or
+    ] all? ;
+
+: generate-code ( word node quot -- length | quot: node -- )
     compiled-offset >r
     compile-aligned
-    swap save-xt
-    [ dup [ generate-node ] with-vop ] each
+    rot save-xt
+    over stack-reserve %prologue
+    call
     compile-aligned
     compiled-offset r> - ;
 
@@ -21,46 +42,175 @@ GENERIC: generate-node ( vop -- )
     dup [ assemble-cell ] each
     length cells ;
 
-: (generate) ( word linear -- )
-    #! Compile a word definition from linear IR.
-    V{ } clone relocation-table set
-    begin-assembly swap >r >r
-        generate-code
-        generate-reloc
-    r> set-compiled-cell
-    r> set-compiled-cell ;
-
 SYMBOL: previous-offset
 
-: generate ( word linear -- )
+: begin-generating ( -- code-len-fixup reloc-len-fixup )
+    compiled-offset previous-offset set
+    V{ } clone relocation-table set
+    init-templates begin-assembly swap ;
+
+: generate-1 ( word node quot -- | quot: node -- )
     #! If generation fails, reset compiled offset.
     [
-        compiled-offset previous-offset set
-        (generate)
+        begin-generating >r >r
+            generate-code
+            generate-reloc
+        r> set-compiled-cell
+        r> set-compiled-cell
     ] [
-        previous-offset get set-compiled-offset
-        rethrow
+        previous-offset get set-compiled-offset rethrow
     ] recover ;
 
-! A few VOPs have trivial generators.
+SYMBOL: generate-queue
 
-M: %label generate-node ( vop -- )
-    vop-label save-xt ;
+: generate-loop ( -- )
+    generate-queue get dup queue-empty? [
+        drop
+    ] [
+        deque first3 generate-1 generate-loop
+    ] if ;
 
-M: %target-label generate-node ( vop -- )
-    drop label 0 assemble-cell absolute-cell ;
+: generate-block ( word node quot -- | quot: node -- )
+    3array generate-queue get enque ;
 
-M: %cleanup generate-node ( vop -- ) drop ;
+GENERIC: generate-node ( node -- )
 
-M: %freg>stack generate-node ( vop -- ) drop ;
+: generate-nodes ( node -- )
+    [ node@ generate-node ] iterate-nodes end-basic-block ;
 
-M: %stack>freg generate-node ( vop -- ) drop ;
+: generate-word ( node -- )
+    [ [ generate-nodes ] with-node-iterator ]
+    generate-block ;
 
-M: %alien-invoke generate-node
-    #! call a C function.
-    drop 0 input 1 input compile-c-call ;
+: generate ( word node -- )
+    [
+        <queue> generate-queue set
+        generate-word generate-loop 
+    ] with-scope ;
 
-: dest/src ( -- dest src ) 0 output-operand 0 input-operand ;
+! node
+M: node generate-node ( node -- next ) drop iterate-next ;
+
+! #label
+: generate-call ( label -- next )
+    end-basic-block
+    tail-call? [ %jump f ] [ %call iterate-next ] if ;
+
+M: #label generate-node ( node -- next )
+    #! We remap the IR node's label to a new label object here,
+    #! to avoid problems with two IR #label nodes having the
+    #! same label in different lexical scopes.
+    dup node-param dup generate-call >r
+    swap node-child generate-word r> ;
+
+! #if
+: generate-if ( node label -- next )
+    <label> [
+        >r >r node-children first2 generate-nodes
+        r> r> %jump-label save-xt generate-nodes
+    ] keep save-xt iterate-next ;
+
+M: #if generate-node ( node -- next )
+    [
+        end-basic-block
+        <label> dup "flag" get %jump-t
+    ] H{
+        { +input { { 0 "flag" } } }
+    } with-template generate-if ;
+
+! #call
+: [with-template] ( quot template -- quot )
+    2array >list [ with-template ] append ;
+
+: define-intrinsic ( word quot template -- | quot: -- )
+    [with-template] "intrinsic" set-word-prop ;
+
+: intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
+
+: define-if-intrinsic ( word quot template -- | quot: label -- )
+    [with-template] "if-intrinsic" set-word-prop ;
+
+: if-intrinsic ( #call -- quot )
+    dup node-successor #if?
+    [ node-param "if-intrinsic" word-prop ] [ drop f ] if ;
+
+M: #call generate-node ( node -- next )
+    dup if-intrinsic [
+        >r <label> dup r> call
+        >r node-successor r> generate-if node-successor
+    ] [
+        dup intrinsic
+        [ call iterate-next ] [ node-param generate-call ] ?if
+    ] if* ;
+
+! #call-label
+M: #call-label generate-node ( node -- next )
+    node-param generate-call ;
+
+! #dispatch
+: target-label ( label -- ) 0 assemble-cell absolute-cell ;
+
+: dispatch-head ( node -- label/node )
+    #! Output the jump table insn and return a list of
+    #! label/branch pairs.
+    [ end-basic-block "n" get %dispatch ]
+    H{ { +input { { 0 "n" } } } } with-template
+    node-children [ <label> dup target-label 2array ] map ;
+
+: dispatch-body ( label/node -- )
+    <label> swap [
+        first2 save-xt generate-nodes end-basic-block
+        dup %jump-label
+    ] each save-xt ;
+
+M: #dispatch generate-node ( node -- next )
+    #! The parameter is a list of nodes, each one is a branch to
+    #! take in case the top of stack has that type.
+    dispatch-head dispatch-body iterate-next ;
+
+! #push
+UNION: immediate fixnum POSTPONE: f ;
+
+: generate-push ( node -- )
+    >#push< dup length dup ensure-vregs
+    alloc-reg# [ <vreg> ] map
+    [ [ load-literal ] 2each ] keep
+    phantom-d get phantom-append ;
+
+M: #push generate-node ( #push -- )
+    generate-push iterate-next ;
+
+! #shuffle
+: phantom-shuffle-input ( n phantom -- seq )
+    2dup length <= [
+        cut-phantom
+    ] [
+        [ phantom-locs ] keep [ length swap head-slice* ] keep
+        [ append 0 ] keep set-length
+    ] if ;
+
+: phantom-shuffle-inputs ( shuffle -- locs locs )
+    dup shuffle-in-d length phantom-d get phantom-shuffle-input
+    swap shuffle-in-r length phantom-r get phantom-shuffle-input ;
+
+: adjust-shuffle ( shuffle -- )
+    dup shuffle-in-d length neg phantom-d get adjust-phantom
+    shuffle-in-r length neg phantom-r get adjust-phantom ;
+
+: shuffle-vregs# ( shuffle -- n )
+    dup shuffle-in-d swap shuffle-in-r additional-vregs# ;
+
+: phantom-shuffle ( shuffle -- )
+    dup shuffle-vregs# ensure-vregs
+    [ phantom-shuffle-inputs ] keep
+    [ shuffle* ] keep adjust-shuffle
+    (template-outputs) ;
+
+M: #shuffle generate-node ( #shuffle -- )
+    node-shuffle phantom-shuffle iterate-next ;
+
+! #return
+M: #return generate-node drop end-basic-block %return f ;
 
 ! These constants must match native/card.h
 : card-bits 7 ;
diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
deleted file mode 100644
index f26a1506b4..0000000000
--- a/library/compiler/linearizer.factor
+++ /dev/null
@@ -1,134 +0,0 @@
-! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic hashtables inference
-kernel math namespaces sequences words ;
-IN: compiler
-
-GENERIC: stack-reserve*
-
-M: object stack-reserve* drop 0 ;
-
-: stack-reserve ( node -- )
-    0 swap [ stack-reserve* max ] each-node ;
-
-DEFER: #terminal?
-
-PREDICATE: #merge #terminal-merge node-successor #terminal? ;
-
-: intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
-
-: if-intrinsic ( #call -- quot )
-    dup node-successor #if?
-    [ node-param "if-intrinsic" word-prop ] [ drop f ] if ;
-
-PREDICATE: #call #terminal-call
-    dup node-successor node-successor #terminal?
-    swap if-intrinsic and ;
-
-UNION: #terminal
-    POSTPONE: f #return #values #terminal-merge ;
-
-: tail-call? ( -- ? )
-    node-stack get [
-        dup #terminal-call? swap node-successor #terminal? or
-    ] all? ;
-
-GENERIC: linearize* ( node -- next )
-
-: linearize-child ( node -- )
-    [ node@ linearize* ] iterate-nodes end-basic-block ;
-
-! A map from words to linear IR.
-SYMBOL: linearized
-
-! Renamed labels. To avoid problems with labels with the same
-! name in different scopes.
-SYMBOL: renamed-labels
-
-: make-linear ( word quot -- )
-    [
-        init-templates
-        swap >r { } make r> linearized get set-hash
-    ] with-node-iterator ; inline
-
-: linearize-1 ( word node -- )
-    swap [
-        dup stack-reserve %prologue , linearize-child
-    ] make-linear ;
-
-: init-linearizer ( -- )
-    H{ } clone linearized set
-    H{ } clone renamed-labels set ;
-
-: linearize ( word dataflow -- linearized )
-    #! Outputs a hashtable mapping from labels to their
-    #! respective linear IR.
-    init-linearizer linearize-1 linearized get ;
-
-M: node linearize* ( node -- next ) drop iterate-next ;
-
-: linearize-call ( label -- next )
-    end-basic-block
-    tail-call? [ %jump , f ] [ %call , iterate-next ] if ;
-
-: rename-label ( label -- label )
-    <label> dup rot renamed-labels get set-hash ;
-
-: renamed-label ( label -- label )
-    renamed-labels get hash ;
-
-: linearize-call-label ( label -- next )
-    rename-label linearize-call ;
-
-M: #label linearize* ( node -- next )
-    #! We remap the IR node's label to a new label object here,
-    #! to avoid problems with two IR #label nodes having the
-    #! same label in different lexical scopes.
-    dup node-param dup linearize-call-label >r
-    renamed-label swap node-child linearize-1 r> ;
-
-: linearize-if ( node label -- next )
-    <label> [
-        >r >r node-children first2 linearize-child
-        r> r> %jump-label , %label , linearize-child
-    ] keep %label , iterate-next ;
-
-M: #call linearize* ( node -- next )
-    dup if-intrinsic [
-        >r <label> dup r> call
-        >r node-successor r> linearize-if node-successor
-    ] [
-        dup intrinsic
-        [ call iterate-next ] [ node-param linearize-call ] ?if
-    ] if* ;
-
-M: #call-label linearize* ( node -- next )
-    node-param renamed-label linearize-call ;
-
-M: #if linearize* ( node -- next )
-    [
-        end-basic-block
-        <label> dup "flag" get %jump-t ,
-    ] H{
-        { +input { { 0 "flag" } } }
-    } with-template linearize-if ;
-
-: dispatch-head ( node -- label/node )
-    #! Output the jump table insn and return a list of
-    #! label/branch pairs.
-    [ end-basic-block "n" get %dispatch , ]
-    H{ { +input { { 0 "n" } } } } with-template
-    node-children [ <label> dup %target-label ,  2array ] map ;
-
-: dispatch-body ( label/node -- )
-    <label> swap [
-        first2 %label , linearize-child end-basic-block
-        dup %jump-label ,
-    ] each %label , ;
-
-M: #dispatch linearize* ( node -- next )
-    #! The parameter is a list of nodes, each one is a branch to
-    #! take in case the top of stack has that type.
-    dispatch-head dispatch-body iterate-next ;
-
-M: #return linearize* drop end-basic-block %return , f ;
diff --git a/library/compiler/ppc/alien.factor b/library/compiler/ppc/alien.factor
deleted file mode 100644
index dd7120cdad..0000000000
--- a/library/compiler/ppc/alien.factor
+++ /dev/null
@@ -1,89 +0,0 @@
-! Copyright (C) 2005, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler
-USING: alien assembler kernel kernel-internals math sequences ;
-
-GENERIC: freg>stack ( stack reg reg-class -- )
-
-GENERIC: stack>freg ( stack reg reg-class -- )
-
-M: int-regs freg>stack drop 1 rot stack@ STW ;
-
-M: int-regs stack>freg drop 1 rot stack@ LWZ ;
-
-: STF float-regs-size 4 = [ STFS ] [ STFD ] if ;
-
-M: float-regs freg>stack >r 1 rot stack@ r> STF ;
-
-: LF float-regs-size 4 = [ LFS ] [ LFD ] if ;
-
-M: float-regs stack>freg >r 1 rot stack@ r> LF ;
-
-M: stack-params stack>freg
-    drop 2dup = [
-        2drop
-    ] [
-        >r 0 1 rot stack@ LWZ 0 1 r> stack@ STW
-    ] if ;
-
-M: stack-params freg>stack
-   >r stack-increment + swap r> stack>freg ;
-
-M: %unbox generate-node ( vop -- )
-    drop
-    ! Call the unboxer
-    2 input f compile-c-call
-    ! Store the return value on the C stack
-    0 input 1 input [ return-reg ] keep freg>stack ;
-
-: struct-ptr/size ( func -- )
-    ! Load destination address
-    3 1 0 input stack@ ADDI
-    ! Load struct size
-    2 input 4 LI
-    f compile-c-call ;
-
-M: %unbox-struct generate-node ( vop -- )
-    drop "unbox_value_struct" struct-ptr/size ;
-
-M: %box-struct generate-node ( vop -- )
-    drop "box_value_struct" struct-ptr/size ;
-
-: (%move) 0 input 1 input 2 input [ fastcall-regs nth ] keep ;
-
-M: %stack>freg generate-node ( vop -- )
-    ! Move a value from the C stack into the fastcall register
-    drop (%move) stack>freg ;
-
-M: %freg>stack generate-node ( vop -- )
-    ! Move a value from a fastcall register to the C stack
-    drop (%move) freg>stack ;
-
-M: %box generate-node ( vop -- )
-    drop
-    ! If the source is a stack location, load it into freg #0.
-    ! If the source is f, then we assume the value is already in
-    ! freg #0.
-    0 input [
-        1 input [ fastcall-regs first ] keep stack>freg
-    ] when*
-    2 input f compile-c-call ;
-
-M: %alien-callback generate-node ( vop -- )
-    drop
-    3 0 input load-indirect
-    "run_callback" f compile-c-call ;
-
-: save-return 0 swap [ return-reg ] keep freg>stack ;
-: load-return 0 swap [ return-reg ] keep stack>freg ;
-
-M: %callback-value generate-node ( vop -- )
-    drop
-    ! Call the unboxer
-    1 input f compile-c-call
-    ! Save return register
-    0 input save-return
-    ! Restore data/callstacks
-    "unnest_stacks" f compile-c-call
-    ! Restore return register
-    0 input load-return ;
diff --git a/library/compiler/ppc/architecture.factor b/library/compiler/ppc/architecture.factor
index f37c35fcbf..7db7535da3 100644
--- a/library/compiler/ppc/architecture.factor
+++ b/library/compiler/ppc/architecture.factor
@@ -1,15 +1,13 @@
 IN: compiler
-USING: assembler kernel kernel-internals math ;
+USING: alien assembler generic kernel kernel-internals math
+memory namespaces sequences words ;
 
 ! PowerPC register assignments
 ! r3-r10 vregs
+! r11 linkage
 ! r14 data stack
 ! r15 call stack
 
-: fixnum-imm? ( -- ? )
-    #! Can fixnum operations take immediate operands?
-    f ; inline
-
 : vregs { 3 4 5 6 7 8 9 10 } ; inline
 
 M: int-regs return-reg drop 3 ;
@@ -21,3 +19,158 @@ M: float-regs fastcall-regs drop { 1 2 3 4 5 6 7 8 } ;
 ! Mach-O -vs- Linux/PPC
 : stack@ macosx? 24 8 ? + ;
 : lr@ macosx? 8 4 ? + ;
+
+GENERIC: loc>operand
+
+M: ds-loc loc>operand ds-loc-n cells neg 14 swap ;
+M: cs-loc loc>operand cs-loc-n cells neg 15 swap ;
+
+M: immediate load-literal ( literal vreg -- )
+    >r address r> v>operand LOAD ;
+
+M: object load-literal ( literal vreg -- )
+    v>operand swap
+    add-literal over
+    LOAD32 rel-2/2 rel-address
+    dup 0 LWZ ;
+
+: stack-increment \ stack-reserve get 32 max stack@ 16 align ;
+
+: %prologue ( n -- )
+    \ stack-reserve set
+    1 1 stack-increment neg STWU
+    0 MFLR
+    0 1 stack-increment lr@ STW ;
+
+: compile-epilogue ( -- )
+    #! At the end of each word that calls a subroutine, we store
+    #! the previous link register value in r0 by popping it off
+    #! the stack, set the link register to the contents of r0,
+    #! and jump to the link register.
+    0 1 stack-increment lr@ LWZ
+    1 1 stack-increment ADDI
+    0 MTLR ;
+
+: word-addr ( word -- )
+    #! Load a word address into r3.
+    dup word-xt 3 LOAD32  rel-2/2 rel-word ;
+
+: %call ( label -- )
+    #! Far C call for primitives, near C call for compiled defs.
+    dup postpone-word
+    dup primitive? [ word-addr  3 MTLR  BLRL ] [ BL ] if ;
+
+: %jump-label ( label -- )
+    #! For tail calls. IP not saved on C stack.
+    dup primitive? [ word-addr  3 MTCTR  BCTR ] [ B ] if ;
+
+: %jump ( label -- )
+    compile-epilogue dup postpone-word %jump-label ;
+
+: %jump-t ( label vreg -- )
+    0 swap v>operand f address CMPI BNE ;
+
+: %dispatch ( vreg -- )
+    v>operand dup dup 1 SRAWI
+    ! The value 24 is a magic number. It is the length of the
+    ! instruction sequence that follows to be generated.
+    compiled-offset 24 + 11 LOAD32  rel-2/2 rel-address
+    dup dup 11 ADD
+    dup dup 0 LWZ
+    MTLR
+    BLR ;
+
+: %return ( -- ) compile-epilogue BLR ;
+
+: %peek ( vreg loc -- ) >r v>operand r> loc>operand LWZ ;
+
+: %replace ( vreg loc -- ) >r v>operand r> loc>operand STW ;
+
+: %inc-d ( n -- ) 14 14 rot cells ADDI ;
+
+: %inc-r ( n -- ) 15 15 rot cells ADDI ;
+
+GENERIC: freg>stack ( stack reg reg-class -- )
+
+GENERIC: stack>freg ( stack reg reg-class -- )
+
+M: int-regs freg>stack drop 1 rot stack@ STW ;
+
+M: int-regs stack>freg drop 1 rot stack@ LWZ ;
+
+: STF float-regs-size 4 = [ STFS ] [ STFD ] if ;
+
+M: float-regs freg>stack >r 1 rot stack@ r> STF ;
+
+: LF float-regs-size 4 = [ LFS ] [ LFD ] if ;
+
+M: float-regs stack>freg >r 1 rot stack@ r> LF ;
+
+M: stack-params stack>freg
+    drop 2dup = [
+        2drop
+    ] [
+        >r 0 1 rot stack@ LWZ 0 1 r> stack@ STW
+    ] if ;
+
+M: stack-params freg>stack
+   >r stack-increment + swap r> stack>freg ;
+
+: (%move) [ fastcall-regs nth ] keep ;
+
+: %stack>freg ( n reg reg-class -- ) (%move) stack>freg ;
+
+: %freg>stack ( n reg reg-class -- ) (%move) freg>stack ;
+
+: %unbox ( n reg-class func -- )
+    ! Call the unboxer
+    f %alien-invoke
+    ! Store the return value on the C stack
+    [ return-reg ] keep freg>stack ;
+
+: %box ( n reg-class func -- )
+    ! If the source is a stack location, load it into freg #0.
+    ! If the source is f, then we assume the value is already in
+    ! freg #0.
+    pick [
+        >r [ fastcall-regs first ] keep stack>freg r>
+    ] [
+        2nip
+    ] if
+    f %alien-invoke ;
+
+: struct-ptr/size ( n reg-class size func -- )
+    rot drop
+    ! Load destination address
+    >r >r 3 1 rot stack@ ADDI r>
+    ! Load struct size
+    4 LI
+    r> f %alien-invoke ;
+
+: %unbox-struct ( n reg-class size -- )
+    "unbox_value_struct" struct-ptr/size ;
+
+: %box-struct ( n reg-class size -- )
+    "box_value_struct" struct-ptr/size ;
+
+: compile-dlsym ( symbol dll register -- )
+    >r 2dup dlsym r> LOAD32 rel-2/2 rel-dlsym ;
+
+: %alien-invoke ( symbol dll -- )
+    11 [ compile-dlsym ] keep MTLR BLRL ;
+
+: %alien-callback ( quot -- )
+    T{ vreg f 0 } load-literal "run_callback" f %alien-invoke ;
+
+: save-return 0 swap [ return-reg ] keep freg>stack ;
+: load-return 0 swap [ return-reg ] keep stack>freg ;
+
+: %callback-value ( reg-class func -- )
+    ! Call the unboxer
+    f %alien-invoke
+    ! Save return register
+    dup save-return
+    ! Restore data/callstacks
+    "unnest_stacks" f %alien-invoke
+    ! Restore return register
+    load-return ;
diff --git a/library/compiler/ppc/fixnum.factor b/library/compiler/ppc/fixnum.factor
deleted file mode 100644
index f5e6b762a8..0000000000
--- a/library/compiler/ppc/fixnum.factor
+++ /dev/null
@@ -1,133 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
-USING: assembler kernel kernel-internals math
-math-internals memory namespaces words ;
-
-: >3-vop< ( -- out1 in1 in2 )
-    0 output-operand 0 input-operand 1 input-operand ;
-
-: simple-overflow ( inv word -- )
-    >r >r
-    <label> "end" set
-    "end" get BNO
-    >3-vop< r> execute
-    0 input-operand dup untag-fixnum
-    1 input-operand dup untag-fixnum
-    >3-vop< r> execute
-    "s48_long_to_bignum" f compile-c-call
-    ! An untagged pointer to the bignum is now in r3; tag it
-    0 output-operand dup bignum-tag ORI
-    "end" get save-xt ; inline
-
-M: %fixnum+ generate-node ( vop -- )
-    drop 0 MTXER >3-vop< ADDO. \ SUBF \ ADD simple-overflow ;
-
-M: %fixnum+fast generate-node ( vop -- ) drop >3-vop< ADD ;
-
-M: %fixnum-fast generate-node ( vop -- ) drop >3-vop< SUBF ;
-
-M: %fixnum- generate-node ( vop -- )
-    drop 0 MTXER >3-vop< SUBFO. \ ADD \ SUBF simple-overflow ;
-
-M: %fixnum* generate-node ( vop -- )
-    #! Note that this assumes the output will be in r3.
-    drop
-    <label> "end" set
-    1 input-operand dup untag-fixnum
-    0 MTXER
-    0 scratch 0 input-operand 1 input-operand MULLWO.
-    "end" get BNO
-    1 scratch 0 input-operand 1 input-operand MULHW
-    4 1 scratch MR
-    3 0 scratch MR
-    "s48_fixnum_pair_to_bignum" f compile-c-call
-    ! now we have to shift it by three bits to remove the second
-    ! tag
-    tag-bits neg 4 LI
-    "s48_bignum_arithmetic_shift" f compile-c-call
-    ! An untagged pointer to the bignum is now in r3; tag it
-    0 output-operand 0 scratch bignum-tag ORI
-    "end" get save-xt
-    0 output-operand 0 scratch MR ;
-
-: generate-fixnum/i
-    #! This VOP is funny. If there is an overflow, it falls
-    #! through to the end, and the result is in 0 output-operand.
-    #! Otherwise it jumps to the "no-overflow" label and the
-    #! result is in 0 scratch.
-    0 scratch 1 input-operand 0 input-operand DIVW
-    ! if the result is greater than the most positive fixnum,
-    ! which can only ever happen if we do
-    ! most-negative-fixnum -1 /i, then the result is a bignum.
-    <label> "end" set
-    <label> "no-overflow" set
-    most-positive-fixnum 1 scratch LOAD
-    0 scratch 0 1 scratch CMP
-    "no-overflow" get BLE
-    most-negative-fixnum neg 3 LOAD
-    "s48_long_to_bignum" f compile-c-call
-    3 dup bignum-tag ORI ;
-
-M: %fixnum/i generate-node ( vop -- )
-    #! This has specific vreg requirements.
-    drop
-    generate-fixnum/i
-    "end" get B
-    "no-overflow" get save-xt
-    0 scratch 0 output-operand tag-fixnum
-    "end" get save-xt ;
-
-: generate-fixnum-mod
-    #! PowerPC doesn't have a MOD instruction; so we compute
-    #! x-(x/y)*y. Puts the result in 1 scratch.
-    1 scratch 0 scratch 0 input-operand MULLW
-    1 scratch 1 scratch 1 input-operand SUBF ;
-
-M: %fixnum-mod generate-node ( vop -- )
-    drop
-    ! divide in2 by in1, store result in out1
-    0 scratch 1 input-operand 0 input-operand DIVW
-    generate-fixnum-mod
-    0 output-operand 1 scratch MR ;
-
-M: %fixnum/mod generate-node ( vop -- )
-    #! This has specific vreg requirements. Note: if there's an
-    #! overflow, (most-negative-fixnum 1 /mod) the modulus is
-    #! always zero.
-    drop
-    generate-fixnum/i
-    0 0 output-operand LI
-    "end" get B
-    "no-overflow" get save-xt
-    generate-fixnum-mod
-    0 scratch 1 output-operand tag-fixnum
-    0 output-operand 1 scratch MR
-    "end" get save-xt ;
-
-M: %fixnum-bitand generate-node ( vop -- ) drop >3-vop< AND ;
-
-M: %fixnum-bitor generate-node ( vop -- ) drop >3-vop< OR ;
-
-M: %fixnum-bitxor generate-node ( vop -- ) drop >3-vop< XOR ;
-
-M: %fixnum-bitnot generate-node ( vop -- )
-    drop dest/src NOT
-    0 output-operand dup untag ;
-
-M: %fixnum>> generate-node ( vop -- )
-    drop
-    1 input-operand 0 output-operand 0 input SRAWI
-    0 output-operand dup untag ;
-
-M: %fixnum-sgn generate-node ( vop -- )
-    drop dest/src cell-bits 1- SRAWI 0 output-operand dup untag ;
-
-: fixnum-jump ( -- label )
-    1 input-operand 0 0 input-operand CMP label ;
-
-M: %jump-fixnum<  generate-node ( vop -- ) drop fixnum-jump BLT ;
-M: %jump-fixnum<= generate-node ( vop -- ) drop fixnum-jump BLE ;
-M: %jump-fixnum>  generate-node ( vop -- ) drop fixnum-jump BGT ;
-M: %jump-fixnum>= generate-node ( vop -- ) drop fixnum-jump BGE ;
-M: %jump-eq?      generate-node ( vop -- ) drop fixnum-jump BEQ ;
diff --git a/library/compiler/ppc/generator.factor b/library/compiler/ppc/generator.factor
deleted file mode 100644
index 3c9fc49463..0000000000
--- a/library/compiler/ppc/generator.factor
+++ /dev/null
@@ -1,108 +0,0 @@
-! Copyright (C) 2005, 200 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler
-USING: alien assembler inference kernel kernel-internals lists
-math memory namespaces words ;
-
-: compile-dlsym ( symbol dll register -- )
-    >r 2dup dlsym  r> LOAD32 rel-2/2 rel-dlsym ;
-
-: compile-c-call ( symbol dll -- )
-    11 [ compile-dlsym ] keep MTLR  BLRL ;
-
-: stack-increment \ stack-reserve get 32 max stack@ 16 align ;
-
-M: %prologue generate-node ( vop -- )
-    drop
-    0 input \ stack-reserve set
-    1 1 stack-increment neg STWU
-    0 MFLR
-    0 1 stack-increment lr@ STW ;
-
-: compile-epilogue
-    #! At the end of each word that calls a subroutine, we store
-    #! the previous link register value in r0 by popping it off
-    #! the stack, set the link register to the contents of r0,
-    #! and jump to the link register.
-    0 1 stack-increment lr@ LWZ
-    1 1 stack-increment ADDI
-    0 MTLR ;
-
-: word-addr ( word -- )
-    #! Load a word address into r3.
-    dup word-xt 3 LOAD32  rel-2/2 rel-word ;
-
-: compile-call ( label -- )
-    #! Far C call for primitives, near C call for compiled defs.
-    dup postpone-word
-    dup primitive? [ word-addr  3 MTLR  BLRL ] [ BL ] if ;
-
-M: %call generate-node ( vop -- )
-    vop-label compile-call ;
-
-: compile-jump ( label -- )
-    #! For tail calls. IP not saved on C stack.
-    dup postpone-word
-    dup primitive? [ word-addr  3 MTCTR  BCTR ] [ B ] if ;
-
-M: %jump generate-node ( vop -- )
-    drop compile-epilogue label compile-jump ;
-
-M: %jump-label generate-node ( vop -- )
-    drop label compile-jump ;
-
-M: %jump-t generate-node ( vop -- )
-    drop 0 input-operand 0 swap f address CMPI label BNE ;
-
-M: %return generate-node ( vop -- )
-    drop compile-epilogue BLR ;
-
-: untag ( dest src -- ) 0 0 31 tag-bits - RLWINM ;
-
-M: %untag generate-node ( vop -- )
-    drop dest/src untag ;
-
-: tag-fixnum ( src dest -- ) tag-bits SLWI ;
-
-: untag-fixnum ( src dest -- ) tag-bits SRAWI ;
-
-M: %dispatch generate-node ( vop -- )
-    drop
-    0 input-operand dup 1 SRAWI
-    ! The value 24 is a magic number. It is the length of the
-    ! instruction sequence that follows to be generated.
-    compiled-offset 24 + 0 scratch LOAD32  rel-2/2 rel-address
-    0 input-operand dup 0 scratch ADD
-    0 input-operand dup 0 LWZ
-    0 input-operand MTLR
-    BLR ;
-
-M: %type generate-node ( vop -- )
-    drop
-    <label> "f" set
-    <label> "end" set
-    ! Get the tag
-    0 input-operand 1 scratch tag-mask ANDI
-    ! Tag the tag
-    1 scratch 0 scratch tag-fixnum
-    ! Compare with object tag number (3).
-    0 1 scratch object-tag CMPI
-    ! Jump if the object doesn't store type info in its header
-    "end" get BNE
-    ! It does store type info in its header
-    ! Is the pointer itself equal to 3? Then its F_TYPE (9).
-    0 0 input-operand object-tag CMPI
-    "f" get BEQ
-    ! The pointer is not equal to 3. Load the object header.
-    0 scratch 0 input-operand object-tag neg LWZ
-    0 scratch dup untag
-    "end" get B
-    "f" get save-xt
-    ! The pointer is equal to 3. Load F_TYPE (9).
-    f type tag-bits shift 0 scratch LI
-    "end" get save-xt
-    0 output-operand 0 scratch MR ;
-
-M: %tag generate-node ( vop -- )
-    drop dest/src swap tag-mask ANDI
-    0 output-operand dup tag-fixnum ;
diff --git a/library/compiler/ppc/intrinsics.factor b/library/compiler/ppc/intrinsics.factor
new file mode 100644
index 0000000000..50a8971688
--- /dev/null
+++ b/library/compiler/ppc/intrinsics.factor
@@ -0,0 +1,225 @@
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler
+USING: assembler kernel kernel-internals math math-internals
+namespaces sequences ;
+
+: untag ( dest src -- ) 0 0 31 tag-bits - RLWINM ;
+
+: tag-fixnum ( src dest -- ) tag-bits SLWI ;
+
+: untag-fixnum ( src dest -- ) tag-bits SRAWI ;
+
+\ tag [
+    "in" operand dup tag-mask ANDI
+    "in" operand dup tag-fixnum
+] H{
+    { +input { { f "in" } } }
+    { +output { "in" } }
+} define-intrinsic
+
+: generate-slot ( size quot -- )
+    >r >r
+    ! turn tagged fixnum slot # into an offset, multiple of 4
+    "n" operand dup tag-bits r> - SRAWI
+    ! compute slot address
+    "obj" operand dup "n" operand ADD
+    ! load slot value
+    "obj" operand dup r> call ; inline
+
+\ slot [
+    "obj" operand dup untag
+    cell log2 [ 0 LWZ ] generate-slot
+] H{
+    { +input { { f "obj" } { f "n" } } }
+    { +output { "obj" } }
+} define-intrinsic
+
+\ char-slot [
+    1 [ string-offset LHZ ] generate-slot
+    "obj" operand dup tag-fixnum
+] H{
+    { +input { { f "n" } { f "obj" } } }
+    { +output { "obj" } }
+} define-intrinsic
+
+: define-binary-op ( word op -- )
+    [ [ "x" operand "y" operand "x" operand ] % , ] [ ] make H{
+        { +input { { f "x" } { f "y" } } }
+        { +output { "x" } }
+    } define-intrinsic ;
+
+{
+    { fixnum+fast ADD }
+    { fixnum-fast SUBF }
+    { fixnum-bitand AND }
+    { fixnum-bitor OR }
+    { fixnum-bitxor XOR }
+} [
+    first2 define-binary-op
+] each
+
+\ fixnum-bitnot [
+    "x" operand dup NOT
+    "x" operand dup untag
+] H{
+    { +input { { f "x" } } }
+    { +output { "x" } }
+} define-intrinsic
+
+: define-binary-jump ( word op -- )
+    [
+        [ end-basic-block "x" operand 0 "y" operand CMP ] % ,
+     ] [ ] make H{ { +input { { f "x" } { f "y" } } } }
+    define-if-intrinsic ;
+
+{
+    { fixnum< BLT }
+    { fixnum<= BLE }
+    { fixnum> BGT }
+    { fixnum>= BGE }
+    { eq? BEQ }
+} [
+    first2 define-binary-jump
+] each
+
+! M: %type generate-node ( vop -- )
+!     drop
+!     <label> "f" set
+!     <label> "end" set
+!     ! Get the tag
+!     0 input-operand 1 scratch tag-mask ANDI
+!     ! Tag the tag
+!     1 scratch 0 scratch tag-fixnum
+!     ! Compare with object tag number (3).
+!     0 1 scratch object-tag CMPI
+!     ! Jump if the object doesn't store type info in its header
+!     "end" get BNE
+!     ! It does store type info in its header
+!     ! Is the pointer itself equal to 3? Then its F_TYPE (9).
+!     0 0 input-operand object-tag CMPI
+!     "f" get BEQ
+!     ! The pointer is not equal to 3. Load the object header.
+!     0 scratch 0 input-operand object-tag neg LWZ
+!     0 scratch dup untag
+!     "end" get B
+!     "f" get save-xt
+!     ! The pointer is equal to 3. Load F_TYPE (9).
+!     f type tag-bits shift 0 scratch LI
+!     "end" get save-xt
+!     0 output-operand 0 scratch MR ;
+! 
+! : generate-set-slot ( size quot -- )
+!     >r >r
+!     ! turn tagged fixnum slot # into an offset, multiple of 4
+!     2 input-operand dup tag-bits r> - SRAWI
+!     ! compute slot address in 1st input
+!     2 input-operand dup 1 input-operand ADD
+!     ! store new slot value
+!     0 input-operand 2 input-operand r> call ; inline
+! 
+! M: %set-slot generate-node ( vop -- )
+!     drop cell log2 [ 0 STW ] generate-set-slot ;
+! 
+! M: %write-barrier generate-node ( vop -- )
+!     #! Mark the card pointed to by vreg.
+!     drop
+!     0 input-operand dup card-bits SRAWI
+!     0 input-operand dup 16 ADD
+!     0 scratch 0 input-operand 0 LBZ
+!     0 scratch dup card-mark ORI
+!     0 scratch 0 input-operand 0 STB ;
+! 
+! : simple-overflow ( inv word -- )
+!     >r >r
+!     <label> "end" set
+!     "end" get BNO
+!     >3-vop< r> execute
+!     0 input-operand dup untag-fixnum
+!     1 input-operand dup untag-fixnum
+!     >3-vop< r> execute
+!     "s48_long_to_bignum" f compile-c-call
+!     ! An untagged pointer to the bignum is now in r3; tag it
+!     0 output-operand dup bignum-tag ORI
+!     "end" get save-xt ; inline
+! 
+! M: %fixnum+ generate-node ( vop -- )
+!     drop 0 MTXER >3-vop< ADDO. \ SUBF \ ADD simple-overflow ;
+! 
+! M: %fixnum- generate-node ( vop -- )
+!     drop 0 MTXER >3-vop< SUBFO. \ ADD \ SUBF simple-overflow ;
+! 
+! M: %fixnum* generate-node ( vop -- )
+!     #! Note that this assumes the output will be in r3.
+!     drop
+!     <label> "end" set
+!     1 input-operand dup untag-fixnum
+!     0 MTXER
+!     0 scratch 0 input-operand 1 input-operand MULLWO.
+!     "end" get BNO
+!     1 scratch 0 input-operand 1 input-operand MULHW
+!     4 1 scratch MR
+!     3 0 scratch MR
+!     "s48_fixnum_pair_to_bignum" f compile-c-call
+!     ! now we have to shift it by three bits to remove the second
+!     ! tag
+!     tag-bits neg 4 LI
+!     "s48_bignum_arithmetic_shift" f compile-c-call
+!     ! An untagged pointer to the bignum is now in r3; tag it
+!     0 output-operand 0 scratch bignum-tag ORI
+!     "end" get save-xt
+!     0 output-operand 0 scratch MR ;
+! 
+! : generate-fixnum/i
+!     #! This VOP is funny. If there is an overflow, it falls
+!     #! through to the end, and the result is in 0 output-operand.
+!     #! Otherwise it jumps to the "no-overflow" label and the
+!     #! result is in 0 scratch.
+!     0 scratch 1 input-operand 0 input-operand DIVW
+!     ! if the result is greater than the most positive fixnum,
+!     ! which can only ever happen if we do
+!     ! most-negative-fixnum -1 /i, then the result is a bignum.
+!     <label> "end" set
+!     <label> "no-overflow" set
+!     most-positive-fixnum 1 scratch LOAD
+!     0 scratch 0 1 scratch CMP
+!     "no-overflow" get BLE
+!     most-negative-fixnum neg 3 LOAD
+!     "s48_long_to_bignum" f compile-c-call
+!     3 dup bignum-tag ORI ;
+! 
+! M: %fixnum/i generate-node ( vop -- )
+!     #! This has specific vreg requirements.
+!     drop
+!     generate-fixnum/i
+!     "end" get B
+!     "no-overflow" get save-xt
+!     0 scratch 0 output-operand tag-fixnum
+!     "end" get save-xt ;
+! 
+! : generate-fixnum-mod
+!     #! PowerPC doesn't have a MOD instruction; so we compute
+!     #! x-(x/y)*y. Puts the result in 1 scratch.
+!     1 scratch 0 scratch 0 input-operand MULLW
+!     1 scratch 1 scratch 1 input-operand SUBF ;
+! 
+! M: %fixnum-mod generate-node ( vop -- )
+!     drop
+!     ! divide in2 by in1, store result in out1
+!     0 scratch 1 input-operand 0 input-operand DIVW
+!     generate-fixnum-mod
+!     0 output-operand 1 scratch MR ;
+! 
+! M: %fixnum/mod generate-node ( vop -- )
+!     #! This has specific vreg requirements. Note: if there's an
+!     #! overflow, (most-negative-fixnum 1 /mod) the modulus is
+!     #! always zero.
+!     drop
+!     generate-fixnum/i
+!     0 0 output-operand LI
+!     "end" get B
+!     "no-overflow" get save-xt
+!     generate-fixnum-mod
+!     0 scratch 1 output-operand tag-fixnum
+!     0 output-operand 1 scratch MR
+!     "end" get save-xt ;
diff --git a/library/compiler/ppc/slots.factor b/library/compiler/ppc/slots.factor
deleted file mode 100644
index 6209357695..0000000000
--- a/library/compiler/ppc/slots.factor
+++ /dev/null
@@ -1,64 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
-USING: alien assembler inference kernel
-kernel-internals lists math memory namespaces sequences words ;
-
-: generate-slot ( size quot -- )
-    >r >r
-    ! turn tagged fixnum slot # into an offset, multiple of 4
-    0 input-operand dup tag-bits r> - SRAWI
-    ! compute slot address
-    0 output-operand dup 0 input-operand ADD
-    ! load slot value
-    0 output-operand dup r> call ; inline
-
-M: %slot generate-node ( vop -- )
-    drop cell log2 [ 0 LWZ ] generate-slot ;
-
-M: %fast-slot generate-node ( vop -- )
-    drop 0 output-operand dup 0 input LWZ ;
-
-: generate-set-slot ( size quot -- )
-    >r >r
-    ! turn tagged fixnum slot # into an offset, multiple of 4
-    2 input-operand dup tag-bits r> - SRAWI
-    ! compute slot address in 1st input
-    2 input-operand dup 1 input-operand ADD
-    ! store new slot value
-    0 input-operand 2 input-operand r> call ; inline
-
-M: %set-slot generate-node ( vop -- )
-    drop cell log2 [ 0 STW ] generate-set-slot ;
-
-M: %fast-set-slot generate-node ( vop -- )
-    drop 0 input-operand 1 input-operand 2 input STW ;
-
-M: %write-barrier generate-node ( vop -- )
-    #! Mark the card pointed to by vreg.
-    drop
-    0 input-operand dup card-bits SRAWI
-    0 input-operand dup 16 ADD
-    0 scratch 0 input-operand 0 LBZ
-    0 scratch dup card-mark ORI
-    0 scratch 0 input-operand 0 STB ;
-
-M: %char-slot generate-node ( vop -- )
-    drop 1 [ string-offset LHZ ] generate-slot
-    0 output-operand dup tag-fixnum ;
-
-M: %set-char-slot generate-node ( vop -- )
-    ! untag the new value in 0th input
-    drop 0 input-operand dup untag-fixnum
-    1 [ string-offset STH ] generate-set-slot ;
-
-: userenv ( reg -- )
-    #! Load the userenv pointer in a virtual register.
-    "userenv" f dlsym swap LOAD32 0 rel-2/2 rel-userenv ;
-
-M: %getenv generate-node ( vop -- )
-    drop 0 output-operand dup dup userenv 0 input cells LWZ ;
-
-M: %setenv generate-node ( vop -- )
-    drop 0 scratch userenv
-    0 input-operand 0 scratch 1 input cells STW ;
diff --git a/library/compiler/ppc/stack.factor b/library/compiler/ppc/stack.factor
deleted file mode 100644
index abba554663..0000000000
--- a/library/compiler/ppc/stack.factor
+++ /dev/null
@@ -1,39 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
-USING: assembler errors kernel kernel-internals math
-memory namespaces words ;
-
-GENERIC: loc>operand
-
-M: ds-loc loc>operand ds-loc-n cells neg 14 swap ;
-M: cs-loc loc>operand cs-loc-n cells neg 15 swap ;
-
-: %literal ( quot -- )
-    0 output vreg? [
-        0 input 0 output-operand rot call
-    ] [
-        0 input 11 rot call
-        11 0 output loc>operand STW
-    ] if ; inline
-
-M: %immediate generate-node ( vop -- )
-    drop [ >r address r> LOAD ] %literal ;
-
-: load-indirect ( dest literal -- )
-    add-literal over LOAD32 rel-2/2 rel-address dup 0 LWZ ;
-
-M: %indirect generate-node ( vop -- )
-    drop [ swap load-indirect ] %literal ;
-
-M: %peek generate-node ( vop -- )
-    drop 0 output-operand 0 input loc>operand LWZ ;
-
-M: %replace generate-node ( vop -- )
-    drop 0 input-operand 0 output loc>operand STW ;
-
-M: %inc-d generate-node ( vop -- )
-    drop 14 14 0 input cells ADDI ;
-
-M: %inc-r generate-node ( vop -- )
-    drop 15 15 0 input cells ADDI ;
diff --git a/library/compiler/stack.factor b/library/compiler/stack.factor
deleted file mode 100644
index 2cfc2e5e8d..0000000000
--- a/library/compiler/stack.factor
+++ /dev/null
@@ -1,47 +0,0 @@
-! Copyright (C) 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler
-USING: arrays generic inference io kernel math
-namespaces prettyprint sequences vectors words ;
-
-: immediate? ( obj -- ? ) dup fixnum? swap not or ;
-
-: load-literal ( obj dest -- )
-    over immediate? [ %immediate ] [ %indirect ] if , ;
-
-: phantom-shuffle-input ( n phantom -- seq )
-    2dup length <= [
-        cut-phantom
-    ] [
-        [ phantom-locs ] keep [ length swap head-slice* ] keep
-        [ append 0 ] keep set-length
-    ] if ;
-
-: phantom-shuffle-inputs ( shuffle -- locs locs )
-    dup shuffle-in-d length phantom-d get phantom-shuffle-input
-    swap shuffle-in-r length phantom-r get phantom-shuffle-input ;
-
-: adjust-shuffle ( shuffle -- )
-    dup shuffle-in-d length neg phantom-d get adjust-phantom
-    shuffle-in-r length neg phantom-r get adjust-phantom ;
-
-: shuffle-vregs# ( shuffle -- n )
-    dup shuffle-in-d swap shuffle-in-r additional-vregs# ;
-
-: phantom-shuffle ( shuffle -- )
-    dup shuffle-vregs# ensure-vregs
-    [ phantom-shuffle-inputs ] keep
-    [ shuffle* ] keep adjust-shuffle
-    (template-outputs) ;
-
-M: #shuffle linearize* ( #shuffle -- )
-    node-shuffle phantom-shuffle iterate-next ;
-
-: linearize-push ( node -- )
-    >#push< dup length dup ensure-vregs
-    alloc-reg# [ <vreg> ] map
-    [ [ load-literal ] 2each ] keep
-    phantom-d get phantom-append ;
-
-M: #push linearize* ( #push -- )
-    linearize-push iterate-next ;
diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index 7ce0b760dd..1c934b7bf9 100644
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -34,7 +34,7 @@ GENERIC: <loc> ( n stack -- loc )
     #! instruction here.
     swap [
         phantom-stack-height
-        dup zero? [ 2drop ] [ swap execute , ] if
+        dup zero? [ 2drop ] [ swap execute ] if
         0
     ] keep set-phantom-stack-height ; inline
 
@@ -89,7 +89,7 @@ SYMBOL: phantom-r
 : alloc-reg ( -- n ) free-vregs get pop ;
 
 : stack>vreg ( vreg# loc -- operand )
-    >r <vreg> dup r> %peek , ;
+    >r <vreg> dup r> %peek ;
 
 : stack>new-vreg ( loc -- vreg )
     alloc-reg swap stack>vreg ;
@@ -98,7 +98,7 @@ SYMBOL: phantom-r
     over loc? [
         2drop
     ] [
-        over [ %replace , ] [ 2drop ] if
+        over [ %replace ] [ 2drop ] if
     ] if ;
 
 : vregs>stack ( phantom -- )
@@ -257,3 +257,5 @@ SYMBOL: +clobber
 : with-template ( quot spec -- )
     fix-spec [ template-inputs call template-outputs ] bind
     compute-free-vregs ; inline
+
+: operand ( var -- op ) get v>operand ; inline
diff --git a/library/compiler/vops.factor b/library/compiler/vops.factor
deleted file mode 100644
index 129b90b096..0000000000
--- a/library/compiler/vops.factor
+++ /dev/null
@@ -1,340 +0,0 @@
-! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler
-USING: arrays errors generic hashtables kernel kernel-internals
-lists math memory namespaces parser sequences words ;
-
-! The linear IR is the second of the two intermediate
-! representations used by Factor. It is basically a high-level
-! assembly language. Linear IR operations are called VOPs.
-
-! This file defines all the types of VOPs. A linear IR program
-! is then just a list of VOPs.
-
-: <label> ( -- label )
-    #! Make a label.
-    gensym  dup t "label" set-word-prop ;
-
-: label? ( obj -- ? )
-    dup word? [ "label" word-prop ] [ drop f ] if ;
-
-! A virtual register
-TUPLE: vreg n ;
-
-! Register classes
-TUPLE: int-regs ;
-TUPLE: float-regs size ;
-
-! A pseudo-register class for parameters spilled on the stack
-TUPLE: stack-params ;
-
-GENERIC: return-reg ( register-class -- reg )
-
-GENERIC: fastcall-regs ( register-class -- regs )
-
-M: stack-params fastcall-regs drop 0 ;
-
-GENERIC: reg-size ( register-class -- n )
-
-GENERIC: inc-reg-class ( register-class -- )
-
-M: int-regs reg-size drop cell ;
-
-: (inc-reg-class)
-    dup class inc
-    macosx? [ reg-size stack-params +@ ] [ drop ] if ;
-
-M: int-regs inc-reg-class
-    (inc-reg-class) ;
-
-M: float-regs reg-size float-regs-size ;
-
-M: float-regs inc-reg-class
-    dup (inc-reg-class)
-    macosx? [ reg-size 4 / int-regs +@ ] [ drop ] if ;
-
-GENERIC: v>operand
-
-M: integer v>operand tag-bits shift ;
-
-M: vreg v>operand vreg-n vregs nth ;
-
-M: f v>operand address ;
-
-! A virtual operation
-TUPLE: vop inputs outputs label ;
-
-: (scratch)
-    vop get dup vop-inputs swap vop-outputs append
-    [ vreg? ] subset [ v>operand ] map vregs diff ;
-
-: scratch ( n -- reg )
-    #! Output a scratch register that is not used by the
-    #! current VOP.
-    \ scratch get nth ;
-
-: with-vop ( vop quot -- )
-    swap vop set (scratch) \ scratch set call ; inline
-
-: input ( n -- obj ) vop get vop-inputs nth ;
-: input-operand ( n -- n ) input v>operand ;
-: output ( n -- obj ) vop get vop-outputs nth ;
-: output-operand ( n -- n ) output v>operand ;
-: label ( -- label ) vop get vop-label ;
-
-: make-vop ( inputs outputs label vop -- vop )
-    [ >r <vop> r> set-delegate ] keep ;
-
-: empty-vop f f f ;
-: label-vop ( label) >r f f r> ;
-: label/src-vop ( label src) 1array swap f swap ;
-: src-vop ( src) 1array f f ;
-: dest-vop ( dest) 1array dup f ;
-: src/dest-vop ( src dest) >r 1array r> 1array f ;
-: 2-in-vop ( in1 in2) 2array f f ;
-: 3-in-vop ( in1 in2 in3) 3array f f ;
-: 2-in/label-vop ( in1 in2 label) >r 2array f r> ;
-: 2-vop ( in dest) [ 2array ] keep 1array f ;
-: 3-vop ( in1 in2 dest) >r 2array r> 1array f ;
-
-! miscellanea
-TUPLE: %prologue ;
-C: %prologue make-vop ;
-: %prologue src-vop <%prologue> ;
-
-TUPLE: %label ;
-C: %label make-vop ;
-: %label label-vop <%label> ;
-
-TUPLE: %return ;
-C: %return make-vop ;
-: %return empty-vop <%return> ;
-
-TUPLE: %jump ;
-C: %jump make-vop ;
-: %jump label-vop <%jump> ;
-
-TUPLE: %jump-label ;
-C: %jump-label make-vop ;
-: %jump-label label-vop <%jump-label> ;
-
-TUPLE: %call ;
-C: %call make-vop ;
-: %call label-vop <%call> ;
-
-TUPLE: %jump-t ;
-C: %jump-t make-vop ;
-: %jump-t label/src-vop <%jump-t> ;
-
-! dispatch tables
-TUPLE: %dispatch ;
-C: %dispatch make-vop ;
-: %dispatch src-vop <%dispatch> ;
-
-TUPLE: %target-label ;
-C: %target-label make-vop ;
-: %target-label label-vop <%target-label> ;
-
-! stack operations
-TUPLE: %peek ;
-C: %peek make-vop ;
-: %peek swap src/dest-vop <%peek> ;
-
-TUPLE: %replace ;
-C: %replace make-vop ;
-: %replace ( vreg loc -- vop ) src/dest-vop <%replace> ;
-
-TUPLE: %inc-d ;
-C: %inc-d make-vop ;
-: %inc-d ( n -- node ) src-vop <%inc-d> ;
-
-TUPLE: %inc-r ;
-C: %inc-r make-vop ;
-: %inc-r ( n -- ) src-vop <%inc-r> ;
-
-TUPLE: %immediate ;
-C: %immediate make-vop ;
-
-: %immediate ( obj vreg -- vop )
-    src/dest-vop <%immediate> ;
-
-! indirect load of a literal through a table
-TUPLE: %indirect ;
-C: %indirect make-vop ;
-: %indirect ( obj vreg -- )
-    src/dest-vop <%indirect> ;
-
-! object slot accessors
-TUPLE: %untag ;
-C: %untag make-vop ;
-: %untag dest-vop <%untag> ;
-
-TUPLE: %slot ;
-C: %slot make-vop ;
-: %slot ( n vreg ) 2-vop <%slot> ;
-
-: set-slot-vop
-    [ 3array ] keep 1array f ;
-
-TUPLE: %set-slot ;
-C: %set-slot make-vop ;
-
-: %set-slot ( value obj n )
-    #! %set-slot writes to vreg obj.
-    set-slot-vop <%set-slot> ;
-
-! in the 'fast' versions, the object's type and slot number is
-! known at compile time, so these become a single instruction
-TUPLE: %fast-slot ;
-C: %fast-slot make-vop ;
-: %fast-slot ( n vreg )
-    2-vop <%fast-slot> ;
-
-TUPLE: %fast-set-slot ;
-C: %fast-set-slot make-vop ;
-: %fast-set-slot ( value obj n )
-    #! %fast-set-slot writes to vreg obj.
-    over >r 3array r> 1array f <%fast-set-slot> ;
-
-! Char readers and writers
-TUPLE: %char-slot ;
-C: %char-slot make-vop ;
-: %char-slot ( n vreg ) 2-vop <%char-slot> ;
-
-TUPLE: %set-char-slot ;
-C: %set-char-slot make-vop ;
-
-: %set-char-slot ( value ch n )
-    #! %set-char-slot writes to vreg obj.
-    set-slot-vop <%set-char-slot> ;
-
-TUPLE: %write-barrier ;
-C: %write-barrier make-vop ;
-: %write-barrier ( ptr ) dest-vop <%write-barrier> ;
-
-! fixnum intrinsics
-TUPLE: %fixnum+ ;
-C: %fixnum+ make-vop ;       : %fixnum+ 3-vop <%fixnum+> ;
-TUPLE: %fixnum+fast ;
-C: %fixnum+fast make-vop ;   : %fixnum+fast 3-vop <%fixnum+fast> ;
-TUPLE: %fixnum- ;
-C: %fixnum- make-vop ;       : %fixnum- 3-vop <%fixnum-> ;
-TUPLE: %fixnum-fast ;
-C: %fixnum-fast make-vop ;   : %fixnum-fast 3-vop <%fixnum-fast> ;
-TUPLE: %fixnum* ;
-C: %fixnum* make-vop ;       : %fixnum* 3-vop <%fixnum*> ;
-TUPLE: %fixnum-mod ;
-C: %fixnum-mod make-vop ;    : %fixnum-mod 3-vop <%fixnum-mod> ;
-TUPLE: %fixnum/i ;
-C: %fixnum/i make-vop ;      : %fixnum/i 3-vop <%fixnum/i> ;
-TUPLE: %fixnum/mod ;
-C: %fixnum/mod make-vop ;    : %fixnum/mod f <%fixnum/mod> ;
-
-TUPLE: %fixnum-bitand ;
-C: %fixnum-bitand make-vop ; : %fixnum-bitand 3-vop <%fixnum-bitand> ;
-
-TUPLE: %fixnum-bitor ;
-C: %fixnum-bitor make-vop ;  : %fixnum-bitor 3-vop <%fixnum-bitor> ;
-
-TUPLE: %fixnum-bitxor ;
-C: %fixnum-bitxor make-vop ; : %fixnum-bitxor 3-vop <%fixnum-bitxor> ;
-
-TUPLE: %fixnum-bitnot ;
-C: %fixnum-bitnot make-vop ; : %fixnum-bitnot 2-vop <%fixnum-bitnot> ;
-
-! At the VOP level, the 'shift' operation is split into four
-! distinct operations:
-! - shifts with a positive count: calls runtime to make
-!   a bignum
-! - shifts with a small negative count: %fixnum>>
-! - shifts with a small negative count: %fixnum>>
-! - shifts with a large negative count: %fixnum-sgn
-TUPLE: %fixnum>> ;
-C: %fixnum>> make-vop ;   : %fixnum>>   3-vop <%fixnum>>> ;
-
-! due to x86 limitations the destination of this VOP must be
-! vreg 2 (EDX), and the source must be vreg 0 (EAX).
-TUPLE: %fixnum-sgn ;
-C: %fixnum-sgn make-vop ; : %fixnum-sgn src/dest-vop <%fixnum-sgn> ;
-
-! Integer comparison followed by a conditional branch is
-! optimized
-TUPLE: %jump-fixnum<= ;
-C: %jump-fixnum<= make-vop ;
-: %jump-fixnum<= 2-in/label-vop <%jump-fixnum<=> ;
-
-TUPLE: %jump-fixnum< ;
-C: %jump-fixnum< make-vop ; 
-: %jump-fixnum< 2-in/label-vop <%jump-fixnum<> ;
-
-TUPLE: %jump-fixnum>= ;
-C: %jump-fixnum>= make-vop ;
-: %jump-fixnum>= 2-in/label-vop <%jump-fixnum>=> ;
-
-TUPLE: %jump-fixnum> ;
-C: %jump-fixnum> make-vop ; 
-: %jump-fixnum> 2-in/label-vop <%jump-fixnum>> ;
-
-TUPLE: %jump-eq? ;
-C: %jump-eq? make-vop ;     
-: %jump-eq? 2-in/label-vop <%jump-eq?> ;
-
-! some slightly optimized inline assembly
-TUPLE: %type ;
-C: %type make-vop ;
-: %type ( vreg ) dest-vop <%type> ;
-
-TUPLE: %tag ;
-C: %tag make-vop ;
-: %tag ( vreg ) dest-vop <%tag> ;
-
-TUPLE: %getenv ;
-C: %getenv make-vop ;
-: %getenv src/dest-vop <%getenv> ;
-
-TUPLE: %setenv ;
-C: %setenv make-vop ;
-: %setenv 2-in-vop <%setenv> ;
-
-TUPLE: %stack>freg ;
-C: %stack>freg make-vop ;
-: %stack>freg ( n reg reg-class -- vop ) 3-in-vop <%stack>freg> ;
-
-TUPLE: %freg>stack ;
-C: %freg>stack make-vop ;
-: %freg>stack ( n reg reg-class -- vop ) 3-in-vop <%freg>stack> ;
-
-TUPLE: %cleanup ;
-C: %cleanup make-vop ;
-: %cleanup ( n -- vop ) src-vop <%cleanup> ;
-
-TUPLE: %unbox ;
-C: %unbox make-vop ;
-: %unbox ( n reg-class func -- vop ) 3-in-vop <%unbox> ;
-
-TUPLE: %unbox-struct ;
-C: %unbox-struct make-vop ;
-: %unbox-struct ( n reg-class size -- vop )
-    3-in-vop <%unbox-struct> ;
-
-TUPLE: %box ;
-C: %box make-vop ;
-: %box ( n reg-class func -- vop ) 3-in-vop <%box> ;
-
-TUPLE: %box-struct ;
-C: %box-struct make-vop ;
-: %box-struct ( n reg-class size -- vop )
-    3-in-vop <%box-struct> ;
-
-TUPLE: %alien-invoke ;
-C: %alien-invoke make-vop ;
-: %alien-invoke ( func lib -- vop ) 2-in-vop <%alien-invoke> ;
-
-TUPLE: %alien-callback ;
-C: %alien-callback make-vop ;
-: %alien-callback ( quot -- vop ) src-vop <%alien-callback> ;
-
-TUPLE: %callback-value ;
-C: %callback-value make-vop ;
-: %callback-value ( reg-class func -- vop )
-    2-in-vop <%callback-value> ;
diff --git a/library/compiler/x86/architecture.factor b/library/compiler/x86/architecture.factor
index a3eb4024f9..5f857fd0d1 100644
--- a/library/compiler/x86/architecture.factor
+++ b/library/compiler/x86/architecture.factor
@@ -7,10 +7,6 @@ sequences words ;
 ! ESI datastack
 ! EBX callstack
 
-: fixnum-imm? ( -- ? )
-    #! Can fixnum operations take immediate operands?
-    t ; inline
-
 : ds-reg ESI ; inline
 : cs-reg EBX ; inline
 : remainder-reg EDX ; inline
diff --git a/library/compiler/xt.factor b/library/compiler/xt.factor
index f6b92b144e..b8baa0e517 100644
--- a/library/compiler/xt.factor
+++ b/library/compiler/xt.factor
@@ -5,6 +5,13 @@ USING: assembler errors generic hashtables kernel
 kernel-internals lists math namespaces prettyprint sequences
 strings vectors words ;
 
+: <label> ( -- label )
+    #! Make a label.
+    gensym  dup t "label" set-word-prop ;
+
+: label? ( obj -- ? )
+    dup word? [ "label" word-prop ] [ drop f ] if ;
+
 ! We use a hashtable "compiled-xts" that maps words to
 ! xt's that are currently being compiled. The commit-xt's word
 ! sets the xt of each word in the hashtable to the value in the
@@ -170,7 +177,6 @@ SYMBOL: compile-words
     #! added to the list of words to be compiled.
     dup compiled?
     over label? or
-    over linearized get ?hash or
     over compile-words get member? or
     swap compiled-xts get hash or ;
 
diff --git a/library/test/compiler/ifte.factor b/library/test/compiler/ifte.factor
index 065195208b..3249a08fc1 100644
--- a/library/test/compiler/ifte.factor
+++ b/library/test/compiler/ifte.factor
@@ -96,6 +96,7 @@ DEFER: countdown-b
 [ 3 ] [ f dummy-unless-3 ] unit-test
 [ 4 ] [ 4 dummy-unless-3 ] unit-test
 
+! Test cond expansion
 [ "even" ] [
     [
         2 {
diff --git a/library/test/compiler/intrinsics.factor b/library/test/compiler/intrinsics.factor
index a24d9bc4a4..24d2ed20a2 100644
--- a/library/test/compiler/intrinsics.factor
+++ b/library/test/compiler/intrinsics.factor
@@ -64,48 +64,54 @@ math-internals sequences strings test words ;
 [ 11 ] [ 12 [ 7 fixnum-bitxor ] compile-1 ] unit-test
 [ 11 ] [ [ 12 7 fixnum-bitxor ] compile-1 ] unit-test
 
-[ f ] [ 12 7 [ fixnum< ] compile-1 ] unit-test
-[ f ] [ 12 [ 7 fixnum< ] compile-1 ] unit-test
-[ f ] [ [ 12 7 fixnum< ] compile-1 ] unit-test
-[ f ] [ [ 12 12 fixnum< ] compile-1 ] unit-test
+[ f ] [ 12 7 [ fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 12 [ 7 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 12 7 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 12 12 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 12 12 [ fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
 
-[ t ] [ 12 70 [ fixnum< ] compile-1 ] unit-test
-[ t ] [ 12 [ 70 fixnum< ] compile-1 ] unit-test
-[ t ] [ [ 12 70 fixnum< ] compile-1 ] unit-test
+[ t ] [ 12 70 [ fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 12 [ 70 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 12 70 fixnum< [ t ] [ f ] if ] compile-1 ] unit-test
 
-[ f ] [ 12 7 [ fixnum<= ] compile-1 ] unit-test
-[ f ] [ 12 [ 7 fixnum<= ] compile-1 ] unit-test
-[ f ] [ [ 12 7 fixnum<= ] compile-1 ] unit-test
-[ t ] [ [ 12 12 fixnum<= ] compile-1 ] unit-test
+[ f ] [ 12 7 [ fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 12 [ 7 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 12 7 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 12 12 [ fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
 
-[ t ] [ 12 70 [ fixnum<= ] compile-1 ] unit-test
-[ t ] [ 12 [ 70 fixnum<= ] compile-1 ] unit-test
-[ t ] [ [ 12 70 fixnum<= ] compile-1 ] unit-test
+[ t ] [ 12 70 [ fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 12 [ 70 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 12 70 fixnum<= [ t ] [ f ] if ] compile-1 ] unit-test
 
-[ t ] [ 12 7 [ fixnum> ] compile-1 ] unit-test
-[ t ] [ 12 [ 7 fixnum> ] compile-1 ] unit-test
-[ t ] [ [ 12 7 fixnum> ] compile-1 ] unit-test
-[ f ] [ [ 12 12 fixnum> ] compile-1 ] unit-test
+[ t ] [ 12 7 [ fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 12 [ 7 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 12 7 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 12 12 [ fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
 
-[ f ] [ 12 70 [ fixnum> ] compile-1 ] unit-test
-[ f ] [ 12 [ 70 fixnum> ] compile-1 ] unit-test
-[ f ] [ [ 12 70 fixnum> ] compile-1 ] unit-test
+[ f ] [ 12 70 [ fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 12 [ 70 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 12 70 fixnum> [ t ] [ f ] if ] compile-1 ] unit-test
 
-[ t ] [ 12 7 [ fixnum>= ] compile-1 ] unit-test
-[ t ] [ 12 [ 7 fixnum>= ] compile-1 ] unit-test
-[ t ] [ [ 12 7 fixnum>= ] compile-1 ] unit-test
-[ t ] [ [ 12 12 fixnum>= ] compile-1 ] unit-test
+[ t ] [ 12 7 [ fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 12 [ 7 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 12 7 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 12 12 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 12 12 [ fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
 
-[ f ] [ 12 70 [ fixnum>= ] compile-1 ] unit-test
-[ f ] [ 12 [ 70 fixnum>= ] compile-1 ] unit-test
-[ f ] [ [ 12 70 fixnum>= ] compile-1 ] unit-test
+[ f ] [ 12 70 [ fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 12 [ 70 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 12 70 fixnum>= [ t ] [ f ] if ] compile-1 ] unit-test
 
-[ f ] [ 1 2 [ eq? ] compile-1 ] unit-test
-[ f ] [ 1 [ 2 eq? ] compile-1 ] unit-test
-[ f ] [ [ 1 2 eq? ] compile-1 ] unit-test
-[ t ] [ 3 3 [ eq? ] compile-1 ] unit-test
-[ t ] [ 3 [ 3 eq? ] compile-1 ] unit-test
-[ t ] [ [ 3 3 eq? ] compile-1 ] unit-test
+[ f ] [ 1 2 [ eq? [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ 1 [ 2 eq? [ t ] [ f ] if ] compile-1 ] unit-test
+[ f ] [ [ 1 2 eq? [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 3 3 [ eq? [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ 3 [ 3 eq? [ t ] [ f ] if ] compile-1 ] unit-test
+[ t ] [ [ 3 3 eq? [ t ] [ f ] if ] compile-1 ] unit-test
 
 [ -1 ] [ 0 [ fixnum-bitnot ] compile-1 ] unit-test
 [ -1 ] [ [ 0 fixnum-bitnot ] compile-1 ] unit-test
diff --git a/library/test/compiler/linearizer.factor b/library/test/compiler/linearizer.factor
deleted file mode 100644
index 42cdaf0d4a..0000000000
--- a/library/test/compiler/linearizer.factor
+++ /dev/null
@@ -1,15 +0,0 @@
-IN: temporary
-USE: test
-USE: kernel
-USE: compiler
-USE: inference
-USE: words
-USE: sequences
-
-: fie [ ] [ ] if ;
-
-[ ] [ \ fie dup word-def dataflow linearize drop ] unit-test
-
-: foo all-words [ drop ] each ;
-
-[ ] [ \ foo dup word-def dataflow linearize drop ] unit-test
diff --git a/library/test/compiler/simple.factor b/library/test/compiler/simple.factor
index 059ce97a8e..0ee94dd17c 100644
--- a/library/test/compiler/simple.factor
+++ b/library/test/compiler/simple.factor
@@ -42,3 +42,8 @@ full-gc
 : foo dup [ dup [ ] [ ] if drop ] [ drop ] if ; compiled
 
 [ 10 ] [ 10 2 foo ] unit-test
+
+: foox dup [ foox ] when ; inline
+: bar foox ;
+
+[ ] [ \ bar compile ] unit-test
diff --git a/library/test/test.factor b/library/test/test.factor
index 9e6c67657e..b579bb0e0c 100644
--- a/library/test/test.factor
+++ b/library/test/test.factor
@@ -104,7 +104,7 @@ SYMBOL: failures
         "compiler/simple" "compiler/templates"
         "compiler/stack" "compiler/ifte"
         "compiler/generic" "compiler/bail-out"
-        "compiler/linearizer" "compiler/intrinsics"
+        "compiler/intrinsics"
         "compiler/identities" "compiler/optimizer"
         "compiler/alien" "compiler/callbacks"
     } run-tests ;

From 451bfb391546899c40a66ddf0898b45c4927cccb Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Fri, 28 Apr 2006 22:48:48 +0000
Subject: [PATCH 059/112] Move some files around

---
 library/bootstrap/boot-stage1.factor          | 72 +++++++++----------
 .../alien/alien-callback.factor               |  0
 .../{ => compiler}/alien/alien-callback.facts |  0
 .../{ => compiler}/alien/alien-invoke.factor  |  0
 .../{ => compiler}/alien/alien-invoke.facts   |  0
 library/{ => compiler}/alien/aliens.factor    |  0
 library/{ => compiler}/alien/aliens.facts     |  0
 library/{ => compiler}/alien/c-types.factor   |  0
 library/{ => compiler}/alien/c-types.facts    |  0
 library/{ => compiler}/alien/compiler.factor  |  0
 library/{ => compiler}/alien/malloc.factor    |  0
 library/{ => compiler}/alien/malloc.facts     |  0
 .../alien/primitive-types.factor              |  0
 library/{ => compiler}/alien/structs.factor   |  0
 library/{ => compiler}/alien/structs.facts    |  0
 library/{ => compiler}/alien/syntax.factor    |  0
 library/{ => compiler}/alien/syntax.facts     |  0
 .../{ => generator}/architecture.factor       |  0
 .../compiler/{ => generator}/assembler.factor |  0
 .../compiler/{ => generator}/generator.factor |  0
 .../compiler/{ => generator}/templates.factor |  0
 library/compiler/{ => generator}/xt.factor    |  0
 .../{ => compiler}/inference/branches.factor  |  0
 .../{ => compiler}/inference/dataflow.factor  |  0
 .../{ => compiler}/inference/inference.factor |  0
 .../{ => compiler}/inference/inference.facts  |  0
 .../inference/known-words.factor              |  0
 .../{ => compiler}/inference/shuffle.factor   |  0
 library/{ => compiler}/inference/stack.factor |  0
 library/{ => compiler}/inference/words.factor |  0
 .../optimizer}/call-optimizers.factor         |  0
 .../optimizer}/class-infer.factor             |  0
 .../optimizer}/inline-methods.factor          |  0
 .../optimizer}/kill-literals.factor           |  0
 .../optimizer}/optimizer.factor               |  0
 .../optimizer}/print-dataflow.factor          |  0
 36 files changed, 35 insertions(+), 37 deletions(-)
 rename library/{ => compiler}/alien/alien-callback.factor (100%)
 rename library/{ => compiler}/alien/alien-callback.facts (100%)
 rename library/{ => compiler}/alien/alien-invoke.factor (100%)
 rename library/{ => compiler}/alien/alien-invoke.facts (100%)
 rename library/{ => compiler}/alien/aliens.factor (100%)
 rename library/{ => compiler}/alien/aliens.facts (100%)
 rename library/{ => compiler}/alien/c-types.factor (100%)
 rename library/{ => compiler}/alien/c-types.facts (100%)
 rename library/{ => compiler}/alien/compiler.factor (100%)
 rename library/{ => compiler}/alien/malloc.factor (100%)
 rename library/{ => compiler}/alien/malloc.facts (100%)
 rename library/{ => compiler}/alien/primitive-types.factor (100%)
 rename library/{ => compiler}/alien/structs.factor (100%)
 rename library/{ => compiler}/alien/structs.facts (100%)
 rename library/{ => compiler}/alien/syntax.factor (100%)
 rename library/{ => compiler}/alien/syntax.facts (100%)
 rename library/compiler/{ => generator}/architecture.factor (100%)
 rename library/compiler/{ => generator}/assembler.factor (100%)
 rename library/compiler/{ => generator}/generator.factor (100%)
 rename library/compiler/{ => generator}/templates.factor (100%)
 rename library/compiler/{ => generator}/xt.factor (100%)
 rename library/{ => compiler}/inference/branches.factor (100%)
 rename library/{ => compiler}/inference/dataflow.factor (100%)
 rename library/{ => compiler}/inference/inference.factor (100%)
 rename library/{ => compiler}/inference/inference.facts (100%)
 rename library/{ => compiler}/inference/known-words.factor (100%)
 rename library/{ => compiler}/inference/shuffle.factor (100%)
 rename library/{ => compiler}/inference/stack.factor (100%)
 rename library/{ => compiler}/inference/words.factor (100%)
 rename library/{inference => compiler/optimizer}/call-optimizers.factor (100%)
 rename library/{inference => compiler/optimizer}/class-infer.factor (100%)
 rename library/{inference => compiler/optimizer}/inline-methods.factor (100%)
 rename library/{inference => compiler/optimizer}/kill-literals.factor (100%)
 rename library/{inference => compiler/optimizer}/optimizer.factor (100%)
 rename library/{inference => compiler/optimizer}/print-dataflow.factor (100%)

diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor
index 6a928e1e21..cc19dac1c2 100644
--- a/library/bootstrap/boot-stage1.factor
+++ b/library/bootstrap/boot-stage1.factor
@@ -77,7 +77,7 @@ vectors words ;
         "/library/generic/math-combination.factor"
         "/library/generic/tuple.factor"
         
-        "/library/alien/aliens.factor"
+        "/library/compiler/alien/aliens.factor"
         
         "/library/syntax/prettyprint.factor"
         "/library/syntax/see.factor"
@@ -111,33 +111,35 @@ vectors words ;
 
         "/library/compiler/architecture.factor"
 
-        "/library/inference/shuffle.factor"
-        "/library/inference/dataflow.factor"
-        "/library/inference/inference.factor"
-        "/library/inference/branches.factor"
-        "/library/inference/words.factor"
-        "/library/inference/class-infer.factor"
-        "/library/inference/kill-literals.factor"
-        "/library/inference/optimizer.factor"
-        "/library/inference/inline-methods.factor"
-        "/library/inference/known-words.factor"
-        "/library/inference/stack.factor"
-        "/library/inference/call-optimizers.factor"
-        "/library/inference/print-dataflow.factor"
+        "/library/compiler/inference/shuffle.factor"
+        "/library/compiler/inference/dataflow.factor"
+        "/library/compiler/inference/inference.factor"
+        "/library/compiler/inference/branches.factor"
+        "/library/compiler/inference/words.factor"
+        "/library/compiler/inference/stack.factor"
+
+        "/library/compiler/optimizer/class-infer.factor"
+        "/library/compiler/optimizer/kill-literals.factor"
+        "/library/compiler/optimizer/optimizer.factor"
+        "/library/compiler/optimizer/inline-methods.factor"
+        "/library/compiler/optimizer/known-words.factor"
+        "/library/compiler/optimizer/call-optimizers.factor"
+        "/library/compiler/optimizer/print-dataflow.factor"
+
+        "/library/compiler/generator/assembler.factor"
+        "/library/compiler/generator/templates.factor"
+        "/library/compiler/generator/xt.factor"
+        "/library/compiler/generator/generator.factor"
 
-        "/library/compiler/assembler.factor"
-        "/library/compiler/templates.factor"
-        "/library/compiler/xt.factor"
-        "/library/compiler/generator.factor"
         "/library/compiler/compiler.factor"
 
-        "/library/alien/malloc.factor"
-        "/library/alien/c-types.factor"
-        "/library/alien/structs.factor"
-        "/library/alien/compiler.factor"
-        "/library/alien/alien-invoke.factor"
-        "/library/alien/alien-callback.factor"
-        "/library/alien/syntax.factor"
+        "/library/compiler/alien/malloc.factor"
+        "/library/compiler/alien/c-types.factor"
+        "/library/compiler/alien/structs.factor"
+        "/library/compiler/alien/compiler.factor"
+        "/library/compiler/alien/alien-invoke.factor"
+        "/library/compiler/alien/alien-callback.factor"
+        "/library/compiler/alien/syntax.factor"
         
         "/library/io/buffer.factor"
 
@@ -189,13 +191,13 @@ vectors words ;
         "/library/kernel.facts"
         "/library/threads.facts"
         "/library/words.facts"
-        "/library/alien/alien-callback.facts"
-        "/library/alien/alien-invoke.facts"
-        "/library/alien/aliens.facts"
-        "/library/alien/c-types.facts"
-        "/library/alien/malloc.facts"
-        "/library/alien/structs.facts"
-        "/library/alien/syntax.facts"
+        "/library/compiler/alien/alien-callback.facts"
+        "/library/compiler/alien/alien-invoke.facts"
+        "/library/compiler/alien/aliens.facts"
+        "/library/compiler/alien/c-types.facts"
+        "/library/compiler/alien/malloc.facts"
+        "/library/compiler/alien/structs.facts"
+        "/library/compiler/alien/syntax.facts"
         "/library/bootstrap/image.facts"
         "/library/collections/growable.facts"
         "/library/collections/arrays.facts"
@@ -293,11 +295,7 @@ vectors words ;
                 {
                     "/library/compiler/ppc/assembler.factor"
                     "/library/compiler/ppc/architecture.factor"
-                    ! "/library/compiler/ppc/generator.factor"
-                    ! "/library/compiler/ppc/slots.factor"
-                    ! "/library/compiler/ppc/stack.factor"
-                    ! "/library/compiler/ppc/fixnum.factor"
-                    ! "/library/compiler/ppc/alien.factor"
+                    "/library/compiler/ppc/intrinsics.factor"
                 }
             ]
         } {
diff --git a/library/alien/alien-callback.factor b/library/compiler/alien/alien-callback.factor
similarity index 100%
rename from library/alien/alien-callback.factor
rename to library/compiler/alien/alien-callback.factor
diff --git a/library/alien/alien-callback.facts b/library/compiler/alien/alien-callback.facts
similarity index 100%
rename from library/alien/alien-callback.facts
rename to library/compiler/alien/alien-callback.facts
diff --git a/library/alien/alien-invoke.factor b/library/compiler/alien/alien-invoke.factor
similarity index 100%
rename from library/alien/alien-invoke.factor
rename to library/compiler/alien/alien-invoke.factor
diff --git a/library/alien/alien-invoke.facts b/library/compiler/alien/alien-invoke.facts
similarity index 100%
rename from library/alien/alien-invoke.facts
rename to library/compiler/alien/alien-invoke.facts
diff --git a/library/alien/aliens.factor b/library/compiler/alien/aliens.factor
similarity index 100%
rename from library/alien/aliens.factor
rename to library/compiler/alien/aliens.factor
diff --git a/library/alien/aliens.facts b/library/compiler/alien/aliens.facts
similarity index 100%
rename from library/alien/aliens.facts
rename to library/compiler/alien/aliens.facts
diff --git a/library/alien/c-types.factor b/library/compiler/alien/c-types.factor
similarity index 100%
rename from library/alien/c-types.factor
rename to library/compiler/alien/c-types.factor
diff --git a/library/alien/c-types.facts b/library/compiler/alien/c-types.facts
similarity index 100%
rename from library/alien/c-types.facts
rename to library/compiler/alien/c-types.facts
diff --git a/library/alien/compiler.factor b/library/compiler/alien/compiler.factor
similarity index 100%
rename from library/alien/compiler.factor
rename to library/compiler/alien/compiler.factor
diff --git a/library/alien/malloc.factor b/library/compiler/alien/malloc.factor
similarity index 100%
rename from library/alien/malloc.factor
rename to library/compiler/alien/malloc.factor
diff --git a/library/alien/malloc.facts b/library/compiler/alien/malloc.facts
similarity index 100%
rename from library/alien/malloc.facts
rename to library/compiler/alien/malloc.facts
diff --git a/library/alien/primitive-types.factor b/library/compiler/alien/primitive-types.factor
similarity index 100%
rename from library/alien/primitive-types.factor
rename to library/compiler/alien/primitive-types.factor
diff --git a/library/alien/structs.factor b/library/compiler/alien/structs.factor
similarity index 100%
rename from library/alien/structs.factor
rename to library/compiler/alien/structs.factor
diff --git a/library/alien/structs.facts b/library/compiler/alien/structs.facts
similarity index 100%
rename from library/alien/structs.facts
rename to library/compiler/alien/structs.facts
diff --git a/library/alien/syntax.factor b/library/compiler/alien/syntax.factor
similarity index 100%
rename from library/alien/syntax.factor
rename to library/compiler/alien/syntax.factor
diff --git a/library/alien/syntax.facts b/library/compiler/alien/syntax.facts
similarity index 100%
rename from library/alien/syntax.facts
rename to library/compiler/alien/syntax.facts
diff --git a/library/compiler/architecture.factor b/library/compiler/generator/architecture.factor
similarity index 100%
rename from library/compiler/architecture.factor
rename to library/compiler/generator/architecture.factor
diff --git a/library/compiler/assembler.factor b/library/compiler/generator/assembler.factor
similarity index 100%
rename from library/compiler/assembler.factor
rename to library/compiler/generator/assembler.factor
diff --git a/library/compiler/generator.factor b/library/compiler/generator/generator.factor
similarity index 100%
rename from library/compiler/generator.factor
rename to library/compiler/generator/generator.factor
diff --git a/library/compiler/templates.factor b/library/compiler/generator/templates.factor
similarity index 100%
rename from library/compiler/templates.factor
rename to library/compiler/generator/templates.factor
diff --git a/library/compiler/xt.factor b/library/compiler/generator/xt.factor
similarity index 100%
rename from library/compiler/xt.factor
rename to library/compiler/generator/xt.factor
diff --git a/library/inference/branches.factor b/library/compiler/inference/branches.factor
similarity index 100%
rename from library/inference/branches.factor
rename to library/compiler/inference/branches.factor
diff --git a/library/inference/dataflow.factor b/library/compiler/inference/dataflow.factor
similarity index 100%
rename from library/inference/dataflow.factor
rename to library/compiler/inference/dataflow.factor
diff --git a/library/inference/inference.factor b/library/compiler/inference/inference.factor
similarity index 100%
rename from library/inference/inference.factor
rename to library/compiler/inference/inference.factor
diff --git a/library/inference/inference.facts b/library/compiler/inference/inference.facts
similarity index 100%
rename from library/inference/inference.facts
rename to library/compiler/inference/inference.facts
diff --git a/library/inference/known-words.factor b/library/compiler/inference/known-words.factor
similarity index 100%
rename from library/inference/known-words.factor
rename to library/compiler/inference/known-words.factor
diff --git a/library/inference/shuffle.factor b/library/compiler/inference/shuffle.factor
similarity index 100%
rename from library/inference/shuffle.factor
rename to library/compiler/inference/shuffle.factor
diff --git a/library/inference/stack.factor b/library/compiler/inference/stack.factor
similarity index 100%
rename from library/inference/stack.factor
rename to library/compiler/inference/stack.factor
diff --git a/library/inference/words.factor b/library/compiler/inference/words.factor
similarity index 100%
rename from library/inference/words.factor
rename to library/compiler/inference/words.factor
diff --git a/library/inference/call-optimizers.factor b/library/compiler/optimizer/call-optimizers.factor
similarity index 100%
rename from library/inference/call-optimizers.factor
rename to library/compiler/optimizer/call-optimizers.factor
diff --git a/library/inference/class-infer.factor b/library/compiler/optimizer/class-infer.factor
similarity index 100%
rename from library/inference/class-infer.factor
rename to library/compiler/optimizer/class-infer.factor
diff --git a/library/inference/inline-methods.factor b/library/compiler/optimizer/inline-methods.factor
similarity index 100%
rename from library/inference/inline-methods.factor
rename to library/compiler/optimizer/inline-methods.factor
diff --git a/library/inference/kill-literals.factor b/library/compiler/optimizer/kill-literals.factor
similarity index 100%
rename from library/inference/kill-literals.factor
rename to library/compiler/optimizer/kill-literals.factor
diff --git a/library/inference/optimizer.factor b/library/compiler/optimizer/optimizer.factor
similarity index 100%
rename from library/inference/optimizer.factor
rename to library/compiler/optimizer/optimizer.factor
diff --git a/library/inference/print-dataflow.factor b/library/compiler/optimizer/print-dataflow.factor
similarity index 100%
rename from library/inference/print-dataflow.factor
rename to library/compiler/optimizer/print-dataflow.factor

From b55d3041abf5d0f3ee13c391758545ef111a373d Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Fri, 28 Apr 2006 23:04:04 +0000
Subject: [PATCH 060/112] Bootstrap fixes

---
 library/bootstrap/boot-stage1.factor        | 21 ++++++++++-----------
 library/bootstrap/boot-stage2.factor        |  2 ++
 library/bootstrap/primitives.factor         |  2 +-
 library/compiler/generator/generator.factor |  8 ++++----
 library/compiler/optimizer/optimizer.factor |  2 +-
 5 files changed, 18 insertions(+), 17 deletions(-)

diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor
index cc19dac1c2..71ae3beaf2 100644
--- a/library/bootstrap/boot-stage1.factor
+++ b/library/bootstrap/boot-stage1.factor
@@ -109,23 +109,22 @@ vectors words ;
         "/library/io/server.factor"
         "/library/tools/jedit.factor"
 
-        "/library/compiler/architecture.factor"
-
         "/library/compiler/inference/shuffle.factor"
         "/library/compiler/inference/dataflow.factor"
         "/library/compiler/inference/inference.factor"
         "/library/compiler/inference/branches.factor"
         "/library/compiler/inference/words.factor"
         "/library/compiler/inference/stack.factor"
+        "/library/compiler/inference/known-words.factor"
 
         "/library/compiler/optimizer/class-infer.factor"
         "/library/compiler/optimizer/kill-literals.factor"
         "/library/compiler/optimizer/optimizer.factor"
         "/library/compiler/optimizer/inline-methods.factor"
-        "/library/compiler/optimizer/known-words.factor"
         "/library/compiler/optimizer/call-optimizers.factor"
         "/library/compiler/optimizer/print-dataflow.factor"
 
+        "/library/compiler/generator/architecture.factor"
         "/library/compiler/generator/assembler.factor"
         "/library/compiler/generator/templates.factor"
         "/library/compiler/generator/xt.factor"
@@ -191,13 +190,6 @@ vectors words ;
         "/library/kernel.facts"
         "/library/threads.facts"
         "/library/words.facts"
-        "/library/compiler/alien/alien-callback.facts"
-        "/library/compiler/alien/alien-invoke.facts"
-        "/library/compiler/alien/aliens.facts"
-        "/library/compiler/alien/c-types.facts"
-        "/library/compiler/alien/malloc.facts"
-        "/library/compiler/alien/structs.facts"
-        "/library/compiler/alien/syntax.facts"
         "/library/bootstrap/image.facts"
         "/library/collections/growable.facts"
         "/library/collections/arrays.facts"
@@ -215,6 +207,14 @@ vectors words ;
         "/library/collections/flatten.facts"
         "/library/collections/vectors.facts"
         "/library/collections/virtual-sequences.facts"
+        "/library/compiler/alien/alien-callback.facts"
+        "/library/compiler/alien/alien-invoke.facts"
+        "/library/compiler/alien/aliens.facts"
+        "/library/compiler/alien/c-types.facts"
+        "/library/compiler/alien/malloc.facts"
+        "/library/compiler/alien/structs.facts"
+        "/library/compiler/alien/syntax.facts"
+        "/library/compiler/inference/inference.facts"
         "/library/compiler/compiler.facts"
         "/library/generic/early-generic.facts"
         "/library/generic/generic.facts"
@@ -222,7 +222,6 @@ vectors words ;
         "/library/generic/slots.facts"
         "/library/generic/standard-combination.facts"
         "/library/generic/tuple.facts"
-        "/library/inference/inference.facts"
         "/library/io/binary.facts"
         "/library/io/buffer.facts"
         "/library/io/c-streams.facts"
diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor
index ba1de70cb3..2e315e9599 100644
--- a/library/bootstrap/boot-stage2.factor
+++ b/library/bootstrap/boot-stage2.factor
@@ -23,6 +23,8 @@ H{ } clone help-graph set-global xref-articles
 
     "Compiling base..." print flush
 
+    \ + compile
+    \ = compile
     { "kernel" "sequences" "assembler" } compile-vocabs
 
     "Compiling system..." print flush
diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor
index fee3cec058..26a9491e4a 100644
--- a/library/bootstrap/primitives.factor
+++ b/library/bootstrap/primitives.factor
@@ -11,7 +11,7 @@ vectors words ;
 "Creating primitives and basic runtime structures..." print flush
 
 H{ } clone c-types set
-"/library/alien/primitive-types.factor" parse-resource
+"/library/compiler/alien/primitive-types.factor" parse-resource
 
 ! These symbols need the same hashcode in the target as in the
 ! host.
diff --git a/library/compiler/generator/generator.factor b/library/compiler/generator/generator.factor
index 0d3b2862a9..98616c2b08 100644
--- a/library/compiler/generator/generator.factor
+++ b/library/compiler/generator/generator.factor
@@ -12,6 +12,10 @@ M: object stack-reserve* drop 0 ;
 : stack-reserve ( node -- n )
     0 swap [ stack-reserve* max ] each-node ;
 
+: if-intrinsic ( #call -- quot )
+    dup node-successor #if?
+    [ node-param "if-intrinsic" word-prop ] [ drop f ] if ;
+
 DEFER: #terminal?
 
 PREDICATE: #merge #terminal-merge node-successor #terminal? ;
@@ -130,10 +134,6 @@ M: #if generate-node ( node -- next )
 : define-if-intrinsic ( word quot template -- | quot: label -- )
     [with-template] "if-intrinsic" set-word-prop ;
 
-: if-intrinsic ( #call -- quot )
-    dup node-successor #if?
-    [ node-param "if-intrinsic" word-prop ] [ drop f ] if ;
-
 M: #call generate-node ( node -- next )
     dup if-intrinsic [
         >r <label> dup r> call
diff --git a/library/compiler/optimizer/optimizer.factor b/library/compiler/optimizer/optimizer.factor
index ae4cc58a82..4affecae6d 100644
--- a/library/compiler/optimizer/optimizer.factor
+++ b/library/compiler/optimizer/optimizer.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: optimizer
-USING: compiler generic hashtables inference io kernel
+USING: generic hashtables inference io kernel
 lists math namespaces sequences vectors ;
 
 SYMBOL: optimizer-changed

From 906fea6508a48846a0ddd0c07c5687a55a32f218 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Fri, 28 Apr 2006 23:23:50 +0000
Subject: [PATCH 061/112] Updating x86 backend for new changes

---
 library/bootstrap/boot-stage1.factor          |  5 +-
 .../compiler/generator/architecture.factor    |  5 +-
 library/compiler/ppc/architecture.factor      |  8 +-
 library/compiler/x86/alien.factor             | 53 +++++------
 library/compiler/x86/architecture.factor      | 65 +++++++++++--
 library/compiler/x86/generator.factor         | 92 ------------------
 .../x86/{fixnum.factor => intrinsics.factor}  | 94 ++++++++++++++++++-
 library/compiler/x86/slots.factor             | 74 ---------------
 library/compiler/x86/stack.factor             | 30 ------
 9 files changed, 184 insertions(+), 242 deletions(-)
 delete mode 100644 library/compiler/x86/generator.factor
 rename library/compiler/x86/{fixnum.factor => intrinsics.factor} (62%)
 delete mode 100644 library/compiler/x86/slots.factor
 delete mode 100644 library/compiler/x86/stack.factor

diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor
index 71ae3beaf2..29f717929a 100644
--- a/library/bootstrap/boot-stage1.factor
+++ b/library/bootstrap/boot-stage1.factor
@@ -282,11 +282,8 @@ vectors words ;
                 {
                     "/library/compiler/x86/assembler.factor"
                     "/library/compiler/x86/architecture.factor"
-                    "/library/compiler/x86/generator.factor"
-                    "/library/compiler/x86/slots.factor"
-                    "/library/compiler/x86/stack.factor"
-                    "/library/compiler/x86/fixnum.factor"
                     "/library/compiler/x86/alien.factor"
+                    "/library/compiler/x86/intrinsics.factor"
                 }
             ]
         } {
diff --git a/library/compiler/generator/architecture.factor b/library/compiler/generator/architecture.factor
index acc122ed6a..0d154b8523 100644
--- a/library/compiler/generator/architecture.factor
+++ b/library/compiler/generator/architecture.factor
@@ -25,7 +25,10 @@ DEFER: vregs ( -- regs )
 G: load-literal ( obj vreg -- ) 1 standard-combination ;
 
 ! Set up caller stack frame (PowerPC and AMD64)
-DEFER: %prologue ( n -- )
+: %prologue ( n -- ) drop ;
+
+! Tear down stack frame (PowerPC and AMD64)
+: %epilogue ( n -- ) drop ;
 
 ! Tail call another word
 DEFER: %jump ( label -- )
diff --git a/library/compiler/ppc/architecture.factor b/library/compiler/ppc/architecture.factor
index 7db7535da3..69e2129627 100644
--- a/library/compiler/ppc/architecture.factor
+++ b/library/compiler/ppc/architecture.factor
@@ -1,3 +1,5 @@
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 IN: compiler
 USING: alien assembler generic kernel kernel-internals math
 memory namespaces sequences words ;
@@ -42,7 +44,7 @@ M: object load-literal ( literal vreg -- )
     0 MFLR
     0 1 stack-increment lr@ STW ;
 
-: compile-epilogue ( -- )
+: %epilogue ( -- )
     #! At the end of each word that calls a subroutine, we store
     #! the previous link register value in r0 by popping it off
     #! the stack, set the link register to the contents of r0,
@@ -65,7 +67,7 @@ M: object load-literal ( literal vreg -- )
     dup primitive? [ word-addr  3 MTCTR  BCTR ] [ B ] if ;
 
 : %jump ( label -- )
-    compile-epilogue dup postpone-word %jump-label ;
+    %epilogue dup postpone-word %jump-label ;
 
 : %jump-t ( label vreg -- )
     0 swap v>operand f address CMPI BNE ;
@@ -80,7 +82,7 @@ M: object load-literal ( literal vreg -- )
     MTLR
     BLR ;
 
-: %return ( -- ) compile-epilogue BLR ;
+: %return ( -- ) %epilogue BLR ;
 
 : %peek ( vreg loc -- ) >r v>operand r> loc>operand LWZ ;
 
diff --git a/library/compiler/x86/alien.factor b/library/compiler/x86/alien.factor
index e57785d625..e3ee5c5492 100644
--- a/library/compiler/x86/alien.factor
+++ b/library/compiler/x86/alien.factor
@@ -1,5 +1,5 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 IN: compiler
 USING: alien arrays assembler inference kernel
 kernel-internals lists math memory namespaces words ;
@@ -30,55 +30,52 @@ M: float-regs load-return-reg
 M: %unbox generate-node
     drop 2 input f compile-c-call  1 input push-return-reg ;
 
-: struct-ptr/size ( func -- )
+: struct-ptr/size ( size func -- )
     ! Load struct size
-    2 input PUSH
+    swap PUSH
     ! Load destination address
     EAX PUSH
     ! Copy the struct to the stack
-    f compile-c-call
+    f %alien-invoke
     ! Clean up
     EAX POP
     ECX POP ;
 
-M: %unbox-struct generate-node ( vop -- )
-    drop
+: %unbox-struct ( n reg-class size -- )
+    2nip
     ! Increase stack size
-    ESP 2 input SUB
+    ESP over SUB
     ! Save destination address in EAX
     EAX ESP MOV
     "unbox_value_struct" struct-ptr/size ;
 
-M: %box-struct generate-node ( vop -- )
+: %box-struct ( n reg-class size -- )
+    2nip
     ! Compute source address in EAX
     EAX ESP MOV
     EAX 4 ADD
-    drop "box_value_struct" struct-ptr/size ;
+    "box_value_struct" struct-ptr/size ;
 
-M: %box generate-node
-    drop
-    0 input [ 4 + 1 input load-return-reg ] when*
-    1 input push-return-reg
-    2 input f compile-c-call
-    1 input drop-return-reg ;
+: %box ( n reg-class func -- )
+    rot [ 4 + pick load-return-reg ] when*
+    over push-return-reg
+    f %alien-invoke
+    drop-return-reg ;
 
-M: %alien-callback generate-node ( vop -- )
-    drop
-    EAX 0 input load-indirect
+: %alien-callback ( quot -- )
+    EAX swap load-literal
     EAX PUSH
-    "run_callback" f compile-c-call
+    "run_callback" f %alien-invoke
     EAX POP ;
 
-M: %callback-value generate-node ( vop -- )
-    drop
+: %callback-value ( reg-class func -- )
     ! Call the unboxer
-    1 input f compile-c-call
+    f %alien-invoke
     ! Save return register
-    0 input push-return-reg
+    dup push-return-reg
     ! Restore data/callstacks
-    "unnest_stacks" f compile-c-call
+    "unnest_stacks" f %alien-invoke
     ! Restore return register
-    0 input pop-return-reg ;
+    dup pop-return-reg ;
 
-M: %cleanup generate-node
-    drop 0 input dup zero? [ drop ] [ ESP swap ADD ] if ;
+: %cleanup ( n -- ) dup zero? [ drop ] [ ESP swap ADD ] if ;
diff --git a/library/compiler/x86/architecture.factor b/library/compiler/x86/architecture.factor
index 5f857fd0d1..e32282ede7 100644
--- a/library/compiler/x86/architecture.factor
+++ b/library/compiler/x86/architecture.factor
@@ -1,6 +1,8 @@
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 IN: compiler
 USING: alien arrays assembler generic kernel kernel-internals
-sequences words ;
+math sequences words ;
 
 ! x86 register assignments
 ! EAX, ECX, EDX vregs
@@ -9,16 +11,22 @@ sequences words ;
 
 : ds-reg ESI ; inline
 : cs-reg EBX ; inline
+: reg-stack ( n reg -- op ) swap cells neg [+] ;
+
+M: ds-loc v>operand ds-loc-n ds-reg reg-stack ;
+
+M: cs-loc v>operand cs-loc-n cs-reg reg-stack ;
+
 : remainder-reg EDX ; inline
 
 : vregs { EAX ECX EDX } ; inline
 
-: compile-c-call ( symbol dll -- )
+: %alien-invoke ( symbol dll -- )
     2dup dlsym CALL rel-relative rel-dlsym ;
 
 : compile-c-call* ( symbol dll args -- operands )
     reverse-slice
-    [ [ PUSH ] each compile-c-call ] keep
+    [ [ PUSH ] each %alien-invoke ] keep
     [ drop EDX POP ] each ;
 
 ! On x86, parameters are never passed in registers.
@@ -36,9 +44,52 @@ M: float-regs fastcall-regs drop { } ;
 
 : prepare-division CDQ ; inline
 
-: compile-prologue ; inline
+M: immediate load-literal ( dest literal -- )
+    address MOV ;
 
-: compile-epilogue ; inline
+M: object load-literal ( dest literal -- )
+    add-literal [] MOV rel-absolute-cell rel-address ;
 
-: load-indirect ( dest literal -- )
-    add-literal [] MOV rel-absolute-cell rel-address ; inline
+: (%call) ( label -- label )
+    dup postpone-word dup primitive? [ address-operand ] when ;
+
+: %call ( label -- ) (%call) CALL ;
+
+: %jump ( label -- ) %epilogue (%call) JMP ;
+
+: %jump-label ( label -- ) JMP ;
+
+: %jump-t ( label vreg -- )
+    v>operand f v>operand CMP JNE ;
+
+: %dispatch ( vreg -- )
+    #! Compile a piece of code that jumps to an offset in a
+    #! jump table indexed by the fixnum at the top of the stack.
+    #! The jump table must immediately follow this macro.
+    drop
+    <label> "end" set
+    ! Untag and multiply to get a jump table offset
+    dup fixnum>slot@
+    ! Add to jump table base. We use a temporary register since
+    ! on AMD4 we have to load a 64-bit immediate. On x86, this
+    ! is redundant.
+    0 scratch HEX: ffffffff MOV "end" get absolute-cell
+    dup 0 scratch ADD
+    ! Jump to jump table entry
+    dup [] JMP
+    ! Align for better performance
+    compile-aligned
+    ! Fix up jump table pointer
+    "end" get save-xt ;
+
+: %return ( -- ) %epilogue RET ;
+
+: %peek ( vreg loc -- ) [ v>operand ] 2apply MOV ;
+
+: %replace ( vreg loc -- ) swap %peek ;
+
+: (%inc) 0 input cells dup 0 > [ ADD ] [ neg SUB ] if ;
+
+: %inc-d ( n -- ) ds-reg (%inc) ;
+
+: %inc-r ( n -- ) cs-reg (%inc) ;
diff --git a/library/compiler/x86/generator.factor b/library/compiler/x86/generator.factor
deleted file mode 100644
index 1d272a03be..0000000000
--- a/library/compiler/x86/generator.factor
+++ /dev/null
@@ -1,92 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
-USING: alien arrays assembler inference kernel
-kernel-internals lists math memory namespaces sequences words ;
-
-! Not used on x86
-M: %prologue generate-node ( vop -- )  drop ;
-
-: (%call)
-    label dup postpone-word
-    dup primitive? [ address-operand ] when ;
-
-M: %call generate-node ( vop -- )
-    drop (%call) CALL ;
-
-M: %jump generate-node ( vop -- )
-    drop compile-epilogue (%call) JMP ;
-
-M: %jump-label generate-node ( vop -- )
-    drop label JMP ;
-
-M: %jump-t generate-node ( vop -- )
-    drop
-    ! Compare input with f
-    0 input-operand f address CMP
-    ! If not equal, jump
-    label JNE ;
-
-M: %return generate-node ( vop -- )
-    drop compile-epilogue RET ;
-
-M: %dispatch generate-node ( vop -- )
-    #! Compile a piece of code that jumps to an offset in a
-    #! jump table indexed by the fixnum at the top of the stack.
-    #! The jump table must immediately follow this macro.
-    drop
-    <label> "end" set
-    ! Untag and multiply to get a jump table offset
-    0 input-operand fixnum>slot@
-    ! Add to jump table base. We use a temporary register since
-    ! on AMD4 we have to load a 64-bit immediate. On x86, this
-    ! is redundant.
-    0 scratch HEX: ffffffff MOV "end" get absolute-cell
-    0 input-operand 0 scratch ADD
-    ! Jump to jump table entry
-    0 input-operand [] JMP
-    ! Align for better performance
-    compile-aligned
-    ! Fix up jump table pointer
-    "end" get save-xt ;
-
-M: %type generate-node ( vop -- )
-    #! Intrinstic version of type primitive.
-    drop
-    <label> "header" set
-    <label> "f" set
-    <label> "end" set
-    ! Make a copy
-    0 scratch 0 output-operand MOV
-    ! Get the tag
-    0 output-operand tag-mask AND
-    ! Compare with object tag number (3).
-    0 output-operand object-tag CMP
-    ! Jump if the object doesn't store type info in its header
-    "header" get JE
-    ! It doesn't store type info in its header
-    0 output-operand tag-bits SHL
-    "end" get JMP
-    "header" get save-xt
-    ! It does store type info in its header
-    ! Is the pointer itself equal to 3? Then its F_TYPE (9).
-    0 scratch object-tag CMP
-    "f" get JE
-    ! The pointer is not equal to 3. Load the object header.
-    0 output-operand 0 scratch object-tag neg [+] MOV
-    ! Mask off header tag, making a fixnum.
-    0 output-operand object-tag XOR
-    "end" get JMP
-    "f" get save-xt
-    ! The pointer is equal to 3. Load F_TYPE (9).
-    0 output-operand f type tag-bits shift MOV
-    "end" get save-xt ;
-
-M: %tag generate-node ( vop -- )
-    drop
-    0 input-operand tag-mask AND
-    0 input-operand tag-bits SHL ;
-
-M: %untag generate-node ( vop -- )
-    drop
-    0 output-operand tag-mask bitnot AND ;
diff --git a/library/compiler/x86/fixnum.factor b/library/compiler/x86/intrinsics.factor
similarity index 62%
rename from library/compiler/x86/fixnum.factor
rename to library/compiler/x86/intrinsics.factor
index 8fee285fe6..2bb78d6c15 100644
--- a/library/compiler/x86/fixnum.factor
+++ b/library/compiler/x86/intrinsics.factor
@@ -1,8 +1,96 @@
-! Copyright (C) 2005 Slava Pestov.
+! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: compiler
-USING: arrays assembler errors kernel kernel-internals
-math math-internals memory namespaces words ;
+
+M: %type generate-node ( vop -- )
+    #! Intrinstic version of type primitive.
+    drop
+    <label> "header" set
+    <label> "f" set
+    <label> "end" set
+    ! Make a copy
+    0 scratch 0 output-operand MOV
+    ! Get the tag
+    0 output-operand tag-mask AND
+    ! Compare with object tag number (3).
+    0 output-operand object-tag CMP
+    ! Jump if the object doesn't store type info in its header
+    "header" get JE
+    ! It doesn't store type info in its header
+    0 output-operand tag-bits SHL
+    "end" get JMP
+    "header" get save-xt
+    ! It does store type info in its header
+    ! Is the pointer itself equal to 3? Then its F_TYPE (9).
+    0 scratch object-tag CMP
+    "f" get JE
+    ! The pointer is not equal to 3. Load the object header.
+    0 output-operand 0 scratch object-tag neg [+] MOV
+    ! Mask off header tag, making a fixnum.
+    0 output-operand object-tag XOR
+    "end" get JMP
+    "f" get save-xt
+    ! The pointer is equal to 3. Load F_TYPE (9).
+    0 output-operand f type tag-bits shift MOV
+    "end" get save-xt ;
+
+M: %tag generate-node ( vop -- )
+    drop
+    0 input-operand tag-mask AND
+    0 input-operand tag-bits SHL ;
+
+M: %untag generate-node ( vop -- )
+    drop
+    0 output-operand tag-mask bitnot AND ;
+
+M: %slot generate-node ( vop -- )
+    drop
+    ! turn tagged fixnum slot # into an offset, multiple of 4
+    0 input-operand fixnum>slot@
+    ! compute slot address
+    dest/src ADD
+    ! load slot value
+    0 output-operand dup [] MOV ;
+
+: card-offset 1 getenv ; inline
+
+M: %write-barrier generate-node ( vop -- )
+    #! Mark the card pointed to by vreg.
+    drop
+    0 input-operand card-bits SHR
+    0 input-operand card-offset ADD rel-absolute-cell rel-cards
+    0 input-operand [] card-mark OR ;
+
+M: %set-slot generate-node ( vop -- )
+    drop
+    ! turn tagged fixnum slot # into an offset
+    2 input-operand fixnum>slot@
+    ! compute slot address
+    2 input-operand 1 input-operand ADD
+    ! store new slot value
+    2 input-operand [] 0 input-operand MOV ;
+
+: >register-16 ( reg -- reg )
+    "register" word-prop { AX CX DX } nth ;
+
+: scratch-16 ( n -- reg ) scratch >register-16 ;
+
+M: %char-slot generate-node ( vop -- )
+    drop
+    0 input-operand 2 SHR
+    0 scratch dup XOR
+    dest/src ADD
+    0 scratch-16 0 output-operand string-offset [+] MOV
+    0 scratch tag-bits SHL
+    0 output-operand 0 scratch MOV ;
+
+M: %set-char-slot generate-node ( vop -- )
+    drop
+    0 input-operand tag-bits SHR
+    2 input-operand 2 SHR
+    2 input-operand 1 input-operand ADD
+    2 input-operand string-offset [+]
+    0 input-operand >register-16 MOV ;
 
 : literal-overflow ( -- dest src )
     #! Called if the src operand is a literal.
diff --git a/library/compiler/x86/slots.factor b/library/compiler/x86/slots.factor
deleted file mode 100644
index d1527bce42..0000000000
--- a/library/compiler/x86/slots.factor
+++ /dev/null
@@ -1,74 +0,0 @@
-! Copyright (C) 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler
-USING: alien arrays assembler inference kernel
-kernel-internals lists math memory namespaces sequences words ;
-
-M: %slot generate-node ( vop -- )
-    drop
-    ! turn tagged fixnum slot # into an offset, multiple of 4
-    0 input-operand fixnum>slot@
-    ! compute slot address
-    dest/src ADD
-    ! load slot value
-    0 output-operand dup [] MOV ;
-
-M: %fast-slot generate-node ( vop -- )
-    drop 0 output-operand 1 input-operand 0 input [+] MOV ;
-
-: card-offset 1 getenv ; inline
-
-M: %write-barrier generate-node ( vop -- )
-    #! Mark the card pointed to by vreg.
-    drop
-    0 input-operand card-bits SHR
-    0 input-operand card-offset ADD rel-absolute-cell rel-cards
-    0 input-operand [] card-mark OR ;
-
-M: %set-slot generate-node ( vop -- )
-    drop
-    ! turn tagged fixnum slot # into an offset
-    2 input-operand fixnum>slot@
-    ! compute slot address
-    2 input-operand 1 input-operand ADD
-    ! store new slot value
-    2 input-operand [] 0 input-operand MOV ;
-
-M: %fast-set-slot generate-node ( vop -- )
-    drop 1 input-operand 2 input [+] 0 input-operand MOV ;
-
-: >register-16 ( reg -- reg )
-    "register" word-prop { AX CX DX } nth ;
-
-: scratch-16 ( n -- reg ) scratch >register-16 ;
-
-M: %char-slot generate-node ( vop -- )
-    drop
-    0 input-operand 2 SHR
-    0 scratch dup XOR
-    dest/src ADD
-    0 scratch-16 0 output-operand string-offset [+] MOV
-    0 scratch tag-bits SHL
-    0 output-operand 0 scratch MOV ;
-
-M: %set-char-slot generate-node ( vop -- )
-    drop
-    0 input-operand tag-bits SHR
-    2 input-operand 2 SHR
-    2 input-operand 1 input-operand ADD
-    2 input-operand string-offset [+]
-    0 input-operand >register-16 MOV ;
-
-: userenv@ ( n -- addr ) cells "userenv" f dlsym + ;
-
-M: %getenv generate-node ( vop -- )
-    drop
-    0 output-operand 0 input userenv@ MOV
-    0 input rel-absolute-cell rel-userenv
-    0 output-operand dup [] MOV ;
-
-M: %setenv generate-node ( vop -- )
-    drop
-    0 scratch 1 input userenv@ MOV
-    1 input rel-absolute-cell rel-userenv
-    0 scratch [] 0 input-operand MOV ;
diff --git a/library/compiler/x86/stack.factor b/library/compiler/x86/stack.factor
deleted file mode 100644
index f40786e3b7..0000000000
--- a/library/compiler/x86/stack.factor
+++ /dev/null
@@ -1,30 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
-USING: alien arrays assembler inference kernel
-kernel-internals lists math memory sequences words ;
-
-: reg-stack ( n reg -- op ) swap cells neg [+] ;
-
-M: ds-loc v>operand ds-loc-n ds-reg reg-stack ;
-
-M: cs-loc v>operand cs-loc-n cs-reg reg-stack ;
-
-M: %peek generate-node ( vop -- )
-    drop 0 output-operand 0 input-operand MOV ;
-
-M: %replace generate-node ( vop -- )
-    drop 0 output-operand 0 input-operand MOV ;
-
-: (%inc) 0 input cells dup 0 > [ ADD ] [ neg SUB ] if ;
-
-M: %inc-d generate-node ( vop -- ) drop ds-reg (%inc) ;
-
-M: %inc-r generate-node ( vop -- ) drop cs-reg (%inc) ;
-
-M: %immediate generate-node ( vop -- )
-    drop 0 output-operand 0 input address MOV ;
-
-M: %indirect generate-node ( vop -- )
-    #! indirect load of a literal through a table
-    drop 0 output-operand 0 input load-indirect ;

From f684243e2f6b352ab6da054de6906592f0e14b44 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sat, 29 Apr 2006 21:13:02 +0000
Subject: [PATCH 062/112] Got scratch registers working; PowerPC backend fully
 operational, x86 in progress

---
 TODO.FACTOR.txt                             |   5 +-
 library/compiler/generator/generator.factor |   8 +-
 library/compiler/generator/templates.factor |  56 ++-
 library/compiler/intrinsics.factor          | 150 --------
 library/compiler/ppc/architecture.factor    |  17 +-
 library/compiler/ppc/intrinsics.factor      | 364 ++++++++++++--------
 library/compiler/x86/architecture.factor    |  17 +-
 7 files changed, 280 insertions(+), 337 deletions(-)
 delete mode 100644 library/compiler/intrinsics.factor

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 6edf8eba78..1df68b8ece 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,8 +1,8 @@
 should fix in 0.82:
 
+- type inference busted for tuple constructors
 - constant branch folding
-- getenv, setenv, fast-slot stuff
-- more flexible fixnum intrinsics
+- fast-slot stuff
 - compile if-intrinsic even if there is no #if there
 - 3 >n fep
 - amd64 %box-struct
@@ -13,7 +13,6 @@ should fix in 0.82:
 - speed up ideas:
   - only do clipping for certain gadgets
   - use glRect
-- cocoa: global menu bar with useful commands
 
 + portability:
 
diff --git a/library/compiler/generator/generator.factor b/library/compiler/generator/generator.factor
index 98616c2b08..1d3e3a66d8 100644
--- a/library/compiler/generator/generator.factor
+++ b/library/compiler/generator/generator.factor
@@ -117,7 +117,7 @@ M: #label generate-node ( node -- next )
 M: #if generate-node ( node -- next )
     [
         end-basic-block
-        <label> dup "flag" get %jump-t
+        <label> dup %jump-t
     ] H{
         { +input { { 0 "flag" } } }
     } with-template generate-if ;
@@ -153,8 +153,10 @@ M: #call-label generate-node ( node -- next )
 : dispatch-head ( node -- label/node )
     #! Output the jump table insn and return a list of
     #! label/branch pairs.
-    [ end-basic-block "n" get %dispatch ]
-    H{ { +input { { 0 "n" } } } } with-template
+    [ end-basic-block %dispatch ] H{
+        { +input { { f "n" } } }
+        { +scratch { { f "scratch" } } }
+    } with-template
     node-children [ <label> dup target-label 2array ] map ;
 
 : dispatch-body ( label/node -- )
diff --git a/library/compiler/generator/templates.factor b/library/compiler/generator/templates.factor
index 1c934b7bf9..144635146f 100644
--- a/library/compiler/generator/templates.factor
+++ b/library/compiler/generator/templates.factor
@@ -4,8 +4,27 @@ IN: compiler
 USING: arrays generic hashtables inference io kernel math
 namespaces prettyprint sequences vectors words ;
 
+! Register allocation
 SYMBOL: free-vregs
 
+: alloc-reg ( -- n )
+    free-vregs get pop ;
+
+: alloc-reg# ( n -- regs )
+    free-vregs [ cut ] change ;
+
+: requested-vregs ( template -- n )
+    0 [ [ 1+ ] unless ] reduce ;
+
+: template-vreg# ( template template -- n )
+    [ requested-vregs ] 2apply + ;
+
+: alloc-vregs ( template -- template )
+    [ first [ alloc-reg ] unless* ] map ;
+
+: adjust-free-vregs ( seq -- )
+    free-vregs [ diff ] change ;
+
 ! A data stack location.
 TUPLE: ds-loc n ;
 
@@ -86,8 +105,6 @@ SYMBOL: phantom-r
 : finalize-heights ( -- )
     phantoms [ finalize-height ] 2apply ;
 
-: alloc-reg ( -- n ) free-vregs get pop ;
-
 : stack>vreg ( vreg# loc -- operand )
     >r <vreg> dup r> %peek ;
 
@@ -143,18 +160,6 @@ SYMBOL: phantom-r
     used-vregs vregs length reverse diff
     >vector free-vregs set ;
 
-: requested-vregs ( template -- n )
-    0 [ [ 1+ ] unless ] reduce ;
-
-: template-vreg# ( template template -- n )
-    [ requested-vregs ] 2apply + ;
-
-: alloc-regs ( template -- template )
-    [ [ alloc-reg ] unless* ] map ;
-
-: alloc-reg# ( n -- regs )
-    free-vregs [ cut ] change ;
-
 : additional-vregs# ( seq seq -- n )
     2array phantoms 2array [ [ length ] map ] 2apply v-
     0 [ 0 max + ] reduce ;
@@ -176,8 +181,7 @@ SYMBOL: phantom-r
 
 : stack>vregs ( phantom template -- values )
     [
-        [ first ] map alloc-regs
-        dup length rot phantom-locs
+        alloc-vregs dup length rot phantom-locs
         [ stack>vreg ] 2map
     ] 2keep length neg swap adjust-phantom ;
 
@@ -226,8 +230,6 @@ SYMBOL: +clobber
         { +clobber { } }
     } swap hash-union ;
 
-: adjust-free-vregs ( seq -- ) free-vregs [ diff ] change ;
-
 : output-vregs ( -- seq seq )
     +output +clobber [ get [ get ] map ] 2apply ;
 
@@ -236,7 +238,11 @@ SYMBOL: +clobber
     [ swap member? ] contains-with? ;
 
 : slow-input ( template -- )
+    ! Are we loading stuff from the stack? Then flush out
+    ! remaining vregs, not slurped in by fast-input.
     dup empty? [ finalize-contents ] unless
+    ! Do the outputs clash with vregs on the phantom stacks?
+    ! Then we must flush them first.
     outputs-clash? [ finalize-contents ] when
     phantom-d get swap [ stack>vregs ] keep phantom-vregs ;
 
@@ -244,11 +250,23 @@ SYMBOL: +clobber
     +input +scratch [ get [ second get vreg-n ] map ] 2apply
     append ;
 
+: guess-vregs ( -- n )
+    +input get dup { } additional-vregs# +scratch get length + ;
+
+: alloc-scratch ( -- )
+    +scratch get [ alloc-vregs [ <vreg> ] map ] keep
+    phantom-vregs ;
+
 : template-inputs ( -- )
-    +input get dup { } additional-vregs# ensure-vregs
+    ! Ensure we have enough to hold any new stack elements we
+    ! will read (if any), and scratch.
+    guess-vregs ensure-vregs
+    ! Split the template into available (fast) parts and those
+    ! that require allocating registers and reading the stack
     match-template fast-input
     used-vregs adjust-free-vregs
     slow-input
+    alloc-scratch
     input-vregs adjust-free-vregs ;
 
 : template-outputs ( -- )
diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
deleted file mode 100644
index 1f53b6d535..0000000000
--- a/library/compiler/intrinsics.factor
+++ /dev/null
@@ -1,150 +0,0 @@
-! Copyright (C) 2005, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler
-USING: arrays assembler generic hashtables
-inference kernel kernel-internals lists math math-internals
-namespaces sequences words ;
-
-\ slot [
-    [
-        "obj" get %untag ,
-        "n" get "obj" get %slot ,
-    ] H{
-        { +input { { f "obj" } { f "n" } } }
-        { +output { "obj" } }
-    } with-template
-] "intrinsic" set-word-prop
-
-\ set-slot [
-    [
-        "obj" get %untag ,
-        "val" get "obj" get "slot" get %set-slot ,
-        finalize-contents
-        "obj" get %write-barrier ,
-    ] H{
-        { +input { { f "val" } { f "obj" } { f "slot" } } }
-        { +clobber { "obj" } }
-    } with-template
-] "intrinsic" set-word-prop
-
-\ char-slot [
-    [
-        "n" get "str" get %char-slot ,
-    ] H{
-        { +input { { f "n" } { f "str" } } }
-        { +output { "str" } }
-    } with-template
-] "intrinsic" set-word-prop
-
-\ set-char-slot [
-    [
-        "ch" get "str" get "n" get %set-char-slot ,
-    ] H{
-        { +input { { f "ch" } { f "n" } { f "str" } } }
-    } with-template
-] "intrinsic" set-word-prop
-
-\ type [
-    [ finalize-contents "in" get %type , ] H{
-        { +input { { f "in" } } }
-        { +output { "in" } }
-    } with-template
-] "intrinsic" set-word-prop
-
-\ tag [
-    [ "in" get %tag , ] H{
-        { +input { { f "in" } } }
-        { +output { "in" } }
-    } with-template
-] "intrinsic" set-word-prop
-
-: binary-op ( op -- )
-    [
-        finalize-contents >r "y" get "x" get dup r> execute ,
-    ] H{
-        { +input { { 0 "x" } { 1 "y" } } }
-        { +output { "x" } }
-    } with-template ; inline
-
-{
-    { fixnum+       %fixnum+       }
-    { fixnum-       %fixnum-       }
-    { fixnum/i      %fixnum/i      }
-    { fixnum*       %fixnum*       }
-} [
-    first2 [ binary-op ] curry
-    "intrinsic" set-word-prop
-] each
-
-: binary-op-fast ( op -- )
-    [
-        >r "y" get "x" get dup r> execute ,
-    ] H{
-        { +input { { f "x" } { f "y" } } }
-        { +output { "x" } }
-    } with-template ; inline
-
-{
-    { fixnum-bitand %fixnum-bitand }
-    { fixnum-bitor  %fixnum-bitor  }
-    { fixnum-bitxor %fixnum-bitxor }
-    { fixnum+fast   %fixnum+fast   }
-    { fixnum-fast   %fixnum-fast   }
-} [
-    first2 [ binary-op-fast ] curry
-    "intrinsic" set-word-prop
-] each
-
-: binary-jump ( label op -- )
-    [
-        end-basic-block >r >r "y" get "x" get r> r> execute ,
-    ] H{
-        { +input { { f "x" } { f "y" } } }
-    } with-template ; inline
-
-{
-    { fixnum<= %jump-fixnum<= }
-    { fixnum<  %jump-fixnum<  }
-    { fixnum>= %jump-fixnum>= }
-    { fixnum>  %jump-fixnum>  }
-    { eq?      %jump-eq?      }
-} [
-    first2 [ binary-jump ] curry
-    "if-intrinsic" set-word-prop
-] each
-
-\ fixnum-mod [
-    ! This is not clever. Because of x86, %fixnum-mod is
-    ! hard-coded to put its output in vreg 2, which happends to
-    ! be EDX there.
-    [
-        finalize-contents
-        T{ vreg f 2 } "out" set
-        "y" get "x" get "out" get %fixnum-mod ,
-    ] H{
-        { +input { { 0 "x" } { 1 "y" } } }
-        ! { +scratch { { 2 "out" } } }
-        { +output { "out" } }
-    } with-template
-] "intrinsic" set-word-prop
-
-\ fixnum/mod [
-    ! See the remark on fixnum-mod for vreg usage
-    [
-        finalize-contents
-        T{ vreg f 2 } "rem" set
-        "y" get "x" get 2array
-        "rem" get "x" get 2array %fixnum/mod ,
-    ] H{
-        { +input { { 0 "x" } { 1 "y" } } }
-        ! { +scratch { { 2 "rem" } } }
-        { +output { "x" "rem" } }
-    } with-template
-] "intrinsic" set-word-prop
-
-\ fixnum-bitnot [
-    [ "x" get dup %fixnum-bitnot , ] H{
-        { +input { { f "x" } } }
-        { +output { "x" } }
-    } with-template
-] "intrinsic" set-word-prop
diff --git a/library/compiler/ppc/architecture.factor b/library/compiler/ppc/architecture.factor
index 69e2129627..3c8b729419 100644
--- a/library/compiler/ppc/architecture.factor
+++ b/library/compiler/ppc/architecture.factor
@@ -69,17 +69,18 @@ M: object load-literal ( literal vreg -- )
 : %jump ( label -- )
     %epilogue dup postpone-word %jump-label ;
 
-: %jump-t ( label vreg -- )
-    0 swap v>operand f address CMPI BNE ;
+: %jump-t ( label -- )
+    0 "flag" operand f address CMPI BNE ;
 
-: %dispatch ( vreg -- )
-    v>operand dup dup 1 SRAWI
+: %dispatch ( -- )
+    "n" operand dup 1 SRAWI
     ! The value 24 is a magic number. It is the length of the
     ! instruction sequence that follows to be generated.
-    compiled-offset 24 + 11 LOAD32  rel-2/2 rel-address
-    dup dup 11 ADD
-    dup dup 0 LWZ
-    MTLR
+    compiled-offset 24 + "scratch" operand LOAD32
+    rel-2/2 rel-address
+    "n" operand dup "scratch" operand ADD
+    "n" operand dup 0 LWZ
+    "n" operand MTLR
     BLR ;
 
 : %return ( -- ) %epilogue BLR ;
diff --git a/library/compiler/ppc/intrinsics.factor b/library/compiler/ppc/intrinsics.factor
index 50a8971688..85cace3560 100644
--- a/library/compiler/ppc/intrinsics.factor
+++ b/library/compiler/ppc/intrinsics.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: compiler
-USING: assembler kernel kernel-internals math math-internals
-namespaces sequences ;
+USING: alien assembler kernel kernel-internals math
+math-internals namespaces sequences words ;
 
 : untag ( dest src -- ) 0 0 31 tag-bits - RLWINM ;
 
@@ -11,11 +11,12 @@ namespaces sequences ;
 : untag-fixnum ( src dest -- ) tag-bits SRAWI ;
 
 \ tag [
-    "in" operand dup tag-mask ANDI
-    "in" operand dup tag-fixnum
+    "in" operand "out" operand tag-mask ANDI
+    "out" operand dup tag-fixnum
 ] H{
     { +input { { f "in" } } }
-    { +output { "in" } }
+    { +scratch { { f "out" } } }
+    { +output { "out" } }
 } define-intrinsic
 
 : generate-slot ( size quot -- )
@@ -43,6 +44,42 @@ namespaces sequences ;
     { +output { "obj" } }
 } define-intrinsic
 
+: generate-set-slot ( size quot -- )
+    >r >r
+    ! turn tagged fixnum slot # into an offset, multiple of 4
+    "slot" operand dup tag-bits r> - SRAWI
+    ! compute slot address in 1st input
+    "slot" operand dup "obj" operand ADD
+    ! store new slot value
+    "val" operand "slot" operand r> call ; inline
+
+: generate-write-barrier ( -- )
+    #! Mark the card pointed to by vreg.
+    "obj" operand dup card-bits SRAWI
+    "obj" operand dup 16 ADD
+    "x" operand "obj" operand 0 LBZ
+    "x" operand dup card-mark ORI
+    "x" operand "obj" operand 0 STB ;
+
+\ set-slot [
+    "obj" operand dup untag
+    cell log2 [ 0 STW ] generate-set-slot generate-write-barrier
+] H{
+    { +input { { f "val" } { f "obj" } { f "slot" } } }
+    { +scratch { { f "x" } } }
+    { +clobber { "obj" } }
+} define-intrinsic
+
+\ set-char-slot [
+    ! untag the new value in 0th input
+    "val" operand dup untag-fixnum
+    1 [ string-offset STH ] generate-set-slot
+] H{
+    { +input { { f "val" } { f "slot" } { f "obj" } } }
+    { +scratch { { f "x" } } }
+    { +clobber { "obj" } }
+} define-intrinsic
+
 : define-binary-op ( word op -- )
     [ [ "x" operand "y" operand "x" operand ] % , ] [ ] make H{
         { +input { { f "x" } { f "y" } } }
@@ -59,6 +96,23 @@ namespaces sequences ;
     first2 define-binary-op
 ] each
 
+: generate-fixnum-mod
+    #! PowerPC doesn't have a MOD instruction; so we compute
+    #! x-(x/y)*y. Puts the result in "s" operand.
+    "s" operand "r" operand "y" operand MULLW
+    "s" operand "s" operand "x" operand SUBF ;
+
+\ fixnum-mod [
+    ! divide x by y, store result in x
+    "r" operand "x" operand "y" operand DIVW
+    generate-fixnum-mod
+    "x" operand "s" operand MR
+] H{
+    { +input { { f "x" } { f "y" } } }
+    { +scratch { { f "r" } { f "s" } } }
+    { +output { "x" } }
+} define-intrinsic
+
 \ fixnum-bitnot [
     "x" operand dup NOT
     "x" operand dup untag
@@ -83,143 +137,163 @@ namespaces sequences ;
     first2 define-binary-jump
 ] each
 
-! M: %type generate-node ( vop -- )
-!     drop
-!     <label> "f" set
-!     <label> "end" set
-!     ! Get the tag
-!     0 input-operand 1 scratch tag-mask ANDI
-!     ! Tag the tag
-!     1 scratch 0 scratch tag-fixnum
-!     ! Compare with object tag number (3).
-!     0 1 scratch object-tag CMPI
-!     ! Jump if the object doesn't store type info in its header
-!     "end" get BNE
-!     ! It does store type info in its header
-!     ! Is the pointer itself equal to 3? Then its F_TYPE (9).
-!     0 0 input-operand object-tag CMPI
-!     "f" get BEQ
-!     ! The pointer is not equal to 3. Load the object header.
-!     0 scratch 0 input-operand object-tag neg LWZ
-!     0 scratch dup untag
-!     "end" get B
-!     "f" get save-xt
-!     ! The pointer is equal to 3. Load F_TYPE (9).
-!     f type tag-bits shift 0 scratch LI
-!     "end" get save-xt
-!     0 output-operand 0 scratch MR ;
-! 
-! : generate-set-slot ( size quot -- )
-!     >r >r
-!     ! turn tagged fixnum slot # into an offset, multiple of 4
-!     2 input-operand dup tag-bits r> - SRAWI
-!     ! compute slot address in 1st input
-!     2 input-operand dup 1 input-operand ADD
-!     ! store new slot value
-!     0 input-operand 2 input-operand r> call ; inline
-! 
-! M: %set-slot generate-node ( vop -- )
-!     drop cell log2 [ 0 STW ] generate-set-slot ;
-! 
-! M: %write-barrier generate-node ( vop -- )
-!     #! Mark the card pointed to by vreg.
-!     drop
-!     0 input-operand dup card-bits SRAWI
-!     0 input-operand dup 16 ADD
-!     0 scratch 0 input-operand 0 LBZ
-!     0 scratch dup card-mark ORI
-!     0 scratch 0 input-operand 0 STB ;
-! 
-! : simple-overflow ( inv word -- )
-!     >r >r
-!     <label> "end" set
-!     "end" get BNO
-!     >3-vop< r> execute
-!     0 input-operand dup untag-fixnum
-!     1 input-operand dup untag-fixnum
-!     >3-vop< r> execute
-!     "s48_long_to_bignum" f compile-c-call
-!     ! An untagged pointer to the bignum is now in r3; tag it
-!     0 output-operand dup bignum-tag ORI
-!     "end" get save-xt ; inline
-! 
-! M: %fixnum+ generate-node ( vop -- )
-!     drop 0 MTXER >3-vop< ADDO. \ SUBF \ ADD simple-overflow ;
-! 
-! M: %fixnum- generate-node ( vop -- )
-!     drop 0 MTXER >3-vop< SUBFO. \ ADD \ SUBF simple-overflow ;
-! 
-! M: %fixnum* generate-node ( vop -- )
-!     #! Note that this assumes the output will be in r3.
-!     drop
-!     <label> "end" set
-!     1 input-operand dup untag-fixnum
-!     0 MTXER
-!     0 scratch 0 input-operand 1 input-operand MULLWO.
-!     "end" get BNO
-!     1 scratch 0 input-operand 1 input-operand MULHW
-!     4 1 scratch MR
-!     3 0 scratch MR
-!     "s48_fixnum_pair_to_bignum" f compile-c-call
-!     ! now we have to shift it by three bits to remove the second
-!     ! tag
-!     tag-bits neg 4 LI
-!     "s48_bignum_arithmetic_shift" f compile-c-call
-!     ! An untagged pointer to the bignum is now in r3; tag it
-!     0 output-operand 0 scratch bignum-tag ORI
-!     "end" get save-xt
-!     0 output-operand 0 scratch MR ;
-! 
-! : generate-fixnum/i
-!     #! This VOP is funny. If there is an overflow, it falls
-!     #! through to the end, and the result is in 0 output-operand.
-!     #! Otherwise it jumps to the "no-overflow" label and the
-!     #! result is in 0 scratch.
-!     0 scratch 1 input-operand 0 input-operand DIVW
-!     ! if the result is greater than the most positive fixnum,
-!     ! which can only ever happen if we do
-!     ! most-negative-fixnum -1 /i, then the result is a bignum.
-!     <label> "end" set
-!     <label> "no-overflow" set
-!     most-positive-fixnum 1 scratch LOAD
-!     0 scratch 0 1 scratch CMP
-!     "no-overflow" get BLE
-!     most-negative-fixnum neg 3 LOAD
-!     "s48_long_to_bignum" f compile-c-call
-!     3 dup bignum-tag ORI ;
-! 
-! M: %fixnum/i generate-node ( vop -- )
-!     #! This has specific vreg requirements.
-!     drop
-!     generate-fixnum/i
-!     "end" get B
-!     "no-overflow" get save-xt
-!     0 scratch 0 output-operand tag-fixnum
-!     "end" get save-xt ;
-! 
-! : generate-fixnum-mod
-!     #! PowerPC doesn't have a MOD instruction; so we compute
-!     #! x-(x/y)*y. Puts the result in 1 scratch.
-!     1 scratch 0 scratch 0 input-operand MULLW
-!     1 scratch 1 scratch 1 input-operand SUBF ;
-! 
-! M: %fixnum-mod generate-node ( vop -- )
-!     drop
-!     ! divide in2 by in1, store result in out1
-!     0 scratch 1 input-operand 0 input-operand DIVW
-!     generate-fixnum-mod
-!     0 output-operand 1 scratch MR ;
-! 
-! M: %fixnum/mod generate-node ( vop -- )
-!     #! This has specific vreg requirements. Note: if there's an
-!     #! overflow, (most-negative-fixnum 1 /mod) the modulus is
-!     #! always zero.
-!     drop
-!     generate-fixnum/i
-!     0 0 output-operand LI
-!     "end" get B
-!     "no-overflow" get save-xt
-!     generate-fixnum-mod
-!     0 scratch 1 output-operand tag-fixnum
-!     0 output-operand 1 scratch MR
-!     "end" get save-xt ;
+\ type [
+    <label> "f" set
+    <label> "end" set
+    ! Get the tag
+    "obj" operand "y" operand tag-mask ANDI
+    ! Tag the tag
+    "y" operand "x" operand tag-fixnum
+    ! Compare with object tag number (3).
+    0 "y" operand object-tag CMPI
+    ! Jump if the object doesn't store type info in its header
+    "end" get BNE
+    ! It does store type info in its header
+    ! Is the pointer itself equal to 3? Then its F_TYPE (9).
+    0 "obj" operand object-tag CMPI
+    "f" get BEQ
+    ! The pointer is not equal to 3. Load the object header.
+    "x" operand "obj" operand object-tag neg LWZ
+    "x" operand dup untag
+    "end" get B
+    "f" get save-xt
+    ! The pointer is equal to 3. Load F_TYPE (9).
+    f type tag-bits shift "x" operand LI
+    "end" get save-xt
+] H{
+    { +input { { f "obj" } } }
+    { +scratch { { f "x" } { f "y" } } }
+    { +output { "x" } }
+} define-intrinsic
+
+: simple-overflow ( word -- )
+    >r
+    <label> "end" set
+    "end" get BNO
+    { "x" "y" } [ operand ] map prune [ dup untag-fixnum ] each
+    3 "y" operand "x" operand r> execute
+    "s48_long_to_bignum" f %alien-invoke
+    ! An untagged pointer to the bignum is now in r3; tag it
+    3 "r" operand bignum-tag ORI
+    "end" get save-xt ; inline
+
+\ fixnum+ [
+    finalize-contents
+    0 MTXER
+    "r" operand "y" operand "x" operand ADDO.
+    \ ADD simple-overflow
+] H{
+    { +input { { f "x" } { f "y" } } }
+    { +scratch { { f "r" } } }
+    { +output { "r" } }
+} define-intrinsic
+
+\ fixnum- [
+    finalize-contents
+    0 MTXER
+    "r" operand "y" operand "x" operand SUBFO.
+    \ SUBF simple-overflow
+] H{
+    { +input { { f "x" } { f "y" } } }
+    { +scratch { { f "r" } } }
+    { +output { "r" } }
+} define-intrinsic
+
+: ?MR 2dup = [ 2drop ] [ MR ] if ;
+
+\ fixnum* [
+    finalize-contents
+    <label> "end" set
+    "r" operand "x" operand untag-fixnum
+    0 MTXER
+    11 "y" operand "r" operand MULLWO.
+    "end" get BNO
+    4 "y" operand "r" operand MULHW
+    3 11 ?MR
+    "s48_fixnum_pair_to_bignum" f %alien-invoke
+    ! now we have to shift it by three bits to remove the second
+    ! tag
+    tag-bits neg 4 LI
+    "s48_bignum_arithmetic_shift" f %alien-invoke
+    ! An untagged pointer to the bignum is now in r3; tag it
+    3 11 bignum-tag ORI
+    "end" get save-xt
+    "s" operand 11 MR
+] H{
+    { +input { { f "x" } { f "y" } } }
+    { +scratch { { f "r" } { f "s" } } }
+    { +output { "s" } }
+} define-intrinsic
+
+: generate-fixnum/i
+    #! This VOP is funny. If there is an overflow, it falls
+    #! through to the end, and the result is in "x" operand.
+    #! Otherwise it jumps to the "no-overflow" label and the
+    #! result is in "r" operand.
+    <label> "end" set
+    <label> "no-overflow" set
+    "r" operand "x" operand "y" operand DIVW
+    ! if the result is greater than the most positive fixnum,
+    ! which can only ever happen if we do
+    ! most-negative-fixnum -1 /i, then the result is a bignum.
+    most-positive-fixnum "s" operand LOAD
+    "r" operand 0 "s" operand CMP
+    "no-overflow" get BLE
+    most-negative-fixnum neg 3 LOAD
+    "s48_long_to_bignum" f %alien-invoke
+    "x" operand 3 bignum-tag ORI ;
+
+\ fixnum/i [
+    finalize-contents
+    generate-fixnum/i
+    "end" get B
+    "no-overflow" get save-xt
+    "r" operand "x" operand tag-fixnum
+    "end" get save-xt
+] H{
+    { +input { { f "x" } { f "y" } } }
+    { +scratch { { f "r" } { f "s" } } }
+    { +output { "x" } }
+} define-intrinsic
+
+\ fixnum/mod [
+    finalize-contents
+    generate-fixnum/i
+    0 "s" operand LI
+    "end" get B
+    "no-overflow" get save-xt
+    generate-fixnum-mod
+    "r" operand "x" operand tag-fixnum
+    "end" get save-xt
+] H{
+    { +input { { f "x" } { f "y" } } }
+    { +scratch { { f "r" } { f "s" } } }
+    { +output { "x" "s" } }
+} define-intrinsic
+
+: userenv ( reg -- )
+    #! Load the userenv pointer in a register.
+    "userenv" f dlsym swap LOAD32 0 rel-2/2 rel-userenv ;
+
+\ getenv [
+    "n" operand dup 1 SRAWI
+    "x" operand userenv
+    "x" operand "n" operand "x" operand ADD
+    "x" operand dup 0 LWZ
+] H{
+    { +input { { f "n" } } }
+    { +scratch { { f "x" } } }
+    { +output { "x" } }
+    { +clobber { "n" } }
+} define-intrinsic
+
+\ setenv [
+    "n" operand dup 1 SRAWI
+    "x" operand userenv
+    "x" operand "n" operand "x" operand ADD
+    "val" operand "x" operand 0 STW
+] H{
+    { +input { { f "val" } { f "n" } } }
+    { +scratch { { f "x" } } }
+    { +clobber { "n" } }
+} define-intrinsic
diff --git a/library/compiler/x86/architecture.factor b/library/compiler/x86/architecture.factor
index e32282ede7..112f18e09d 100644
--- a/library/compiler/x86/architecture.factor
+++ b/library/compiler/x86/architecture.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: compiler
 USING: alien arrays assembler generic kernel kernel-internals
-math sequences words ;
+math namespaces sequences words ;
 
 ! x86 register assignments
 ! EAX, ECX, EDX vregs
@@ -59,24 +59,23 @@ M: object load-literal ( dest literal -- )
 
 : %jump-label ( label -- ) JMP ;
 
-: %jump-t ( label vreg -- )
-    v>operand f v>operand CMP JNE ;
+: %jump-t ( label -- )
+    "flag" operand f v>operand CMP JNE ;
 
-: %dispatch ( vreg -- )
+: %dispatch ( -- )
     #! Compile a piece of code that jumps to an offset in a
     #! jump table indexed by the fixnum at the top of the stack.
     #! The jump table must immediately follow this macro.
-    drop
     <label> "end" set
     ! Untag and multiply to get a jump table offset
-    dup fixnum>slot@
+    "n" operand fixnum>slot@
     ! Add to jump table base. We use a temporary register since
     ! on AMD4 we have to load a 64-bit immediate. On x86, this
     ! is redundant.
-    0 scratch HEX: ffffffff MOV "end" get absolute-cell
-    dup 0 scratch ADD
+    "scratch" get HEX: ffffffff MOV "end" get absolute-cell
+    "n" operand "scratch" get ADD
     ! Jump to jump table entry
-    dup [] JMP
+    "n" operand [] JMP
     ! Align for better performance
     compile-aligned
     ! Fix up jump table pointer

From d5d47b6ae8cc543596fd6745970f6e6830ad06a5 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sat, 29 Apr 2006 21:28:51 +0000
Subject: [PATCH 063/112] Fix x86 typo

---
 library/bootstrap/boot-stage1.factor     |  2 +-
 library/compiler/x86/architecture.factor | 18 ++++++++----------
 2 files changed, 9 insertions(+), 11 deletions(-)

diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor
index 29f717929a..05ffbba14b 100644
--- a/library/bootstrap/boot-stage1.factor
+++ b/library/bootstrap/boot-stage1.factor
@@ -283,7 +283,7 @@ vectors words ;
                     "/library/compiler/x86/assembler.factor"
                     "/library/compiler/x86/architecture.factor"
                     "/library/compiler/x86/alien.factor"
-                    "/library/compiler/x86/intrinsics.factor"
+                    ! "/library/compiler/x86/intrinsics.factor"
                 }
             ]
         } {
diff --git a/library/compiler/x86/architecture.factor b/library/compiler/x86/architecture.factor
index 112f18e09d..d1f39683be 100644
--- a/library/compiler/x86/architecture.factor
+++ b/library/compiler/x86/architecture.factor
@@ -2,25 +2,25 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: compiler
 USING: alien arrays assembler generic kernel kernel-internals
-math namespaces sequences words ;
+math memory namespaces sequences words ;
 
 ! x86 register assignments
 ! EAX, ECX, EDX vregs
 ! ESI datastack
 ! EBX callstack
 
+! AMD64 redefines these four
 : ds-reg ESI ; inline
 : cs-reg EBX ; inline
+: remainder-reg EDX ; inline
+: vregs { EAX ECX EDX } ; inline
+
 : reg-stack ( n reg -- op ) swap cells neg [+] ;
 
 M: ds-loc v>operand ds-loc-n ds-reg reg-stack ;
 
 M: cs-loc v>operand cs-loc-n cs-reg reg-stack ;
 
-: remainder-reg EDX ; inline
-
-: vregs { EAX ECX EDX } ; inline
-
 : %alien-invoke ( symbol dll -- )
     2dup dlsym CALL rel-relative rel-dlsym ;
 
@@ -44,8 +44,7 @@ M: float-regs fastcall-regs drop { } ;
 
 : prepare-division CDQ ; inline
 
-M: immediate load-literal ( dest literal -- )
-    address MOV ;
+M: immediate load-literal ( dest literal -- ) address MOV ;
 
 M: object load-literal ( dest literal -- )
     add-literal [] MOV rel-absolute-cell rel-address ;
@@ -59,8 +58,7 @@ M: object load-literal ( dest literal -- )
 
 : %jump-label ( label -- ) JMP ;
 
-: %jump-t ( label -- )
-    "flag" operand f v>operand CMP JNE ;
+: %jump-t ( label -- ) "flag" operand f v>operand CMP JNE ;
 
 : %dispatch ( -- )
     #! Compile a piece of code that jumps to an offset in a
@@ -87,7 +85,7 @@ M: object load-literal ( dest literal -- )
 
 : %replace ( vreg loc -- ) swap %peek ;
 
-: (%inc) 0 input cells dup 0 > [ ADD ] [ neg SUB ] if ;
+: (%inc) cells dup 0 > [ ADD ] [ neg SUB ] if ;
 
 : %inc-d ( n -- ) ds-reg (%inc) ;
 

From 42cd1e89f89955981547bce16d4b7319b51cc46e Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sat, 29 Apr 2006 21:32:15 +0000
Subject: [PATCH 064/112] Fix more typos

---
 library/compiler/x86/alien.factor     | 4 ++--
 library/compiler/x86/assembler.factor | 2 +-
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/library/compiler/x86/alien.factor b/library/compiler/x86/alien.factor
index e3ee5c5492..1f8204c87f 100644
--- a/library/compiler/x86/alien.factor
+++ b/library/compiler/x86/alien.factor
@@ -27,8 +27,8 @@ M: float-regs pop-return-reg
 M: float-regs load-return-reg
     reg-size >r ESP swap [+] r> FLD ;
 
-M: %unbox generate-node
-    drop 2 input f compile-c-call  1 input push-return-reg ;
+: %unbox ( n reg-class func -- )
+    f %alien-invoke push-return-reg drop ;
 
 : struct-ptr/size ( size func -- )
     ! Load struct size
diff --git a/library/compiler/x86/assembler.factor b/library/compiler/x86/assembler.factor
index 8521eb4aa0..7ab30b76cb 100644
--- a/library/compiler/x86/assembler.factor
+++ b/library/compiler/x86/assembler.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: assembler
 USING: arrays compiler errors generic kernel kernel-internals
 lists math namespaces parser sequences words ;
+IN: assembler
 
 ! A postfix assembler for x86 and AMD64.
 

From 8e9a27eea09560ff7be8c655547a5708bdce5707 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sat, 29 Apr 2006 22:33:05 +0000
Subject: [PATCH 065/112] Fix some problems in the x86 backend

---
 library/compiler/generator/architecture.factor |  4 ++--
 library/compiler/x86/alien.factor              |  4 ++--
 library/compiler/x86/architecture.factor       | 14 ++++++++------
 3 files changed, 12 insertions(+), 10 deletions(-)

diff --git a/library/compiler/generator/architecture.factor b/library/compiler/generator/architecture.factor
index 0d154b8523..c1224d442f 100644
--- a/library/compiler/generator/architecture.factor
+++ b/library/compiler/generator/architecture.factor
@@ -25,10 +25,10 @@ DEFER: vregs ( -- regs )
 G: load-literal ( obj vreg -- ) 1 standard-combination ;
 
 ! Set up caller stack frame (PowerPC and AMD64)
-: %prologue ( n -- ) drop ;
+: %prologue ( n -- ) drop ; inline
 
 ! Tear down stack frame (PowerPC and AMD64)
-: %epilogue ( n -- ) drop ;
+: %epilogue ( -- ) ; inline
 
 ! Tail call another word
 DEFER: %jump ( label -- )
diff --git a/library/compiler/x86/alien.factor b/library/compiler/x86/alien.factor
index 1f8204c87f..8a809b80ea 100644
--- a/library/compiler/x86/alien.factor
+++ b/library/compiler/x86/alien.factor
@@ -63,7 +63,7 @@ M: float-regs load-return-reg
     drop-return-reg ;
 
 : %alien-callback ( quot -- )
-    EAX swap load-literal
+    T{ vreg f 0 } load-literal
     EAX PUSH
     "run_callback" f %alien-invoke
     EAX POP ;
@@ -76,6 +76,6 @@ M: float-regs load-return-reg
     ! Restore data/callstacks
     "unnest_stacks" f %alien-invoke
     ! Restore return register
-    dup pop-return-reg ;
+    pop-return-reg ;
 
 : %cleanup ( n -- ) dup zero? [ drop ] [ ESP swap ADD ] if ;
diff --git a/library/compiler/x86/architecture.factor b/library/compiler/x86/architecture.factor
index d1f39683be..e5bafe7fc2 100644
--- a/library/compiler/x86/architecture.factor
+++ b/library/compiler/x86/architecture.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: compiler
 USING: alien arrays assembler generic kernel kernel-internals
 math memory namespaces sequences words ;
+IN: compiler
 
 ! x86 register assignments
 ! EAX, ECX, EDX vregs
@@ -44,9 +44,11 @@ M: float-regs fastcall-regs drop { } ;
 
 : prepare-division CDQ ; inline
 
-M: immediate load-literal ( dest literal -- ) address MOV ;
+M: immediate load-literal ( literal vreg -- )
+    v>operand swap address MOV ;
 
-M: object load-literal ( dest literal -- )
+M: object load-literal ( literal vreg -- )
+    v>operand swap
     add-literal [] MOV rel-absolute-cell rel-address ;
 
 : (%call) ( label -- label )
@@ -70,8 +72,8 @@ M: object load-literal ( dest literal -- )
     ! Add to jump table base. We use a temporary register since
     ! on AMD4 we have to load a 64-bit immediate. On x86, this
     ! is redundant.
-    "scratch" get HEX: ffffffff MOV "end" get absolute-cell
-    "n" operand "scratch" get ADD
+    "scratch" operand HEX: ffffffff MOV "end" get absolute-cell
+    "n" operand "scratch" operand ADD
     ! Jump to jump table entry
     "n" operand [] JMP
     ! Align for better performance
@@ -85,7 +87,7 @@ M: object load-literal ( dest literal -- )
 
 : %replace ( vreg loc -- ) swap %peek ;
 
-: (%inc) cells dup 0 > [ ADD ] [ neg SUB ] if ;
+: (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
 
 : %inc-d ( n -- ) ds-reg (%inc) ;
 

From cad17564ad7eb60a2e987b30f07c6def31cb135a Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sun, 30 Apr 2006 20:12:54 +0000
Subject: [PATCH 066/112] Add +clobber annotations for future optimization

---
 library/compiler/ppc/intrinsics.factor | 5 +++++
 1 file changed, 5 insertions(+)

diff --git a/library/compiler/ppc/intrinsics.factor b/library/compiler/ppc/intrinsics.factor
index 85cace3560..9628ceac3d 100644
--- a/library/compiler/ppc/intrinsics.factor
+++ b/library/compiler/ppc/intrinsics.factor
@@ -186,6 +186,7 @@ math-internals namespaces sequences words ;
     { +input { { f "x" } { f "y" } } }
     { +scratch { { f "r" } } }
     { +output { "r" } }
+    { +clobber { "x" "y" } }
 } define-intrinsic
 
 \ fixnum- [
@@ -197,6 +198,7 @@ math-internals namespaces sequences words ;
     { +input { { f "x" } { f "y" } } }
     { +scratch { { f "r" } } }
     { +output { "r" } }
+    { +clobber { "x" "y" } }
 } define-intrinsic
 
 : ?MR 2dup = [ 2drop ] [ MR ] if ;
@@ -223,6 +225,7 @@ math-internals namespaces sequences words ;
     { +input { { f "x" } { f "y" } } }
     { +scratch { { f "r" } { f "s" } } }
     { +output { "s" } }
+    { +clobber { "x" "y" } }
 } define-intrinsic
 
 : generate-fixnum/i
@@ -254,6 +257,7 @@ math-internals namespaces sequences words ;
     { +input { { f "x" } { f "y" } } }
     { +scratch { { f "r" } { f "s" } } }
     { +output { "x" } }
+    { +clobber { "y" } }
 } define-intrinsic
 
 \ fixnum/mod [
@@ -269,6 +273,7 @@ math-internals namespaces sequences words ;
     { +input { { f "x" } { f "y" } } }
     { +scratch { { f "r" } { f "s" } } }
     { +output { "x" "s" } }
+    { +clobber { "y" } }
 } define-intrinsic
 
 : userenv ( reg -- )

From 706c5d825a2664dd7456ab12bf368a0f4e6c16d9 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sun, 30 Apr 2006 20:13:35 +0000
Subject: [PATCH 067/112] First approximation at x86 intrinsic definitions

---
 library/compiler/x86/intrinsics.factor | 393 ++++++++++++++-----------
 1 file changed, 221 insertions(+), 172 deletions(-)

diff --git a/library/compiler/x86/intrinsics.factor b/library/compiler/x86/intrinsics.factor
index 2bb78d6c15..7e41ac6564 100644
--- a/library/compiler/x86/intrinsics.factor
+++ b/library/compiler/x86/intrinsics.factor
@@ -1,221 +1,270 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
 IN: compiler
+USING: alien assembler kernel kernel-internals math
+math-internals namespaces sequences ;
 
-M: %type generate-node ( vop -- )
+\ tag [
+    "in" operand tag-mask AND
+    "in" operand tag-bits SHL
+] H{
+    { +input { { f "in" } } }
+    { +output { "in" } }
+} define-intrinsic
+
+\ type [
     #! Intrinstic version of type primitive.
-    drop
     <label> "header" set
     <label> "f" set
     <label> "end" set
     ! Make a copy
-    0 scratch 0 output-operand MOV
+    "x" operand "obj" operand MOV
     ! Get the tag
-    0 output-operand tag-mask AND
+    "obj" operand tag-mask AND
     ! Compare with object tag number (3).
-    0 output-operand object-tag CMP
+    "obj" operand object-tag CMP
     ! Jump if the object doesn't store type info in its header
     "header" get JE
     ! It doesn't store type info in its header
-    0 output-operand tag-bits SHL
+    "obj" operand tag-bits SHL
     "end" get JMP
     "header" get save-xt
     ! It does store type info in its header
     ! Is the pointer itself equal to 3? Then its F_TYPE (9).
-    0 scratch object-tag CMP
+    "x" operand object-tag CMP
     "f" get JE
     ! The pointer is not equal to 3. Load the object header.
-    0 output-operand 0 scratch object-tag neg [+] MOV
+    "obj" operand "x" operand object-tag neg [+] MOV
     ! Mask off header tag, making a fixnum.
-    0 output-operand object-tag XOR
+    "obj" operand object-tag XOR
     "end" get JMP
     "f" get save-xt
     ! The pointer is equal to 3. Load F_TYPE (9).
-    0 output-operand f type tag-bits shift MOV
-    "end" get save-xt ;
+    "obj" operand f type tag-bits shift MOV
+    "end" get save-xt
+] H{
+    { +input { { f "obj" } } }
+    { +scratch { { f "x" } { f "y" } } }
+    { +output { "obj" } }
+} define-intrinsic
 
-M: %tag generate-node ( vop -- )
-    drop
-    0 input-operand tag-mask AND
-    0 input-operand tag-bits SHL ;
+: untag ( reg -- ) tag-mask bitnot AND ;
 
-M: %untag generate-node ( vop -- )
-    drop
-    0 output-operand tag-mask bitnot AND ;
-
-M: %slot generate-node ( vop -- )
-    drop
+\ slot [
+    "obj" operand untag
     ! turn tagged fixnum slot # into an offset, multiple of 4
-    0 input-operand fixnum>slot@
+    "n" operand fixnum>slot@
     ! compute slot address
-    dest/src ADD
+    "obj" operand "n" operand ADD
     ! load slot value
-    0 output-operand dup [] MOV ;
+    "obj" operand dup [] MOV
+] H{
+    { +input { { f "obj" } { f "n" } } }
+    { +output { "obj" } }
+    { +clobber { "n" } }
+} define-intrinsic
 
 : card-offset 1 getenv ; inline
 
-M: %write-barrier generate-node ( vop -- )
+: generate-write-barrier ( -- )
     #! Mark the card pointed to by vreg.
-    drop
-    0 input-operand card-bits SHR
-    0 input-operand card-offset ADD rel-absolute-cell rel-cards
-    0 input-operand [] card-mark OR ;
+    "obj" operand card-bits SHR
+    "obj" operand card-offset ADD rel-absolute-cell rel-cards
+    "obj" operand [] card-mark OR ;
 
-M: %set-slot generate-node ( vop -- )
-    drop
+\ set-slot [
+    "obj" operand untag
     ! turn tagged fixnum slot # into an offset
-    2 input-operand fixnum>slot@
+    "slot" operand fixnum>slot@
     ! compute slot address
-    2 input-operand 1 input-operand ADD
+    "obj" operand "slot" operand ADD
     ! store new slot value
-    2 input-operand [] 0 input-operand MOV ;
+    "obj" operand [] "val" operand MOV
+    generate-write-barrier
+] H{
+    { +input { { f "val" } { f "obj" } { f "slot" } } }
+    { +scratch { { f "x" } } }
+    { +clobber { "obj" } }
+} define-intrinsic
 
-: >register-16 ( reg -- reg )
-    "register" word-prop { AX CX DX } nth ;
+\ char-slot [
+    EBX PUSH
+    "n" operand 2 SHR
+    EBX dup XOR
+    EBX "n" operand ADD
+    BX "obj" operand string-offset [+] MOV
+    EBX tag-bits SHL
+    "obj" operand EBX MOV
+    EBX POP
+] H{
+    { +input { { f "n" } { f "obj" } } }
+    { +output { "obj" } }
+    { +clobber { "n" } }
+} define-intrinsic
 
-: scratch-16 ( n -- reg ) scratch >register-16 ;
+\ set-char-slot [
+    "obj" operand untag
+    EBX PUSH
+    "val" operand tag-bits SHR
+    "slot" operand 2 SHR
+    "obj" operand "slot" operand ADD
+    EBX "val" operand MOV
+    "obj" operand string-offset [+] BX MOV
+    EBX POP
+] H{
+    { +input { { f "val" } { f "slot" } { f "obj" } } }
+    { +clobber { "obj" } }
+} define-intrinsic
 
-M: %char-slot generate-node ( vop -- )
-    drop
-    0 input-operand 2 SHR
-    0 scratch dup XOR
-    dest/src ADD
-    0 scratch-16 0 output-operand string-offset [+] MOV
-    0 scratch tag-bits SHL
-    0 output-operand 0 scratch MOV ;
+: define-binary-op ( word op -- )
+    [ [ "x" operand "y" operand ] % , ] [ ] make H{
+        { +input { { f "x" } { f "y" } } }
+        { +output { "x" } }
+    } define-intrinsic ;
 
-M: %set-char-slot generate-node ( vop -- )
-    drop
-    0 input-operand tag-bits SHR
-    2 input-operand 2 SHR
-    2 input-operand 1 input-operand ADD
-    2 input-operand string-offset [+]
-    0 input-operand >register-16 MOV ;
+{
+    { fixnum+fast ADD }
+    { fixnum-fast SUB }
+    { fixnum-bitand AND }
+    { fixnum-bitor OR }
+    { fixnum-bitxor XOR }
+} [
+    first2 define-binary-op
+] each
 
-: literal-overflow ( -- dest src )
-    #! Called if the src operand is a literal.
-    #! Untag the dest operand.
-    dest/src over tag-bits SAR tag-bits neg shift ;
+\ fixnum-bitnot [
+    "x" operand NOT
+    "x" operand tag-mask XOR
+] H{
+    { +input { { f "x" } } }
+    { +output { "x" } }
+} define-intrinsic
 
-: computed-overflow ( -- dest src )
-    #! Called if the src operand is a register.
-    #! Untag both operands.
-    dest/src 2dup tag-bits SAR tag-bits SAR ;
-
-: simple-overflow ( inverse word -- )
-    #! If the previous arithmetic operation overflowed, then we
-    #! turn the result into a bignum and leave it in EAX.
-    <label> "end" set
-    "end" get JNO
-    ! There was an overflow. Recompute the original operand.
-    >r >r dest/src r> execute
-    0 input integer? [ literal-overflow ] [ computed-overflow ] if
-    ! Compute a result, this time it will fit.
-    r> execute
-    ! Create a bignum.
-    "s48_long_to_bignum" f 0 output-operand
-    1array compile-c-call*
-    ! An untagged pointer to the bignum is now in EAX; tag it
-    T{ int-regs } return-reg bignum-tag OR
-    "end" get save-xt ; inline
-
-M: %fixnum+ generate-node ( vop -- )
-    drop dest/src ADD  \ SUB \ ADD simple-overflow ;
-
-M: %fixnum+fast generate-node ( vop -- ) drop dest/src ADD ;
-
-M: %fixnum- generate-node ( vop -- )
-    drop dest/src SUB  \ ADD \ SUB simple-overflow ;
-
-M: %fixnum-fast generate-node ( vop -- ) drop dest/src SUB ;
-
-M: %fixnum* generate-node ( vop -- )
-    drop
-    ! both inputs are tagged, so one of them needs to have its
-    ! tag removed.
-    1 input-operand tag-bits SAR
-    0 input-operand IMUL
-    <label> "end" set
-    "end" get JNO
-    "s48_fixnum_pair_to_bignum" f
-    1 input-operand remainder-reg 2array compile-c-call*
-    ! now we have to shift it by three bits to remove the second
-    ! tag
-    "s48_bignum_arithmetic_shift" f
-    1 input-operand tag-bits neg 2array compile-c-call*
-    ! an untagged pointer to the bignum is now in EAX; tag it
-    T{ int-regs } return-reg bignum-tag OR
-    "end" get save-xt ;
-
-M: %fixnum-mod generate-node ( vop -- )
-    #! This has specific register requirements. Inputs are in
-    #! ECX and EAX, and the result is in EDX.
-    drop
+! This has specific register requirements. Inputs are in
+! ECX and EAX, and the result is in EDX.
+\ fixnum-mod [
     prepare-division
-    0 input-operand IDIV ;
+    "x" operand IDIV
+] H{
+    { +input { { 0 "x" } { 2 "y" } } }
+    { +output { "x" } }
+} define-intrinsic
 
-: generate-fixnum/mod
-    #! The same code is used for %fixnum/i and %fixnum/mod.
-    #! This has specific register requirements. Inputs are in
-    #! ECX and EAX, and the result is in EDX.
-    <label> "end" set
-    prepare-division
-    0 input-operand IDIV
-    ! Make a copy since following shift is destructive
-    0 input-operand 1 input-operand MOV
-    ! Tag the value, since division cancelled tags from both
-    ! inputs
-    1 input-operand tag-bits SHL
-    ! Did it overflow?
-    "end" get JNO
-    ! There was an overflow, so make ECX into a bignum. we must
-    ! save EDX since its volatile.
-    remainder-reg PUSH
-    "s48_long_to_bignum" f
-    0 input-operand 1array compile-c-call*
-    ! An untagged pointer to the bignum is now in EAX; tag it
-    T{ int-regs } return-reg bignum-tag OR
-    ! the remainder is now in EDX
-    remainder-reg POP
-    "end" get save-xt ;
+! : literal-overflow ( -- dest src )
+!     #! Called if the src operand is a literal.
+!     #! Untag the dest operand.
+!     dest/src over tag-bits SAR tag-bits neg shift ;
+! 
+! : computed-overflow ( -- dest src )
+!     #! Called if the src operand is a register.
+!     #! Untag both operands.
+!     dest/src 2dup tag-bits SAR tag-bits SAR ;
+! 
+! : simple-overflow ( inverse word -- )
+!     #! If the previous arithmetic operation overflowed, then we
+!     #! turn the result into a bignum and leave it in EAX.
+!     <label> "end" set
+!     "end" get JNO
+!     ! There was an overflow. Recompute the original operand.
+!     >r >r dest/src r> execute
+!     0 input integer? [ literal-overflow ] [ computed-overflow ] if
+!     ! Compute a result, this time it will fit.
+!     r> execute
+!     ! Create a bignum.
+!     "s48_long_to_bignum" f 0 output-operand
+!     1array compile-c-call*
+!     ! An untagged pointer to the bignum is now in EAX; tag it
+!     T{ int-regs } return-reg bignum-tag OR
+!     "end" get save-xt ; inline
+! 
+! M: %fixnum+ generate-node ( vop -- )
+!     drop dest/src ADD  \ SUB \ ADD simple-overflow ;
+! 
+! M: %fixnum- generate-node ( vop -- )
+!     drop dest/src SUB  \ ADD \ SUB simple-overflow ;
+! 
+! M: %fixnum* generate-node ( vop -- )
+!     drop
+!     ! both inputs are tagged, so one of them needs to have its
+!     ! tag removed.
+!     1 input-operand tag-bits SAR
+!     0 input-operand IMUL
+!     <label> "end" set
+!     "end" get JNO
+!     "s48_fixnum_pair_to_bignum" f
+!     1 input-operand remainder-reg 2array compile-c-call*
+!     ! now we have to shift it by three bits to remove the second
+!     ! tag
+!     "s48_bignum_arithmetic_shift" f
+!     1 input-operand tag-bits neg 2array compile-c-call*
+!     ! an untagged pointer to the bignum is now in EAX; tag it
+!     T{ int-regs } return-reg bignum-tag OR
+!     "end" get save-xt ;
+! 
+! : generate-fixnum/mod
+!     #! The same code is used for %fixnum/i and %fixnum/mod.
+!     #! This has specific register requirements. Inputs are in
+!     #! ECX and EAX, and the result is in EDX.
+!     <label> "end" set
+!     prepare-division
+!     0 input-operand IDIV
+!     ! Make a copy since following shift is destructive
+!     0 input-operand 1 input-operand MOV
+!     ! Tag the value, since division cancelled tags from both
+!     ! inputs
+!     1 input-operand tag-bits SHL
+!     ! Did it overflow?
+!     "end" get JNO
+!     ! There was an overflow, so make ECX into a bignum. we must
+!     ! save EDX since its volatile.
+!     remainder-reg PUSH
+!     "s48_long_to_bignum" f
+!     0 input-operand 1array compile-c-call*
+!     ! An untagged pointer to the bignum is now in EAX; tag it
+!     T{ int-regs } return-reg bignum-tag OR
+!     ! the remainder is now in EDX
+!     remainder-reg POP
+!     "end" get save-xt ;
+! 
+! M: %fixnum/i generate-node drop generate-fixnum/mod ;
+! 
+! M: %fixnum/mod generate-node drop generate-fixnum/mod ;
 
-M: %fixnum/i generate-node drop generate-fixnum/mod ;
+: define-binary-jump ( word op -- )
+    [
+        [ end-basic-block "x" operand "y" operand CMP ] % ,
+    ] [ ] make H{
+        { +input { { f "x" } { f "y" } } }
+    } define-if-intrinsic ;
 
-M: %fixnum/mod generate-node drop generate-fixnum/mod ;
+{
+    { fixnum< JL }
+    { fixnum<= JLE }
+    { fixnum> JG }
+    { fixnum>= JGE }
+    { eq? JE }
+} [
+    first2 define-binary-jump
+] each
 
-M: %fixnum-bitand generate-node ( vop -- ) drop dest/src AND ;
+: %userenv ( -- )
+    "x" operand "userenv" f dlsym MOV
+    rel-absolute-cell rel-userenv
+    "n" operand 1 SHR
+    "n" operand "x" operand ADD ;
 
-M: %fixnum-bitor generate-node ( vop -- ) drop dest/src OR ;
+\ getenv [
+    %userenv  "n" operand dup [] MOV
+] H{
+    { +input { { f "n" } } }
+    { +scratch { { f "x" } } }
+    { +output { "n" } }
+} define-intrinsic
 
-M: %fixnum-bitxor generate-node ( vop -- ) drop dest/src XOR ;
-
-M: %fixnum-bitnot generate-node ( vop -- )
-    drop
-    ! Negate the bits of the operand
-    0 output-operand NOT
-    ! Mask off the low 3 bits to give a fixnum tag
-    0 output-operand tag-mask XOR ;
-
-M: %fixnum>> generate-node
-    drop
-    ! shift register
-    0 output-operand 0 input SAR
-    ! give it a fixnum tag
-    0 output-operand tag-mask bitnot AND ;
-
-M: %fixnum-sgn generate-node
-    #! This has specific register requirements.
-    drop
-    ! store 0 in EDX if EAX is >=0, otherwise store -1.
-    prepare-division
-    ! give it a fixnum tag.
-    0 output-operand tag-bits SHL ;
-
-: fixnum-jump ( -- label )
-    1 input-operand 0 input-operand CMP label ;
-
-M: %jump-fixnum<  generate-node ( vop -- ) drop fixnum-jump JL ;
-M: %jump-fixnum<= generate-node ( vop -- ) drop fixnum-jump JLE ;
-M: %jump-fixnum>  generate-node ( vop -- ) drop fixnum-jump JG ;
-M: %jump-fixnum>= generate-node ( vop -- ) drop fixnum-jump JGE ;
-M: %jump-eq?      generate-node ( vop -- ) drop fixnum-jump JE ;
+\ setenv [
+    %userenv  "n" operand [] "val" operand MOV
+] H{
+    { +input { { f "val" } { f "n" } } }
+    { +scratch { { f "x" } } }
+    { +clobber { "n" } }
+} define-intrinsic

From 73730188c019cca14fdbd1fa630e16757f5ddeb7 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Tue, 2 May 2006 00:45:40 +0000
Subject: [PATCH 068/112] Updating x86 intrinsics

---
 library/compiler/x86/intrinsics.factor | 185 +++++++++++++------------
 1 file changed, 98 insertions(+), 87 deletions(-)

diff --git a/library/compiler/x86/intrinsics.factor b/library/compiler/x86/intrinsics.factor
index 7e41ac6564..066097f303 100644
--- a/library/compiler/x86/intrinsics.factor
+++ b/library/compiler/x86/intrinsics.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: alien arrays assembler kernel kernel-internals lists math
+math-internals namespaces sequences words ;
 IN: compiler
-USING: alien assembler kernel kernel-internals math
-math-internals namespaces sequences ;
 
 \ tag [
     "in" operand tag-mask AND
@@ -83,7 +83,6 @@ math-internals namespaces sequences ;
     generate-write-barrier
 ] H{
     { +input { { f "val" } { f "obj" } { f "slot" } } }
-    { +scratch { { f "x" } } }
     { +clobber { "obj" } }
 } define-intrinsic
 
@@ -91,7 +90,7 @@ math-internals namespaces sequences ;
     EBX PUSH
     "n" operand 2 SHR
     EBX dup XOR
-    EBX "n" operand ADD
+    "obj" operand "n" operand ADD
     BX "obj" operand string-offset [+] MOV
     EBX tag-bits SHL
     "obj" operand EBX MOV
@@ -103,7 +102,6 @@ math-internals namespaces sequences ;
 } define-intrinsic
 
 \ set-char-slot [
-    "obj" operand untag
     EBX PUSH
     "val" operand tag-bits SHR
     "slot" operand 2 SHR
@@ -113,7 +111,7 @@ math-internals namespaces sequences ;
     EBX POP
 ] H{
     { +input { { f "val" } { f "slot" } { f "obj" } } }
-    { +clobber { "obj" } }
+    { +clobber { "val" "slot" "obj" } }
 } define-intrinsic
 
 : define-binary-op ( word op -- )
@@ -144,91 +142,104 @@ math-internals namespaces sequences ;
 ! ECX and EAX, and the result is in EDX.
 \ fixnum-mod [
     prepare-division
-    "x" operand IDIV
+    "y" operand IDIV
 ] H{
-    { +input { { 0 "x" } { 2 "y" } } }
+    { +input { { 0 "x" } { 1 "y" } } }
+    { +scratch { { 2 "out" } } }
+    { +output { "out" } }
+} define-intrinsic
+
+: ?MOV ( dst src -- ) 2dup = [ 2drop ] [ MOV ] if ;
+
+: unique-operands ( operands quot -- )
+    >r [ operand ] map prune r> each ; inline
+
+: simple-overflow ( word -- )
+    finalize-contents
+    "z" operand "x" operand MOV
+    "z" operand "y" operand pick execute
+    ! If the previous arithmetic operation overflowed, then we
+    ! turn the result into a bignum and leave it in EAX.
+    <label> "end" set
+    "end" get JNO
+    ! There was an overflow. Recompute the original operand.
+    { "y" "x" } [ tag-bits SAR ] unique-operands
+    "x" operand "y" operand rot execute
+    "s48_long_to_bignum" f "x" operand 1array compile-c-call*
+    ! An untagged pointer to the bignum is now in EAX; tag it
+    T{ int-regs } return-reg bignum-tag OR
+    "z" operand T{ int-regs } return-reg ?MOV
+    "end" get save-xt ; inline
+
+: simple-overflow-template ( word insn -- )
+    [ simple-overflow ] curry H{
+        { +input { { f "x" } { f "y" } } }
+        { +scratch { { f "z" } } }
+        { +output { "z" } }
+        { +clobber { "x" "y" } }
+    } define-intrinsic ;
+
+\ fixnum+ \ ADD simple-overflow-template
+\ fixnum- \ SUB simple-overflow-template
+
+\ fixnum* [
+    finalize-contents
+    "y" operand tag-bits SAR
+    "y" operand IMUL
+    <label> "end" set
+    "end" get JNO
+    "s48_fixnum_pair_to_bignum" f
+    "x" operand remainder-reg 2array compile-c-call*
+    ! now we have to shift it by three bits to remove the second
+    ! tag
+    "s48_bignum_arithmetic_shift" f
+    "x" operand tag-bits neg 2array compile-c-call*
+    ! an untagged pointer to the bignum is now in EAX; tag it
+    T{ int-regs } return-reg bignum-tag OR
+    "end" get save-xt
+] H{
+    { +input { { 0 "x" } { 1 "y" } } }
     { +output { "x" } }
 } define-intrinsic
 
-! : literal-overflow ( -- dest src )
-!     #! Called if the src operand is a literal.
-!     #! Untag the dest operand.
-!     dest/src over tag-bits SAR tag-bits neg shift ;
+: generate-fixnum/mod
+    #! The same code is used for fixnum/i and fixnum/mod.
+    #! This has specific register
+    #! ECX and EAX, and the result is in EDX.
+    <label> "end" set
+    prepare-division
+    "y" operand IDIV
+    ! Make a copy since following shift is destructive
+    "y" operand "x" operand MOV
+    ! Tag the value, since division cancelled tags from both
+    ! inputs
+    "x" operand tag-bits SHL
+    ! Did it overflow?
+    "end" get JNO
+    ! There was an overflow, so make ECX into a bignum. we must
+    ! save EDX since its volatile.
+    remainder-reg PUSH
+    "s48_long_to_bignum" f
+    "y" operand 1array compile-c-call*
+    ! An untagged pointer to the bignum is now in EAX; tag it
+    T{ int-regs } return-reg bignum-tag OR
+    ! the remainder is now in EDX
+    remainder-reg POP
+    "end" get save-xt ;
+
+\ fixnum/i [ generate-fixnum/mod ] H{
+    { +input { { 0 "x" } { 1 "y" } } }
+    { +scratch { { 2 "out" } } }
+    { +output { "x" } }
+    { +clobber { "x" "y" } }
+} define-intrinsic
 ! 
-! : computed-overflow ( -- dest src )
-!     #! Called if the src operand is a register.
-!     #! Untag both operands.
-!     dest/src 2dup tag-bits SAR tag-bits SAR ;
-! 
-! : simple-overflow ( inverse word -- )
-!     #! If the previous arithmetic operation overflowed, then we
-!     #! turn the result into a bignum and leave it in EAX.
-!     <label> "end" set
-!     "end" get JNO
-!     ! There was an overflow. Recompute the original operand.
-!     >r >r dest/src r> execute
-!     0 input integer? [ literal-overflow ] [ computed-overflow ] if
-!     ! Compute a result, this time it will fit.
-!     r> execute
-!     ! Create a bignum.
-!     "s48_long_to_bignum" f 0 output-operand
-!     1array compile-c-call*
-!     ! An untagged pointer to the bignum is now in EAX; tag it
-!     T{ int-regs } return-reg bignum-tag OR
-!     "end" get save-xt ; inline
-! 
-! M: %fixnum+ generate-node ( vop -- )
-!     drop dest/src ADD  \ SUB \ ADD simple-overflow ;
-! 
-! M: %fixnum- generate-node ( vop -- )
-!     drop dest/src SUB  \ ADD \ SUB simple-overflow ;
-! 
-! M: %fixnum* generate-node ( vop -- )
-!     drop
-!     ! both inputs are tagged, so one of them needs to have its
-!     ! tag removed.
-!     1 input-operand tag-bits SAR
-!     0 input-operand IMUL
-!     <label> "end" set
-!     "end" get JNO
-!     "s48_fixnum_pair_to_bignum" f
-!     1 input-operand remainder-reg 2array compile-c-call*
-!     ! now we have to shift it by three bits to remove the second
-!     ! tag
-!     "s48_bignum_arithmetic_shift" f
-!     1 input-operand tag-bits neg 2array compile-c-call*
-!     ! an untagged pointer to the bignum is now in EAX; tag it
-!     T{ int-regs } return-reg bignum-tag OR
-!     "end" get save-xt ;
-! 
-! : generate-fixnum/mod
-!     #! The same code is used for %fixnum/i and %fixnum/mod.
-!     #! This has specific register requirements. Inputs are in
-!     #! ECX and EAX, and the result is in EDX.
-!     <label> "end" set
-!     prepare-division
-!     0 input-operand IDIV
-!     ! Make a copy since following shift is destructive
-!     0 input-operand 1 input-operand MOV
-!     ! Tag the value, since division cancelled tags from both
-!     ! inputs
-!     1 input-operand tag-bits SHL
-!     ! Did it overflow?
-!     "end" get JNO
-!     ! There was an overflow, so make ECX into a bignum. we must
-!     ! save EDX since its volatile.
-!     remainder-reg PUSH
-!     "s48_long_to_bignum" f
-!     0 input-operand 1array compile-c-call*
-!     ! An untagged pointer to the bignum is now in EAX; tag it
-!     T{ int-regs } return-reg bignum-tag OR
-!     ! the remainder is now in EDX
-!     remainder-reg POP
-!     "end" get save-xt ;
-! 
-! M: %fixnum/i generate-node drop generate-fixnum/mod ;
-! 
-! M: %fixnum/mod generate-node drop generate-fixnum/mod ;
+\ fixnum/mod [ generate-fixnum/mod ] H{
+    { +input { { 0 "x" } { 1 "y" } } }
+    { +scratch { { 2 "out" } } }
+    { +output { "x" "out" } }
+    { +clobber { "x" "y" } }
+} define-intrinsic
 
 : define-binary-jump ( word op -- )
     [
@@ -249,7 +260,7 @@ math-internals namespaces sequences ;
 
 : %userenv ( -- )
     "x" operand "userenv" f dlsym MOV
-    rel-absolute-cell rel-userenv
+    0 rel-absolute-cell rel-userenv
     "n" operand 1 SHR
     "n" operand "x" operand ADD ;
 

From 7c53f7ef5708e341971c7079027aaa7491584fc1 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Tue, 2 May 2006 02:12:08 +0000
Subject: [PATCH 069/112] Disable set-slot intrinsic since it seems problematic

---
 library/bootstrap/boot-stage1.factor   |  2 +-
 library/compiler/x86/intrinsics.factor | 28 +++++++++++++-------------
 2 files changed, 15 insertions(+), 15 deletions(-)

diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor
index 05ffbba14b..29f717929a 100644
--- a/library/bootstrap/boot-stage1.factor
+++ b/library/bootstrap/boot-stage1.factor
@@ -283,7 +283,7 @@ vectors words ;
                     "/library/compiler/x86/assembler.factor"
                     "/library/compiler/x86/architecture.factor"
                     "/library/compiler/x86/alien.factor"
-                    ! "/library/compiler/x86/intrinsics.factor"
+                    "/library/compiler/x86/intrinsics.factor"
                 }
             ]
         } {
diff --git a/library/compiler/x86/intrinsics.factor b/library/compiler/x86/intrinsics.factor
index 066097f303..fe18dce073 100644
--- a/library/compiler/x86/intrinsics.factor
+++ b/library/compiler/x86/intrinsics.factor
@@ -72,19 +72,19 @@ IN: compiler
     "obj" operand card-offset ADD rel-absolute-cell rel-cards
     "obj" operand [] card-mark OR ;
 
-\ set-slot [
-    "obj" operand untag
-    ! turn tagged fixnum slot # into an offset
-    "slot" operand fixnum>slot@
-    ! compute slot address
-    "obj" operand "slot" operand ADD
-    ! store new slot value
-    "obj" operand [] "val" operand MOV
-    generate-write-barrier
-] H{
-    { +input { { f "val" } { f "obj" } { f "slot" } } }
-    { +clobber { "obj" } }
-} define-intrinsic
+! \ set-slot [
+!     "obj" operand untag
+!     ! turn tagged fixnum slot # into an offset
+!     "slot" operand fixnum>slot@
+!     ! compute slot address
+!     "obj" operand "slot" operand ADD
+!     ! store new slot value
+!     "obj" operand [] "val" operand MOV
+!     generate-write-barrier
+! ] H{
+!     { +input { { f "val" } { f "obj" } { f "slot" } } }
+!     { +clobber { "obj" "slot" } }
+! } define-intrinsic
 
 \ char-slot [
     EBX PUSH
@@ -233,7 +233,7 @@ IN: compiler
     { +output { "x" } }
     { +clobber { "x" "y" } }
 } define-intrinsic
-! 
+
 \ fixnum/mod [ generate-fixnum/mod ] H{
     { +input { { 0 "x" } { 1 "y" } } }
     { +scratch { { 2 "out" } } }

From bdd78ad160b255e2f2cfb3a83e3aca80c6ae9e1a Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Tue, 2 May 2006 03:30:24 +0000
Subject: [PATCH 070/112] Generate if-intrinsics in more cases

---
 library/compiler/generator/generator.factor | 45 +++++++++++++++------
 library/compiler/generator/templates.factor |  7 +++-
 library/compiler/ppc/intrinsics.factor      |  3 +-
 3 files changed, 38 insertions(+), 17 deletions(-)

diff --git a/library/compiler/generator/generator.factor b/library/compiler/generator/generator.factor
index 1d3e3a66d8..d52eb6f959 100644
--- a/library/compiler/generator/generator.factor
+++ b/library/compiler/generator/generator.factor
@@ -12,16 +12,19 @@ M: object stack-reserve* drop 0 ;
 : stack-reserve ( node -- n )
     0 swap [ stack-reserve* max ] each-node ;
 
+: intrinsic ( #call -- quot )
+    node-param "intrinsic" word-prop ;
+
 : if-intrinsic ( #call -- quot )
-    dup node-successor #if?
-    [ node-param "if-intrinsic" word-prop ] [ drop f ] if ;
+    node-param "if-intrinsic" word-prop ;
 
 DEFER: #terminal?
 
 PREDICATE: #merge #terminal-merge node-successor #terminal? ;
 
 PREDICATE: #call #terminal-call
-    dup node-successor node-successor #terminal?
+    dup node-successor #if?
+    over node-successor node-successor #terminal? and
     swap if-intrinsic and ;
 
 UNION: #terminal
@@ -108,10 +111,13 @@ M: #label generate-node ( node -- next )
     swap node-child generate-word r> ;
 
 ! #if
+: end-false-branch ( label -- )
+    tail-call? [ %return drop ] [ %jump-label ] if ;
+
 : generate-if ( node label -- next )
     <label> [
         >r >r node-children first2 generate-nodes
-        r> r> %jump-label save-xt generate-nodes
+        r> r> end-false-branch save-xt generate-nodes
     ] keep save-xt iterate-next ;
 
 M: #if generate-node ( node -- next )
@@ -129,19 +135,32 @@ M: #if generate-node ( node -- next )
 : define-intrinsic ( word quot template -- | quot: -- )
     [with-template] "intrinsic" set-word-prop ;
 
-: intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
-
 : define-if-intrinsic ( word quot template -- | quot: label -- )
     [with-template] "if-intrinsic" set-word-prop ;
 
-M: #call generate-node ( node -- next )
-    dup if-intrinsic [
-        >r <label> dup r> call
-        >r node-successor r> generate-if node-successor
+: if>boolean-intrinsic ( label -- )
+    <label> "end" set
+    f T{ vreg f 0 } load-literal
+    "end" get %jump-label
+    save-xt
+    t T{ vreg f 0 } load-literal
+    "end" get save-xt
+    T{ vreg f 0 } phantom-d get phantom-push ;
+
+: do-if-intrinsic ( node -- next )
+    [ <label> dup ] keep if-intrinsic call
+    >r node-successor dup #if? [
+        r> generate-if node-successor
     ] [
-        dup intrinsic
-        [ call iterate-next ] [ node-param generate-call ] ?if
-    ] if* ;
+        drop r> if>boolean-intrinsic iterate-next
+    ] if ;
+
+M: #call generate-node ( node -- next )
+    {
+        { [ dup if-intrinsic ] [ do-if-intrinsic ] }
+        { [ dup intrinsic ] [ intrinsic call iterate-next ] }
+        { [ t ] [ node-param generate-call ] }
+    } cond ;
 
 ! #call-label
 M: #call-label generate-node ( node -- next )
diff --git a/library/compiler/generator/templates.factor b/library/compiler/generator/templates.factor
index 144635146f..f000d491bb 100644
--- a/library/compiler/generator/templates.factor
+++ b/library/compiler/generator/templates.factor
@@ -211,6 +211,9 @@ SYMBOL: phantom-r
     over length swap cut-phantom
     swap phantom-vregs ;
 
+: phantom-push ( obj stack -- )
+    1 over adjust-phantom push ;
+
 : phantom-append ( seq stack -- )
     over length over adjust-phantom swap nappend ;
 
@@ -251,7 +254,7 @@ SYMBOL: +clobber
     append ;
 
 : guess-vregs ( -- n )
-    +input get dup { } additional-vregs# +scratch get length + ;
+    +input get { } additional-vregs# +scratch get length + ;
 
 : alloc-scratch ( -- )
     +scratch get [ alloc-vregs [ <vreg> ] map ] keep
@@ -263,7 +266,7 @@ SYMBOL: +clobber
     guess-vregs ensure-vregs
     ! Split the template into available (fast) parts and those
     ! that require allocating registers and reading the stack
-    match-template fast-input
+    +input get match-template fast-input
     used-vregs adjust-free-vregs
     slow-input
     alloc-scratch
diff --git a/library/compiler/ppc/intrinsics.factor b/library/compiler/ppc/intrinsics.factor
index 9628ceac3d..9c48ea3844 100644
--- a/library/compiler/ppc/intrinsics.factor
+++ b/library/compiler/ppc/intrinsics.factor
@@ -106,11 +106,10 @@ math-internals namespaces sequences words ;
     ! divide x by y, store result in x
     "r" operand "x" operand "y" operand DIVW
     generate-fixnum-mod
-    "x" operand "s" operand MR
 ] H{
     { +input { { f "x" } { f "y" } } }
     { +scratch { { f "r" } { f "s" } } }
-    { +output { "x" } }
+    { +output { "s" } }
 } define-intrinsic
 
 \ fixnum-bitnot [

From 1bc9dbcf2a4cbc4e9ff57af7d6149c7780d0cc1a Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Tue, 2 May 2006 04:11:59 +0000
Subject: [PATCH 071/112] Specializer optimization

---
 TODO.FACTOR.txt                               |  1 -
 examples/raytracer.factor                     | 29 ++++++++--------
 library/bootstrap/boot-stage1.factor          |  1 +
 library/compiler/compiler.factor              |  2 +-
 .../compiler/optimizer/specializers.factor    | 33 +++++++++++++++++++
 library/test/benchmark/fib.factor             |  7 ++--
 6 files changed, 56 insertions(+), 17 deletions(-)
 create mode 100644 library/compiler/optimizer/specializers.factor

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 1df68b8ece..579f039da7 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -3,7 +3,6 @@ should fix in 0.82:
 - type inference busted for tuple constructors
 - constant branch folding
 - fast-slot stuff
-- compile if-intrinsic even if there is no #if there
 - 3 >n fep
 - amd64 %box-struct
 - get factor running on mac intel
diff --git a/examples/raytracer.factor b/examples/raytracer.factor
index 38867117a7..60eafd6b32 100644
--- a/examples/raytracer.factor
+++ b/examples/raytracer.factor
@@ -2,7 +2,7 @@
 ! http://www.ffconsultancy.com/free/ray_tracer/languages.html
 
 USING: arrays compiler generic io kernel lists math namespaces
-sequences test ;
+sequences test words ;
 IN: ray
 
 ! parameters
@@ -27,24 +27,26 @@ GENERIC: intersect-scene ( hit ray scene -- hit )
 TUPLE: sphere center radius ;
 
 : sphere-v ( sphere ray -- v )
-    swap sphere-center swap ray-orig v- ;
+    swap sphere-center swap ray-orig v- ; inline
 
-: sphere-b ( ray v -- b ) swap ray-dir v. ;
+: sphere-b ( ray v -- b ) swap ray-dir v. ; inline
 
 : sphere-disc ( sphere v b -- d )
-    sq swap norm-sq - swap sphere-radius sq + ;
+    sq swap norm-sq - swap sphere-radius sq + ; inline
 
-: -+ ( x y -- x-y x+y ) [ - ] 2keep + ;
+: -+ ( x y -- x-y x+y ) [ - ] 2keep + ; inline
 
 : sphere-b/d ( b d -- t )
-    -+ dup 0.0 < [ 2drop 1.0/0.0 ] [ >r [ 0.0 > ] keep r> ? ] if ;
+    -+ dup 0.0 < [ 2drop 1.0/0.0 ] [ >r [ 0.0 > ] keep r> ? ] if ; inline
 
 : ray-sphere ( sphere ray -- t )
     2dup sphere-v tuck sphere-b [ sphere-disc ] keep
     over 0.0 < [ 2drop 1.0/0.0 ] [ swap sqrt sphere-b/d ] if ;
+    inline
 
 : sphere-n ( ray sphere l -- n )
     pick ray-dir n*v swap sphere-center v- swap ray-orig v+ ;
+    inline
 
 : if-ray-sphere ( hit ray sphere quot -- hit )
     #! quot: hit ray sphere l -- hit
@@ -69,20 +71,20 @@ M: group intersect-scene ( hit ray group -- hit )
         drop
     ] if-ray-sphere ;
 
-: initial-hit T{ hit f { 0.0 0.0 0.0 } 1.0/0.0 } ;
+: initial-hit T{ hit f { 0.0 0.0 0.0 } 1.0/0.0 } ; inline
 
 : initial-intersect ( ray scene -- hit )
-    initial-hit -rot intersect-scene ;
+    initial-hit -rot intersect-scene ; inline
 
 : ray-o ( ray hit -- o )
     over ray-dir over hit-lambda v*n
     swap hit-normal delta v*n v+
-    swap ray-orig v+ ;
+    swap ray-orig v+ ; inline
 
 : sray-intersect ( ray scene hit -- ray )
-    swap >r ray-o light vneg <ray> r> initial-intersect ;
+    swap >r ray-o light vneg <ray> r> initial-intersect ; inline
 
-: ray-g ( hit -- g ) hit-normal light v. ;
+: ray-g ( hit -- g ) hit-normal light v. ; inline
 
 : cast-ray ( ray scene -- g )
     2dup initial-intersect dup hit-lambda 1.0/0.0 = [
@@ -90,9 +92,10 @@ M: group intersect-scene ( hit ray group -- hit )
     ] [
         dup ray-g >r sray-intersect hit-lambda 1.0/0.0 =
         [ r> neg ] [ r> drop 0.0 ] if
-    ] if ;
+    ] if ; inline
 
-: create-center ( c r d -- c2 ) >r 3.0 12.0 sqrt / * r> n*v v+ ;
+: create-center ( c r d -- c2 )
+    >r 3.0 12.0 sqrt / * r> n*v v+ ; inline
 
 DEFER: create ( level c r -- scene )
 
diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor
index 29f717929a..72ebb79b79 100644
--- a/library/bootstrap/boot-stage1.factor
+++ b/library/bootstrap/boot-stage1.factor
@@ -117,6 +117,7 @@ vectors words ;
         "/library/compiler/inference/stack.factor"
         "/library/compiler/inference/known-words.factor"
 
+        "/library/compiler/optimizer/specializers.factor"
         "/library/compiler/optimizer/class-infer.factor"
         "/library/compiler/optimizer/kill-literals.factor"
         "/library/compiler/optimizer/optimizer.factor"
diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor
index ec7681d4ef..9381b12507 100644
--- a/library/compiler/compiler.factor
+++ b/library/compiler/compiler.factor
@@ -7,7 +7,7 @@ namespaces optimizer prettyprint sequences test words ;
 : (compile) ( word -- )
     [
         [
-            dup word-def dataflow optimize generate
+            dup specialized-def dataflow optimize generate
         ] keep
     ] benchmark nip
     "compile-time" set-word-prop ;
diff --git a/library/compiler/optimizer/specializers.factor b/library/compiler/optimizer/specializers.factor
new file mode 100644
index 0000000000..9fc239f283
--- /dev/null
+++ b/library/compiler/optimizer/specializers.factor
@@ -0,0 +1,33 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler
+USING: arrays generic kernel math namespaces sequences words ;
+
+: make-specializer ( quot class picker -- quot )
+    over \ object eq? [
+        2drop
+    ] [
+        [
+            , "predicate" word-prop % dup , , \ if ,
+        ] [ ] make
+    ] if ;
+
+: specialized-def ( word -- quot )
+    dup word-def swap "specializer" word-prop [
+        reverse-slice { dup over pick } [
+            make-specializer
+        ] 2each
+    ] when* ;
+
+{ vneg norm-sq norm normalize } [
+    { array } "specializer" set-word-prop
+] each
+
+\ n*v { object array } "specializer" set-word-prop
+\ v*n { array object } "specializer" set-word-prop
+\ n/v { object array } "specializer" set-word-prop
+\ v/n { array object } "specializer" set-word-prop
+
+{ v+ v- v* v/ vmax vmin v. } [
+    { array array } "specializer" set-word-prop
+] each
diff --git a/library/test/benchmark/fib.factor b/library/test/benchmark/fib.factor
index 2b9e76e683..c9602a4458 100644
--- a/library/test/benchmark/fib.factor
+++ b/library/test/benchmark/fib.factor
@@ -5,6 +5,7 @@ USE: math
 USE: test
 USE: math-internals
 USE: namespaces
+USE: words
 
 ! Five fibonacci implementations, each one slower than the
 ! previous.
@@ -31,8 +32,10 @@ USE: namespaces
 [ 9227465 ] [ 34 fixnum-fib ] unit-test
 
 : fib ( n -- nth fibonacci number )
-    dup 1 <= [ drop 1 ] [ 1- dup fib swap 1- fib + ] if ;
-    compiled
+    dup 1 <= [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ;
+
+\ fib { fixnum } "specializer" set-word-prop
+\ fib compile
 
 [ 9227465 ] [ 34 fib ] unit-test
 

From eb4ba47ef1b19b552301024dd330f25d295981ed Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Tue, 2 May 2006 05:49:52 +0000
Subject: [PATCH 072/112] New optimizations: useless coerce elimination,
 builtin slot type declarations

---
 library/bootstrap/boot-stage2.factor          |   3 +
 library/bootstrap/primitives.factor           | 117 ++++++++++++++----
 library/collections/hashtables.factor         |  37 +++---
 library/compiler/inference/dataflow.factor    |   4 +
 library/compiler/inference/known-words.factor |  20 ++-
 .../compiler/optimizer/call-optimizers.factor |  13 ++
 library/compiler/optimizer/class-infer.factor |   3 +
 .../compiler/optimizer/inline-methods.factor  |   8 +-
 .../compiler/optimizer/print-dataflow.factor  |   8 +-
 .../compiler/optimizer/specializers.factor    |  10 +-
 library/generic/math-combination.factor       |  10 +-
 library/generic/slots.factor                  |  23 ++--
 library/kernel.factor                         |   1 +
 13 files changed, 183 insertions(+), 74 deletions(-)

diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor
index 2e315e9599..0b5ee6173f 100644
--- a/library/bootstrap/boot-stage2.factor
+++ b/library/bootstrap/boot-stage2.factor
@@ -23,6 +23,9 @@ H{ } clone help-graph set-global xref-articles
 
     "Compiling base..." print flush
 
+    \ slot \ set-slot [ usage ] 2apply append
+    [ try-compile ] each
+
     \ + compile
     \ = compile
     { "kernel" "sequences" "assembler" } compile-vocabs
diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor
index 26a9491e4a..ac6724851f 100644
--- a/library/bootstrap/primitives.factor
+++ b/library/bootstrap/primitives.factor
@@ -268,11 +268,17 @@ num-types f <array> builtins set
 
 "cons?" "lists" create t "inline" set-word-prop
 "cons" "lists" create 2 "cons?" "lists" create
-{ { 0 { "car" "lists" } f } { 1 { "cdr" "lists" } f } } define-builtin
+{
+    { 0 object { "car" "lists" } f }
+    { 1 object { "cdr" "lists" } f }
+} define-builtin
 
 "ratio?" "math" create t "inline" set-word-prop
 "ratio" "math" create 4 "ratio?" "math" create
-{ { 0 { "numerator" "math" } f } { 1 { "denominator" "math" } f } } define-builtin
+{
+    { 0 integer { "numerator" "math" } f }
+    { 1 integer { "denominator" "math" } f }
+} define-builtin
 "ratio" "math" create 2 "math-priority" set-word-prop
 
 "float?" "math" create t "inline" set-word-prop
@@ -282,11 +288,14 @@ num-types f <array> builtins set
 
 "complex?" "math" create t "inline" set-word-prop
 "complex" "math" create 6 "complex?" "math" create
-{ { 0 { "real" "math" } f } { 1 { "imaginary" "math" } f } } define-builtin
+{
+    { 0 real { "real" "math" } f }
+    { 1 real { "imaginary" "math" } f }
+} define-builtin
 "complex" "math" create 4 "math-priority" set-word-prop
 
 "alien" "alien" create 7 "alien?" "alien" create
-{ { 1 { "underlying-alien" "alien" } f } } define-builtin
+{ { 1 object { "underlying-alien" "alien" } f } } define-builtin
 
 "array?" "arrays" create t "inline" set-word-prop
 "array" "arrays" create 8 "array?" "arrays" create
@@ -298,49 +307,115 @@ num-types f <array> builtins set
 "hashtable?" "hashtables" create t "inline" set-word-prop
 "hashtable" "hashtables" create 10 "hashtable?" "hashtables" create
 {
-    { 1 { "hash-count" "hashtables" } { "set-hash-count" "hashtables-internals" } }
-    { 2 { "hash-deleted" "hashtables" } { "set-hash-deleted" "hashtables-internals" } }
-    { 3 { "hash-array" "hashtables-internals" } { "set-hash-array" "hashtables-internals" } }
+    {
+        1
+        fixnum
+        { "hash-count" "hashtables" }
+        { "set-hash-count" "hashtables-internals" }
+    } {
+        2
+        fixnum
+        { "hash-deleted" "hashtables" }
+        { "set-hash-deleted" "hashtables-internals" }
+    } {
+        3
+        array
+        { "hash-array" "hashtables-internals" }
+        { "set-hash-array" "hashtables-internals" }
+    }
 } define-builtin
 
 "vector?" "vectors" create t "inline" set-word-prop
 "vector" "vectors" create 11 "vector?" "vectors" create
 {
-    { 1 { "length" "sequences" } { "set-fill" "sequences-internals" } }
-    { 2 { "underlying" "sequences-internals" } { "set-underlying" "sequences-internals" } }
+    {
+        1
+        fixnum
+        { "length" "sequences" }
+        { "set-fill" "sequences-internals" }
+    } {
+        2
+        array
+        { "underlying" "sequences-internals" }
+        { "set-underlying" "sequences-internals" }
+    }
 } define-builtin
 
 "string?" "strings" create t "inline" set-word-prop
 "string" "strings" create 12 "string?" "strings" create
 {
-    { 1 { "length" "sequences" } f }
-    { 2 { "string-hashcode" "kernel-internals" } { "set-string-hashcode" "kernel-internals" } }
+    {
+        1
+        fixnum
+        { "length" "sequences" }
+        f
+    } {
+        2
+        fixnum
+        { "string-hashcode" "kernel-internals" }
+        { "set-string-hashcode" "kernel-internals" }
+    }
 } define-builtin
 
 "sbuf?" "strings" create t "inline" set-word-prop 
 "sbuf" "strings" create 13 "sbuf?" "strings" create
 {
-    { 1 { "length" "sequences" } { "set-fill" "sequences-internals" } }
-    { 2 { "underlying" "sequences-internals" } { "set-underlying" "sequences-internals" } }
+    {
+        1
+        fixnum
+        { "length" "sequences" }
+        { "set-fill" "sequences-internals" }
+    }
+    {
+        2
+        string
+        { "underlying" "sequences-internals" }
+        { "set-underlying" "sequences-internals" }
+    }
 } define-builtin
 
 "wrapper?" "kernel" create t "inline" set-word-prop
 "wrapper" "kernel" create 14 "wrapper?" "kernel" create
-{ { 1 { "wrapped" "kernel" } f } } define-builtin
+{ { 1 object { "wrapped" "kernel" } f } } define-builtin
 
 "dll?" "alien" create t "inline" set-word-prop
 "dll" "alien" create 15 "dll?" "alien" create
-{ { 1 { "dll-path" "alien" } f } } define-builtin
+{ { 1 object { "dll-path" "alien" } f } } define-builtin
 
 "word?" "words" create t "inline" set-word-prop
 "word" "words" create 16 "word?" "words" create
 {
-    { 1 { "hashcode" "kernel" } f }
-    { 2 { "word-name" "words" } f }
-    { 3 { "word-vocabulary" "words" } { "set-word-vocabulary" "words" } }
-    { 4 { "word-primitive" "words" } { "set-word-primitive" "words" } }
-    { 5 { "word-def" "words" } { "set-word-def" "words" } }
-    { 6 { "word-props" "words" } { "set-word-props" "words" } }
+    { 1 fixnum { "hashcode" "kernel" } f }
+    {
+        2
+        object
+        { "word-name" "words" }
+        f
+    }
+    {
+        3
+        object
+        { "word-vocabulary" "words" }
+        { "set-word-vocabulary" "words" }
+    }
+    {
+        4
+        object
+        { "word-primitive" "words" }
+        { "set-word-primitive" "words" }
+    }
+    {
+        5
+        object
+        { "word-def" "words" }
+        { "set-word-def" "words" }
+    }
+    {
+        6
+        object
+        { "word-props" "words" }
+        { "set-word-props" "words" }
+    }
 } define-builtin
 
 "tuple?" "kernel" create t "inline" set-word-prop
diff --git a/library/collections/hashtables.factor b/library/collections/hashtables.factor
index f8b6c1bdf1..0d625d6721 100644
--- a/library/collections/hashtables.factor
+++ b/library/collections/hashtables.factor
@@ -9,9 +9,10 @@ TUPLE: tombstone ;
 : ((empty)) T{ tombstone f } ; inline
 : ((tombstone)) T{ tombstone t } ; inline
 
-: hash@ ( key keys -- n ) >r hashcode r> length 2 /i rem 2 * ;
+: hash@ ( key keys -- n )
+    >r hashcode r> length 2 /i rem 2 * ; inline
 
-: probe ( heys i -- hash i ) 2 + over length mod ;
+: probe ( heys i -- hash i ) 2 + over length mod ; inline
 
 : (key@) ( key keys i -- n )
     3dup swap nth-unsafe {
@@ -21,12 +22,14 @@ TUPLE: tombstone ;
         { [ t ] [ probe (key@) ] }
     } cond ;
 
-: key@ ( key hash -- n ) hash-array 2dup hash@ (key@) ;
+: key@ ( key hash -- n )
+    hash-array 2dup hash@ (key@) ; inline
 
 : if-key ( key hash true false -- | true: index key hash -- )
     >r >r [ key@ ] 2keep pick -1 > r> r> if ; inline
 
-: <hash-array> ( n -- array ) 1+ 4 * ((empty)) <array> ;
+: <hash-array> ( n -- array )
+    1+ 4 * ((empty)) <array> ; inline
 
 : init-hash ( hash -- )
     0 over set-hash-count 0 swap set-hash-deleted ;
@@ -39,35 +42,38 @@ TUPLE: tombstone ;
         2drop 2nip
     ] [
         = [ 2nip ] [ probe (new-key@) ] if
-    ] if ;
+    ] if ; inline
 
 : new-key@ ( key hash -- n )
-    hash-array 2dup hash@ (new-key@) ;
+    hash-array 2dup hash@ (new-key@) ; inline
 
 : nth-pair ( n seq -- key value )
-    [ nth-unsafe ] 2keep >r 1+ r> nth-unsafe ;
+    [ nth-unsafe ] 2keep >r 1+ r> nth-unsafe ; inline
 
 : set-nth-pair ( value key n seq -- )
-    [ set-nth-unsafe ] 2keep >r 1+ r> set-nth-unsafe ;
+    [ set-nth-unsafe ] 2keep >r 1+ r> set-nth-unsafe ; inline
 
-: hash-count+ dup hash-count 1+ swap set-hash-count ;
+: hash-count+
+    dup hash-count 1+ swap set-hash-count ; inline
 
-: hash-deleted+ dup hash-deleted 1+ swap set-hash-deleted ;
+: hash-deleted+
+    dup hash-deleted 1+ swap set-hash-deleted ; inline
 
-: hash-deleted- dup hash-deleted 1- swap set-hash-deleted ;
+: hash-deleted-
+    dup hash-deleted 1- swap set-hash-deleted ; inline
 
 : change-size ( hash old -- )
     dup ((tombstone)) eq? [
         drop hash-deleted-
     ] [
         ((empty)) eq? [ hash-count+ ] [ drop ] if
-    ] if ;
+    ] if ; inline
 
 : (set-hash) ( value key hash -- )
     2dup new-key@ swap
     [ hash-array 2dup nth-unsafe ] keep
     ( value key n hash-array old hash )
-    swap change-size set-nth-pair ;
+    swap change-size set-nth-pair ; inline
 
 : (each-pair) ( quot array i -- | quot: k v -- )
     over length over number= [
@@ -137,7 +143,8 @@ IN: hashtables
         3drop
     ] if-key ;
 
-: hash-size ( hash -- n ) dup hash-count swap hash-deleted - ;
+: hash-size ( hash -- n )
+    dup hash-count swap hash-deleted - ; inline
 
 : hash-empty? ( hash -- ? ) hash-size zero? ;
 
@@ -148,7 +155,7 @@ IN: hashtables
 
 : ?grow-hash ( hash -- )
     dup hash-count 3 * over hash-array length >
-    [ dup grow-hash ] when drop ;
+    [ dup grow-hash ] when drop ; inline
 
 : set-hash ( value key hash -- )
     [ (set-hash) ] keep ?grow-hash ;
diff --git a/library/compiler/inference/dataflow.factor b/library/compiler/inference/dataflow.factor
index 49ab412be5..ae37bf2d08 100644
--- a/library/compiler/inference/dataflow.factor
+++ b/library/compiler/inference/dataflow.factor
@@ -90,6 +90,10 @@ TUPLE: #terminate ;
 C: #terminate make-node ;
 : #terminate ( -- node ) empty-node <#terminate> ;
 
+TUPLE: #declare ;
+C: #declare make-node ;
+: #declare ( classes -- node ) param-node <#declare> ;
+
 : node-inputs ( d-count r-count node -- )
     tuck
     >r r-tail r> set-node-in-r
diff --git a/library/compiler/inference/known-words.factor b/library/compiler/inference/known-words.factor
index 553b22a991..7ae0d7b8c8 100644
--- a/library/compiler/inference/known-words.factor
+++ b/library/compiler/inference/known-words.factor
@@ -4,13 +4,14 @@ hashtables-internals interpreter io io-internals kernel
 kernel-internals lists math math-internals memory parser
 sequences strings vectors words prettyprint ;
 
-! We transform calls to these words into 'branched' forms;
-! eg, there is no VOP for fixnum<=, only fixnum<= followed
-! by an #if, so if we have a 'bare' fixnum<= we add
-! [ t ] [ f ] if at the end.
+\ declare [
+    pop-literal nip
+    dup length ensure-values
+    dup #declare [ >r length d-tail r> set-node-in-d ] keep
+    node,
+] "infer" set-word-prop
+\ declare [ [ object ] [ ] ] "infer-effect" set-word-prop
 
-! This transformation really belongs in the optimizer, but it
-! is simpler to do it here.
 \ fixnum< [ [ fixnum fixnum ] [ object ] ] "infer-effect" set-word-prop
 \ fixnum< t "flushable" set-word-prop
 \ fixnum< t "foldable" set-word-prop
@@ -31,13 +32,6 @@ sequences strings vectors words prettyprint ;
 \ eq? t "flushable" set-word-prop
 \ eq? t "foldable" set-word-prop
 
-: manual-branch ( word -- )
-    dup "infer-effect" word-prop consume/produce
-    [ [ t ] [ f ] if ] infer-quot ;
-
-! { fixnum<= fixnum< fixnum>= fixnum> eq? }
-! [ dup [ manual-branch ] curry "infer" set-word-prop ] each
-
 ! Primitive combinators
 \ call [ [ general-list ] [ ] ] "infer-effect" set-word-prop
 
diff --git a/library/compiler/optimizer/call-optimizers.factor b/library/compiler/optimizer/call-optimizers.factor
index 4f90bd6279..ecf566fa03 100644
--- a/library/compiler/optimizer/call-optimizers.factor
+++ b/library/compiler/optimizer/call-optimizers.factor
@@ -62,6 +62,19 @@ math math-internals sequences words ;
     { [ dup disjoint-eq? ] [ [ f ] inline-literals ] }
 } define-optimizers
 
+: useless-coerce? ( node -- )
+    dup node-in-d first over node-classes ?hash
+    swap node-param "infer-effect" word-prop second first eq? ;
+
+: call>no-op ( node -- node )
+    [ ] dataflow [ subst-node ] keep ;
+
+{ >fixnum >bignum >float } [
+    {
+        { [ dup useless-coerce? ] [ call>no-op ] }
+    } define-optimizers
+] each
+
 ! Arithmetic identities
 SYMBOL: @
 
diff --git a/library/compiler/optimizer/class-infer.factor b/library/compiler/optimizer/class-infer.factor
index 51f93e63dc..9902d88176 100644
--- a/library/compiler/optimizer/class-infer.factor
+++ b/library/compiler/optimizer/class-infer.factor
@@ -134,6 +134,9 @@ M: #dispatch child-ties ( node -- seq )
     dup node-in-d first
     swap node-children length [ <literal-tie> ] map-with ;
 
+M: #declare infer-classes* ( node -- )
+    dup node-param swap node-in-d [ set-value-class* ] 2each ;
+
 DEFER: (infer-classes)
 
 : infer-children ( node -- )
diff --git a/library/compiler/optimizer/inline-methods.factor b/library/compiler/optimizer/inline-methods.factor
index a83cf68f1f..2f8e2e007c 100644
--- a/library/compiler/optimizer/inline-methods.factor
+++ b/library/compiler/optimizer/inline-methods.factor
@@ -71,26 +71,24 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
     last-node 2dup swap post-inline set-node-successor ;
 
 : inline-method ( node -- node )
-    #! We set the #call node's param to f so that it gets killed
-    #! later.
     dup method-dataflow
     [ >r node-param r> remember-node ] 2keep
     [ subst-node ] keep ;
 
-: related? ( actual testing -- ? )
+: 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 dup node-in-d node-classes* first r> related?
+        >r dup node-in-d node-classes* first r> comparable?
     ] [
         2drop f
     ] if ;
 
 : inline-literals ( node literals -- node )
-    #! Make #push -> #return -> successor
+    #! Make #shuffle -> #push -> #return -> successor
     over drop-inputs [
         >r >list [ literalize ] map dataflow [ subst-node ] keep
         r> set-node-successor
diff --git a/library/compiler/optimizer/print-dataflow.factor b/library/compiler/optimizer/print-dataflow.factor
index 6dc50e55c7..68fddd529e 100644
--- a/library/compiler/optimizer/print-dataflow.factor
+++ b/library/compiler/optimizer/print-dataflow.factor
@@ -65,13 +65,7 @@ M: #dispatch node>quot ( ? node -- )
 M: #return node>quot ( ? node -- )
     dup node-param unparse "#return " swap append comment, ;
 
-M: #values node>quot ( ? node -- ) "#values" comment, ;
-
-M: #merge node>quot ( ? node -- ) "#merge" comment, ;
-
-M: #entry node>quot ( ? node -- ) "#entry" comment, ;
-
-M: #terminate node>quot ( ? node -- ) "#terminate" comment, ;
+M: object node>quot ( ? node -- ) dup class comment, ;
 
 : (dataflow>quot) ( ? node -- )
     dup [
diff --git a/library/compiler/optimizer/specializers.factor b/library/compiler/optimizer/specializers.factor
index 9fc239f283..4c6aa1ea7d 100644
--- a/library/compiler/optimizer/specializers.factor
+++ b/library/compiler/optimizer/specializers.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: compiler
-USING: arrays generic kernel math namespaces sequences words ;
+USING: arrays generic hashtables kernel math namespaces
+sequences words ;
 
 : make-specializer ( quot class picker -- quot )
     over \ object eq? [
@@ -31,3 +32,10 @@ USING: arrays generic kernel math namespaces sequences words ;
 { v+ v- v* v/ vmax vmin v. } [
     { array array } "specializer" set-word-prop
 ] each
+
+\ hash* { object hashtable } "specializer" set-word-prop
+\ remove-hash { object hashtable } "specializer" set-word-prop
+\ set-hash { object object hashtable } "specializer" set-word-prop
+
+{ first first2 first3 first4 }
+[ { array } "specializer" set-word-prop ] each
diff --git a/library/generic/math-combination.factor b/library/generic/math-combination.factor
index f8bc656571..68b677d0cf 100644
--- a/library/generic/math-combination.factor
+++ b/library/generic/math-combination.factor
@@ -48,7 +48,7 @@ TUPLE: no-math-method left right generic ;
         2drop object-method
     ] if ;
 
-: math-vtable ( picker quot -- )
+: math-vtable ( picker quot -- quot )
     [
         swap , \ tag ,
         [ num-tags [ type>class ] map swap map % ] { } make ,
@@ -58,7 +58,7 @@ TUPLE: no-math-method left right generic ;
 : math-class? ( object -- ? )
     dup word? [ "math-priority" word-prop ] [ drop f ] if ;
 
-: math-combination ( word -- vtable )
+: math-combination ( word -- quot )
     \ over [
         dup math-class? [
             \ dup [ >r 2dup r> math-method ] math-vtable
@@ -67,5 +67,11 @@ TUPLE: no-math-method left right generic ;
         ] if nip
     ] math-vtable nip ;
 
+: partial-math-dispatch ( word class left/right -- vtable )
+    dup \ dup \ over ? [
+        ( word class left/right class )
+        >r 3dup r> swap [ swap ] unless math-method
+    ] math-vtable >r 3drop r> ;
+
 PREDICATE: generic 2generic ( word -- ? )
     "combination" word-prop [ math-combination ] = ;
diff --git a/library/generic/slots.factor b/library/generic/slots.factor
index b08ced86fe..4ce26c9aa2 100644
--- a/library/generic/slots.factor
+++ b/library/generic/slots.factor
@@ -15,20 +15,24 @@ parser sequences strings words ;
         2drop 2drop
     ] if ;
 
-: define-reader ( class slot reader -- )
-    [ slot ] define-slot-word ;
+: define-reader ( class slot decl reader -- )
+    [ slot ] rot dup object eq? [
+        drop
+    ] [
+        1array [ declare ] curry append
+    ] if define-slot-word ;
 
 : define-writer ( class slot writer -- )
     [ set-slot ] define-slot-word ;
 
-: define-slot ( class slot reader writer -- )
-    >r >r 2dup r> define-reader r> define-writer ;
+: define-slot ( class slot decl reader writer -- )
+    >r >r >r 2dup r> r> define-reader r> define-writer ;
 
 : intern-slots ( spec -- spec )
-    [ first3 [ dup [ first2 create ] when ] 2apply 3array ] map ;
+    [ [ dup array? [ first2 create ] when ] map ] map ;
 
 : define-slots ( class spec -- )
-    [ first3 define-slot ] each-with ;
+    [ first4 define-slot ] each-with ;
 
 : reader-word ( class name -- word )
     >r word-name "-" r> append3 in get 2array ;
@@ -36,10 +40,9 @@ parser sequences strings words ;
 : writer-word ( class name -- word )
     [ swap "set-" % word-name % "-" % % ] "" make in get 2array ;
 
-: simple-slot ( class name -- reader writer )
-    [ reader-word ] 2keep writer-word ;
+: simple-slot ( class name -- )
+    2dup reader-word , writer-word , ;
 
 : simple-slots ( class slots base -- spec )
     over length [ + ] map-with
-    [ >r dupd simple-slot r> -rot 3array ] 2map nip
-    intern-slots ;
+    [ [ , object , dupd simple-slot ] { } make ] 2map nip intern-slots ;
diff --git a/library/kernel.factor b/library/kernel.factor
index aa0249b43b..871a0889b6 100644
--- a/library/kernel.factor
+++ b/library/kernel.factor
@@ -79,6 +79,7 @@ M: wrapper literalize <wrapper> ;
 IN: kernel-internals
 
 ! These words are unsafe. Don't use them.
+: declare ( types -- ) drop ;
 
 : array-capacity 1 slot ; inline
 : array-nth swap 2 fixnum+fast slot ; inline

From fd3f37c8e3125194ae04a330f244891463dbd288 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Tue, 2 May 2006 07:05:57 +0000
Subject: [PATCH 073/112] Aggressive arithmetic inlining

---
 .../compiler/optimizer/call-optimizers.factor |   9 +-
 library/compiler/optimizer/class-infer.factor |   3 +
 .../compiler/optimizer/inline-methods.factor  | 104 +++++++++++-------
 library/generic/math-combination.factor       |  12 +-
 library/tools/describe.factor                 |   2 +-
 5 files changed, 76 insertions(+), 54 deletions(-)

diff --git a/library/compiler/optimizer/call-optimizers.factor b/library/compiler/optimizer/call-optimizers.factor
index ecf566fa03..4d627d5d3e 100644
--- a/library/compiler/optimizer/call-optimizers.factor
+++ b/library/compiler/optimizer/call-optimizers.factor
@@ -1,5 +1,5 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 IN: optimizer
 USING: arrays errors generic hashtables inference kernel lists
 math math-internals sequences words ;
@@ -63,7 +63,7 @@ math math-internals sequences words ;
 } define-optimizers
 
 : useless-coerce? ( node -- )
-    dup node-in-d first over node-classes ?hash
+    dup node-in-d first over node-class
     swap node-param "infer-effect" word-prop second first eq? ;
 
 : call>no-op ( node -- node )
@@ -185,7 +185,6 @@ M: #call optimize-node* ( node -- node/t )
         { [ dup partial-eval? ] [ partial-eval ] }
         { [ dup find-identity nip ] [ apply-identities ] }
         { [ dup optimizer-hooks ] [ optimize-hooks ] }
-        { [ dup inlining-class ] [ inline-method ] }
         { [ dup optimize-predicate? ] [ optimize-predicate ] }
-        { [ t ] [ drop t ] }
+        { [ t ] [ inline-method ] }
     } cond ;
diff --git a/library/compiler/optimizer/class-infer.factor b/library/compiler/optimizer/class-infer.factor
index 9902d88176..0e05e8ea46 100644
--- a/library/compiler/optimizer/class-infer.factor
+++ b/library/compiler/optimizer/class-infer.factor
@@ -6,6 +6,9 @@ kernel-internals math namespaces sequences words ;
 
 ! Infer possible classes of values in a dataflow IR.
 
+: node-class ( value node -- class )
+    node-classes ?hash [ object ] unless* ;
+
 ! Variables used by the class inferencer
 
 ! Current value --> class mapping
diff --git a/library/compiler/optimizer/inline-methods.factor b/library/compiler/optimizer/inline-methods.factor
index 2f8e2e007c..92ce37745e 100644
--- a/library/compiler/optimizer/inline-methods.factor
+++ b/library/compiler/optimizer/inline-methods.factor
@@ -5,55 +5,33 @@ USING: arrays generic hashtables inference kernel lists math
 namespaces sequences words ;
 
 ! Method inlining optimization
+: dispatch# ( #call -- n )
+    node-param "combination" word-prop first ;
 
-GENERIC: dispatching-values ( node word -- seq )
-
-M: object dispatching-values 2drop { } ;
-
-M: standard-generic dispatching-values
-    "combination" word-prop first swap
-    node-in-d reverse-slice nth 1array ;
-
-M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
-
-: node-classes* ( node seq -- seq )
-    >r node-classes r>
-    [ swap ?hash [ object ] unless* ] map-with ;
-
-: dispatching-classes ( node -- seq )
-    dup node-in-d empty? [
-        drop { }
-    ] [
-        dup dup node-param dispatching-values node-classes*
-    ] if ;
+: dispatching-class ( node -- seq )
+    dup dispatch# over node-in-d reverse-slice nth
+    swap node-class ;
 
 : already-inlined? ( node -- ? )
     #! Was this node inlined from definition of 'word'?
     dup node-param swap node-history memq? ;
 
+: specific-method ( word class -- ? ) swap order min-class ;
+
 : inlining-class ( #call -- class )
     #! If the generic dispatch can be eliminated, return the
     #! class of the method that will always be invoked here.
-    dup already-inlined? [
-        drop f
+    dup node-param swap dispatching-class
+    specific-method ;
+
+: will-inline-method ( node -- quot/t )
+    #! t indicates failure
+    dup inlining-class dup [
+        swap node-param "methods" word-prop hash
     ] [
-        dup dispatching-classes dup empty? [
-            2drop f
-        ] [
-            dup all-eq? [
-                first swap node-param order min-class
-            ] [
-                2drop f
-            ] if
-        ] if
+        2drop t
     ] if ;
 
-: will-inline ( node -- quot )
-    dup inlining-class swap node-param "methods" word-prop hash ;
-
-: method-dataflow ( node -- dataflow )
-    dup will-inline swap node-in-d dataflow-with ;
-
 : post-inline ( #return/#values #call/#merge -- )
     dup [
         [
@@ -70,10 +48,17 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
     #! last node of 'new' and the first node of 'old'.
     last-node 2dup swap post-inline set-node-successor ;
 
-: inline-method ( node -- node )
-    dup method-dataflow
-    [ >r node-param r> remember-node ] 2keep
-    [ subst-node ] keep ;
+: (inline-method) ( #call quot -- node )
+    dup t eq? [
+        2drop t
+    ] [
+        over node-in-d dataflow-with
+        [ >r node-param r> remember-node ] 2keep
+        [ subst-node ] keep
+    ] if ;
+
+: inline-standard-method ( node -- node )
+    dup will-inline-method (inline-method) ;
 
 : comparable? ( actual testing -- ? )
     #! If actual is a subset of testing or if the two classes
@@ -98,3 +83,40 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
     dup node-param "predicating" word-prop >r
     dup dup node-in-d node-classes* first r> class<
     1array inline-literals ;
+
+: math-both-known? ( word left right -- ? )
+    math-class-max specific-method ;
+    
+: partial-math ( word class left/right -- vtable )
+    dup \ dup \ over ? [
+        ( word class left/right class )
+        >r 3dup r> swap [ swap ] unless math-method
+    ] math-vtable >r 3drop r> ;
+
+: will-inline-math-method ( word left right -- quot/t )
+    #! t indicates failure
+    {
+        { [ 3dup math-both-known? ] [ math-method ] }
+        { [ 3dup drop specific-method ] [ drop t partial-math ] }
+        { [ 3dup nip specific-method ] [ nip f partial-math ] }
+        { [ t ] [ 3drop t ] }
+    } cond ;
+
+: inline-math-method ( #call -- node )
+    dup node-param
+    over dup node-in-d [ swap node-class ] map-with first2
+    will-inline-math-method (inline-method) ;
+
+: inline-standard-method? ( #call -- ? )
+    dup already-inlined? not swap node-param standard-generic?
+    and ;
+
+: inline-math-method? ( #call -- ? )
+    dup node-history empty? swap node-param 2generic? and ;
+
+: inline-method ( #call -- node )
+    {
+        { [ dup inline-standard-method? ] [ inline-standard-method ] }
+        { [ dup inline-math-method? ] [ inline-math-method ] }
+        { [ t ] [ drop t ] }
+    } cond ;
diff --git a/library/generic/math-combination.factor b/library/generic/math-combination.factor
index 68b677d0cf..c7d2af0882 100644
--- a/library/generic/math-combination.factor
+++ b/library/generic/math-combination.factor
@@ -7,7 +7,11 @@ math namespaces sequences words ;
 ! Math combination for generic dyadic upgrading arithmetic.
 
 : math-priority ( class -- n )
-    "math-priority" word-prop [ 100 ] unless* ;
+    dup "members" word-prop [
+        0 [ math-priority max ] reduce
+    ] [
+        "math-priority" word-prop [ 100 ] unless*
+    ] ?if ;
 
 : math-class< ( class class -- ? )
     [ math-priority ] 2apply < ;
@@ -67,11 +71,5 @@ TUPLE: no-math-method left right generic ;
         ] if nip
     ] math-vtable nip ;
 
-: partial-math-dispatch ( word class left/right -- vtable )
-    dup \ dup \ over ? [
-        ( word class left/right class )
-        >r 3dup r> swap [ swap ] unless math-method
-    ] math-vtable >r 3drop r> ;
-
 PREDICATE: generic 2generic ( word -- ? )
     "combination" word-prop [ math-combination ] = ;
diff --git a/library/tools/describe.factor b/library/tools/describe.factor
index 5bceede23e..69c5a66632 100644
--- a/library/tools/describe.factor
+++ b/library/tools/describe.factor
@@ -31,7 +31,7 @@ M: object summary
 
 : slot-sheet ( obj -- sheet )
     dup class "slots" word-prop
-    dup [ second ] map -rot
+    dup [ third ] map -rot
     [ first slot ] map-with
     2array ;
 

From adca3c8464dfab02cbb288b7da310dac73f13699 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Tue, 2 May 2006 10:05:58 +0000
Subject: [PATCH 074/112] Tweaking some declarations

---
 library/collections/growable.factor           |  9 +++----
 library/collections/namespaces.factor         | 24 +++++++++++--------
 library/collections/sequences-epilogue.factor | 10 ++++----
 library/collections/sequences.factor          |  4 ++--
 .../compiler/optimizer/print-dataflow.factor  |  2 +-
 .../compiler/optimizer/specializers.factor    | 12 ++++++----
 library/continuations.factor                  | 10 +++++---
 7 files changed, 42 insertions(+), 29 deletions(-)

diff --git a/library/collections/growable.factor b/library/collections/growable.factor
index 1beed28947..4c9d13ebec 100644
--- a/library/collections/growable.factor
+++ b/library/collections/growable.factor
@@ -13,7 +13,7 @@ GENERIC: set-fill
 : capacity ( seq -- n ) underlying length ; inline
 
 : expand ( len seq -- )
-    [ underlying resize ] keep set-underlying ;
+    [ underlying resize ] keep set-underlying ; inline
 
 : new-size ( n -- n ) 3 * dup 50 < [ drop 50 ] when ;
 
@@ -22,7 +22,7 @@ GENERIC: set-fill
         >r 1+ r>
         2dup capacity > [ over new-size over expand ] when
         2dup set-fill
-    ] when 2drop ;
+    ] when 2drop ; inline
 
 TUPLE: bounds-error index seq ;
 
@@ -35,7 +35,8 @@ TUPLE: bounds-error index seq ;
     2dup bounds-check? [ bounds-error ] unless ; inline
 
 : grow-length ( len seq -- )
-    growable-check 2dup capacity > [ 2dup expand ] when set-fill ;
+    growable-check 2dup capacity > [ 2dup expand ] when set-fill
+    ; inline
 
 : clone-growable ( obj -- obj )
-    (clone) dup underlying clone over set-underlying ;
+    (clone) dup underlying clone over set-underlying ; inline
diff --git a/library/collections/namespaces.factor b/library/collections/namespaces.factor
index 6f7cd3cfd7..70b0cab312 100644
--- a/library/collections/namespaces.factor
+++ b/library/collections/namespaces.factor
@@ -1,19 +1,23 @@
-! Copyright (C) 2003, 2005 Slava Pestov.
+! Copyright (C) 2003, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+IN: kernel-internals
+USING: vectors ;
+
+: namestack* ( -- ns ) 3 getenv { vector } declare ; inline
+
 IN: namespaces
 USING: arrays hashtables kernel kernel-internals lists math
-sequences strings vectors words ;
+sequences strings words ;
 
-: namestack* ( -- ns ) 3 getenv ; inline
 : namestack ( -- ns ) namestack* clone ; inline
-: set-namestack ( ns -- ) clone 3 setenv ; inline
-: namespace ( -- namespace ) namestack* peek ; inline
-: >n ( namespace -- n:namespace ) namestack* push ; inline
-: n> ( n:namespace -- namespace ) namestack* pop ; inline
-: ndrop ( n:namespace -- ) namestack* pop* ; inline
-: global ( -- g ) 4 getenv ; inline
+: set-namestack ( ns -- ) >vector 3 setenv ; inline
+: namespace ( -- namespace ) namestack* peek ;
+: >n ( namespace -- n:namespace ) namestack* push ;
+: n> ( n:namespace -- namespace ) namestack* pop ;
+: ndrop ( n:namespace -- ) namestack* pop* ;
+: global ( -- g ) 4 getenv { hashtable } declare ; inline
 : get ( variable -- value ) namestack* hash-stack ; flushable
-: set ( value variable -- ) namespace set-hash ;
+: set ( value variable -- ) namespace set-hash ; inline
 : on ( var -- ) t swap set ; inline
 : off ( var -- ) f swap set ; inline
 : get-global ( var -- value ) global hash ; inline
diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor
index f37f61c5c0..5d6de06034 100644
--- a/library/collections/sequences-epilogue.factor
+++ b/library/collections/sequences-epilogue.factor
@@ -5,13 +5,13 @@ USING: errors generic kernel kernel-internals math
 sequences-internals strings vectors words ;
 
 : first2 ( { x y } -- x y )
-    1 swap bounds-check nip first2-unsafe ; inline
+    1 swap bounds-check nip first2-unsafe ; flushable
 
 : first3 ( { x y z } -- x y z )
-    2 swap bounds-check nip first3-unsafe ; inline
+    2 swap bounds-check nip first3-unsafe ; flushable
 
 : first4 ( { x y z w } -- x y z w )
-    3 swap bounds-check nip first4-unsafe ; inline
+    3 swap bounds-check nip first4-unsafe ; flushable
 
 M: object like drop ;
 
@@ -93,10 +93,10 @@ M: object like drop ;
 : pop* ( sequence -- )
     [ length 1- ] keep
     [ 0 -rot set-nth ] 2keep
-    set-length ; inline
+    set-length ;
 
 : pop ( sequence -- element )
-    dup peek swap pop* ; inline
+    dup peek swap pop* ;
 
 M: object reverse-slice ( seq -- seq ) <reversed> ;
 
diff --git a/library/collections/sequences.factor b/library/collections/sequences.factor
index 40d2636b95..6ce835d229 100644
--- a/library/collections/sequences.factor
+++ b/library/collections/sequences.factor
@@ -12,7 +12,7 @@ GENERIC: like ( seq seq -- seq ) flushable
 GENERIC: reverse ( seq -- seq ) flushable
 GENERIC: reverse-slice ( seq -- seq ) flushable
 
-: empty? ( seq -- ? ) length zero? ;
+: empty? ( seq -- ? ) length zero? ; inline
 
 : first 0 swap nth ; inline
 : second 1 swap nth ; inline
@@ -20,7 +20,7 @@ GENERIC: reverse-slice ( seq -- seq ) flushable
 : fourth 3 swap nth ; inline
 
 : push ( element sequence -- )
-    dup length swap set-nth ; inline
+    dup length swap set-nth ;
 
 : ?push ( elt seq/f -- seq )
     [ 1 <vector> ] unless* [ push ] keep ;
diff --git a/library/compiler/optimizer/print-dataflow.factor b/library/compiler/optimizer/print-dataflow.factor
index 68fddd529e..d99d21e8c5 100644
--- a/library/compiler/optimizer/print-dataflow.factor
+++ b/library/compiler/optimizer/print-dataflow.factor
@@ -65,7 +65,7 @@ M: #dispatch node>quot ( ? node -- )
 M: #return node>quot ( ? node -- )
     dup node-param unparse "#return " swap append comment, ;
 
-M: object node>quot ( ? node -- ) dup class comment, ;
+M: object node>quot ( ? node -- ) dup class word-name comment, ;
 
 : (dataflow>quot) ( ? node -- )
     dup [
diff --git a/library/compiler/optimizer/specializers.factor b/library/compiler/optimizer/specializers.factor
index 4c6aa1ea7d..c56a6249d1 100644
--- a/library/compiler/optimizer/specializers.factor
+++ b/library/compiler/optimizer/specializers.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: compiler
 USING: arrays generic hashtables kernel math namespaces
-sequences words ;
+sequences vectors words ;
 
 : make-specializer ( quot class picker -- quot )
     over \ object eq? [
@@ -33,9 +33,13 @@ sequences words ;
     { array array } "specializer" set-word-prop
 ] each
 
-\ hash* { object hashtable } "specializer" set-word-prop
-\ remove-hash { object hashtable } "specializer" set-word-prop
-\ set-hash { object object hashtable } "specializer" set-word-prop
+{ hash* remove-hash set-hash } [
+    { hashtable } "specializer" set-word-prop
+] each
 
 { first first2 first3 first4 }
 [ { array } "specializer" set-word-prop ] each
+
+{ peek pop* pop push } [
+    { vector } "specializer" set-word-prop
+] each
diff --git a/library/continuations.factor b/library/continuations.factor
index 2cbea0fc49..fd897ca8ae 100644
--- a/library/continuations.factor
+++ b/library/continuations.factor
@@ -1,9 +1,13 @@
-! Copyright (C) 2003, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! Copyright (C) 2003, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: kernel-internals
+USING: vectors ;
+
+: catchstack* ( -- cs ) 6 getenv { vector } declare ; inline
+
 IN: errors
 USING: kernel kernel-internals ;
 
-: catchstack* ( -- cs ) 6 getenv ; inline
 : catchstack ( -- cs ) catchstack* clone ; inline
 : set-catchstack ( cs -- ) clone 6 setenv ; inline
 

From 5d7d2050810eb13c31c48a8abbd15801fe76935f Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Tue, 2 May 2006 10:13:43 +0000
Subject: [PATCH 075/112] Type inference for clone and (clone)

---
 library/compiler/optimizer/class-infer.factor | 17 ++++++++++-------
 1 file changed, 10 insertions(+), 7 deletions(-)

diff --git a/library/compiler/optimizer/class-infer.factor b/library/compiler/optimizer/class-infer.factor
index 0e05e8ea46..5a7d2cce4f 100644
--- a/library/compiler/optimizer/class-infer.factor
+++ b/library/compiler/optimizer/class-infer.factor
@@ -107,23 +107,26 @@ M: node child-ties ( node -- seq )
     ] if ;
 
 \ make-tuple [
-    dup node-in-d first value-literal 1array
+    node-in-d first value-literal 1array
 ] "output-classes" set-word-prop
 
+{ clone (clone) } [
+    [
+        node-in-d [ value-class* ] map
+    ] "output-classes" set-word-prop
+] each
+
 : output-classes ( node -- seq )
     dup node-param "output-classes" word-prop [
         call
     ] [
         node-param "infer-effect" word-prop second
         dup integer? [ drop f ] when
-    ] ?if ;
+    ] if* ;
 
 M: #call infer-classes* ( node -- )
-    dup node-param [
-        dup create-ties
-        dup output-classes
-        [ over node-out-d intersect-classes ] when*
-    ] when drop ;
+    dup create-ties dup output-classes
+    [ swap node-out-d intersect-classes ] [ drop ] if* ;
 
 M: #push infer-classes* ( node -- )
     node-out-d

From 1a86171a99cde73c1e2feb33936f20097e3d525d Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Tue, 2 May 2006 18:16:59 +0000
Subject: [PATCH 076/112] Working on method inlining optimization

---
 TODO.FACTOR.txt                               |   1 -
 library/bootstrap/primitives.factor           |   5 -
 library/cocoa/utilities.factor                |   3 -
 library/collections/lists.factor              |   5 +-
 library/collections/sequences.factor          |   2 +-
 .../compiler/optimizer/call-optimizers.factor |   2 +-
 library/compiler/optimizer/class-infer.factor |   3 +
 .../compiler/optimizer/inline-methods.factor  | 147 +++++++++---------
 library/compiler/ppc/intrinsics.factor        |   4 +-
 library/generic/generic.factor                |   2 +-
 library/generic/math-combination.factor       |  45 +++---
 library/kernel.factor                         |   6 +-
 library/test/generic.factor                   |   8 +
 13 files changed, 120 insertions(+), 113 deletions(-)

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 579f039da7..d7acafcbb4 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,6 +1,5 @@
 should fix in 0.82:
 
-- type inference busted for tuple constructors
 - constant branch folding
 - fast-slot stuff
 - 3 >n fep
diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor
index ac6724851f..6e4911ea2c 100644
--- a/library/bootstrap/primitives.factor
+++ b/library/bootstrap/primitives.factor
@@ -258,12 +258,10 @@ num-types f <array> builtins set
 
 "fixnum?" "math" create t "inline" set-word-prop
 "fixnum" "math" create 0 "fixnum?" "math" create { } define-builtin
-"fixnum" "math" create 0 "math-priority" set-word-prop
 "fixnum" "math" create ">fixnum" "math" lookup unit "coercer" set-word-prop
 
 "bignum?" "math" create t "inline" set-word-prop
 "bignum" "math" create 1 "bignum?" "math" create { } define-builtin
-"bignum" "math" create 1 "math-priority" set-word-prop
 "bignum" "math" create ">bignum" "math" lookup unit "coercer" set-word-prop
 
 "cons?" "lists" create t "inline" set-word-prop
@@ -279,11 +277,9 @@ num-types f <array> builtins set
     { 0 integer { "numerator" "math" } f }
     { 1 integer { "denominator" "math" } f }
 } define-builtin
-"ratio" "math" create 2 "math-priority" set-word-prop
 
 "float?" "math" create t "inline" set-word-prop
 "float" "math" create 5 "float?" "math" create { } define-builtin
-"float" "math" create 3 "math-priority" set-word-prop
 "float" "math" create ">float" "math" lookup unit "coercer" set-word-prop
 
 "complex?" "math" create t "inline" set-word-prop
@@ -292,7 +288,6 @@ num-types f <array> builtins set
     { 0 real { "real" "math" } f }
     { 1 real { "imaginary" "math" } f }
 } define-builtin
-"complex" "math" create 4 "math-priority" set-word-prop
 
 "alien" "alien" create 7 "alien?" "alien" create
 { { 1 object { "underlying-alien" "alien" } f } } define-builtin
diff --git a/library/cocoa/utilities.factor b/library/cocoa/utilities.factor
index f35555a915..966e456f3e 100644
--- a/library/cocoa/utilities.factor
+++ b/library/cocoa/utilities.factor
@@ -119,9 +119,6 @@ H{
 : class-methods ( classname -- seq )
     objc-meta-class objc-methods ;
 
-: make-dip ( quot n -- quot )
-    dup \ >r <array> -rot \ r> <array> append3 ;
-
 : <super> ( receiver class -- super )
     "objc-super" <c-object>
     [ set-objc-super-class ] keep
diff --git a/library/collections/lists.factor b/library/collections/lists.factor
index 79c6aa5ff8..da71c523b9 100644
--- a/library/collections/lists.factor
+++ b/library/collections/lists.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2003, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: lists USING: errors generic kernel math sequences ;
+IN: lists USING: arrays errors generic kernel math sequences ;
 
 M: f car ;
 M: f cdr ;
@@ -79,6 +79,9 @@ M: cons = ( obj cons -- ? )
 
 : curry ( obj quot -- quot ) >r literalize r> cons ;
 
+: make-dip ( quot n -- quot )
+    dup \ >r <array> -rot \ r> <array> append3 >list ;
+
 : (>list) ( n i seq -- list )
     pick pick <= [
         3drop [ ]
diff --git a/library/collections/sequences.factor b/library/collections/sequences.factor
index 6ce835d229..fbcd04dfbb 100644
--- a/library/collections/sequences.factor
+++ b/library/collections/sequences.factor
@@ -26,7 +26,7 @@ GENERIC: reverse-slice ( seq -- seq ) flushable
     [ 1 <vector> ] unless* [ push ] keep ;
 
 : bounds-check? ( n seq -- ? )
-    over 0 >= [ length < ] [ 2drop f ] if ;
+    over 0 >= [ length < ] [ 2drop f ] if ; inline
 
 : ?nth ( n seq/f -- elt/f )
     2dup bounds-check? [ nth ] [ 2drop f ] if ;
diff --git a/library/compiler/optimizer/call-optimizers.factor b/library/compiler/optimizer/call-optimizers.factor
index 4d627d5d3e..e74453ad0b 100644
--- a/library/compiler/optimizer/call-optimizers.factor
+++ b/library/compiler/optimizer/call-optimizers.factor
@@ -63,7 +63,7 @@ math math-internals sequences words ;
 } define-optimizers
 
 : useless-coerce? ( node -- )
-    dup node-in-d first over node-class
+    dup 0 node-class#
     swap node-param "infer-effect" word-prop second first eq? ;
 
 : call>no-op ( node -- node )
diff --git a/library/compiler/optimizer/class-infer.factor b/library/compiler/optimizer/class-infer.factor
index 5a7d2cce4f..04bb487765 100644
--- a/library/compiler/optimizer/class-infer.factor
+++ b/library/compiler/optimizer/class-infer.factor
@@ -9,6 +9,9 @@ kernel-internals math namespaces sequences words ;
 : node-class ( value node -- class )
     node-classes ?hash [ object ] unless* ;
 
+: node-class# ( node n -- class )
+    swap [ node-in-d reverse-slice nth ] keep node-class ;
+
 ! Variables used by the class inferencer
 
 ! Current value --> class mapping
diff --git a/library/compiler/optimizer/inline-methods.factor b/library/compiler/optimizer/inline-methods.factor
index 92ce37745e..de85a18be8 100644
--- a/library/compiler/optimizer/inline-methods.factor
+++ b/library/compiler/optimizer/inline-methods.factor
@@ -1,37 +1,10 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: optimizer
-USING: arrays generic hashtables inference kernel lists math
-namespaces sequences words ;
-
-! Method inlining optimization
-: dispatch# ( #call -- n )
-    node-param "combination" word-prop first ;
-
-: dispatching-class ( node -- seq )
-    dup dispatch# over node-in-d reverse-slice nth
-    swap node-class ;
-
-: already-inlined? ( node -- ? )
-    #! Was this node inlined from definition of 'word'?
-    dup node-param swap node-history memq? ;
-
-: specific-method ( word class -- ? ) swap order min-class ;
-
-: inlining-class ( #call -- class )
-    #! If the generic dispatch can be eliminated, return the
-    #! class of the method that will always be invoked here.
-    dup node-param swap dispatching-class
-    specific-method ;
-
-: will-inline-method ( node -- quot/t )
-    #! t indicates failure
-    dup inlining-class dup [
-        swap node-param "methods" word-prop hash
-    ] [
-        2drop t
-    ] if ;
+USING: arrays generic hashtables inference kernel
+kernel-internals lists math namespaces sequences words ;
 
+! Some utilities for splicing in dataflow IR subtrees
 : post-inline ( #return/#values #call/#merge -- )
     dup [
         [
@@ -54,12 +27,82 @@ namespaces sequences words ;
     ] [
         over node-in-d dataflow-with
         [ >r node-param r> remember-node ] 2keep
-        [ subst-node ] keep
+        [ subst-node ] keep [ infer-classes ] keep
+    ] if ;
+
+! Single dispatch method inlining optimization
+: dispatch# ( #call -- n )
+    node-param "combination" word-prop first ;
+
+: dispatching-class ( node -- seq ) dup dispatch# node-class# ;
+
+: already-inlined? ( node -- ? )
+    #! Was this node inlined from definition of 'word'?
+    dup node-param swap node-history memq? ;
+
+: specific-method ( word class -- ? ) swap order min-class ;
+
+: inlining-class ( #call -- class )
+    #! If the generic dispatch can be eliminated, return the
+    #! class of the method that will always be invoked here.
+    dup node-param swap dispatching-class
+    specific-method ;
+
+: will-inline-method ( node -- quot/t )
+    #! t indicates failure
+    dup inlining-class dup [
+        swap node-param "methods" word-prop hash
+    ] [
+        2drop t
     ] if ;
 
 : inline-standard-method ( node -- node )
     dup will-inline-method (inline-method) ;
 
+: inline-standard-method? ( #call -- ? )
+    dup already-inlined? not swap node-param standard-generic?
+    and ;
+
+! Partial dispatch of 2generic words
+: math-both-known? ( word left right -- ? )
+    math-class-max specific-method ;
+
+: max-tag ( class -- n ) types peek 1+ num-tags min ;
+
+: left-partial-math ( word left right -- quot/t )
+    #! The left type is known; dispatch on right
+    \ dup swap max-tag
+    [ >r 2dup r> math-method ] math-vtable* 2nip ;
+
+: right-partial-math ( word left right -- quot/t )
+    #! The right type is known; dispatch on left
+    \ over rot max-tag
+    [ >r 2dup r> swap math-method ] math-vtable* 2nip ;
+
+: will-inline-math-method ( word left right -- quot/t )
+    #! t indicates failure
+    {
+        { [ 3dup math-both-known? ] [ math-method ] }
+        { [ 3dup drop specific-method ] [ left-partial-math ] }
+        { [ 3dup nip specific-method ] [ right-partial-math ] }
+        { [ t ] [ 3drop t ] }
+    } cond ;
+
+: inline-math-method ( #call -- node )
+    dup node-param over 1 node-class# pick 0 node-class#
+    will-inline-math-method (inline-method) ;
+
+: inline-math-method? ( #call -- ? )
+    dup node-history empty? swap node-param 2generic? and ;
+
+: inline-method ( #call -- node )
+    {
+        { [ dup inline-standard-method? ] [ inline-standard-method ] }
+        { [ dup inline-math-method? ] [ inline-math-method ] }
+        { [ t ] [ drop 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.
@@ -67,7 +110,7 @@ namespaces sequences words ;
 
 : optimize-predicate? ( #call -- ? )
     dup node-param "predicating" word-prop dup [
-        >r dup node-in-d node-classes* first r> comparable?
+        >r dup 0 node-class# r> comparable?
     ] [
         2drop f
     ] if ;
@@ -81,42 +124,4 @@ namespaces sequences words ;
 
 : optimize-predicate ( #call -- node )
     dup node-param "predicating" word-prop >r
-    dup dup node-in-d node-classes* first r> class<
-    1array inline-literals ;
-
-: math-both-known? ( word left right -- ? )
-    math-class-max specific-method ;
-    
-: partial-math ( word class left/right -- vtable )
-    dup \ dup \ over ? [
-        ( word class left/right class )
-        >r 3dup r> swap [ swap ] unless math-method
-    ] math-vtable >r 3drop r> ;
-
-: will-inline-math-method ( word left right -- quot/t )
-    #! t indicates failure
-    {
-        { [ 3dup math-both-known? ] [ math-method ] }
-        { [ 3dup drop specific-method ] [ drop t partial-math ] }
-        { [ 3dup nip specific-method ] [ nip f partial-math ] }
-        { [ t ] [ 3drop t ] }
-    } cond ;
-
-: inline-math-method ( #call -- node )
-    dup node-param
-    over dup node-in-d [ swap node-class ] map-with first2
-    will-inline-math-method (inline-method) ;
-
-: inline-standard-method? ( #call -- ? )
-    dup already-inlined? not swap node-param standard-generic?
-    and ;
-
-: inline-math-method? ( #call -- ? )
-    dup node-history empty? swap node-param 2generic? and ;
-
-: inline-method ( #call -- node )
-    {
-        { [ dup inline-standard-method? ] [ inline-standard-method ] }
-        { [ dup inline-math-method? ] [ inline-math-method ] }
-        { [ t ] [ drop t ] }
-    } cond ;
+    dup 0 node-class# r> class< 1array inline-literals ;
diff --git a/library/compiler/ppc/intrinsics.factor b/library/compiler/ppc/intrinsics.factor
index 9c48ea3844..9432aee2eb 100644
--- a/library/compiler/ppc/intrinsics.factor
+++ b/library/compiler/ppc/intrinsics.factor
@@ -67,7 +67,7 @@ math-internals namespaces sequences words ;
 ] H{
     { +input { { f "val" } { f "obj" } { f "slot" } } }
     { +scratch { { f "x" } } }
-    { +clobber { "obj" } }
+    { +clobber { "obj" "slot" } }
 } define-intrinsic
 
 \ set-char-slot [
@@ -77,7 +77,7 @@ math-internals namespaces sequences words ;
 ] H{
     { +input { { f "val" } { f "slot" } { f "obj" } } }
     { +scratch { { f "x" } } }
-    { +clobber { "obj" } }
+    { +clobber { "val" "slot" "obj" } }
 } define-intrinsic
 
 : define-binary-op ( word op -- )
diff --git a/library/generic/generic.factor b/library/generic/generic.factor
index f1c7fa9948..50dd653699 100644
--- a/library/generic/generic.factor
+++ b/library/generic/generic.factor
@@ -39,7 +39,7 @@ SYMBOL: builtins
     ] hash-each ;
 
 : types ( class -- types )
-    [ (types) ] make-hash hash-keys ;
+    [ (types) ] make-hash hash-keys natural-sort ;
 
 DEFER: class<
 
diff --git a/library/generic/math-combination.factor b/library/generic/math-combination.factor
index c7d2af0882..8f2a0a05a8 100644
--- a/library/generic/math-combination.factor
+++ b/library/generic/math-combination.factor
@@ -1,35 +1,29 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: generic
-USING: errors generic hashtables kernel kernel-internals lists
-math namespaces sequences words ;
+USING: arrays errors generic hashtables kernel kernel-internals
+lists math namespaces sequences words ;
 
 ! Math combination for generic dyadic upgrading arithmetic.
 
-: math-priority ( class -- n )
-    dup "members" word-prop [
-        0 [ math-priority max ] reduce
-    ] [
-        "math-priority" word-prop [ 100 ] unless*
-    ] ?if ;
+: first/last ( seq -- pair ) dup first swap peek 2array ;
 
-: math-class< ( class class -- ? )
-    [ math-priority ] 2apply < ;
+: math-class-compare ( class class -- n )
+    [
+        dup number class<
+        [ types first/last ] [ drop { 100 100 } ] if
+    ] 2apply <=> ;
 
 : math-class-max ( class class -- class )
-    [ swap math-class< ] 2keep ? ;
+    [ math-class-compare 0 > ] 2keep ? ;
+
+: (math-upgrade) ( max class -- quot )
+    dupd = [ drop [ ] ] [ "coercer" word-prop ] if ;
 
 : math-upgrade ( left right -- quot )
-    2dup math-class< [
-        nip "coercer" word-prop
-        dup [ [ >r ] swap [ r> ] append3 ] when
-    ] [
-        2dup swap math-class< [
-            drop "coercer" word-prop
-        ] [
-            2drop [ ]
-        ] if
-    ] if ;
+    [ math-class-max ] 2keep
+    >r over r> (math-upgrade)
+    >r (math-upgrade) dup [ 1 make-dip ] when r> append ;
 
 TUPLE: no-math-method left right generic ;
 
@@ -52,13 +46,16 @@ TUPLE: no-math-method left right generic ;
         2drop object-method
     ] if ;
 
-: math-vtable ( picker quot -- quot )
+: math-vtable* ( picker max quot -- quot )
     [
-        swap , \ tag ,
-        [ num-tags [ type>class ] map swap map % ] { } make ,
+        rot , \ tag ,
+        [ >r [ type>class ] map r> map % ] { } make ,
         \ dispatch ,
     ] [ ] make ; inline
 
+: math-vtable ( picker quot -- quot )
+    num-tags swap math-vtable* ; inline
+
 : math-class? ( object -- ? )
     dup word? [ "math-priority" word-prop ] [ drop f ] if ;
 
diff --git a/library/kernel.factor b/library/kernel.factor
index 871a0889b6..c18ff92ce1 100644
--- a/library/kernel.factor
+++ b/library/kernel.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
 IN: kernel
-USING: generic kernel-internals math-internals ;
+USING: generic kernel-internals math math-internals ;
 
 : 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline
 
@@ -81,7 +81,7 @@ IN: kernel-internals
 ! These words are unsafe. Don't use them.
 : declare ( types -- ) drop ;
 
-: array-capacity 1 slot ; inline
+: array-capacity 1 slot { fixnum } declare ; inline
 : array-nth swap 2 fixnum+fast slot ; inline
 : set-array-nth swap 2 fixnum+fast set-slot ; inline
 
diff --git a/library/test/generic.factor b/library/test/generic.factor
index 84f044a2e4..c1075377e2 100644
--- a/library/test/generic.factor
+++ b/library/test/generic.factor
@@ -200,3 +200,11 @@ TUPLE: delegating ;
 [ t ] [ \ + 2generic? ] unit-test
 
 [ "SYMBOL: not-a-class C: not-a-class ;" parse ] unit-test-fails
+
+! Test math-combination
+[ [ >r >float r> ] ] [ \ real \ float math-upgrade ] unit-test
+[ [ >float ] ] [ \ float \ real math-upgrade ] unit-test
+[ [ >r >bignum r> ] ] [ \ fixnum \ bignum math-upgrade ] unit-test
+[ [ >float ] ] [ \ float \ integer math-upgrade ] unit-test
+[ number ] [ \ number \ float math-class-max ] unit-test
+[ float ] [ \ real \ float math-class-max ] unit-test

From 229b0c26a44b89fc51e48f379e675436c5c21660 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Wed, 3 May 2006 00:26:48 +0000
Subject: [PATCH 077/112] Minor fixes

---
 doc/handbook/collections.facts                   |  1 -
 examples/mandel.factor                           |  2 +-
 library/collections/namespaces.facts             |  2 +-
 library/compiler/generator/xt.factor             |  4 ++--
 library/compiler/optimizer/inline-methods.factor | 12 ++++++------
 library/compiler/optimizer/optimizer.factor      |  4 ++--
 library/continuations.facts                      |  2 +-
 library/generic/math-combination.factor          |  8 ++++----
 library/generic/math-combination.facts           |  9 ---------
 library/math/math.factor                         |  8 ++++----
 library/tools/annotations.factor                 |  6 +-----
 11 files changed, 22 insertions(+), 36 deletions(-)

diff --git a/doc/handbook/collections.facts b/doc/handbook/collections.facts
index bb35ca060a..ac5991e962 100644
--- a/doc/handbook/collections.facts
+++ b/doc/handbook/collections.facts
@@ -139,7 +139,6 @@ ARTICLE: "namespaces-make" "Constructing sequences"
 
 ARTICLE: "namespaces-internals" "Namespace implementation details"
 "The namestack holds namespaces."
-{ $subsection namestack* }
 { $subsection namestack }
 { $subsection set-namestack }
 "A pair of words push and pop namespaces on the namestack."
diff --git a/examples/mandel.factor b/examples/mandel.factor
index c50491867b..c738ec0f50 100644
--- a/examples/mandel.factor
+++ b/examples/mandel.factor
@@ -70,7 +70,7 @@ strings test ;
     ] map-with ;
 
 : iter ( c z nb-iter -- x )
-    over absq 4.0 >= over 0 = or
+    over absq 4.0 >= over zero? or
     [ 2nip ] [ 1- >r sq dupd + r> iter ] if ; inline
 
 SYMBOL: cols
diff --git a/library/collections/namespaces.facts b/library/collections/namespaces.facts
index cf476d92d9..886f82ae2b 100644
--- a/library/collections/namespaces.facts
+++ b/library/collections/namespaces.facts
@@ -1,5 +1,5 @@
 IN: namespaces
-USING: help ;
+USING: help kernel-internals ;
 
 HELP: get "( variable -- value )"
 { $values { "variable" "a variable, by convention a symbol" } { "value" "the value, or " { $link f } } }
diff --git a/library/compiler/generator/xt.factor b/library/compiler/generator/xt.factor
index b8baa0e517..c2962af6b7 100644
--- a/library/compiler/generator/xt.factor
+++ b/library/compiler/generator/xt.factor
@@ -2,8 +2,8 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: compiler
 USING: assembler errors generic hashtables kernel
-kernel-internals lists math namespaces prettyprint sequences
-strings vectors words ;
+kernel-internals lists math namespaces prettyprint queues
+sequences strings vectors words ;
 
 : <label> ( -- label )
     #! Make a label.
diff --git a/library/compiler/optimizer/inline-methods.factor b/library/compiler/optimizer/inline-methods.factor
index de85a18be8..7e1383047c 100644
--- a/library/compiler/optimizer/inline-methods.factor
+++ b/library/compiler/optimizer/inline-methods.factor
@@ -45,8 +45,7 @@ kernel-internals lists math namespaces sequences words ;
 : inlining-class ( #call -- class )
     #! If the generic dispatch can be eliminated, return the
     #! class of the method that will always be invoked here.
-    dup node-param swap dispatching-class
-    specific-method ;
+    dup node-param swap dispatching-class specific-method ;
 
 : will-inline-method ( node -- quot/t )
     #! t indicates failure
@@ -83,8 +82,8 @@ kernel-internals lists math namespaces sequences words ;
     #! t indicates failure
     {
         { [ 3dup math-both-known? ] [ math-method ] }
-        { [ 3dup drop specific-method ] [ left-partial-math ] }
-        { [ 3dup nip specific-method ] [ right-partial-math ] }
+        ! { [ 3dup drop specific-method ] [ left-partial-math ] }
+        ! { [ 3dup nip specific-method ] [ right-partial-math ] }
         { [ t ] [ 3drop t ] }
     } cond ;
 
@@ -93,7 +92,8 @@ kernel-internals lists math namespaces sequences words ;
     will-inline-math-method (inline-method) ;
 
 : inline-math-method? ( #call -- ? )
-    dup node-history empty? swap node-param 2generic? and ;
+    dup node-history [ 2generic? ] contains? not
+    swap node-param 2generic? and ;
 
 : inline-method ( #call -- node )
     {
@@ -110,7 +110,7 @@ kernel-internals lists math namespaces sequences words ;
 
 : optimize-predicate? ( #call -- ? )
     dup node-param "predicating" word-prop dup [
-        >r dup 0 node-class# r> comparable?
+        >r 0 node-class# r> comparable?
     ] [
         2drop f
     ] if ;
diff --git a/library/compiler/optimizer/optimizer.factor b/library/compiler/optimizer/optimizer.factor
index 4affecae6d..e8bdfec2a0 100644
--- a/library/compiler/optimizer/optimizer.factor
+++ b/library/compiler/optimizer/optimizer.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: optimizer
-USING: generic hashtables inference io kernel
-lists math namespaces sequences vectors ;
+USING: generic hashtables inference io kernel lists math
+namespaces sequences test vectors ;
 
 SYMBOL: optimizer-changed
 
diff --git a/library/continuations.facts b/library/continuations.facts
index cd01fdccb5..d19997dc72 100644
--- a/library/continuations.facts
+++ b/library/continuations.facts
@@ -1,4 +1,4 @@
-USING: errors help kernel ;
+USING: errors help kernel kernel-internals ;
 
 HELP: catchstack* "( -- catchstack )"
 { $values { "catchstack" "a vector" } }
diff --git a/library/generic/math-combination.factor b/library/generic/math-combination.factor
index 8f2a0a05a8..a35b5754f0 100644
--- a/library/generic/math-combination.factor
+++ b/library/generic/math-combination.factor
@@ -8,9 +8,12 @@ lists math namespaces sequences words ;
 
 : first/last ( seq -- pair ) dup first swap peek 2array ;
 
+: math-class? ( object -- ? )
+    dup word? [ number bootstrap-word class< ] [ drop f ] if ;
+
 : math-class-compare ( class class -- n )
     [
-        dup number class<
+        dup math-class?
         [ types first/last ] [ drop { 100 100 } ] if
     ] 2apply <=> ;
 
@@ -56,9 +59,6 @@ TUPLE: no-math-method left right generic ;
 : math-vtable ( picker quot -- quot )
     num-tags swap math-vtable* ; inline
 
-: math-class? ( object -- ? )
-    dup word? [ "math-priority" word-prop ] [ drop f ] if ;
-
 : math-combination ( word -- quot )
     \ over [
         dup math-class? [
diff --git a/library/generic/math-combination.facts b/library/generic/math-combination.facts
index 58904ed6f9..a783171fa2 100644
--- a/library/generic/math-combination.facts
+++ b/library/generic/math-combination.facts
@@ -1,14 +1,5 @@
 USING: generic help math ;
 
-HELP: math-priority "( class -- n )"
-{ $values { "class" "a class word" } { "n" "a non-negative integer" } }
-{ $description "Outputs the priority of a built-in number class. If class A has a lower priority than class B, then applying a binary math operation to an instance of A and B will upgrade the instance of A to B's type." }
-{ $notes "To simplify implementation of the math method combination, this word outputs 100 for non-numeric classes. Priorities of numeric classes must always be less than 100." } ;
-
-HELP: math-class< "( class1 class2 -- ? )"
-{ $values { "class1" "a class word" } { "class2" "a class word" } { "?" "a boolean" } }
-{ $description "Defines a total ordering on built-in number classes." } ;
-
 HELP: math-upgrade "( class1 class2 -- quot )"
 { $values { "class1" "a class word" } { "class2" "a class word" } { "quot" "a quotation with stack effect " { $snippet "( n n -- n n )" } } }
 { $description "Outputs a quotation for upgrading numberical types. It takes two numbers on the stack, an instance of " { $snippet "class1" } ", and an instance of " { $snippet "class2" } ", and converts the one with the lower priority to the higher priority type." }
diff --git a/library/math/math.factor b/library/math/math.factor
index 7a8afbfe32..7812df3032 100644
--- a/library/math/math.factor
+++ b/library/math/math.factor
@@ -36,9 +36,9 @@ GENERIC: absq ( n -- |n|^2 ) foldable
 GENERIC: zero? ( x -- ? ) foldable
 M: object zero? drop f ;
 
-: sq dup * ; inline
-: neg 0 swap - ; inline
-: recip 1 swap / ; inline
+: sq dup * ; foldable
+: neg 0 swap - ; foldable
+: recip 1 swap / ; foldable
 : max ( x y -- z ) [ > ] 2keep ? ; foldable
 : min ( x y -- z ) [ < ] 2keep ? ; foldable
 : between? ( x min max -- ? ) pick >= >r >= r> and ; foldable
@@ -48,7 +48,7 @@ M: object zero? drop f ;
 : truncate ( x -- y ) dup 1 mod - ; foldable
 
 : floor ( x -- y )
-    dup 1 mod dup 0 =
+    dup 1 mod dup zero?
     [ drop ] [ dup 0 < [ - 1- ] [ - ] if ] if ; foldable
 
 : ceiling ( x -- y ) neg floor neg ; foldable
diff --git a/library/tools/annotations.factor b/library/tools/annotations.factor
index 093ad0a71b..b8109123d5 100644
--- a/library/tools/annotations.factor
+++ b/library/tools/annotations.factor
@@ -27,9 +27,5 @@ sequences strings walker ;
         nip [ swap % dup [ walk ] curry , , \ if , ] [ ] make
     ] annotate ;
 
-: with-profile ( quot word -- )
-    millis >r >r call r> millis r> - swap global [ +@ ] bind ;
-    inline
-
 : profile ( word -- )
-    [ swap [ with-profile ] curry cons ] annotate ;
+    [ swap [ global [ inc ] bind call ] curry cons ] annotate ;

From e2f6bf6fef0616b742a3933a2d858e4a0c99ff29 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Thu, 4 May 2006 20:05:58 +0000
Subject: [PATCH 078/112] Update x86 assembler for SSE2

---
 library/compiler/amd64/alien.factor   |  6 +++---
 library/compiler/x86/assembler.factor | 20 ++++++++++++++------
 2 files changed, 17 insertions(+), 9 deletions(-)

diff --git a/library/compiler/amd64/alien.factor b/library/compiler/amd64/alien.factor
index f84ff9dc6d..824b31e109 100644
--- a/library/compiler/amd64/alien.factor
+++ b/library/compiler/amd64/alien.factor
@@ -14,11 +14,11 @@ M: int-regs freg>stack drop >r stack@ r> MOV ;
 
 M: int-regs stack>freg drop swap stack@ MOV ;
 
-: MOVSS/LPD float-regs-size 4 = [ MOVSS ] [ MOVLPD ] if ;
+: MOVSS/D float-regs-size 4 = [ MOVSS ] [ MOVSD ] if ;
 
-M: float-regs freg>stack >r >r stack@ r> r> MOVSS/LPD ;
+M: float-regs freg>stack >r >r stack@ r> r> MOVSS/D ;
 
-M: float-regs stack>freg >r swap stack@ r> MOVSS/LPD ;
+M: float-regs stack>freg >r swap stack@ r> MOVSS/D ;
 
 M: stack-params stack>freg
     drop >r R11 swap stack@ MOV r> stack@ R11 MOV ;
diff --git a/library/compiler/x86/assembler.factor b/library/compiler/x86/assembler.factor
index 7ab30b76cb..51a493ceef 100644
--- a/library/compiler/x86/assembler.factor
+++ b/library/compiler/x86/assembler.factor
@@ -374,12 +374,20 @@ M: operand CMP OCT: 071 2-operand ;
 ( SSE multimedia instructions )
 
 : 2-operand-sse ( dst src op1 op2 -- )
-    pick register-128? [ nip ] [ drop swapd ] if
+    #! We swap the operands here to make everything consistent
+    #! with the integer instructions.
+    swap assemble-1 swapd
     >r 2dup t prefix HEX: 0f assemble-1 r>
     assemble-1 reg-code swap addressing ;
 
-: MOVLPD ( dest src -- )
-    HEX: 66 assemble-1 HEX: 12 HEX: 13 2-operand-sse ;
-
-: MOVSS ( dest src -- )
-    HEX: f3 assemble-1 HEX: 10 HEX: 11 2-operand-sse ;
+: MOVSS ( dest src -- ) HEX: f3 HEX: 10 2-operand-sse ;
+: MOVSD ( dest src -- ) HEX: f2 HEX: 10 2-operand-sse ;
+: ADDSD ( dest src -- ) HEX: f2 HEX: 58 2-operand-sse ;
+: MULSD ( dest src -- ) HEX: f2 HEX: 59 2-operand-sse ;
+: SUBSD ( dest src -- ) HEX: f2 HEX: 5c 2-operand-sse ;
+: DIVSD ( dest src -- ) HEX: f2 HEX: 5e 2-operand-sse ;
+: SQRTSD ( dest src -- ) HEX: f2 HEX: 51 2-operand-sse ;
+: UCOMISD ( dest src -- ) HEX: 66 HEX: 2e 2-operand-sse ;
+: COMISD ( dest src -- ) HEX: 66 HEX: 2f 2-operand-sse ;
+: CVTSI2SD ( dest src -- ) HEX: f2 HEX: 2a 2-operand-sse ;
+: CVTSD2SI ( dest src -- ) HEX: f2 HEX: 2d 2-operand-sse ;

From 19641646646179422a72dc2869630dca3eaa1774 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Thu, 4 May 2006 22:08:52 +0000
Subject: [PATCH 079/112] vregs now delegate to a register class

---
 library/compiler/amd64/architecture.factor     | 14 ++++++--------
 library/compiler/generator/architecture.factor | 13 ++++++++-----
 library/compiler/generator/generator.factor    |  8 ++++----
 library/compiler/generator/templates.factor    |  6 +++---
 library/compiler/optimizer/class-infer.factor  |  2 +-
 library/compiler/ppc/architecture.factor       |  5 ++---
 library/compiler/x86/alien.factor              |  2 +-
 library/compiler/x86/architecture.factor       | 10 ++++++----
 library/compiler/x86/intrinsics.factor         | 12 ++++++++----
 library/test/compiler/callbacks.factor         |  4 ++--
 10 files changed, 41 insertions(+), 35 deletions(-)

diff --git a/library/compiler/amd64/architecture.factor b/library/compiler/amd64/architecture.factor
index 4922f704d5..59be8dfbe9 100644
--- a/library/compiler/amd64/architecture.factor
+++ b/library/compiler/amd64/architecture.factor
@@ -5,7 +5,8 @@ USING: alien arrays assembler kernel
 kernel-internals math namespaces sequences ;
 
 ! AMD64 register assignments
-! RAX RCX RDX RSI RDI R8 R9 R10 R11 vregs
+! RAX RCX RDX RSI RDI R8 R9 R10 R11 integer vregs
+! XMM0 - XMM7 float vregs
 ! R13 cards_offset
 ! R14 datastack
 ! R15 callstack
@@ -14,11 +15,9 @@ kernel-internals math namespaces sequences ;
 : cs-reg R15 ; inline
 : remainder-reg RDX ; inline
 
-: vregs { RAX RCX RDX RSI RDI R8 R9 R10 R11 } ; inline
-
 M: int-regs return-reg drop RAX ;
-
-M: int-regs fastcall-regs drop { RDI RSI RDX RCX R8 R9 } ;
+M: int-regs vregs { RAX RCX RDX RSI RDI R8 R9 R10 R11 } ;
+M: int-regs fastcall-regs { RDI RSI RDX RCX R8 R9 } ;
 
 : compile-c-call ( symbol dll -- )
     2dup dlsym R10 swap MOV
@@ -29,9 +28,8 @@ M: int-regs fastcall-regs drop { RDI RSI RDX RCX R8 R9 } ;
     swap [ MOV ] 2each compile-c-call ;
 
 M: float-regs return-reg drop XMM0 ;
-
-M: float-regs fastcall-regs
-    drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
+M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
+M: float-regs fastcall-regs vregs ;
 
 : address-operand ( address -- operand )
     #! On AMD64, we have to load 64-bit addresses into a
diff --git a/library/compiler/generator/architecture.factor b/library/compiler/generator/architecture.factor
index c1224d442f..e464b8e443 100644
--- a/library/compiler/generator/architecture.factor
+++ b/library/compiler/generator/architecture.factor
@@ -5,10 +5,16 @@ sequences ;
 ! A scratch register for computations
 TUPLE: vreg n ;
 
+C: vreg ( n reg-class -- vreg )
+    [ set-delegate ] keep [ set-vreg-n ] keep ;
+
 ! Register classes
 TUPLE: int-regs ;
 TUPLE: float-regs size ;
 
+: <int-vreg> ( n -- vreg ) T{ int-regs } <vreg> ;
+: <float-vreg> ( n -- vreg ) T{ float-regs f 8 } <vreg> ;
+
 ! A pseudo-register class for parameters spilled on the stack
 TUPLE: stack-params ;
 
@@ -19,7 +25,7 @@ GENERIC: return-reg ( register-class -- reg )
 GENERIC: fastcall-regs ( register-class -- regs )
 
 ! Sequence mapping vreg-n to native assembler registers
-DEFER: vregs ( -- regs )
+GENERIC: vregs ( register-class -- regs )
 
 ! Load a literal (immediate or indirect)
 G: load-literal ( obj vreg -- ) 1 standard-combination ;
@@ -105,9 +111,6 @@ M: float-regs inc-reg-class
     macosx? [ reg-size 4 / int-regs +@ ] [ drop ] if ;
 
 GENERIC: v>operand
-
 M: integer v>operand tag-bits shift ;
-
-M: vreg v>operand vreg-n vregs nth ;
-
+M: vreg v>operand dup vreg-n swap vregs nth ;
 M: f v>operand address ;
diff --git a/library/compiler/generator/generator.factor b/library/compiler/generator/generator.factor
index d52eb6f959..d4c0ece09b 100644
--- a/library/compiler/generator/generator.factor
+++ b/library/compiler/generator/generator.factor
@@ -140,12 +140,12 @@ M: #if generate-node ( node -- next )
 
 : if>boolean-intrinsic ( label -- )
     <label> "end" set
-    f T{ vreg f 0 } load-literal
+    f 0 <int-vreg> load-literal
     "end" get %jump-label
     save-xt
-    t T{ vreg f 0 } load-literal
+    t 0 <int-vreg> load-literal
     "end" get save-xt
-    T{ vreg f 0 } phantom-d get phantom-push ;
+    0 <int-vreg> phantom-d get phantom-push ;
 
 : do-if-intrinsic ( node -- next )
     [ <label> dup ] keep if-intrinsic call
@@ -194,7 +194,7 @@ UNION: immediate fixnum POSTPONE: f ;
 
 : generate-push ( node -- )
     >#push< dup length dup ensure-vregs
-    alloc-reg# [ <vreg> ] map
+    alloc-reg# [ <int-vreg> ] map
     [ [ load-literal ] 2each ] keep
     phantom-d get phantom-append ;
 
diff --git a/library/compiler/generator/templates.factor b/library/compiler/generator/templates.factor
index f000d491bb..69f20cc82b 100644
--- a/library/compiler/generator/templates.factor
+++ b/library/compiler/generator/templates.factor
@@ -106,7 +106,7 @@ SYMBOL: phantom-r
     phantoms [ finalize-height ] 2apply ;
 
 : stack>vreg ( vreg# loc -- operand )
-    >r <vreg> dup r> %peek ;
+    >r <int-vreg> dup r> %peek ;
 
 : stack>new-vreg ( loc -- vreg )
     alloc-reg swap stack>vreg ;
@@ -157,7 +157,7 @@ SYMBOL: phantom-r
     phantoms append [ vreg? ] subset [ vreg-n ] map ;
 
 : compute-free-vregs ( -- )
-    used-vregs vregs length reverse diff
+    used-vregs T{ int-regs } vregs length reverse diff
     >vector free-vregs set ;
 
 : additional-vregs# ( seq seq -- n )
@@ -257,7 +257,7 @@ SYMBOL: +clobber
     +input get { } additional-vregs# +scratch get length + ;
 
 : alloc-scratch ( -- )
-    +scratch get [ alloc-vregs [ <vreg> ] map ] keep
+    +scratch get [ alloc-vregs [ <int-vreg> ] map ] keep
     phantom-vregs ;
 
 : template-inputs ( -- )
diff --git a/library/compiler/optimizer/class-infer.factor b/library/compiler/optimizer/class-infer.factor
index 04bb487765..66dea6dd2d 100644
--- a/library/compiler/optimizer/class-infer.factor
+++ b/library/compiler/optimizer/class-infer.factor
@@ -10,7 +10,7 @@ kernel-internals math namespaces sequences words ;
     node-classes ?hash [ object ] unless* ;
 
 : node-class# ( node n -- class )
-    swap [ node-in-d reverse-slice nth ] keep node-class ;
+    swap [ node-in-d reverse-slice ?nth ] keep node-class ;
 
 ! Variables used by the class inferencer
 
diff --git a/library/compiler/ppc/architecture.factor b/library/compiler/ppc/architecture.factor
index 3c8b729419..412c8281d9 100644
--- a/library/compiler/ppc/architecture.factor
+++ b/library/compiler/ppc/architecture.factor
@@ -10,10 +10,9 @@ memory namespaces sequences words ;
 ! r14 data stack
 ! r15 call stack
 
-: vregs { 3 4 5 6 7 8 9 10 } ; inline
-
 M: int-regs return-reg drop 3 ;
 M: int-regs fastcall-regs drop { 3 4 5 6 7 8 9 10 } ;
+M: int-regs vregs drop { 3 4 5 6 7 8 9 10 } ;
 
 M: float-regs return-reg drop 1 ;
 M: float-regs fastcall-regs drop { 1 2 3 4 5 6 7 8 } ;
@@ -163,7 +162,7 @@ M: stack-params freg>stack
     11 [ compile-dlsym ] keep MTLR BLRL ;
 
 : %alien-callback ( quot -- )
-    T{ vreg f 0 } load-literal "run_callback" f %alien-invoke ;
+    0 <int-vreg> load-literal "run_callback" f %alien-invoke ;
 
 : save-return 0 swap [ return-reg ] keep freg>stack ;
 : load-return 0 swap [ return-reg ] keep stack>freg ;
diff --git a/library/compiler/x86/alien.factor b/library/compiler/x86/alien.factor
index 8a809b80ea..e55d03e774 100644
--- a/library/compiler/x86/alien.factor
+++ b/library/compiler/x86/alien.factor
@@ -63,7 +63,7 @@ M: float-regs load-return-reg
     drop-return-reg ;
 
 : %alien-callback ( quot -- )
-    T{ vreg f 0 } load-literal
+    0 <int-vreg> load-literal
     EAX PUSH
     "run_callback" f %alien-invoke
     EAX POP ;
diff --git a/library/compiler/x86/architecture.factor b/library/compiler/x86/architecture.factor
index e5bafe7fc2..532816d909 100644
--- a/library/compiler/x86/architecture.factor
+++ b/library/compiler/x86/architecture.factor
@@ -5,20 +5,20 @@ math memory namespaces sequences words ;
 IN: compiler
 
 ! x86 register assignments
-! EAX, ECX, EDX vregs
+! EAX, ECX, EDX integer vregs
+! XMM0 - XMM7 float vregs
 ! ESI datastack
 ! EBX callstack
 
-! AMD64 redefines these four
+! AMD64 redefines a lot of words in this file
+
 : ds-reg ESI ; inline
 : cs-reg EBX ; inline
 : remainder-reg EDX ; inline
-: vregs { EAX ECX EDX } ; inline
 
 : reg-stack ( n reg -- op ) swap cells neg [+] ;
 
 M: ds-loc v>operand ds-loc-n ds-reg reg-stack ;
-
 M: cs-loc v>operand cs-loc-n cs-reg reg-stack ;
 
 : %alien-invoke ( symbol dll -- )
@@ -32,8 +32,10 @@ M: cs-loc v>operand cs-loc-n cs-reg reg-stack ;
 ! On x86, parameters are never passed in registers.
 M: int-regs return-reg drop EAX ;
 M: int-regs fastcall-regs drop { } ;
+M: int-regs vregs drop { EAX ECX EDX } ;
 
 M: float-regs fastcall-regs drop { } ;
+M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 
 : address-operand ( address -- operand )
     #! On x86, we can always use an address as an operand
diff --git a/library/compiler/x86/intrinsics.factor b/library/compiler/x86/intrinsics.factor
index fe18dce073..c4aea1c22d 100644
--- a/library/compiler/x86/intrinsics.factor
+++ b/library/compiler/x86/intrinsics.factor
@@ -4,6 +4,7 @@ USING: alien arrays assembler kernel kernel-internals lists math
 math-internals namespaces sequences words ;
 IN: compiler
 
+! Type checks
 \ tag [
     "in" operand tag-mask AND
     "in" operand tag-bits SHL
@@ -48,6 +49,7 @@ IN: compiler
     { +output { "obj" } }
 } define-intrinsic
 
+! Slots
 : untag ( reg -- ) tag-mask bitnot AND ;
 
 \ slot [
@@ -114,7 +116,8 @@ IN: compiler
     { +clobber { "val" "slot" "obj" } }
 } define-intrinsic
 
-: define-binary-op ( word op -- )
+! Fixnums
+: define-fixnum-op ( word op -- )
     [ [ "x" operand "y" operand ] % , ] [ ] make H{
         { +input { { f "x" } { f "y" } } }
         { +output { "x" } }
@@ -127,7 +130,7 @@ IN: compiler
     { fixnum-bitor OR }
     { fixnum-bitxor XOR }
 } [
-    first2 define-binary-op
+    first2 define-fixnum-op
 ] each
 
 \ fixnum-bitnot [
@@ -241,7 +244,7 @@ IN: compiler
     { +clobber { "x" "y" } }
 } define-intrinsic
 
-: define-binary-jump ( word op -- )
+: define-fixnum-jump ( word op -- )
     [
         [ end-basic-block "x" operand "y" operand CMP ] % ,
     ] [ ] make H{
@@ -255,9 +258,10 @@ IN: compiler
     { fixnum>= JGE }
     { eq? JE }
 } [
-    first2 define-binary-jump
+    first2 define-fixnum-jump
 ] each
 
+! User environment
 : %userenv ( -- )
     "x" operand "userenv" f dlsym MOV
     0 rel-absolute-cell rel-userenv
diff --git a/library/test/compiler/callbacks.factor b/library/test/compiler/callbacks.factor
index 2129a30101..97a77baf49 100644
--- a/library/test/compiler/callbacks.factor
+++ b/library/test/compiler/callbacks.factor
@@ -1,6 +1,6 @@
 IN: temporary
-USING: alien compiler errors inference io kernel math memory
-namespaces test threads ;
+USING: alien compiler errors inference io kernel kernel-internals
+math memory namespaces test threads ;
 
 : callback-1 "void" { } [ ] alien-callback ; compiled
 

From 4af21da8455cb1a959ec3b7c9c4982aa0c8ca1a8 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Thu, 4 May 2006 22:19:39 +0000
Subject: [PATCH 080/112] Register allocation cleanup

---
 library/compiler/generator/generator.factor |  5 ++---
 library/compiler/generator/templates.factor | 21 ++++++++-------------
 2 files changed, 10 insertions(+), 16 deletions(-)

diff --git a/library/compiler/generator/generator.factor b/library/compiler/generator/generator.factor
index d4c0ece09b..f8dba4d840 100644
--- a/library/compiler/generator/generator.factor
+++ b/library/compiler/generator/generator.factor
@@ -193,9 +193,8 @@ M: #dispatch generate-node ( node -- next )
 UNION: immediate fixnum POSTPONE: f ;
 
 : generate-push ( node -- )
-    >#push< dup length dup ensure-vregs
-    alloc-reg# [ <int-vreg> ] map
-    [ [ load-literal ] 2each ] keep
+    >#push< dup length ensure-vregs
+    [ T{ int-regs } alloc-reg [ load-literal ] keep ] map
     phantom-d get phantom-append ;
 
 M: #push generate-node ( #push -- )
diff --git a/library/compiler/generator/templates.factor b/library/compiler/generator/templates.factor
index 69f20cc82b..1a9f8897c9 100644
--- a/library/compiler/generator/templates.factor
+++ b/library/compiler/generator/templates.factor
@@ -5,13 +5,12 @@ USING: arrays generic hashtables inference io kernel math
 namespaces prettyprint sequences vectors words ;
 
 ! Register allocation
+
+! Hash mapping reg-classes to mutable vectors
 SYMBOL: free-vregs
 
-: alloc-reg ( -- n )
-    free-vregs get pop ;
-
-: alloc-reg# ( n -- regs )
-    free-vregs [ cut ] change ;
+: alloc-reg ( reg-class -- vreg )
+    >r free-vregs get pop r> <vreg> ;
 
 : requested-vregs ( template -- n )
     0 [ [ 1+ ] unless ] reduce ;
@@ -20,7 +19,7 @@ SYMBOL: free-vregs
     [ requested-vregs ] 2apply + ;
 
 : alloc-vregs ( template -- template )
-    [ first [ alloc-reg ] unless* ] map ;
+    [ first [ <int-vreg> ] [ T{ int-regs } alloc-reg ] if* ] map ;
 
 : adjust-free-vregs ( seq -- )
     free-vregs [ diff ] change ;
@@ -105,11 +104,8 @@ SYMBOL: phantom-r
 : finalize-heights ( -- )
     phantoms [ finalize-height ] 2apply ;
 
-: stack>vreg ( vreg# loc -- operand )
-    >r <int-vreg> dup r> %peek ;
-
 : stack>new-vreg ( loc -- vreg )
-    alloc-reg swap stack>vreg ;
+    T{ int-regs } alloc-reg [ swap %peek ] keep ;
 
 : vreg>stack ( value loc -- )
     over loc? [
@@ -182,7 +178,7 @@ SYMBOL: phantom-r
 : stack>vregs ( phantom template -- values )
     [
         alloc-vregs dup length rot phantom-locs
-        [ stack>vreg ] 2map
+        [ dupd %peek ] 2map
     ] 2keep length neg swap adjust-phantom ;
 
 : compatible-values? ( value template -- ? )
@@ -257,8 +253,7 @@ SYMBOL: +clobber
     +input get { } additional-vregs# +scratch get length + ;
 
 : alloc-scratch ( -- )
-    +scratch get [ alloc-vregs [ <int-vreg> ] map ] keep
-    phantom-vregs ;
+    +scratch get [ alloc-vregs ] keep phantom-vregs ;
 
 : template-inputs ( -- )
     ! Ensure we have enough to hold any new stack elements we

From 95ee1a41f1177c23cc9a7e3f45ee6701717e19a5 Mon Sep 17 00:00:00 2001
From: Kevin Reid <kpreid@mac.com>
Date: Tue, 11 Apr 2006 13:49:47 +0000
Subject: [PATCH 081/112] Set cp_dir executable during 'make macosx.app'.

---
 Makefile | 1 +
 1 file changed, 1 insertion(+)

diff --git a/Makefile b/Makefile
index 03706e3120..3c54e66962 100644
--- a/Makefile
+++ b/Makefile
@@ -110,6 +110,7 @@ macosx.app:
 	mkdir -p $(BUNDLE)/Contents/Resources/fonts/
 	cp -R fonts/*.ttf $(BUNDLE)/Contents/Resources/fonts/
 
+	chmod +x cp_dir
 	find doc library contrib \( -name '*.factor' \
 		-o -name '*.facts' \
 		-o -name '*.txt' \

From f808f659b5d1aff659b8f0ba9e6e17dceca0bffe Mon Sep 17 00:00:00 2001
From: Kevin Reid <kpreid@mac.com>
Date: Fri, 5 May 2006 03:20:21 +0000
Subject: [PATCH 082/112] Add instructions for starting the GUI on Mac OS X to
 README.txt.

---
 README.txt | 10 +++++++++-
 1 file changed, 9 insertions(+), 1 deletion(-)

diff --git a/README.txt b/README.txt
index c6c9a4cf2d..1b69448f8d 100644
--- a/README.txt
+++ b/README.txt
@@ -94,12 +94,20 @@ To run the Factor system, issue the following command:
 This will start the interactive listener where Factor expressions may
 be entered.
 
-To run the graphical user interface, issue the following command:
+To run the graphical user interface on non-Mac OS X systems, issue the
+following command:
 
   ./f factor.image -shell=ui
 
 Note that on Windows, this is the default.
 
+To prepare to run the GUI on Mac OS X, issue the following command:
+
+  make macosx.app
+
+once after bootstrapping, then double-click the Factor application to
+run it.
+
 On Unix, this might fail if the SDL libraries are not installed, or are
 installed under unconventional names. This can be solved by explicitly
 naming the libraries during bootstrap, as in the next section.

From ade9b3333cc6de375638adf80d147e8723cbabe3 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Fri, 5 May 2006 05:59:39 +0000
Subject: [PATCH 083/112] Updated readme, fixed documentation typo, better
 no-method error reporting

---
 README.txt                                   | 107 ++++++++++---------
 library/collections/sequences-epilogue.facts |   4 +-
 library/tools/debugger.factor                |  12 ++-
 3 files changed, 67 insertions(+), 56 deletions(-)

diff --git a/README.txt b/README.txt
index 1b69448f8d..602262a74c 100644
--- a/README.txt
+++ b/README.txt
@@ -4,6 +4,19 @@ The Factor programming language
 This file covers installation and basic usage of the Factor
 implementation. It is not an introduction to the language itself.
 
+* Contents
+
+- Platform support
+- Compiling Factor
+- Building Factor
+- Running Factor on Unix with X11
+- Running Factor on Mac OS X
+- Running Factor on Windows
+- Source organization
+- Learning Factor
+- Community
+- Credits
+
 * Platform support
 
 Factor is fully supported on the following platforms:
@@ -28,9 +41,8 @@ Other platforms are not supported.
 
 The Factor runtime is written in C, and is built with GNU make and gcc.
 
-Note that on x86 systems, Factor _cannot_ be compiled with gcc 3.3. This
-is due to a bug in gcc and there is nothing we can do about it. Please
-use gcc 2.95, 3.4, or 4.0.
+Factor requires gcc 3.4 or later. On x86, it /will not/ build using gcc
+3.3 or earlier.
 
 Run 'make' (or 'gmake' on non-Linux platforms) with one of the following
 parameters to build the Factor runtime:
@@ -48,9 +60,9 @@ The following options can be given to make:
   DEBUG=1
 
 The former allows optimization flags to be specified, for example
-"-march=pentium4 -ffast-math -O3". Optimization flags can make a *huge*
-difference in Factor's performance, so willing hackers should
-experiment.
+"-march=pentium4 -ffast-math -O3". Nowadays most of the hard work is
+done by Factor compiled code, so optimizing the runtime is not that
+important. Usually the defaults are fine.
 
 The DEBUG flag disables optimization and builds an executable with
 debug symbols. This is probably only of interest to people intending to
@@ -85,80 +97,69 @@ completes, a 'factor.image' file will be generated. Note that this image
 is both CPU and OS-specific, so in general cannot be shared between
 machines.
 
-* Running Factor
+* Running Factor on Unix with X11
 
-To run the Factor system, issue the following command:
+On Unix, Factor can either run a graphical user interface using X11, or
+a terminal listener.
+
+If your DISPLAY environment variable is set, the UI will start
+automatically:
 
   ./f factor.image
 
-This will start the interactive listener where Factor expressions may
-be entered.
+To run an interactive terminal listener:
 
-To run the graphical user interface on non-Mac OS X systems, issue the
-following command:
+  ./f factor.image -shell=tty
 
-  ./f factor.image -shell=ui
+If you're inside a terminal session, you can start the UI with one of
+the following two commands:
 
-Note that on Windows, this is the default.
+  ui
+  [ ui ] in-thread
+  
+The latter keeps the terminal listener running.
 
-To prepare to run the GUI on Mac OS X, issue the following command:
+* Running Factor on Mac OS X
+
+On Mac OS X, a Cocoa UI is available in addition to the terminal
+listener.
+
+The 'f' executable runs the terminal listener:
+
+  ./f factor.image
+
+The Cocoa UI requires that after bootstrapping you build the Factor.app
+application bundle:
 
   make macosx.app
 
-once after bootstrapping, then double-click the Factor application to
-run it.
+This copies the runtime executable, factor.image (which must exist at
+this point), and the library source into a self-contained Factor.app.
 
-On Unix, this might fail if the SDL libraries are not installed, or are
-installed under unconventional names. This can be solved by explicitly
-naming the libraries during bootstrap, as in the next section.
+Factor.app runs the UI when double-clicked and can be transported
+between PowerPC Macs.
 
-* Setting up SDL libraries for use with Factor
+* Running Factor on Windows
 
-The Windows binary package for Factor includes all prerequisite DLLs.
-On Unix, you need recent versions of SDL and FreeType.
+On Windows, double-clicking f.exe will start running the Win32-based UI
+with the factor.image in the same directory as the executable.
 
-If you have installed these libraries but the UI still fails with an
-error, you will need to find out the exact names that they are installed
-as, and issue a command similar to the following to bootstrap Factor:
-
-  ./f boot.image.<foo> -libraries:sdl:name=libSDL-1.2.so
-                       -libraries:freetype:name=libfreetype.so
+Bootstrap runs in a Windows command prompt, however after bootstrapping
+only the UI can be used.
 
 * Source organization
 
   doc/ - the developer's handbook, and various other bits and pieces
   native/ - sources for the Factor runtime, written in C
   library/ - sources for the library, written in Factor
-    alien/ - C library interface
-    bootstrap/ - code for generating boot images
-    cocoa/ - Mac OS X Cocoa API and Objective-C runtime binding
-    collections/ - data types including but not limited to lists,
-      vectors, hashtables, and operations on them
-    compiler/ - optimizing native compiler
-    freetype/ - FreeType binding, rendering glyphs to OpenGL textures
-    generic/ - generic words, for object oriented programming style
-    help/ - online help system
-    inference/ - stack effect inference, used by compiler, as well as a
-      useful development tool of its own
-    io/ - input and output streams
-    math/ - integers, ratios, floats, complex numbers, vectors, matrices
-    opengl/ - OpenGL graphics library binding
-    syntax/ - parser and object prettyprinter
-    test/ - unit test framework and test suite
-    tools/ - interactive development tools
-    ui/ - UI framework
-    unix/ - Unix-specific I/O code
-    win32/ - Windows-specific I/O code
   contrib/ - various handy libraries not part of the core
   examples/ - small examples illustrating various language features
   fonts/ - TrueType fonts used by UI
 
 * Learning Factor
 
-The UI has a simple tutorial that will show you the most basic concepts.
-
-There is a detailed language and library reference available at
-http://factorcode.org/handbook.pdf.
+The UI has a tutorial and defailed reference documentation. You can
+browse it in the UI or by running the HTTP server (contrib/httpd).
 
 You can browse the source code; it is organized into small,
 well-commented files and should be easy to follow once you have a good
diff --git a/library/collections/sequences-epilogue.facts b/library/collections/sequences-epilogue.facts
index 7d9e56ee75..1057e37c2e 100644
--- a/library/collections/sequences-epilogue.facts
+++ b/library/collections/sequences-epilogue.facts
@@ -40,8 +40,8 @@ HELP: memq? "( obj seq -- ? )"
 }
 { $see-also index index* member? } ;
 
-HELP: remove "( elt seq -- ? )"
-{ $values { "elt" "an object" } { "seq" "a sequence" } }
+HELP: remove "( elt seq -- newseq )"
+{ $values { "elt" "an object" } { "seq" "a sequence" } { "newseq" "a new sequence" } }
 { $description "Outputs a new sequence containing all elements of the input sequence except those equal to the given element." } ;
 
 HELP: subst "( newseq oldseq seq -- )"
diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor
index 59824fb5c9..6aa4d5b68e 100644
--- a/library/tools/debugger.factor
+++ b/library/tools/debugger.factor
@@ -88,7 +88,17 @@ M: kernel-error error. ( error -- )
         [ objc-error. ]
     } dispatch ;
 
-M: no-method summary drop "No suitable method" ;
+M: no-method summary
+    "No suitable method" ;
+
+M: no-method error. ( error -- )
+    "Generic word " write
+    dup no-method-generic pprint
+    " does not define a method for the " write
+    dup no-method-object class pprint
+    " class." print
+    "Allowed classes: " write dup no-method-generic order .
+    "Dispatching on object: " write no-method-object short. ;
 
 M: no-math-method summary drop "No suitable arithmetic method" ;
 

From a6e9ed5c21b0a3be6eefa00d375bab31faccbae6 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Fri, 5 May 2006 06:00:17 +0000
Subject: [PATCH 084/112] Preliminary floating point intrinsics work

---
 library/compiler/amd64/architecture.factor  |  4 +-
 library/compiler/generator/generator.factor | 13 +++-
 library/compiler/generator/templates.factor | 74 +++++++++++----------
 library/compiler/x86/architecture.factor    | 34 ++++++++--
 library/compiler/x86/intrinsics.factor      | 33 +++++++++
 5 files changed, 115 insertions(+), 43 deletions(-)

diff --git a/library/compiler/amd64/architecture.factor b/library/compiler/amd64/architecture.factor
index 59be8dfbe9..9a48d9b571 100644
--- a/library/compiler/amd64/architecture.factor
+++ b/library/compiler/amd64/architecture.factor
@@ -16,8 +16,8 @@ kernel-internals math namespaces sequences ;
 : remainder-reg RDX ; inline
 
 M: int-regs return-reg drop RAX ;
-M: int-regs vregs { RAX RCX RDX RSI RDI R8 R9 R10 R11 } ;
-M: int-regs fastcall-regs { RDI RSI RDX RCX R8 R9 } ;
+M: int-regs vregs drop { RAX RCX RDX RSI RDI R8 R9 R10 R11 } ;
+M: int-regs fastcall-regs drop { RDI RSI RDX RCX R8 R9 } ;
 
 : compile-c-call ( symbol dll -- )
     2dup dlsym R10 swap MOV
diff --git a/library/compiler/generator/generator.factor b/library/compiler/generator/generator.factor
index f8dba4d840..435dcecb4a 100644
--- a/library/compiler/generator/generator.factor
+++ b/library/compiler/generator/generator.factor
@@ -192,8 +192,16 @@ M: #dispatch generate-node ( node -- next )
 ! #push
 UNION: immediate fixnum POSTPONE: f ;
 
+: alloc-literal-reg ( literal -- vreg )
+    float? T{ float-regs f 8 } T{ int-regs } ? alloc-reg ;
+
+! : generate-push ( node -- )
+!     >#push< dup [ class ] map requested-vregs ensure-vregs
+!     [ dup alloc-literal-reg [ load-literal ] keep ] map
+!     phantom-d get phantom-append ;
+
 : generate-push ( node -- )
-    >#push< dup length ensure-vregs
+    >#push< dup length 0 ensure-vregs
     [ T{ int-regs } alloc-reg [ load-literal ] keep ] map
     phantom-d get phantom-append ;
 
@@ -221,7 +229,7 @@ M: #push generate-node ( #push -- )
     dup shuffle-in-d swap shuffle-in-r additional-vregs# ;
 
 : phantom-shuffle ( shuffle -- )
-    dup shuffle-vregs# ensure-vregs
+    dup shuffle-vregs# 0 ensure-vregs
     [ phantom-shuffle-inputs ] keep
     [ shuffle* ] keep adjust-shuffle
     (template-outputs) ;
@@ -236,4 +244,5 @@ M: #return generate-node drop end-basic-block %return f ;
 : card-bits 7 ;
 : card-mark HEX: 80 ;
 
+: float-offset 8 float-tag - ;
 : string-offset 3 cells object-tag - ;
diff --git a/library/compiler/generator/templates.factor b/library/compiler/generator/templates.factor
index 1a9f8897c9..1e7982fd17 100644
--- a/library/compiler/generator/templates.factor
+++ b/library/compiler/generator/templates.factor
@@ -7,22 +7,18 @@ namespaces prettyprint sequences vectors words ;
 ! Register allocation
 
 ! Hash mapping reg-classes to mutable vectors
-SYMBOL: free-vregs
+: free-vregs ( reg-class -- seq ) \ free-vregs get hash ;
 
-: alloc-reg ( reg-class -- vreg )
-    >r free-vregs get pop r> <vreg> ;
+: alloc-reg ( reg-class -- vreg ) free-vregs pop ;
 
-: requested-vregs ( template -- n )
-    0 [ [ 1+ ] unless ] reduce ;
-
-: template-vreg# ( template template -- n )
-    [ requested-vregs ] 2apply + ;
+: take-reg ( vreg -- ) dup delegate free-vregs delete ;
 
 : alloc-vregs ( template -- template )
-    [ first [ <int-vreg> ] [ T{ int-regs } alloc-reg ] if* ] map ;
-
-: adjust-free-vregs ( seq -- )
-    free-vregs [ diff ] change ;
+    [
+        first dup
+        H{ { f T{ int-regs } } { float T{ float-regs f 8 } } }
+        hash [ alloc-reg ] [ <int-vreg> dup take-reg ] ?if
+    ] map ;
 
 ! A data stack location.
 TUPLE: ds-loc n ;
@@ -84,7 +80,6 @@ M: phantom-callstack finalize-height
     dup length swap phantom-locs ;
 
 : adjust-phantom ( n phantom -- )
-    #! Change stack heiht.
     [ phantom-stack-height + ] keep set-phantom-stack-height ;
 
 GENERIC: cut-phantom ( n phantom -- seq )
@@ -150,22 +145,29 @@ SYMBOL: phantom-r
     finalize-contents finalize-heights ;
 
 : used-vregs ( -- seq )
-    phantoms append [ vreg? ] subset [ vreg-n ] map ;
+    phantoms append [ vreg? ] subset ;
+
+: (compute-free-vregs) ( used class -- vector )
+    dup vregs length reverse [ swap <vreg> ] map-with diff
+    >vector ;
 
 : compute-free-vregs ( -- )
-    used-vregs T{ int-regs } vregs length reverse diff
-    >vector free-vregs set ;
+    used-vregs
+    { T{ int-regs } T{ float-regs f 8 } }
+    [ 2dup (compute-free-vregs) ] map>hash \ free-vregs set
+    drop ;
 
 : additional-vregs# ( seq seq -- n )
     2array phantoms 2array [ [ length ] map ] 2apply v-
     0 [ 0 max + ] reduce ;
 
-: free-vregs* ( -- n )
-    free-vregs get length
-    phantoms [ [ loc? ] subset length ] 2apply + - ;
+: free-vregs* ( -- int# float# )
+    T{ int-regs } free-vregs length
+    phantoms [ [ loc? ] subset length ] 2apply + -
+    T{ float-regs f 8 } free-vregs length ;
 
-: ensure-vregs ( n -- )
-    compute-free-vregs free-vregs* <=
+: ensure-vregs ( int# float# -- )
+    compute-free-vregs free-vregs* swapd <= >r <= r> and
     [ finalize-contents compute-free-vregs ] unless ;
 
 : lazy-load ( value loc -- value )
@@ -181,12 +183,18 @@ SYMBOL: phantom-r
         [ dupd %peek ] 2map
     ] 2keep length neg swap adjust-phantom ;
 
+: compatible-vreg? ( n vreg -- ? )
+    {
+        { [ dup [ int-regs? ] is? ] [ vreg-n = ] }
+        { [ dup [ float-regs? ] is? ] [ 2drop t ] }
+        { [ t ] [ 2drop f ] }
+    } cond ;
+
 : compatible-values? ( value template -- ? )
     {
         { [ over loc? ] [ 2drop t ] }
-        { [ dup not ] [ 2drop t ] }
-        { [ over not ] [ 2drop f ] }
-        { [ dup integer? ] [ swap vreg-n = ] }
+        { [ dup { f float } memq? ] [ 2drop t ] }
+        { [ dup integer? ] [ swap compatible-vreg? ] }
     } cond ;
 
 : template-match? ( template phantom -- ? )
@@ -245,12 +253,12 @@ SYMBOL: +clobber
     outputs-clash? [ finalize-contents ] when
     phantom-d get swap [ stack>vregs ] keep phantom-vregs ;
 
-: input-vregs ( -- seq )
-    +input +scratch [ get [ second get vreg-n ] map ] 2apply
-    append ;
+: requested-vregs ( template -- int# float# )
+    dup length swap [ float eq? ] subset length [ - ] keep ;
 
-: guess-vregs ( -- n )
-    +input get { } additional-vregs# +scratch get length + ;
+: guess-vregs ( -- int# float# )
+    +input get { } additional-vregs#
+    +scratch get requested-vregs >r + r> ;
 
 : alloc-scratch ( -- )
     +scratch get [ alloc-vregs ] keep phantom-vregs ;
@@ -261,11 +269,9 @@ SYMBOL: +clobber
     guess-vregs ensure-vregs
     ! Split the template into available (fast) parts and those
     ! that require allocating registers and reading the stack
-    +input get match-template fast-input
-    used-vregs adjust-free-vregs
-    slow-input
-    alloc-scratch
-    input-vregs adjust-free-vregs ;
+    +input get match-template fast-input slow-input
+    ! Finally allocate scratch registers
+    alloc-scratch ;
 
 : template-outputs ( -- )
     +output get [ get ] map { } (template-outputs) ;
diff --git a/library/compiler/x86/architecture.factor b/library/compiler/x86/architecture.factor
index 532816d909..70a0a20614 100644
--- a/library/compiler/x86/architecture.factor
+++ b/library/compiler/x86/architecture.factor
@@ -46,12 +46,23 @@ M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 
 : prepare-division CDQ ; inline
 
+: unboxify-float ( obj vreg quot -- | quot: obj int-vreg )
+    over [ float-regs? ] is? [
+        swap >r T{ int-regs } alloc-reg [ swap call ] keep
+        r> swap [ v>operand ] 2apply float-offset [+] MOVSD
+    ] [
+        call
+    ] if ; inline
+
 M: immediate load-literal ( literal vreg -- )
-    v>operand swap address MOV ;
+    v>operand swap v>operand MOV ;
+
+: load-indirect ( literal vreg -- )
+    v>operand swap add-literal [] MOV
+    rel-absolute-cell rel-address ;
 
 M: object load-literal ( literal vreg -- )
-    v>operand swap
-    add-literal [] MOV rel-absolute-cell rel-address ;
+    [ load-indirect ] unboxify-float ;
 
 : (%call) ( label -- label )
     dup postpone-word dup primitive? [ address-operand ] when ;
@@ -85,9 +96,22 @@ M: object load-literal ( literal vreg -- )
 
 : %return ( -- ) %epilogue RET ;
 
-: %peek ( vreg loc -- ) [ v>operand ] 2apply MOV ;
+: vreg-mov [ v>operand ] 2apply MOV ;
 
-: %replace ( vreg loc -- ) swap %peek ;
+: %peek ( vreg loc -- )
+    swap [ swap vreg-mov ] unboxify-float ;
+
+: %replace ( vreg loc -- )
+    over [ float-regs? ] is? [
+        ! >r
+        ! "fp-scratch" operand "allot.here" f dlsym [] MOV
+        ! "fp-scratch" operand [] float-tag >header MOV
+        ! "fp-scratch" operand 8 [+] r> MOVSD
+        ! "allot.here" f dlsym [] 16 ADD
+        vreg-mov
+    ] [
+        vreg-mov
+    ] if ;
 
 : (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
 
diff --git a/library/compiler/x86/intrinsics.factor b/library/compiler/x86/intrinsics.factor
index c4aea1c22d..e98ab9ec33 100644
--- a/library/compiler/x86/intrinsics.factor
+++ b/library/compiler/x86/intrinsics.factor
@@ -261,6 +261,39 @@ IN: compiler
     first2 define-fixnum-jump
 ] each
 
+! Floats
+! : define-float-op ( word op -- )
+!     [ [ "x" operand "y" operand ] % , ] [ ] make H{
+!         { +input { { float "x" } { float "y" } } }
+!         { +output { "x" } }
+!     } define-intrinsic ;
+! 
+! {
+!     { float+ ADDSD }
+!     { float- SUBSD }
+!     { float* MULSD }
+!     { float/f DIVSD }
+! } [
+!     first2 define-float-op
+! ] each
+! 
+! : define-float-jump ( word op -- )
+!     [
+!         [ end-basic-block "x" operand "y" operand COMISD ] % ,
+!     ] [ ] make H{
+!         { +input { { float "x" } { float "y" } } }
+!     } define-if-intrinsic ;
+! 
+! {
+!     { float< JL }
+!     { float<= JLE }
+!     { float> JG }
+!     { float>= JGE }
+!     { float= JE }
+! } [
+!     first2 define-float-jump
+! ] each
+
 ! User environment
 : %userenv ( -- )
     "x" operand "userenv" f dlsym MOV

From 2fa14f55ad3a37b357066082bf3ea286d5229f95 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Fri, 5 May 2006 06:08:37 +0000
Subject: [PATCH 085/112] New 'pentium4' architecture

---
 library/bootstrap/boot-stage1.factor        | 68 ++++++++++-----------
 library/bootstrap/image.factor              |  2 +-
 library/compiler/x86/architecture.factor    |  4 ++
 library/compiler/x86/intrinsics-sse2.factor | 38 ++++++++++++
 library/compiler/x86/intrinsics.factor      | 33 ----------
 5 files changed, 77 insertions(+), 68 deletions(-)
 create mode 100644 library/compiler/x86/intrinsics-sse2.factor

diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor
index 72ebb79b79..bb217acdf6 100644
--- a/library/bootstrap/boot-stage1.factor
+++ b/library/bootstrap/boot-stage1.factor
@@ -9,6 +9,10 @@ vectors words ;
 
 "/library/bootstrap/primitives.factor" run-resource
 
+: if-arch ( arch seq -- )
+    architecture rot member?
+    [ [ parse-resource % ] each ] [ drop ] if ;
+
 ! The [ ] make form creates a boot quotation
 [
     \ boot ,
@@ -277,40 +281,34 @@ vectors words ;
         "/doc/handbook/words.facts"
     } [ parse-resource % ] each
     
-    architecture get {
-        {
-            [ dup "x86" = ] [
-                {
-                    "/library/compiler/x86/assembler.factor"
-                    "/library/compiler/x86/architecture.factor"
-                    "/library/compiler/x86/alien.factor"
-                    "/library/compiler/x86/intrinsics.factor"
-                }
-            ]
-        } {
-            [ dup "ppc" = ] [
-                {
-                    "/library/compiler/ppc/assembler.factor"
-                    "/library/compiler/ppc/architecture.factor"
-                    "/library/compiler/ppc/intrinsics.factor"
-                }
-            ]
-        } {
-            [ dup "amd64" = ] [
-                {
-                    "/library/compiler/x86/assembler.factor"
-                    "/library/compiler/amd64/architecture.factor"
-                    "/library/compiler/x86/generator.factor"
-                    "/library/compiler/amd64/generator.factor"
-                    "/library/compiler/x86/slots.factor"
-                    "/library/compiler/amd64/slots.factor"
-                    "/library/compiler/x86/stack.factor"
-                    "/library/compiler/x86/fixnum.factor"
-                    "/library/compiler/amd64/alien.factor"
-                }
-            ]
-        }
-    } cond [ parse-resource % ] each drop
+    { "x86" "pentium4" } {
+        "/library/compiler/x86/assembler.factor"
+        "/library/compiler/x86/architecture.factor"
+        "/library/compiler/x86/alien.factor"
+        "/library/compiler/x86/intrinsics.factor"
+    } if-arch
+    
+    { "pentium4" } {
+        "/library/compiler/x86/intrinsics-sse2.factor"
+    } if-arch
+
+    { "ppc" } {
+        "/library/compiler/ppc/assembler.factor"
+        "/library/compiler/ppc/architecture.factor"
+        "/library/compiler/ppc/intrinsics.factor"
+    } if-arch
+
+    { "amd64" } {
+        "/library/compiler/x86/assembler.factor"
+        "/library/compiler/amd64/architecture.factor"
+        "/library/compiler/x86/generator.factor"
+        "/library/compiler/amd64/generator.factor"
+        "/library/compiler/x86/slots.factor"
+        "/library/compiler/amd64/slots.factor"
+        "/library/compiler/x86/stack.factor"
+        "/library/compiler/x86/fixnum.factor"
+        "/library/compiler/amd64/alien.factor"
+    } if-arch
     
     [
         "/library/bootstrap/boot-stage2.factor" run-resource
@@ -330,3 +328,5 @@ vocabularies get [
 "Building generic words..." print flush
 
 all-words [ generic? ] subset [ make-generic ] each
+
+FORGET: if-arch
diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor
index dabb7de804..a0ee4204cf 100644
--- a/library/bootstrap/image.factor
+++ b/library/bootstrap/image.factor
@@ -361,4 +361,4 @@ M: hashtable ' ( hashtable -- pointer )
     ] with-scope ;
 
 : make-images ( -- )
-    { "x86" "ppc" "amd64" } [ make-image ] each ;
+    { "x86" "pentium4" "ppc" "amd64" } [ make-image ] each ;
diff --git a/library/compiler/x86/architecture.factor b/library/compiler/x86/architecture.factor
index 70a0a20614..676a6a2801 100644
--- a/library/compiler/x86/architecture.factor
+++ b/library/compiler/x86/architecture.factor
@@ -47,6 +47,8 @@ M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 : prepare-division CDQ ; inline
 
 : unboxify-float ( obj vreg quot -- | quot: obj int-vreg )
+    #! The SSE2 code here will never be generated unless SSE2
+    #! intrinsics are loaded.
     over [ float-regs? ] is? [
         swap >r T{ int-regs } alloc-reg [ swap call ] keep
         r> swap [ v>operand ] 2apply float-offset [+] MOVSD
@@ -102,6 +104,8 @@ M: object load-literal ( literal vreg -- )
     swap [ swap vreg-mov ] unboxify-float ;
 
 : %replace ( vreg loc -- )
+    #! The SSE2 code here will never be generated unless SSE2
+    #! intrinsics are loaded.
     over [ float-regs? ] is? [
         ! >r
         ! "fp-scratch" operand "allot.here" f dlsym [] MOV
diff --git a/library/compiler/x86/intrinsics-sse2.factor b/library/compiler/x86/intrinsics-sse2.factor
new file mode 100644
index 0000000000..239d63e456
--- /dev/null
+++ b/library/compiler/x86/intrinsics-sse2.factor
@@ -0,0 +1,38 @@
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien arrays assembler kernel kernel-internals lists math
+math-internals namespaces sequences words ;
+IN: compiler
+
+! Floats
+: define-float-op ( word op -- )
+    [ [ "x" operand "y" operand ] % , ] [ ] make H{
+        { +input { { float "x" } { float "y" } } }
+        { +output { "x" } }
+    } define-intrinsic ;
+
+{
+    { float+ ADDSD }
+    { float- SUBSD }
+    { float* MULSD }
+    { float/f DIVSD }
+} [
+    first2 define-float-op
+] each
+
+: define-float-jump ( word op -- )
+    [
+        [ end-basic-block "x" operand "y" operand COMISD ] % ,
+    ] [ ] make H{
+        { +input { { float "x" } { float "y" } } }
+    } define-if-intrinsic ;
+
+{
+    { float< JL }
+    { float<= JLE }
+    { float> JG }
+    { float>= JGE }
+    { float= JE }
+} [
+    first2 define-float-jump
+] each
diff --git a/library/compiler/x86/intrinsics.factor b/library/compiler/x86/intrinsics.factor
index e98ab9ec33..c4aea1c22d 100644
--- a/library/compiler/x86/intrinsics.factor
+++ b/library/compiler/x86/intrinsics.factor
@@ -261,39 +261,6 @@ IN: compiler
     first2 define-fixnum-jump
 ] each
 
-! Floats
-! : define-float-op ( word op -- )
-!     [ [ "x" operand "y" operand ] % , ] [ ] make H{
-!         { +input { { float "x" } { float "y" } } }
-!         { +output { "x" } }
-!     } define-intrinsic ;
-! 
-! {
-!     { float+ ADDSD }
-!     { float- SUBSD }
-!     { float* MULSD }
-!     { float/f DIVSD }
-! } [
-!     first2 define-float-op
-! ] each
-! 
-! : define-float-jump ( word op -- )
-!     [
-!         [ end-basic-block "x" operand "y" operand COMISD ] % ,
-!     ] [ ] make H{
-!         { +input { { float "x" } { float "y" } } }
-!     } define-if-intrinsic ;
-! 
-! {
-!     { float< JL }
-!     { float<= JLE }
-!     { float> JG }
-!     { float>= JGE }
-!     { float= JE }
-! } [
-!     first2 define-float-jump
-! ] each
-
 ! User environment
 : %userenv ( -- )
     "x" operand "userenv" f dlsym MOV

From da29021086f7b52eb2f80ebd0cf32b36f7eeb350 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sat, 6 May 2006 00:06:57 +0000
Subject: [PATCH 086/112] Working on float intrinsics

---
 TODO.FACTOR.txt                               | 36 ++++++++++---------
 library/bootstrap/boot-stage1.factor          |  2 +-
 library/bootstrap/image.factor                | 25 ++++++-------
 .../compiler/generator/architecture.factor    |  3 ++
 library/compiler/generator/generator.factor   | 10 ++----
 library/compiler/generator/templates.factor   |  9 ++---
 library/compiler/x86/architecture.factor      | 34 +++++++++---------
 library/compiler/x86/assembler.factor         |  2 +-
 library/compiler/x86/intrinsics-sse2.factor   | 36 +++++++++++++++++--
 library/kernel.factor                         |  3 ++
 library/math/float.factor                     | 11 ++++--
 library/test/compiler/float.factor            | 25 +++++++++++++
 library/test/test.factor                      |  2 +-
 native/gc.h                                   |  2 +-
 14 files changed, 133 insertions(+), 67 deletions(-)
 create mode 100644 library/test/compiler/float.factor

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index d7acafcbb4..c2a6d56013 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,21 +1,17 @@
 should fix in 0.82:
 
-- constant branch folding
-- fast-slot stuff
-- 3 >n fep
+- callback segv
+- generate-push should not do anything without sse2
+- get literals working
+- get loads from stack working
+- get boxing working
+- straighten out "fp-scratch"
+- clean up/rewrite register allocation
+
 - amd64 %box-struct
-- get factor running on mac intel
 - when generating a 32-bit image on a 64-bit system, large numbers which should
   be bignums become fixnums
-- clicks sent twice
-- speed up ideas:
-  - only do clipping for certain gadgets
-  - use glRect
-
-+ portability:
-
-- win64 port
-- amd64 %unbox-struct
+- get factor running on mac intel
 
 + io:
 
@@ -23,9 +19,14 @@ should fix in 0.82:
 - better i/o scheduler
 - yield in a loop starves i/o
 - "localhost" 50 <client> won't fail
+- issues with timeouts
 
 + ui/help:
 
+- clicks sent twice
+- speed up ideas:
+  - only do clipping for certain gadgets
+  - use glRect
 - polish OS X menu bar code
 - help search
 - reimplement clicking input
@@ -54,16 +55,16 @@ should fix in 0.82:
 
 + compiler/ffi:
 
+- win64 port
+- amd64 %unbox-struct
+- constant branch folding
 - core foundation should use unicode strings
 - alien>utf16-string, utf16-string>alien words
 - can <void*> only be called with an alien?
 - remove <char*>, <ushort*>, set-char*-nth, set-ushort*-nth since they
   have incorrect semantics
-- improve callback efficiency
-- float intrinsics
 - complex float type
 - complex float intrinsics
-- out of memory from overflow check
 - remove literal table
 - C functions returning structs by value
 - FIELD: char key_vector[32];
@@ -73,10 +74,11 @@ should fix in 0.82:
 - [ [ dup call ] dup call ] infer hangs
 - the invalid recursion form case needs to be fixed, for inlines too
 - code gc
-- compiled gc check slows things down
+- fix compiled gc check
 
 + misc:
 
+- 3 >n fep
 - code walker & exceptions
 - slice: if sequence or seq start is changed, abstraction violation
 - make 3.4 bits>double an error
diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor
index bb217acdf6..041bc8be1e 100644
--- a/library/bootstrap/boot-stage1.factor
+++ b/library/bootstrap/boot-stage1.factor
@@ -10,7 +10,7 @@ vectors words ;
 "/library/bootstrap/primitives.factor" run-resource
 
 : if-arch ( arch seq -- )
-    architecture rot member?
+    architecture get rot member?
     [ [ parse-resource % ] each ] [ drop ] if ;
 
 ! The [ ] make form creates a boot quotation
diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor
index a0ee4204cf..5d6f02f281 100644
--- a/library/bootstrap/image.factor
+++ b/library/bootstrap/image.factor
@@ -62,9 +62,6 @@ SYMBOL: architecture
 : word-type      16 ; inline
 : tuple-type     17 ; inline
 
-: immediate ( x tag -- tagged ) swap tag-bits shift bitor ;
-: >header ( id -- tagged ) object-tag immediate ;
-
 ( Image header )
 
 : base 1024 ;
@@ -106,9 +103,9 @@ GENERIC: ' ( obj -- ptr )
 
 ( Fixnums )
 
-: emit-fixnum ( n -- ) fixnum-tag immediate emit ;
+: emit-fixnum ( n -- ) fixnum-tag tag-address emit ;
 
-M: fixnum ' ( n -- tagged ) fixnum-tag immediate ;
+M: fixnum ' ( n -- tagged ) fixnum-tag tag-address ;
 
 ( Bignums )
 
@@ -136,14 +133,14 @@ M: fixnum ' ( n -- tagged ) fixnum-tag immediate ;
 M: bignum ' ( bignum -- tagged )
     #! This can only emit 0, -1 and 1.
     bignum-tag here-as >r
-    bignum-tag >header emit
+    bignum-tag tag-header emit
     emit-bignum align-here r> ;
 
 ( Floats )
 
 M: float ' ( float -- tagged )
     float-tag here-as >r
-    float-tag >header emit
+    float-tag tag-header emit
     align-here
     double>bits emit-64
     r> ;
@@ -177,7 +174,7 @@ M: f ' ( obj -- ptr )
     dup word-vocabulary ' >r
     dup word-name ' >r
     object-tag here-as over objects get set-hash
-    word-type >header emit
+    word-type tag-header emit
     hashcode emit-fixnum
     r> emit
     r> emit
@@ -209,7 +206,7 @@ M: word ' ( word -- pointer ) ;
 M: wrapper ' ( wrapper -- pointer )
     wrapped '
     object-tag here-as >r
-    wrapper-type >header emit
+    wrapper-type tag-header emit
     emit r> ;
 
 ( Conses )
@@ -234,7 +231,7 @@ M: complex ' ( c -- tagged ) >rect complex-tag emit-cons ;
 
 : emit-string ( string -- ptr )
     object-tag here-as swap
-    string-type >header emit
+    string-type tag-header emit
     dup length emit-fixnum
     dup hashcode emit-fixnum
     pack-string emit-chars
@@ -250,7 +247,7 @@ M: string ' ( string -- pointer )
 : emit-array ( list type -- pointer )
     >r [ ' ] map r>
     object-tag here-as >r
-    >header emit
+    tag-header emit
     dup length emit-fixnum
     ( elements -- ) emit-seq
     align-here r> ;
@@ -270,7 +267,7 @@ M: array ' ( array -- pointer )
 M: vector ' ( vector -- pointer )
     dup underlying ' swap length
     object-tag here-as >r
-    vector-type >header emit
+    vector-type tag-header emit
     emit-fixnum ( length )
     emit ( array ptr )
     align-here r> ;
@@ -278,7 +275,7 @@ M: vector ' ( vector -- pointer )
 M: sbuf ' ( sbuf -- pointer )
     dup underlying ' swap length
     object-tag here-as >r
-    sbuf-type >header emit
+    sbuf-type tag-header emit
     emit-fixnum ( length )
     emit ( array ptr )
     align-here r> ;
@@ -288,7 +285,7 @@ M: sbuf ' ( sbuf -- pointer )
 M: hashtable ' ( hashtable -- pointer )
     [ hash-array ' ] keep
     object-tag here-as >r
-    hashtable-type >header emit
+    hashtable-type tag-header emit
     dup hash-count emit-fixnum
     hash-deleted emit-fixnum
     emit ( array ptr )
diff --git a/library/compiler/generator/architecture.factor b/library/compiler/generator/architecture.factor
index e464b8e443..3a3f7f3649 100644
--- a/library/compiler/generator/architecture.factor
+++ b/library/compiler/generator/architecture.factor
@@ -27,6 +27,9 @@ GENERIC: fastcall-regs ( register-class -- regs )
 ! Sequence mapping vreg-n to native assembler registers
 GENERIC: vregs ( register-class -- regs )
 
+! Map a sequence of literals to f or float
+DEFER: literal-template ( literals -- template )
+
 ! Load a literal (immediate or indirect)
 G: load-literal ( obj vreg -- ) 1 standard-combination ;
 
diff --git a/library/compiler/generator/generator.factor b/library/compiler/generator/generator.factor
index 435dcecb4a..70e067ced4 100644
--- a/library/compiler/generator/generator.factor
+++ b/library/compiler/generator/generator.factor
@@ -195,14 +195,10 @@ UNION: immediate fixnum POSTPONE: f ;
 : alloc-literal-reg ( literal -- vreg )
     float? T{ float-regs f 8 } T{ int-regs } ? alloc-reg ;
 
-! : generate-push ( node -- )
-!     >#push< dup [ class ] map requested-vregs ensure-vregs
-!     [ dup alloc-literal-reg [ load-literal ] keep ] map
-!     phantom-d get phantom-append ;
-
 : generate-push ( node -- )
-    >#push< dup length 0 ensure-vregs
-    [ T{ int-regs } alloc-reg [ load-literal ] keep ] map
+    >#push< dup literal-template
+    dup requested-vregs ensure-vregs
+    alloc-vregs [ [ load-literal ] 2each ] keep
     phantom-d get phantom-append ;
 
 M: #push generate-node ( #push -- )
diff --git a/library/compiler/generator/templates.factor b/library/compiler/generator/templates.factor
index 1e7982fd17..d089ce1ec5 100644
--- a/library/compiler/generator/templates.factor
+++ b/library/compiler/generator/templates.factor
@@ -15,7 +15,7 @@ namespaces prettyprint sequences vectors words ;
 
 : alloc-vregs ( template -- template )
     [
-        first dup
+        dup
         H{ { f T{ int-regs } } { float T{ float-regs f 8 } } }
         hash [ alloc-reg ] [ <int-vreg> dup take-reg ] ?if
     ] map ;
@@ -179,7 +179,7 @@ SYMBOL: phantom-r
 
 : stack>vregs ( phantom template -- values )
     [
-        alloc-vregs dup length rot phantom-locs
+        [ first ] map alloc-vregs dup length rot phantom-locs
         [ dupd %peek ] 2map
     ] 2keep length neg swap adjust-phantom ;
 
@@ -258,10 +258,11 @@ SYMBOL: +clobber
 
 : guess-vregs ( -- int# float# )
     +input get { } additional-vregs#
-    +scratch get requested-vregs >r + r> ;
+    +scratch get [ first ] map requested-vregs >r + r> ;
 
 : alloc-scratch ( -- )
-    +scratch get [ alloc-vregs ] keep phantom-vregs ;
+    +scratch get
+    [ [ first ] map alloc-vregs ] keep phantom-vregs ;
 
 : template-inputs ( -- )
     ! Ensure we have enough to hold any new stack elements we
diff --git a/library/compiler/x86/architecture.factor b/library/compiler/x86/architecture.factor
index 676a6a2801..1a3c030224 100644
--- a/library/compiler/x86/architecture.factor
+++ b/library/compiler/x86/architecture.factor
@@ -46,16 +46,26 @@ M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 
 : prepare-division CDQ ; inline
 
+: fp-scratch ( -- vreg )
+    "fp-scratch" get [
+        T{ int-regs } alloc-reg dup "fp-scratch" set
+    ] unless* ;
+
 : unboxify-float ( obj vreg quot -- | quot: obj int-vreg )
     #! The SSE2 code here will never be generated unless SSE2
     #! intrinsics are loaded.
     over [ float-regs? ] is? [
-        swap >r T{ int-regs } alloc-reg [ swap call ] keep
+        swap >r fp-scratch [ swap call ] keep
         r> swap [ v>operand ] 2apply float-offset [+] MOVSD
     ] [
         call
     ] if ; inline
 
+: literal-template
+    #! All literals go into integer registers unless SSE2
+    #! intrinsics are loaded.
+    length f <array> ;
+
 M: immediate load-literal ( literal vreg -- )
     v>operand swap v>operand MOV ;
 
@@ -98,24 +108,16 @@ M: object load-literal ( literal vreg -- )
 
 : %return ( -- ) %epilogue RET ;
 
-: vreg-mov [ v>operand ] 2apply MOV ;
+: vreg-mov swap [ v>operand ] 2apply MOV ;
 
 : %peek ( vreg loc -- )
-    swap [ swap vreg-mov ] unboxify-float ;
+    swap [ vreg-mov ] unboxify-float ;
 
-: %replace ( vreg loc -- )
-    #! The SSE2 code here will never be generated unless SSE2
-    #! intrinsics are loaded.
-    over [ float-regs? ] is? [
-        ! >r
-        ! "fp-scratch" operand "allot.here" f dlsym [] MOV
-        ! "fp-scratch" operand [] float-tag >header MOV
-        ! "fp-scratch" operand 8 [+] r> MOVSD
-        ! "allot.here" f dlsym [] 16 ADD
-        vreg-mov
-    ] [
-        vreg-mov
-    ] if ;
+GENERIC: (%replace) ( vreg loc reg-class -- )
+
+M: int-regs (%replace) drop vreg-mov ;
+
+: %replace ( vreg loc -- ) over (%replace) ;
 
 : (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
 
diff --git a/library/compiler/x86/assembler.factor b/library/compiler/x86/assembler.factor
index 51a493ceef..ca56945b84 100644
--- a/library/compiler/x86/assembler.factor
+++ b/library/compiler/x86/assembler.factor
@@ -376,7 +376,7 @@ M: operand CMP OCT: 071 2-operand ;
 : 2-operand-sse ( dst src op1 op2 -- )
     #! We swap the operands here to make everything consistent
     #! with the integer instructions.
-    swap assemble-1 swapd
+    swap assemble-1 pick register-128? [ swapd ] [ 1 bitor ] if
     >r 2dup t prefix HEX: 0f assemble-1 r>
     assemble-1 reg-code swap addressing ;
 
diff --git a/library/compiler/x86/intrinsics-sse2.factor b/library/compiler/x86/intrinsics-sse2.factor
index 239d63e456..8e43378169 100644
--- a/library/compiler/x86/intrinsics-sse2.factor
+++ b/library/compiler/x86/intrinsics-sse2.factor
@@ -1,9 +1,41 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays assembler kernel kernel-internals lists math
-math-internals namespaces sequences words ;
+USING: alien arrays assembler generic kernel kernel-internals
+lists math math-internals memory namespaces sequences words ;
 IN: compiler
 
+: literal-template
+    #! floats map to 'float' so we put float literals in float
+    #! vregs
+    [ class ] map ;
+
+: load-zone-ptr ( vreg -- )
+    #! Load pointer to start of zone array
+    "generations" f dlsym [] MOV ;
+
+: load-allot-ptr ( vreg -- )
+    dup load-zone-ptr dup cell [+] MOV ;
+
+: inc-allot-ptr ( vreg n -- )
+    >r dup load-zone-ptr cell [+] r> ADD ;
+
+: with-inline-alloc ( vreg spec prequot postquot -- )
+    #! both quotations are called with the vreg
+    rot [
+        >r >r v>operand dup load-allot-ptr
+        dup [] \ tag-header get call tag-header MOV
+        r> over slip dup \ tag get call OR
+        r> over slip \ size get call inc-allot-ptr
+    ] bind ; inline
+
+M: float-regs (%replace) ( vreg loc reg-class -- )
+    drop fp-scratch H{
+        { tag-header [ float-tag ] }
+        { tag [ float-tag ] }
+        { size [ 16 ] }
+    } [ 8 [+] rot v>operand MOVSD ]
+    [ >r v>operand r> MOV ] with-inline-alloc ;
+
 ! Floats
 : define-float-op ( word op -- )
     [ [ "x" operand "y" operand ] % , ] [ ] make H{
diff --git a/library/kernel.factor b/library/kernel.factor
index c18ff92ce1..8c54939ab3 100644
--- a/library/kernel.factor
+++ b/library/kernel.factor
@@ -102,6 +102,9 @@ IN: kernel-internals
 
 : cell 17 getenv ; foldable
 
+: tag-address ( x tag -- tagged ) swap tag-bits shift bitor ;
+: tag-header ( id -- tagged ) object-tag tag-address ;
+
 IN: kernel
 
 : win32? windows? cell 4 = and ; inline
diff --git a/library/math/float.factor b/library/math/float.factor
index 9af3f3bbf1..b17fc6c0fd 100644
--- a/library/math/float.factor
+++ b/library/math/float.factor
@@ -1,7 +1,13 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+IN: math-internals
+USING: math kernel ;
+
+: float= ( n n -- )
+    #! The compiler replaces this with a better intrinsic.
+    [ double>bits ] 2apply number= ;
+
 IN: math
-USING: generic kernel math-internals ;
 
 UNION: real rational float ;
 
@@ -17,12 +23,11 @@ M: real <=> - ;
 M: float zero?
     double>bits HEX: 8000000000000000 [ bitor ] keep number= ;
 
-M: float number= [ double>bits ] 2apply number= ;
-
 M: float < float< ;
 M: float <= float<= ;
 M: float > float> ;
 M: float >= float>= ;
+M: float number= float= ;
 
 M: float + float+ ;
 M: float - float- ;
diff --git a/library/test/compiler/float.factor b/library/test/compiler/float.factor
new file mode 100644
index 0000000000..e23da1fbd8
--- /dev/null
+++ b/library/test/compiler/float.factor
@@ -0,0 +1,25 @@
+IN: temporary
+USING: compiler kernel memory math math-internals test ;
+
+[ 5.0 ] [ [ 5.0 ] compile-1 full-gc full-gc full-gc ] unit-test
+[ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-1 ] unit-test
+
+[ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-1 ] unit-test
+[ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-1 ] unit-test
+[ 3.0 ] [ 1.0 2.0 [ float+ ] compile-1 ] unit-test
+[ 3.0 ] [ 1.0 2.0 [ swap float+ ] compile-1 ] unit-test
+
+[ -1.0 ] [ 1.0 [ 2.0 float- ] compile-1 ] unit-test
+[ 1.0 ] [ 1.0 [ 2.0 swap float- ] compile-1 ] unit-test
+[ -1.0 ] [ 1.0 2.0 [ float- ] compile-1 ] unit-test
+[ 1.0 ] [ 1.0 2.0 [ swap float- ] compile-1 ] unit-test
+
+[ 6.0 ] [ 3.0 [ 2.0 float* ] compile-1 ] unit-test
+[ 6.0 ] [ 3.0 [ 2.0 swap float* ] compile-1 ] unit-test
+[ 6.0 ] [ 3.0 2.0 [ float* ] compile-1 ] unit-test
+[ 6.0 ] [ 3.0 2.0 [ swap float* ] compile-1 ] unit-test
+
+[ 0.5 ] [ 1.0 [ 2.0 float/f ] compile-1 ] unit-test
+[ 2.0 ] [ 1.0 [ 2.0 swap float/f ] compile-1 ] unit-test
+[ 0.5 ] [ 1.0 2.0 [ float/f ] compile-1 ] unit-test
+[ 2.0 ] [ 1.0 2.0 [ swap float/f ] compile-1 ] unit-test
diff --git a/library/test/test.factor b/library/test/test.factor
index b579bb0e0c..2d6a0389d5 100644
--- a/library/test/test.factor
+++ b/library/test/test.factor
@@ -104,7 +104,7 @@ SYMBOL: failures
         "compiler/simple" "compiler/templates"
         "compiler/stack" "compiler/ifte"
         "compiler/generic" "compiler/bail-out"
-        "compiler/intrinsics"
+        "compiler/intrinsics" "compiler/float"
         "compiler/identities" "compiler/optimizer"
         "compiler/alien" "compiler/callbacks"
     } run-tests ;
diff --git a/native/gc.h b/native/gc.h
index 07482fcbdb..0151aa9b95 100644
--- a/native/gc.h
+++ b/native/gc.h
@@ -18,7 +18,7 @@ CELL gen_count;
 /* the oldest generation */
 #define TENURED (gen_count-1)
 
-ZONE *generations;
+DLLEXPORT ZONE *generations;
 
 /* used during garbage collection only */
 ZONE *newspace;

From 6318d7d719e1882ed8f10730be61e49f1f180b78 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sat, 6 May 2006 01:41:57 +0000
Subject: [PATCH 087/112] Floating point fixes

---
 TODO.FACTOR.txt                               |  6 ---
 library/bootstrap/profile-pentium4.factor     |  6 +++
 library/compiler/generator/generator.factor   |  3 --
 library/compiler/generator/templates.factor   | 39 ++++++++++++-------
 .../compiler/optimizer/specializers.factor    | 22 +++++++++--
 library/generic/math-combination.factor       |  4 +-
 library/generic/tuple.factor                  |  2 +-
 library/kernel.factor                         |  5 ---
 library/math/complex.factor                   |  3 --
 library/math/constants.factor                 |  5 ++-
 library/math/float.factor                     |  6 +--
 library/math/integer.factor                   | 10 +----
 library/math/math.factor                      |  4 +-
 library/math/ratio.factor                     |  3 --
 library/test/compiler/optimizer.factor        |  4 +-
 library/test/compiler/simple.factor           |  2 +-
 library/test/compiler/templates.factor        |  2 +-
 17 files changed, 67 insertions(+), 59 deletions(-)
 create mode 100644 library/bootstrap/profile-pentium4.factor

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index c2a6d56013..4061265c64 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,11 +1,5 @@
 should fix in 0.82:
 
-- callback segv
-- generate-push should not do anything without sse2
-- get literals working
-- get loads from stack working
-- get boxing working
-- straighten out "fp-scratch"
 - clean up/rewrite register allocation
 
 - amd64 %box-struct
diff --git a/library/bootstrap/profile-pentium4.factor b/library/bootstrap/profile-pentium4.factor
new file mode 100644
index 0000000000..daa47e4f52
--- /dev/null
+++ b/library/bootstrap/profile-pentium4.factor
@@ -0,0 +1,6 @@
+USING: image kernel-internals namespaces ;
+
+! Do not load this file into a running image, ever.
+
+4 \ cell set
+big-endian off
diff --git a/library/compiler/generator/generator.factor b/library/compiler/generator/generator.factor
index 70e067ced4..2fa70abfad 100644
--- a/library/compiler/generator/generator.factor
+++ b/library/compiler/generator/generator.factor
@@ -192,9 +192,6 @@ M: #dispatch generate-node ( node -- next )
 ! #push
 UNION: immediate fixnum POSTPONE: f ;
 
-: alloc-literal-reg ( literal -- vreg )
-    float? T{ float-regs f 8 } T{ int-regs } ? alloc-reg ;
-
 : generate-push ( node -- )
     >#push< dup literal-template
     dup requested-vregs ensure-vregs
diff --git a/library/compiler/generator/templates.factor b/library/compiler/generator/templates.factor
index d089ce1ec5..2a4b290588 100644
--- a/library/compiler/generator/templates.factor
+++ b/library/compiler/generator/templates.factor
@@ -13,11 +13,16 @@ namespaces prettyprint sequences vectors words ;
 
 : take-reg ( vreg -- ) dup delegate free-vregs delete ;
 
+: reg-spec>class ( spec -- class )
+    float eq? T{ float-regs f 8 } T{ int-regs } ? ;
+
 : alloc-vregs ( template -- template )
     [
-        dup
-        H{ { f T{ int-regs } } { float T{ float-regs f 8 } } }
-        hash [ alloc-reg ] [ <int-vreg> dup take-reg ] ?if
+        dup integer? [
+            <int-vreg> dup take-reg
+        ] [
+            reg-spec>class alloc-reg
+        ] if
     ] map ;
 
 ! A data stack location.
@@ -99,8 +104,8 @@ SYMBOL: phantom-r
 : finalize-heights ( -- )
     phantoms [ finalize-height ] 2apply ;
 
-: stack>new-vreg ( loc -- vreg )
-    T{ int-regs } alloc-reg [ swap %peek ] keep ;
+: stack>new-vreg ( loc spec -- vreg )
+    reg-spec>class alloc-reg [ swap %peek ] keep ;
 
 : vreg>stack ( value loc -- )
     over loc? [
@@ -121,7 +126,7 @@ SYMBOL: phantom-r
 
 : live-locs ( phantom phantom -- hash )
     [ (live-locs) ] 2apply append prune
-    [ dup stack>new-vreg ] map>hash ;
+    [ dup f stack>new-vreg ] map>hash ;
 
 : lazy-store ( value loc -- )
     over loc? [
@@ -170,12 +175,18 @@ SYMBOL: phantom-r
     compute-free-vregs free-vregs* swapd <= >r <= r> and
     [ finalize-contents compute-free-vregs ] unless ;
 
-: lazy-load ( value loc -- value )
-    over loc?
-    [ dupd = [ drop f ] [ stack>new-vreg ] if ] [ drop ] if ;
-
-: phantom-vregs ( values template -- )
-    [ >r f lazy-load r> second set ] 2each ;
+: lazy-load ( values template -- template )
+    [
+        first2 >r over loc? [
+            over integer? [
+                >r <int-vreg> dup r> %peek
+            ] [
+                stack>new-vreg
+            ] if
+        ] [
+            drop
+        ] if r> 2array
+    ] 2map ;
 
 : stack>vregs ( phantom template -- values )
     [
@@ -213,7 +224,7 @@ SYMBOL: phantom-r
     phantom-d get
     over length neg over adjust-phantom
     over length swap cut-phantom
-    swap phantom-vregs ;
+    swap lazy-load [ first2 set ] each ;
 
 : phantom-push ( obj stack -- )
     1 over adjust-phantom push ;
@@ -244,6 +255,8 @@ SYMBOL: +clobber
     output-vregs append phantoms append
     [ swap member? ] contains-with? ;
 
+: phantom-vregs ( values template -- ) [ second set ] 2each ;
+
 : slow-input ( template -- )
     ! Are we loading stuff from the stack? Then flush out
     ! remaining vregs, not slurped in by fast-input.
diff --git a/library/compiler/optimizer/specializers.factor b/library/compiler/optimizer/specializers.factor
index c56a6249d1..47c38a63db 100644
--- a/library/compiler/optimizer/specializers.factor
+++ b/library/compiler/optimizer/specializers.factor
@@ -1,10 +1,10 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: compiler
-USING: arrays generic hashtables kernel math namespaces
-sequences vectors words ;
+USING: arrays generic hashtables kernel kernel-internals math
+namespaces sequences vectors words ;
 
-: make-specializer ( quot class picker -- quot )
+: make-standard-specializer ( quot class picker -- quot )
     over \ object eq? [
         2drop
     ] [
@@ -13,6 +13,18 @@ sequences vectors words ;
         ] [ ] make
     ] if ;
 
+: make-math-specializer ( quot picker -- quot )
+    [
+        , \ tag , num-tags swap <array> , \ dispatch ,
+    ] [ ] make ;
+
+: make-specializer ( quot class picker -- quot )
+    over number eq? [
+        nip make-math-specializer
+    ] [
+        make-standard-specializer
+    ] if ;
+
 : specialized-def ( word -- quot )
     dup word-def swap "specializer" word-prop [
         reverse-slice { dup over pick } [
@@ -20,6 +32,10 @@ sequences vectors words ;
         ] 2each
     ] when* ;
 
+{ 1+ 1- sq neg recip sgn truncate } [
+    { number } "specializer" set-word-prop
+] each
+
 { vneg norm-sq norm normalize } [
     { array } "specializer" set-word-prop
 ] each
diff --git a/library/generic/math-combination.factor b/library/generic/math-combination.factor
index a35b5754f0..10751ff9cf 100644
--- a/library/generic/math-combination.factor
+++ b/library/generic/math-combination.factor
@@ -6,7 +6,7 @@ lists math namespaces sequences words ;
 
 ! Math combination for generic dyadic upgrading arithmetic.
 
-: first/last ( seq -- pair ) dup first swap peek 2array ;
+: last/first ( seq -- pair ) dup peek swap first 2array ;
 
 : math-class? ( object -- ? )
     dup word? [ number bootstrap-word class< ] [ drop f ] if ;
@@ -14,7 +14,7 @@ lists math namespaces sequences words ;
 : math-class-compare ( class class -- n )
     [
         dup math-class?
-        [ types first/last ] [ drop { 100 100 } ] if
+        [ types last/first ] [ drop { 100 100 } ] if
     ] 2apply <=> ;
 
 : math-class-max ( class class -- class )
diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor
index 6c9379892d..767c0932c9 100644
--- a/library/generic/tuple.factor
+++ b/library/generic/tuple.factor
@@ -39,7 +39,7 @@ IN: generic
         r> 2drop
     ] if ;
 
-: delegate-slots { { 3 delegate set-delegate } } ;
+: delegate-slots { { 3 object delegate set-delegate } } ;
 
 : tuple-slots ( tuple slots -- )
     2dup "slot-names" set-word-prop
diff --git a/library/kernel.factor b/library/kernel.factor
index 8c54939ab3..0e473d75d6 100644
--- a/library/kernel.factor
+++ b/library/kernel.factor
@@ -102,9 +102,6 @@ IN: kernel-internals
 
 : cell 17 getenv ; foldable
 
-: tag-address ( x tag -- tagged ) swap tag-bits shift bitor ;
-: tag-header ( id -- tagged ) object-tag tag-address ;
-
 IN: kernel
 
 : win32? windows? cell 4 = and ; inline
@@ -113,7 +110,5 @@ IN: kernel
 IN: memory
 
 : generations ( -- n ) 15 getenv ;
-
 : image ( -- path ) 16 getenv ;
-
 : save ( -- ) image save-image ;
diff --git a/library/math/complex.factor b/library/math/complex.factor
index 90547d7598..0166d64db2 100644
--- a/library/math/complex.factor
+++ b/library/math/complex.factor
@@ -61,9 +61,6 @@ M: complex * ( x y -- x*y ) 2dup *re - -rot *im + (rect>) ;
 M: complex / ( x y -- x/y ) complex/ tuck / >r / r> (rect>) ;
 M: complex /f ( x y -- x/y ) complex/ tuck /f >r /f r> (rect>) ;
 
-M: complex 1+ >rect >r 1+ r> (rect>) ;
-M: complex 1- >rect >r 1- r> (rect>) ;
-
 M: complex abs ( z -- |z| ) absq fsqrt ;
 
 M: complex hashcode ( n -- n )
diff --git a/library/math/constants.factor b/library/math/constants.factor
index 7ed04d23d7..0220a5f69d 100644
--- a/library/math/constants.factor
+++ b/library/math/constants.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: kernel-internals
-USING: namespaces math ;
+USING: kernel namespaces math ;
 
 : bootstrap-cell \ cell get ; inline
 : cells cell * ; inline
@@ -10,6 +10,9 @@ USING: namespaces math ;
 : cell-bits 8 cells ; inline
 : bootstrap-cell-bits 8 bootstrap-cells ; inline
 
+: tag-address ( x tag -- tagged ) swap tag-bits shift bitor ;
+: tag-header ( id -- tagged ) object-tag tag-address ;
+
 IN: math
 
 : i C{ 0 1 } ; inline
diff --git a/library/math/float.factor b/library/math/float.factor
index b17fc6c0fd..911c193e25 100644
--- a/library/math/float.factor
+++ b/library/math/float.factor
@@ -20,8 +20,7 @@ M: real <=> - ;
 : fp-nan? ( float -- ? )
     double>bits -51 shift BIN: 111111111111 [ bitand ] keep = ;
 
-M: float zero?
-    double>bits HEX: 8000000000000000 [ bitor ] keep number= ;
+M: float zero? ( float -- ? ) dup 0.0 = swap -0.0 = or ;
 
 M: float < float< ;
 M: float <= float<= ;
@@ -35,6 +34,3 @@ M: float * float* ;
 M: float / float/f ;
 M: float /f float/f ;
 M: float mod float-mod ;
-
-M: float 1+ 1.0 float+ ;
-M: float 1- 1.0 float- ;
diff --git a/library/math/integer.factor b/library/math/integer.factor
index 605a909478..118f276e73 100644
--- a/library/math/integer.factor
+++ b/library/math/integer.factor
@@ -59,9 +59,6 @@ M: fixnum mod fixnum-mod ;
 
 M: fixnum /mod fixnum/mod ;
 
-M: fixnum 1+ 1 fixnum+ ;
-M: fixnum 1- 1 fixnum- ;
-
 M: fixnum bitand fixnum-bitand ;
 M: fixnum bitor fixnum-bitor ;
 M: fixnum bitxor fixnum-bitxor ;
@@ -69,8 +66,6 @@ M: fixnum shift fixnum-shift ;
 
 M: fixnum bitnot fixnum-bitnot ;
 
-M: fixnum zero? 0 eq? ;
-
 M: bignum number= bignum= ;
 M: bignum < bignum< ;
 M: bignum <= bignum<= ;
@@ -86,9 +81,6 @@ M: bignum mod bignum-mod ;
 
 M: bignum /mod bignum/mod ;
 
-M: bignum 1+ 1 >bignum bignum+ ;
-M: bignum 1- 1 >bignum bignum- ;
-
 M: bignum bitand bignum-bitand ;
 M: bignum bitor bignum-bitor ;
 M: bignum bitxor bignum-bitxor ;
@@ -96,4 +88,4 @@ M: bignum shift bignum-shift ;
 
 M: bignum bitnot bignum-bitnot ;
 
-M: bignum zero? 0 >bignum bignum= ;
+M: integer zero? 0 number= ;
diff --git a/library/math/math.factor b/library/math/math.factor
index 7812df3032..480689b402 100644
--- a/library/math/math.factor
+++ b/library/math/math.factor
@@ -28,14 +28,14 @@ G: shift  ( x n -- y ) math-combination ; foldable
 
 GENERIC: bitnot ( n -- n ) foldable
 
-GENERIC: 1+ ( x -- x+1 ) foldable
-GENERIC: 1- ( x -- x-1 ) foldable
 GENERIC: abs ( z -- |z| ) foldable
 GENERIC: absq ( n -- |n|^2 ) foldable
 
 GENERIC: zero? ( x -- ? ) foldable
 M: object zero? drop f ;
 
+: 1+ 1 + ; foldable
+: 1- 1 - ; foldable
 : sq dup * ; foldable
 : neg 0 swap - ; foldable
 : recip 1 swap / ; foldable
diff --git a/library/math/ratio.factor b/library/math/ratio.factor
index 1c61c56f83..70907a563b 100644
--- a/library/math/ratio.factor
+++ b/library/math/ratio.factor
@@ -37,6 +37,3 @@ M: ratio / scale / ;
 M: ratio /i scale /i ;
 M: ratio mod 2dup >r >r /i r> r> rot * - ;
 M: ratio /f scale /f ;
-
-M: ratio 1+ >fraction [ + ] keep fraction> ;
-M: ratio 1- >fraction [ - ] keep fraction> ;
diff --git a/library/test/compiler/optimizer.factor b/library/test/compiler/optimizer.factor
index 0fa16b2012..b4600cd277 100644
--- a/library/test/compiler/optimizer.factor
+++ b/library/test/compiler/optimizer.factor
@@ -1,8 +1,8 @@
-IN: temporary
 USING: arrays assembler compiler generic
 hashtables inference kernel kernel-internals lists math
 optimizer prettyprint sequences strings test vectors words
 sequences-internals ;
+IN: temporary
 
 : kill-1
     [ 1 2 3 ] [ + ] over drop drop ; compiled
@@ -38,6 +38,8 @@ sequences-internals ;
 
 : set= 2dup subset? >r swap subset? r> and ;
 
+USE: optimizer
+
 : kill-set dup live-values swap literals hash-diff ;
 
 : kill-set=
diff --git a/library/test/compiler/simple.factor b/library/test/compiler/simple.factor
index 0ee94dd17c..2674f6a3dd 100644
--- a/library/test/compiler/simple.factor
+++ b/library/test/compiler/simple.factor
@@ -1,4 +1,3 @@
-IN: temporary
 USE: compiler
 USE: test
 USE: math
@@ -7,6 +6,7 @@ USE: words
 USE: kernel
 USE: math-internals
 USE: memory
+IN: temporary
 
 : no-op ; compiled
 
diff --git a/library/test/compiler/templates.factor b/library/test/compiler/templates.factor
index 5dc1e92c37..650f1d02f3 100644
--- a/library/test/compiler/templates.factor
+++ b/library/test/compiler/templates.factor
@@ -1,8 +1,8 @@
 ! Black box testing of templater optimization
 
-IN: temporary
 USING: arrays compiler kernel kernel-internals math
 math-internals namespaces sequences sequences-internals test ;
+IN: temporary
 
 ! Oops!
 [ 5000 ] [ [ 5000 ] compile-1 ] unit-test

From e13b28e0d5524a160d063035ad32a9834a795bd9 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sat, 6 May 2006 03:06:08 +0000
Subject: [PATCH 088/112] More float tests, x86 float fixes

---
 TODO.FACTOR.txt                               |  2 +
 library/compiler/generator/generator.factor   | 15 +++---
 .../compiler/optimizer/call-optimizers.factor |  4 +-
 library/compiler/x86/assembler.factor         | 42 +++++++--------
 library/compiler/x86/intrinsics-sse2.factor   |  8 +--
 library/math/float.factor                     |  7 +--
 library/test/compiler/float.factor            | 51 +++++++++++++++++++
 library/test/compiler/identities.factor       | 10 ++--
 8 files changed, 96 insertions(+), 43 deletions(-)

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 4061265c64..f0bcd888df 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,6 +1,8 @@
 should fix in 0.82:
 
 - clean up/rewrite register allocation
+- moving between int and float vregs
+- intrinsic fixnum>float float>fixnum
 
 - amd64 %box-struct
 - when generating a 32-bit image on a 64-bit system, large numbers which should
diff --git a/library/compiler/generator/generator.factor b/library/compiler/generator/generator.factor
index 2fa70abfad..6083da2639 100644
--- a/library/compiler/generator/generator.factor
+++ b/library/compiler/generator/generator.factor
@@ -125,7 +125,7 @@ M: #if generate-node ( node -- next )
         end-basic-block
         <label> dup %jump-t
     ] H{
-        { +input { { 0 "flag" } } }
+        { +input { { f "flag" } } }
     } with-template generate-if ;
 
 ! #call
@@ -145,7 +145,8 @@ M: #if generate-node ( node -- next )
     save-xt
     t 0 <int-vreg> load-literal
     "end" get save-xt
-    0 <int-vreg> phantom-d get phantom-push ;
+    0 <int-vreg> phantom-d get phantom-push
+    compute-free-vregs ;
 
 : do-if-intrinsic ( node -- next )
     [ <label> dup ] keep if-intrinsic call
@@ -193,10 +194,12 @@ M: #dispatch generate-node ( node -- next )
 UNION: immediate fixnum POSTPONE: f ;
 
 : generate-push ( node -- )
-    >#push< dup literal-template
-    dup requested-vregs ensure-vregs
-    alloc-vregs [ [ load-literal ] 2each ] keep
-    phantom-d get phantom-append ;
+    [
+        >#push< dup literal-template
+        dup requested-vregs ensure-vregs
+        alloc-vregs [ [ load-literal ] 2each ] keep
+        phantom-d get phantom-append
+    ] with-scope ;
 
 M: #push generate-node ( #push -- )
     generate-push iterate-next ;
diff --git a/library/compiler/optimizer/call-optimizers.factor b/library/compiler/optimizer/call-optimizers.factor
index e74453ad0b..26dbf2632c 100644
--- a/library/compiler/optimizer/call-optimizers.factor
+++ b/library/compiler/optimizer/call-optimizers.factor
@@ -122,7 +122,7 @@ SYMBOL: @
     { { -1 @ } [ nip 0 swap - ]  }
 } define-identities
 
-[ / /i /f fixnum/i fixnum/f bignum/i bignum/f float/f ] {
+[ / fixnum/i fixnum/f bignum/i bignum/f float/f ] {
     { { @ 1 }  [ drop ]          }
     { { @ -1 } [ drop 0 swap - ] }
 } define-identities
@@ -176,7 +176,7 @@ SYMBOL: @
     { { @ @ } [ 2drop t ] }
 } define-identities
 
-[ eq? number= = ] {
+[ eq? bignum= float= number= = ] {
     { { @ @ } [ 2drop t ] }
 } define-identities
 
diff --git a/library/compiler/x86/assembler.factor b/library/compiler/x86/assembler.factor
index ca56945b84..02f626b08a 100644
--- a/library/compiler/x86/assembler.factor
+++ b/library/compiler/x86/assembler.factor
@@ -286,28 +286,28 @@ M: integer CALL HEX: e8 assemble-1 from assemble-4 ;
 M: callable CALL 0 CALL relative-4 ;
 M: operand CALL BIN: 010 t HEX: ff 1-operand ;
 
-GENERIC: JUMPcc ( opcode addr -- )
-M: integer JUMPcc ( opcode addr -- )
-    HEX: 0f assemble-1  swap assemble-1  from assemble-4 ;
-M: callable JUMPcc ( opcode addr -- )
-    >r 0 JUMPcc r> relative-4 ;
+G: JUMPcc ( addr opcode -- ) 1 standard-combination ;
+M: integer JUMPcc ( addr opcode -- )
+    swap HEX: 0f assemble-1  swap assemble-1  from assemble-4 ;
+M: callable JUMPcc ( addr opcode -- )
+    swap >r 0 swap JUMPcc r> relative-4 ;
 
-: JO  HEX: 80 swap JUMPcc ;
-: JNO HEX: 81 swap JUMPcc ;
-: JB  HEX: 82 swap JUMPcc ;
-: JAE HEX: 83 swap JUMPcc ;
-: JE  HEX: 84 swap JUMPcc ; ! aka JZ
-: JNE HEX: 85 swap JUMPcc ;
-: JBE HEX: 86 swap JUMPcc ;
-: JA  HEX: 87 swap JUMPcc ;
-: JS  HEX: 88 swap JUMPcc ;
-: JNS HEX: 89 swap JUMPcc ;
-: JP  HEX: 8a swap JUMPcc ;
-: JNP HEX: 8b swap JUMPcc ;
-: JL  HEX: 8c swap JUMPcc ;
-: JGE HEX: 8d swap JUMPcc ;
-: JLE HEX: 8e swap JUMPcc ;
-: JG  HEX: 8f swap JUMPcc ;
+: JO  HEX: 80 JUMPcc ;
+: JNO HEX: 81 JUMPcc ;
+: JB  HEX: 82 JUMPcc ;
+: JAE HEX: 83 JUMPcc ;
+: JE  HEX: 84 JUMPcc ; ! aka JZ
+: JNE HEX: 85 JUMPcc ;
+: JBE HEX: 86 JUMPcc ;
+: JA  HEX: 87 JUMPcc ;
+: JS  HEX: 88 JUMPcc ;
+: JNS HEX: 89 JUMPcc ;
+: JP  HEX: 8a JUMPcc ;
+: JNP HEX: 8b JUMPcc ;
+: JL  HEX: 8c JUMPcc ;
+: JGE HEX: 8d JUMPcc ;
+: JLE HEX: 8e JUMPcc ;
+: JG  HEX: 8f JUMPcc ;
 
 : RET ( -- ) HEX: c3 assemble-1 ;
 
diff --git a/library/compiler/x86/intrinsics-sse2.factor b/library/compiler/x86/intrinsics-sse2.factor
index 8e43378169..e6cd8e33fb 100644
--- a/library/compiler/x86/intrinsics-sse2.factor
+++ b/library/compiler/x86/intrinsics-sse2.factor
@@ -60,10 +60,10 @@ M: float-regs (%replace) ( vreg loc reg-class -- )
     } define-if-intrinsic ;
 
 {
-    { float< JL }
-    { float<= JLE }
-    { float> JG }
-    { float>= JGE }
+    { float< JB }
+    { float<= JBE }
+    { float> JA }
+    { float>= JAE }
     { float= JE }
 } [
     first2 define-float-jump
diff --git a/library/math/float.factor b/library/math/float.factor
index 911c193e25..62a9a1666e 100644
--- a/library/math/float.factor
+++ b/library/math/float.factor
@@ -3,9 +3,9 @@
 IN: math-internals
 USING: math kernel ;
 
-: float= ( n n -- )
+: float= ( n n -- ? )
     #! The compiler replaces this with a better intrinsic.
-    [ double>bits ] 2apply number= ;
+    [ double>bits ] 2apply number= ; foldable
 
 IN: math
 
@@ -20,7 +20,8 @@ M: real <=> - ;
 : fp-nan? ( float -- ? )
     double>bits -51 shift BIN: 111111111111 [ bitand ] keep = ;
 
-M: float zero? ( float -- ? ) dup 0.0 = swap -0.0 = or ;
+M: float zero? ( float -- ? )
+    dup 0.0 float= swap -0.0 float= or ;
 
 M: float < float< ;
 M: float <= float<= ;
diff --git a/library/test/compiler/float.factor b/library/test/compiler/float.factor
index e23da1fbd8..cc7639b258 100644
--- a/library/test/compiler/float.factor
+++ b/library/test/compiler/float.factor
@@ -23,3 +23,54 @@ USING: compiler kernel memory math math-internals test ;
 [ 2.0 ] [ 1.0 [ 2.0 swap float/f ] compile-1 ] unit-test
 [ 0.5 ] [ 1.0 2.0 [ float/f ] compile-1 ] unit-test
 [ 2.0 ] [ 1.0 2.0 [ swap float/f ] compile-1 ] unit-test
+
+[ t ] [ 1.0 2.0 [ float< ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 2.0 float< ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 2.0 swap float< ] compile-1 ] unit-test
+[ f ] [ 1.0 1.0 [ float< ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 1.0 float< ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 1.0 swap float< ] compile-1 ] unit-test
+[ f ] [ 3.0 1.0 [ float< ] compile-1 ] unit-test
+[ f ] [ 3.0 [ 1.0 float< ] compile-1 ] unit-test
+[ t ] [ 3.0 [ 1.0 swap float< ] compile-1 ] unit-test
+
+[ t ] [ 1.0 2.0 [ float<= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 2.0 float<= ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 2.0 swap float<= ] compile-1 ] unit-test
+[ t ] [ 1.0 1.0 [ float<= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 1.0 float<= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 1.0 swap float<= ] compile-1 ] unit-test
+[ f ] [ 3.0 1.0 [ float<= ] compile-1 ] unit-test
+[ f ] [ 3.0 [ 1.0 float<= ] compile-1 ] unit-test
+[ t ] [ 3.0 [ 1.0 swap float<= ] compile-1 ] unit-test
+
+[ f ] [ 1.0 2.0 [ float> ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 2.0 float> ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 2.0 swap float> ] compile-1 ] unit-test
+[ f ] [ 1.0 1.0 [ float> ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 1.0 float> ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 1.0 swap float> ] compile-1 ] unit-test
+[ t ] [ 3.0 1.0 [ float> ] compile-1 ] unit-test
+[ t ] [ 3.0 [ 1.0 float> ] compile-1 ] unit-test
+[ f ] [ 3.0 [ 1.0 swap float> ] compile-1 ] unit-test
+
+[ f ] [ 1.0 2.0 [ float>= ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 2.0 float>= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 2.0 swap float>= ] compile-1 ] unit-test
+[ t ] [ 1.0 1.0 [ float>= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 1.0 float>= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 1.0 swap float>= ] compile-1 ] unit-test
+[ t ] [ 3.0 1.0 [ float>= ] compile-1 ] unit-test
+[ t ] [ 3.0 [ 1.0 float>= ] compile-1 ] unit-test
+[ f ] [ 3.0 [ 1.0 swap float>= ] compile-1 ] unit-test
+
+[ f ] [ 1.0 2.0 [ float= ] compile-1 ] unit-test
+[ t ] [ 1.0 1.0 [ float= ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 2.0 float= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 1.0 float= ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 2.0 swap float= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 1.0 swap float= ] compile-1 ] unit-test
+
+[ t ] [ 0.0 [ dup 0.0 float= swap -0.0 float= or ] compile-1 ] unit-test
+[ t ] [ -0.0 [ dup 0.0 float= swap -0.0 float= or ] compile-1 ] unit-test
+[ f ] [ 3.0 [ dup 0.0 float= swap -0.0 float= or ] compile-1 ] unit-test
diff --git a/library/test/compiler/identities.factor b/library/test/compiler/identities.factor
index 2926e540b7..b296f7b5ee 100644
--- a/library/test/compiler/identities.factor
+++ b/library/test/compiler/identities.factor
@@ -1,5 +1,5 @@
 IN: temporary
-USING: compiler kernel math test vectors ;
+USING: compiler kernel kernel-internals math test vectors ;
 
 [ 5 ] [ 5 [ 0 + ] compile-1 ] unit-test
 [ 5 ] [ 5 [ 0 swap + ] compile-1 ] unit-test
@@ -22,12 +22,6 @@ USING: compiler kernel math test vectors ;
 [ 0 ] [ 5 [ 1 mod ] compile-1 ] unit-test
 [ 0 ] [ 5 [ 1 rem ] compile-1 ] unit-test
 
-[ 5 ] [ 5 [ 1 ^ ] compile-1 ] unit-test
-[ 25 ] [ 5 [ 2 ^ ] compile-1 ] unit-test
-[ 1/5 ] [ 5 [ -1 ^ ] compile-1 ] unit-test
-[ 1/25 ] [ 5 [ -2 ^ ] compile-1 ] unit-test
-[ 1 ] [ 5 [ 1 swap ^ ] compile-1 ] unit-test
-
 [ 5 ] [ 5 [ -1 bitand ] compile-1 ] unit-test
 [ 0 ] [ 5 [ 0 bitand ] compile-1 ] unit-test
 [ 5 ] [ 5 [ -1 swap bitand ] compile-1 ] unit-test
@@ -58,3 +52,5 @@ USING: compiler kernel math test vectors ;
 [ t ] [ 5 [ dup = ] compile-1 ] unit-test
 [ t ] [ 5 [ dup number= ] compile-1 ] unit-test
 [ t ] [ \ vector [ \ vector = ] compile-1 ] unit-test
+
+[ 3 ] [ 10/3 [ { ratio } declare 1 /i ] compile-1 ] unit-test

From e0af419b9b1e5f6d76cb6313afb48ec8f8e8ec83 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sat, 6 May 2006 04:27:40 +0000
Subject: [PATCH 089/112] Minor fixes

---
 library/compiler/generator/generator.factor | 11 +++++------
 library/test/compiler/float.factor          |  2 ++
 2 files changed, 7 insertions(+), 6 deletions(-)

diff --git a/library/compiler/generator/generator.factor b/library/compiler/generator/generator.factor
index 6083da2639..7776637345 100644
--- a/library/compiler/generator/generator.factor
+++ b/library/compiler/generator/generator.factor
@@ -194,12 +194,11 @@ M: #dispatch generate-node ( node -- next )
 UNION: immediate fixnum POSTPONE: f ;
 
 : generate-push ( node -- )
-    [
-        >#push< dup literal-template
-        dup requested-vregs ensure-vregs
-        alloc-vregs [ [ load-literal ] 2each ] keep
-        phantom-d get phantom-append
-    ] with-scope ;
+    >#push< dup literal-template
+    dup requested-vregs ensure-vregs
+    alloc-vregs [ [ load-literal ] 2each ] keep
+    phantom-d get phantom-append
+    "fp-scratch" off ;
 
 M: #push generate-node ( #push -- )
     generate-push iterate-next ;
diff --git a/library/test/compiler/float.factor b/library/test/compiler/float.factor
index cc7639b258..01ab401f9d 100644
--- a/library/test/compiler/float.factor
+++ b/library/test/compiler/float.factor
@@ -4,6 +4,8 @@ USING: compiler kernel memory math math-internals test ;
 [ 5.0 ] [ [ 5.0 ] compile-1 full-gc full-gc full-gc ] unit-test
 [ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-1 ] unit-test
 
+[ 1 2 3 4.0 ] [ [ 1 2 3 4.0 ] compile-1 ] unit-test
+
 [ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-1 ] unit-test
 [ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-1 ] unit-test
 [ 3.0 ] [ 1.0 2.0 [ float+ ] compile-1 ] unit-test

From 593165784bc118cd6077721a0c3bfe917af75af0 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Tue, 9 May 2006 15:30:26 +0000
Subject: [PATCH 090/112] Remove unswons word

---
 contrib/math/infix.factor                     |  2 ++
 .../parser-combinators.factor                 |  2 ++
 library/cli.factor                            |  2 +-
 library/collections/lists.factor              |  1 -
 library/test/inference.factor                 |  1 -
 library/test/lists/cons.factor                |  3 ---
 library/test/test.factor                      | 23 +++++++++----------
 7 files changed, 16 insertions(+), 18 deletions(-)

diff --git a/contrib/math/infix.factor b/contrib/math/infix.factor
index 46f5639be0..f0c8e1df70 100644
--- a/contrib/math/infix.factor
+++ b/contrib/math/infix.factor
@@ -89,6 +89,8 @@ UNION: value number string ;
     #! The semicolon token
     T{ tok f CHAR: ; } ;
 
+: unswons uncons swap ;
+
 : nest-apply ( [ ast ] -- apply )
     unswons unit swap [
         swap <apply> unit
diff --git a/contrib/parser-combinators/parser-combinators.factor b/contrib/parser-combinators/parser-combinators.factor
index c85599044c..eed33ff8b8 100644
--- a/contrib/parser-combinators/parser-combinators.factor
+++ b/contrib/parser-combinators/parser-combinators.factor
@@ -237,6 +237,8 @@ M: list pdrop ( n object -- object )
   >r uncons r> ( x1 xs2 x )
   swap cons cons ;
 
+: unswons uncons swap ;
+
 : <&>-do-parser2 ( [[ x xs ]] parser2 -- result )
   #! Called by the <&>-parser on each result of the
   #! successfull parse of parser1. It's input is the
diff --git a/library/cli.factor b/library/cli.factor
index a2dba89ccf..3dd48f7999 100644
--- a/library/cli.factor
+++ b/library/cli.factor
@@ -12,7 +12,7 @@ parser sequences strings ;
     ] when ;
 
 : set-path ( value seq -- )
-    unswons over [ nest [ set-path ] bind ] [ nip set ] if ;
+    uncons swap over [ nest [ set-path ] bind ] [ nip set ] if ;
 
 : cli-var-param ( name value -- )
     swap ":" split >list set-path ;
diff --git a/library/collections/lists.factor b/library/collections/lists.factor
index da71c523b9..f8017a7a29 100644
--- a/library/collections/lists.factor
+++ b/library/collections/lists.factor
@@ -16,7 +16,6 @@ PREDICATE: general-list list ( list -- ? )
     [ cdr list? ] [ t ] if* ;
 
 : uncons ( [[ car cdr ]] -- car cdr ) dup car swap cdr ; inline
-: unswons ( [[ car cdr ]] -- cdr car ) dup cdr swap car ; inline
 
 : swons ( cdr car -- [[ car cdr ]] ) swap cons ; inline
 : unit ( a -- [ a ] ) f cons ; inline
diff --git a/library/test/inference.factor b/library/test/inference.factor
index 27527dee77..b7fbb3d224 100644
--- a/library/test/inference.factor
+++ b/library/test/inference.factor
@@ -220,7 +220,6 @@ M: ratio xyz
 [ { 2 1 } ] [ [ swons ] infer ] unit-test
 [ { 1 2 } ] [ [ uncons ] infer ] unit-test
 [ { 1 1 } ] [ [ unit ] infer ] unit-test
-[ { 1 2 } ] [ [ unswons ] infer ] unit-test
 [ { 1 1 } ] [ [ list? ] infer ] unit-test
 
 [ { 1 0 } ] [ [ >n ] infer ] unit-test
diff --git a/library/test/lists/cons.factor b/library/test/lists/cons.factor
index d53c7485c7..13fa00d87d 100644
--- a/library/test/lists/cons.factor
+++ b/library/test/lists/cons.factor
@@ -27,9 +27,6 @@ USE: sequences
 [ 1 2     ] [ [[ 1 2 ]] uncons ] unit-test
 [ 1 [ 2 ] ] [ [ 1 2 ]   uncons ] unit-test
 
-[ 1 2     ] [ [[ 2 1 ]] unswons ] unit-test
-[ [ 2 ] 1 ] [ [ 1 2 ]   unswons ] unit-test
-
 [ 1 3 ] [ [[ 1 2 ]] [[ 3 4 ]] 2car ] unit-test
 [ 2 4 ] [ [[ 1 2 ]] [[ 3 4 ]] 2cdr ] unit-test
 
diff --git a/library/test/test.factor b/library/test/test.factor
index 2d6a0389d5..3271dacc61 100644
--- a/library/test/test.factor
+++ b/library/test/test.factor
@@ -1,18 +1,16 @@
-! Factor test suite.
-
+! Copyright (C) 2003, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 IN: test
-USING: arrays errors hashtables inspector io kernel lists math
+USING: arrays errors hashtables inspector io kernel math
 memory namespaces parser prettyprint sequences strings words ;
 
 TUPLE: assert got expect ;
 
 M: assert summary drop "Assertion failed" ;
 
-: assert= ( a b -- )
-    2dup = [ 2drop ] [ <assert> throw ] if ;
+: assert= ( a b -- ) 2dup = [ 2drop ] [ <assert> throw ] if ;
 
-: print-test ( input output -- )
-    "--> " write 2array . flush ;
+: print-test ( input output -- ) "--> " write 2array . flush ;
 
 : benchmark ( quot -- gctime runtime )
     millis >r gc-time >r call gc-time r> - millis r> - ;
@@ -26,7 +24,7 @@ M: assert summary drop "Assertion failed" ;
         [
             2dup print-test
             swap >r >r clear r> call
-            datastack >list r> assert=
+            datastack r> >vector assert=
         ] keep-datastack 2drop
     ] time ;
 
@@ -38,10 +36,10 @@ M: assert summary drop "Assertion failed" ;
 
 SYMBOL: failures
 
-: failure failures [ cons ] change ;
+: failure failures get push ;
 
 : test-handler ( name quot -- ? )
-    catch [ dup error. cons failure f ] [ t ] if* ;
+    catch [ dup error. 2array failure f ] [ t ] if* ;
 
 : test-path ( name -- path )
     "/library/test/" swap ".factor" append3 ;
@@ -54,14 +52,15 @@ SYMBOL: failures
         ] assert-depth drop
     ] test-handler ;
 
-: prepare-tests ( -- ) failures off "temporary" forget-vocab ;
+: prepare-tests ( -- )
+    V{ } clone failures set "temporary" forget-vocab ;
 
 : passed.
     "Tests passed:" print . ;
 
 : failed.
     "Tests failed:" print
-    failures get [ unswons write ": " write error. ] each ;
+    failures get [ first2 swap write ": " write error. ] each ;
 
 : run-tests ( list -- )
     prepare-tests [ test ] subset terpri passed. failed. ;

From da2fc4eaba021d576163f0c8bf2f760c43ac150e Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Tue, 9 May 2006 15:31:10 +0000
Subject: [PATCH 091/112] Compiler work

---
 TODO.FACTOR.txt                               |  1 -
 .../compiler/generator/architecture.factor    | 26 ++++++-----
 library/compiler/generator/generator.factor   |  2 +-
 library/compiler/generator/templates.factor   | 30 ++++++-------
 library/compiler/ppc/architecture.factor      |  2 +
 library/compiler/x86/architecture.factor      | 44 +++++++------------
 library/compiler/x86/intrinsics-sse2.factor   | 13 ++++--
 library/test/compiler/templates.factor        |  2 +
 8 files changed, 60 insertions(+), 60 deletions(-)

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index f0bcd888df..9420a213ff 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,7 +1,6 @@
 should fix in 0.82:
 
 - clean up/rewrite register allocation
-- moving between int and float vregs
 - intrinsic fixnum>float float>fixnum
 
 - amd64 %box-struct
diff --git a/library/compiler/generator/architecture.factor b/library/compiler/generator/architecture.factor
index 3a3f7f3649..98d2e84a62 100644
--- a/library/compiler/generator/architecture.factor
+++ b/library/compiler/generator/architecture.factor
@@ -1,6 +1,6 @@
 IN: compiler
-USING: generic kernel kernel-internals math memory namespaces
-sequences ;
+USING: arrays generic kernel kernel-internals math memory
+namespaces sequences ;
 
 ! A scratch register for computations
 TUPLE: vreg n ;
@@ -69,6 +69,20 @@ DEFER: %peek ( vreg loc -- )
 ! Store vreg to stack
 DEFER: %replace ( vreg loc -- )
 
+! Move one vreg to another
+DEFER: %move-int>int ( dst src -- )
+DEFER: %move-int>float ( dst src -- )
+
+: %move ( dst src -- )
+    2dup = [
+        2drop
+    ] [
+        2dup [ delegate class ] 2apply 2array {
+            { [ { int-regs int-regs } = ] [ %move-int>int ] }
+            { [ { float-regs int-regs } = ] [ %move-int>float ] }
+        } cond
+    ] if ;
+
 ! FFI stuff
 DEFER: %unbox ( n reg-class func -- )
 
@@ -84,14 +98,6 @@ DEFER: %alien-callback ( quot -- )
 
 DEFER: %callback-value ( reg-class func -- )
 
-! A few FFI operations have default implementations
-: %cleanup ( n -- ) drop ;
-
-: %stack>freg ( n reg reg-class -- ) 3drop ;
-
-: %freg>stack ( n reg reg-class -- ) 3drop ;
-
-! Some stuff probably not worth redefining in other backends
 M: stack-params fastcall-regs drop 0 ;
 
 GENERIC: reg-size ( register-class -- n )
diff --git a/library/compiler/generator/generator.factor b/library/compiler/generator/generator.factor
index 7776637345..910acf2532 100644
--- a/library/compiler/generator/generator.factor
+++ b/library/compiler/generator/generator.factor
@@ -194,7 +194,7 @@ M: #dispatch generate-node ( node -- next )
 UNION: immediate fixnum POSTPONE: f ;
 
 : generate-push ( node -- )
-    >#push< dup literal-template
+    >#push< dup length f <array>
     dup requested-vregs ensure-vregs
     alloc-vregs [ [ load-literal ] 2each ] keep
     phantom-d get phantom-append
diff --git a/library/compiler/generator/templates.factor b/library/compiler/generator/templates.factor
index 2a4b290588..ca61addff8 100644
--- a/library/compiler/generator/templates.factor
+++ b/library/compiler/generator/templates.factor
@@ -175,18 +175,20 @@ SYMBOL: phantom-r
     compute-free-vregs free-vregs* swapd <= >r <= r> and
     [ finalize-contents compute-free-vregs ] unless ;
 
+: spec>vreg ( spec -- vreg )
+    dup integer? [ <int-vreg> ] [ reg-spec>class alloc-reg ] if ;
+
+: (lazy-load) ( value spec -- value )
+    spec>vreg swap [
+        {
+            { [ dup loc? ] [ %peek ] }
+            { [ dup vreg? ] [ %move ] }
+            { [ t ] [ 2drop ] }
+        } cond
+    ] keep ;
+
 : lazy-load ( values template -- template )
-    [
-        first2 >r over loc? [
-            over integer? [
-                >r <int-vreg> dup r> %peek
-            ] [
-                stack>new-vreg
-            ] if
-        ] [
-            drop
-        ] if r> 2array
-    ] 2map ;
+    [ first2 >r (lazy-load) r> 2array ] 2map ;
 
 : stack>vregs ( phantom template -- values )
     [
@@ -195,11 +197,7 @@ SYMBOL: phantom-r
     ] 2keep length neg swap adjust-phantom ;
 
 : compatible-vreg? ( n vreg -- ? )
-    {
-        { [ dup [ int-regs? ] is? ] [ vreg-n = ] }
-        { [ dup [ float-regs? ] is? ] [ 2drop t ] }
-        { [ t ] [ 2drop f ] }
-    } cond ;
+    dup [ int-regs? ] is? [ vreg-n = ] [ 2drop f ] if ;
 
 : compatible-values? ( value template -- ? )
     {
diff --git a/library/compiler/ppc/architecture.factor b/library/compiler/ppc/architecture.factor
index 412c8281d9..7e44856f60 100644
--- a/library/compiler/ppc/architecture.factor
+++ b/library/compiler/ppc/architecture.factor
@@ -176,3 +176,5 @@ M: stack-params freg>stack
     "unnest_stacks" f %alien-invoke
     ! Restore return register
     load-return ;
+
+: %cleanup ( n -- ) drop ;
diff --git a/library/compiler/x86/architecture.factor b/library/compiler/x86/architecture.factor
index 1a3c030224..f5c798cf37 100644
--- a/library/compiler/x86/architecture.factor
+++ b/library/compiler/x86/architecture.factor
@@ -46,36 +46,13 @@ M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 
 : prepare-division CDQ ; inline
 
-: fp-scratch ( -- vreg )
-    "fp-scratch" get [
-        T{ int-regs } alloc-reg dup "fp-scratch" set
-    ] unless* ;
-
-: unboxify-float ( obj vreg quot -- | quot: obj int-vreg )
-    #! The SSE2 code here will never be generated unless SSE2
-    #! intrinsics are loaded.
-    over [ float-regs? ] is? [
-        swap >r fp-scratch [ swap call ] keep
-        r> swap [ v>operand ] 2apply float-offset [+] MOVSD
-    ] [
-        call
-    ] if ; inline
-
-: literal-template
-    #! All literals go into integer registers unless SSE2
-    #! intrinsics are loaded.
-    length f <array> ;
-
 M: immediate load-literal ( literal vreg -- )
     v>operand swap v>operand MOV ;
 
-: load-indirect ( literal vreg -- )
+M: object load-literal ( literal vreg -- )
     v>operand swap add-literal [] MOV
     rel-absolute-cell rel-address ;
 
-M: object load-literal ( literal vreg -- )
-    [ load-indirect ] unboxify-float ;
-
 : (%call) ( label -- label )
     dup postpone-word dup primitive? [ address-operand ] when ;
 
@@ -108,14 +85,21 @@ M: object load-literal ( literal vreg -- )
 
 : %return ( -- ) %epilogue RET ;
 
-: vreg-mov swap [ v>operand ] 2apply MOV ;
+: %move-int>int ( dst src -- )
+    [ v>operand ] 2apply MOV ;
 
-: %peek ( vreg loc -- )
-    swap [ vreg-mov ] unboxify-float ;
+: %move-int>float ( dst src -- )
+    [ v>operand ] 2apply float-offset [+] MOVSD ;
+
+GENERIC: (%peek) ( vreg loc reg-class -- )
+
+M: int-regs (%peek) drop %move-int>int ;
+
+: %peek ( vreg loc -- ) over (%peek) ;
 
 GENERIC: (%replace) ( vreg loc reg-class -- )
 
-M: int-regs (%replace) drop vreg-mov ;
+M: int-regs (%replace) drop swap %move-int>int ;
 
 : %replace ( vreg loc -- ) over (%replace) ;
 
@@ -124,3 +108,7 @@ M: int-regs (%replace) drop vreg-mov ;
 : %inc-d ( n -- ) ds-reg (%inc) ;
 
 : %inc-r ( n -- ) cs-reg (%inc) ;
+
+: %stack>freg ( n reg reg-class -- ) 3drop ;
+
+: %freg>stack ( n reg reg-class -- ) 3drop ;
diff --git a/library/compiler/x86/intrinsics-sse2.factor b/library/compiler/x86/intrinsics-sse2.factor
index e6cd8e33fb..60ab472423 100644
--- a/library/compiler/x86/intrinsics-sse2.factor
+++ b/library/compiler/x86/intrinsics-sse2.factor
@@ -4,10 +4,15 @@ USING: alien arrays assembler generic kernel kernel-internals
 lists math math-internals memory namespaces sequences words ;
 IN: compiler
 
-: literal-template
-    #! floats map to 'float' so we put float literals in float
-    #! vregs
-    [ class ] map ;
+: fp-scratch ( -- vreg )
+    "fp-scratch" get [
+        T{ int-regs } alloc-reg dup "fp-scratch" set
+    ] unless* ;
+
+M: float-regs (%peek) ( vreg loc reg-class -- )
+    drop
+    fp-scratch swap %move-int>int
+    fp-scratch %move-int>float ;
 
 : load-zone-ptr ( vreg -- )
     #! Load pointer to start of zone array
diff --git a/library/test/compiler/templates.factor b/library/test/compiler/templates.factor
index 650f1d02f3..3f6d84a1dd 100644
--- a/library/test/compiler/templates.factor
+++ b/library/test/compiler/templates.factor
@@ -31,6 +31,8 @@ unit-test
 ! Test literals in either side of a shuffle
 [ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-1 ] unit-test
 
+[ 2 ] [ 1 2 [ swap fixnum/i ] compile-1 ] unit-test
+
 : foo ;
 
 [ 4 4 ]

From 1234a8aa39e6aba003a8281b3f69974b5ffb2854 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Tue, 9 May 2006 15:31:28 +0000
Subject: [PATCH 092/112] Working on new example program

---
 examples/homology.factor | 156 +++++++++++++++++++++++++++++++++++++++
 1 file changed, 156 insertions(+)
 create mode 100644 examples/homology.factor

diff --git a/examples/homology.factor b/examples/homology.factor
new file mode 100644
index 0000000000..a4c495e302
--- /dev/null
+++ b/examples/homology.factor
@@ -0,0 +1,156 @@
+IN: homology
+USING: kernel sequences arrays math words namespaces
+hashtables prettyprint io ;
+
+! Utilities
+: S{ [ [ dup ] map>hash ] [ ] ; parsing
+
+: (lengthen) ( seq n -- seq )
+    over length - f <array> append ;
+
+: lengthen ( sim sim -- sim sim )
+    2dup max-length tuck (lengthen) >r (lengthen) r> ;
+
+: unswons* 1 over tail swap first ;
+
+: swons* 1array swap append ;
+
+: rot-seq ( seq -- seq ) unswons* add ;
+
+: <point> ( -- sim ) gensym 1array ;
+
+: (C) ( point sim -- sim )
+    [ [ append natural-sort ] map-with ] map-with ;
+
+: (\/) ( sim sim -- sim ) lengthen [ append natural-sort ] 2map ;
+
+: <range> ( from to -- seq ) dup <slice> ;
+
+! Simplicial complexes
+SYMBOL: basepoint
+
+: {*} ( -- sim )
+    #! Initial object in category
+    { { { basepoint } } } ;
+
+: \/ ( sim sim -- sim )
+    #! Glue two complexes at base point
+    (\/) [ prune ] map ;
+
+: +point ( sim -- sim )
+    #! Adjoint an isolated point
+    unswons* <point> add swons* ;
+
+: C ( sim -- sim )
+    #! Cone on a space
+    <point> over first over add >r swap (C) r> swons* ;
+
+: S ( sim -- sim )
+    #! Suspension
+    [
+        <point> <point> 2dup 2array >r
+        pick (C) >r swap (C) r> (\/) r> swons*
+    ] keep (\/) ;
+
+: S^0 ( -- sim )
+    #! Degenerate sphere -- two points
+    {*} +point ;
+
+: S^ ( n -- sim )
+    #! Sphere
+    S^0 swap [ S ] times ;
+
+: D^ ( n -- sim )
+    #! Disc
+    1- S^ C ;
+
+! Mod 2 matrix algebra
+: remove-1 ( n seq -- seq )
+    >r { } swap dup 1+ r> replace-slice ;
+
+: symmetric-diff ( hash hash -- hash )
+    clone swap [
+        drop dup pick hash [
+            over remove-hash
+        ] [
+            dup pick set-hash
+        ] if
+    ] hash-each ;
+
+SYMBOL: row-basis
+SYMBOL: matrix
+SYMBOL: current-row
+
+: rows ( -- n ) matrix get length ;
+
+: exchange-rows ( m n -- )
+    2dup = [ 2drop ] [ matrix get exchange ] if ;
+
+: row ( n -- row ) matrix get nth ;
+
+: set-row ( row n -- ) matrix get set-nth ;
+
+: add-row ( src# dst# -- )
+    [ [ row ] 2apply symmetric-diff ] keep set-row ;
+
+: pivot-row ( basis-elt -- n )
+    current-row get rows <range>
+    [ row hash-member? ] find-with nip ;
+
+: kill-column ( basis-elt pivot -- )
+    dup 1+ rows <range> [
+        pick over row hash-member? [ dupd add-row ] [ drop ] if
+    ] each 2drop ;
+
+: with-matrix ( matrix basis quot -- matrix )
+    [
+        >r row-basis set matrix set r> call matrix get
+    ] with-scope ; inline
+
+: (row-reduce)
+    0 current-row set
+    row-basis get [
+        dup pivot-row dup [
+            current-row get exchange-rows
+            current-row get kill-column
+            current-row inc
+        ] [
+            2drop
+        ] if
+    ] each ;
+
+: ker/im ( -- ker im )
+    matrix get [ hash-empty? ] subset length
+    row-basis get [
+        matrix get [ hash-member? ] contains-with?
+    ] subset length ;
+
+: row-reduce ( matrix basis -- rowsp colsp matrix )
+    [ (row-reduce) ker/im ] with-matrix ;
+
+! Mod 2 homology
+: (boundary) ( seq -- chain )
+    dup length 1 <= [
+        H{ }
+    ] [
+        dup length [ over remove-1 dup ] map>hash
+    ] if nip ;
+
+: boundary ( chain -- chain )
+    H{ } swap [ drop (boundary) symmetric-diff ] hash-each ;
+
+: homology ( sim -- seq )
+    dup [ [ (boundary) ] map ] map rot-seq
+    [ row-reduce drop 2array ] 2map ;
+
+: print-matrix ( matrix basis -- )
+    swap [
+        swap [
+            ( row basis-elt )
+            swap hash-member? 1 0 ? pprint bl
+        ] each-with terpri
+    ] each-with ;
+
+2 S^ [ [ [ (boundary) ] map ] map unswons* drop ] keep
+[ [ row-reduce 2nip ] 2map ] keep
+[ print-matrix terpri ] 2each

From 3c92baf8ed54bca92bc0a57870212d0635057b83 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Tue, 9 May 2006 16:38:57 +0000
Subject: [PATCH 093/112] Bootstrap and compiler fixes

---
 library/bootstrap/boot-stage1.factor             | 13 +++++++++++--
 library/compiler/generator/architecture.factor   | 10 ++++++++--
 library/compiler/generator/templates.factor      |  4 ++--
 library/compiler/optimizer/inline-methods.factor |  2 +-
 library/test/test.factor                         |  9 +++++----
 5 files changed, 27 insertions(+), 11 deletions(-)

diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor
index 041bc8be1e..348d5c208c 100644
--- a/library/bootstrap/boot-stage1.factor
+++ b/library/bootstrap/boot-stage1.factor
@@ -9,9 +9,17 @@ vectors words ;
 
 "/library/bootstrap/primitives.factor" run-resource
 
+: parse-resource* ( path -- )
+    [ parse-resource ] catch [
+        dup error.
+        "Try again? [yn]" print
+        readln "yY" subseq?
+        [ drop parse-resource* ] [ rethrow ] if
+    ] when* ;
+
 : if-arch ( arch seq -- )
     architecture get rot member?
-    [ [ parse-resource % ] each ] [ drop ] if ;
+    [ [ parse-resource* % ] each ] [ drop ] if ;
 
 ! The [ ] make form creates a boot quotation
 [
@@ -279,7 +287,7 @@ vectors words ;
         "/doc/handbook/tools.facts"
         "/doc/handbook/tutorial.facts"
         "/doc/handbook/words.facts"
-    } [ parse-resource % ] each
+    } [ parse-resource* % ] each
     
     { "x86" "pentium4" } {
         "/library/compiler/x86/assembler.factor"
@@ -330,3 +338,4 @@ vocabularies get [
 all-words [ generic? ] subset [ make-generic ] each
 
 FORGET: if-arch
+FORGET: parse-resource*
diff --git a/library/compiler/generator/architecture.factor b/library/compiler/generator/architecture.factor
index 98d2e84a62..f93b5e80c3 100644
--- a/library/compiler/generator/architecture.factor
+++ b/library/compiler/generator/architecture.factor
@@ -78,8 +78,8 @@ DEFER: %move-int>float ( dst src -- )
         2drop
     ] [
         2dup [ delegate class ] 2apply 2array {
-            { [ { int-regs int-regs } = ] [ %move-int>int ] }
-            { [ { float-regs int-regs } = ] [ %move-int>float ] }
+            { [ dup { int-regs int-regs } = ] [ drop %move-int>int ] }
+            { [ dup { float-regs int-regs } = ] [ drop %move-int>float ] }
         } cond
     ] if ;
 
@@ -92,8 +92,14 @@ DEFER: %box ( n reg-class func -- )
 
 DEFER: %box-struct ( n reg-class size -- )
 
+DEFER: %stack>freg ( n reg reg-class -- )
+
+DEFER: %freg>stack ( n reg reg-class -- )
+
 DEFER: %alien-invoke ( library function -- )
 
+DEFER: %cleanup ( n -- )
+
 DEFER: %alien-callback ( quot -- )
 
 DEFER: %callback-value ( reg-class func -- )
diff --git a/library/compiler/generator/templates.factor b/library/compiler/generator/templates.factor
index ca61addff8..bf19329b88 100644
--- a/library/compiler/generator/templates.factor
+++ b/library/compiler/generator/templates.factor
@@ -179,8 +179,8 @@ SYMBOL: phantom-r
     dup integer? [ <int-vreg> ] [ reg-spec>class alloc-reg ] if ;
 
 : (lazy-load) ( value spec -- value )
-    spec>vreg swap [
-        {
+    spec>vreg [
+        swap {
             { [ dup loc? ] [ %peek ] }
             { [ dup vreg? ] [ %move ] }
             { [ t ] [ 2drop ] }
diff --git a/library/compiler/optimizer/inline-methods.factor b/library/compiler/optimizer/inline-methods.factor
index 7e1383047c..4873389ded 100644
--- a/library/compiler/optimizer/inline-methods.factor
+++ b/library/compiler/optimizer/inline-methods.factor
@@ -27,7 +27,7 @@ kernel-internals lists math namespaces sequences words ;
     ] [
         over node-in-d dataflow-with
         [ >r node-param r> remember-node ] 2keep
-        [ subst-node ] keep [ infer-classes ] keep
+        [ subst-node ] keep
     ] if ;
 
 ! Single dispatch method inlining optimization
diff --git a/library/test/test.factor b/library/test/test.factor
index 3271dacc61..6f538b2a2d 100644
--- a/library/test/test.factor
+++ b/library/test/test.factor
@@ -1,8 +1,9 @@
 ! Copyright (C) 2003, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: test
-USING: arrays errors hashtables inspector io kernel math
-memory namespaces parser prettyprint sequences strings words ;
+USING: arrays errors hashtables inspector io kernel lists math
+memory namespaces parser prettyprint sequences strings words
+vectors ;
 
 TUPLE: assert got expect ;
 
@@ -36,7 +37,7 @@ M: assert summary drop "Assertion failed" ;
 
 SYMBOL: failures
 
-: failure failures get push ;
+: failure failures [ ?push ] change ;
 
 : test-handler ( name quot -- ? )
     catch [ dup error. 2array failure f ] [ t ] if* ;
@@ -53,7 +54,7 @@ SYMBOL: failures
     ] test-handler ;
 
 : prepare-tests ( -- )
-    V{ } clone failures set "temporary" forget-vocab ;
+    failures off "temporary" forget-vocab ;
 
 : passed.
     "Tests passed:" print . ;

From 3b6cccb6205c781ce4e3957a558e847f41c77b5e Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Tue, 9 May 2006 17:17:03 +0000
Subject: [PATCH 094/112] Templates cleanups

---
 library/compiler/generator/templates.factor | 66 ++++++++-------------
 1 file changed, 24 insertions(+), 42 deletions(-)

diff --git a/library/compiler/generator/templates.factor b/library/compiler/generator/templates.factor
index bf19329b88..49f883cf91 100644
--- a/library/compiler/generator/templates.factor
+++ b/library/compiler/generator/templates.factor
@@ -16,14 +16,12 @@ namespaces prettyprint sequences vectors words ;
 : reg-spec>class ( spec -- class )
     float eq? T{ float-regs f 8 } T{ int-regs } ? ;
 
-: alloc-vregs ( template -- template )
-    [
-        dup integer? [
-            <int-vreg> dup take-reg
-        ] [
-            reg-spec>class alloc-reg
-        ] if
-    ] map ;
+: spec>vreg ( spec -- vreg )
+    dup integer? [
+        <int-vreg> dup take-reg
+    ] [
+        reg-spec>class alloc-reg
+    ] if ;
 
 ! A data stack location.
 TUPLE: ds-loc n ;
@@ -175,26 +173,17 @@ SYMBOL: phantom-r
     compute-free-vregs free-vregs* swapd <= >r <= r> and
     [ finalize-contents compute-free-vregs ] unless ;
 
-: spec>vreg ( spec -- vreg )
-    dup integer? [ <int-vreg> ] [ reg-spec>class alloc-reg ] if ;
+: (lazy-load) ( spec value -- value )
+    {
+        { [ dup loc? ] [ >r spec>vreg dup r> %peek ] }
+        { [ dup [ float-regs? ] is? ] [ nip ] }
+        { [ over float eq? ] [ >r spec>vreg dup r> %move ] }
+        { [ t ] [ nip ] }
+    } cond ;
 
-: (lazy-load) ( value spec -- value )
-    spec>vreg [
-        swap {
-            { [ dup loc? ] [ %peek ] }
-            { [ dup vreg? ] [ %move ] }
-            { [ t ] [ 2drop ] }
-        } cond
-    ] keep ;
-
-: lazy-load ( values template -- template )
-    [ first2 >r (lazy-load) r> 2array ] 2map ;
-
-: stack>vregs ( phantom template -- values )
-    [
-        [ first ] map alloc-vregs dup length rot phantom-locs
-        [ dupd %peek ] 2map
-    ] 2keep length neg swap adjust-phantom ;
+: lazy-load ( values template -- )
+    dup length neg phantom-d get adjust-phantom
+    [ first2 >r swap (lazy-load) r> set ] 2each ;
 
 : compatible-vreg? ( n vreg -- ? )
     dup [ int-regs? ] is? [ vreg-n = ] [ 2drop f ] if ;
@@ -219,10 +208,7 @@ SYMBOL: phantom-r
     [ split-template ] [ drop { } ] if ;
 
 : fast-input ( template -- )
-    phantom-d get
-    over length neg over adjust-phantom
-    over length swap cut-phantom
-    swap lazy-load [ first2 set ] each ;
+    phantom-d get over length swap cut-phantom swap lazy-load ;
 
 : phantom-push ( obj stack -- )
     1 over adjust-phantom push ;
@@ -253,16 +239,13 @@ SYMBOL: +clobber
     output-vregs append phantoms append
     [ swap member? ] contains-with? ;
 
-: phantom-vregs ( values template -- ) [ second set ] 2each ;
-
 : slow-input ( template -- )
-    ! Are we loading stuff from the stack? Then flush out
-    ! remaining vregs, not slurped in by fast-input.
-    dup empty? [ finalize-contents ] unless
-    ! Do the outputs clash with vregs on the phantom stacks?
-    ! Then we must flush them first.
-    outputs-clash? [ finalize-contents ] when
-    phantom-d get swap [ stack>vregs ] keep phantom-vregs ;
+    #! Are we loading stuff from the stack? Then flush out
+    #! remaining vregs, not slurped in by fast-input.
+    #! Do the outputs clash with vregs on the phantom stacks?
+    #! Then we must flush them first.
+    dup empty? not outputs-clash? or [ finalize-contents ] when
+    [ length phantom-d get phantom-locs ] keep lazy-load ;
 
 : requested-vregs ( template -- int# float# )
     dup length swap [ float eq? ] subset length [ - ] keep ;
@@ -272,8 +255,7 @@ SYMBOL: +clobber
     +scratch get [ first ] map requested-vregs >r + r> ;
 
 : alloc-scratch ( -- )
-    +scratch get
-    [ [ first ] map alloc-vregs ] keep phantom-vregs ;
+    +scratch get [ first2 >r spec>vreg r> set ] each ;
 
 : template-inputs ( -- )
     ! Ensure we have enough to hold any new stack elements we

From 9f62c309c7317b2fd5397acd8274de33e3b493b4 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Tue, 9 May 2006 17:48:43 +0000
Subject: [PATCH 095/112] Minor tweak

---
 examples/mandel.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/examples/mandel.factor b/examples/mandel.factor
index c738ec0f50..ae74192ba5 100644
--- a/examples/mandel.factor
+++ b/examples/mandel.factor
@@ -88,7 +88,7 @@ SYMBOL: cols
 : render ( -- )
     height [
         width [
-            2dup swap c 0 nb-iter iter dup 0 = [
+            2dup swap c 0 nb-iter iter dup zero? [
                 drop "\0\0\0"
             ] [
                 cols get [ length mod ] keep nth

From a395743af5db31e544e7287b793659972b42b367 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Tue, 9 May 2006 17:48:55 +0000
Subject: [PATCH 096/112] Templates fixes for float vreg allocation

---
 library/compiler/generator/templates.factor | 25 +++++++++------------
 library/test/compiler/float.factor          |  4 +++-
 2 files changed, 13 insertions(+), 16 deletions(-)

diff --git a/library/compiler/generator/templates.factor b/library/compiler/generator/templates.factor
index 49f883cf91..ac370698a2 100644
--- a/library/compiler/generator/templates.factor
+++ b/library/compiler/generator/templates.factor
@@ -103,14 +103,10 @@ SYMBOL: phantom-r
     phantoms [ finalize-height ] 2apply ;
 
 : stack>new-vreg ( loc spec -- vreg )
-    reg-spec>class alloc-reg [ swap %peek ] keep ;
+    spec>vreg [ swap %peek ] keep ;
 
 : vreg>stack ( value loc -- )
-    over loc? [
-        2drop
-    ] [
-        over [ %replace ] [ 2drop ] if
-    ] if ;
+    over loc? over not or [ 2drop ] [ %replace ] if ;
 
 : vregs>stack ( phantom -- )
     [
@@ -144,11 +140,9 @@ SYMBOL: phantom-r
 : finalize-contents ( -- )
     phantoms 2dup flush-locs [ vregs>stack ] 2apply ;
 
-: end-basic-block ( -- )
-    finalize-contents finalize-heights ;
+: end-basic-block ( -- ) finalize-contents finalize-heights ;
 
-: used-vregs ( -- seq )
-    phantoms append [ vreg? ] subset ;
+: used-vregs ( -- seq ) phantoms append [ vreg? ] subset ;
 
 : (compute-free-vregs) ( used class -- vector )
     dup vregs length reverse [ swap <vreg> ] map-with diff
@@ -160,17 +154,17 @@ SYMBOL: phantom-r
     [ 2dup (compute-free-vregs) ] map>hash \ free-vregs set
     drop ;
 
-: additional-vregs# ( seq seq -- n )
+: additional-vregs ( seq seq -- n )
     2array phantoms 2array [ [ length ] map ] 2apply v-
     0 [ 0 max + ] reduce ;
 
-: free-vregs* ( -- int# float# )
+: free-vregs# ( -- int# float# )
     T{ int-regs } free-vregs length
     phantoms [ [ loc? ] subset length ] 2apply + -
     T{ float-regs f 8 } free-vregs length ;
 
 : ensure-vregs ( int# float# -- )
-    compute-free-vregs free-vregs* swapd <= >r <= r> and
+    compute-free-vregs free-vregs# swapd <= >r <= r> and
     [ finalize-contents compute-free-vregs ] unless ;
 
 : (lazy-load) ( spec value -- value )
@@ -191,7 +185,8 @@ SYMBOL: phantom-r
 : compatible-values? ( value template -- ? )
     {
         { [ over loc? ] [ 2drop t ] }
-        { [ dup { f float } memq? ] [ 2drop t ] }
+        { [ dup not ] [ drop [ float-regs? ] is? not ] }
+        { [ dup float eq? ] [ 2drop t ] }
         { [ dup integer? ] [ swap compatible-vreg? ] }
     } cond ;
 
@@ -251,7 +246,7 @@ SYMBOL: +clobber
     dup length swap [ float eq? ] subset length [ - ] keep ;
 
 : guess-vregs ( -- int# float# )
-    +input get { } additional-vregs#
+    +input get { } additional-vregs
     +scratch get [ first ] map requested-vregs >r + r> ;
 
 : alloc-scratch ( -- )
diff --git a/library/test/compiler/float.factor b/library/test/compiler/float.factor
index 01ab401f9d..49cb4b51b5 100644
--- a/library/test/compiler/float.factor
+++ b/library/test/compiler/float.factor
@@ -1,10 +1,12 @@
 IN: temporary
-USING: compiler kernel memory math math-internals test ;
+USING: compiler kernel kernel-internals memory math
+math-internals test ;
 
 [ 5.0 ] [ [ 5.0 ] compile-1 full-gc full-gc full-gc ] unit-test
 [ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-1 ] unit-test
 
 [ 1 2 3 4.0 ] [ [ 1 2 3 4.0 ] compile-1 ] unit-test
+[ 5 ] [ 1.0 [ 2.0 float+ tag ] compile-1 ] unit-test
 
 [ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-1 ] unit-test
 [ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-1 ] unit-test

From bfc0a0e67a45690fff3d1080b4f9dcfeb93cddfa Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Wed, 10 May 2006 01:37:07 +0000
Subject: [PATCH 097/112] Floating point intrinsics for PowerPC

---
 TODO.FACTOR.txt                               |   4 +-
 library/bootstrap/boot-stage1.factor          |   3 +-
 .../compiler/generator/architecture.factor    |   6 +-
 library/compiler/generator/generator.factor   |  12 +-
 library/compiler/ppc/architecture.factor      |  62 +++++++--
 library/compiler/ppc/assembler.factor         |  37 ++++--
 library/compiler/ppc/intrinsics.factor        | 119 +++++++++++-------
 library/compiler/x86/architecture.factor      |   8 --
 library/compiler/x86/intrinsics-sse2.factor   |  18 ++-
 library/test/compiler/assembler-x86.factor    |   9 --
 library/unix/io.factor                        |   2 +-
 11 files changed, 178 insertions(+), 102 deletions(-)
 delete mode 100644 library/test/compiler/assembler-x86.factor

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 9420a213ff..3ae4c2acc8 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,7 +1,8 @@
 should fix in 0.82:
 
-- clean up/rewrite register allocation
+- clean up fp-scratch
 - intrinsic fixnum>float float>fixnum
+- update amd64 backend
 
 - amd64 %box-struct
 - when generating a 32-bit image on a 64-bit system, large numbers which should
@@ -10,6 +11,7 @@ should fix in 0.82:
 
 + io:
 
+- gdb triggers 'mutliple i/o ops on port' error
 - stream server can hang because of exception handler limitations
 - better i/o scheduler
 - yield in a loop starves i/o
diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor
index 348d5c208c..cbb2d3b72c 100644
--- a/library/bootstrap/boot-stage1.factor
+++ b/library/bootstrap/boot-stage1.factor
@@ -12,8 +12,7 @@ vectors words ;
 : parse-resource* ( path -- )
     [ parse-resource ] catch [
         dup error.
-        "Try again? [yn]" print
-        readln "yY" subseq?
+        "Try again? [yn]" print flush readln "yY" subseq?
         [ drop parse-resource* ] [ rethrow ] if
     ] when* ;
 
diff --git a/library/compiler/generator/architecture.factor b/library/compiler/generator/architecture.factor
index f93b5e80c3..987cd6265a 100644
--- a/library/compiler/generator/architecture.factor
+++ b/library/compiler/generator/architecture.factor
@@ -64,10 +64,12 @@ DEFER: %inc-d ( n -- )
 DEFER: %inc-r ( n -- )
 
 ! Load stack into vreg
-DEFER: %peek ( vreg loc -- )
+GENERIC: (%peek) ( vreg loc reg-class -- )
+: %peek ( vreg loc -- ) over (%peek) ;
 
 ! Store vreg to stack
-DEFER: %replace ( vreg loc -- )
+GENERIC: (%replace) ( vreg loc reg-class -- )
+: %replace ( vreg loc -- ) over (%replace) ;
 
 ! Move one vreg to another
 DEFER: %move-int>int ( dst src -- )
diff --git a/library/compiler/generator/generator.factor b/library/compiler/generator/generator.factor
index 910acf2532..35f8fcf475 100644
--- a/library/compiler/generator/generator.factor
+++ b/library/compiler/generator/generator.factor
@@ -196,9 +196,8 @@ UNION: immediate fixnum POSTPONE: f ;
 : generate-push ( node -- )
     >#push< dup length f <array>
     dup requested-vregs ensure-vregs
-    alloc-vregs [ [ load-literal ] 2each ] keep
-    phantom-d get phantom-append
-    "fp-scratch" off ;
+    [ spec>vreg [ load-literal ] keep ] 2map
+    phantom-d get phantom-append ;
 
 M: #push generate-node ( #push -- )
     generate-push iterate-next ;
@@ -221,7 +220,7 @@ M: #push generate-node ( #push -- )
     shuffle-in-r length neg phantom-r get adjust-phantom ;
 
 : shuffle-vregs# ( shuffle -- n )
-    dup shuffle-in-d swap shuffle-in-r additional-vregs# ;
+    dup shuffle-in-d swap shuffle-in-r additional-vregs ;
 
 : phantom-shuffle ( shuffle -- )
     dup shuffle-vregs# 0 ensure-vregs
@@ -241,3 +240,8 @@ M: #return generate-node drop end-basic-block %return f ;
 
 : float-offset 8 float-tag - ;
 : string-offset 3 cells object-tag - ;
+
+: fp-scratch ( -- vreg )
+    "fp-scratch" get [
+        T{ int-regs } alloc-reg dup "fp-scratch" set
+    ] unless* ;
diff --git a/library/compiler/ppc/architecture.factor b/library/compiler/ppc/architecture.factor
index 7e44856f60..88532d0299 100644
--- a/library/compiler/ppc/architecture.factor
+++ b/library/compiler/ppc/architecture.factor
@@ -5,7 +5,8 @@ USING: alien assembler generic kernel kernel-internals math
 memory namespaces sequences words ;
 
 ! PowerPC register assignments
-! r3-r10 vregs
+! r3-r10 integer vregs
+! f0-f13 float vregs
 ! r11 linkage
 ! r14 data stack
 ! r15 call stack
@@ -16,6 +17,7 @@ M: int-regs vregs drop { 3 4 5 6 7 8 9 10 } ;
 
 M: float-regs return-reg drop 1 ;
 M: float-regs fastcall-regs drop { 1 2 3 4 5 6 7 8 } ;
+M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
 
 ! Mach-O -vs- Linux/PPC
 : stack@ macosx? 24 8 ? + ;
@@ -27,7 +29,7 @@ M: ds-loc loc>operand ds-loc-n cells neg 14 swap ;
 M: cs-loc loc>operand cs-loc-n cells neg 15 swap ;
 
 M: immediate load-literal ( literal vreg -- )
-    >r address r> v>operand LOAD ;
+    [ v>operand ] 2apply LOAD ;
 
 M: object load-literal ( literal vreg -- )
     v>operand swap
@@ -84,9 +86,50 @@ M: object load-literal ( literal vreg -- )
 
 : %return ( -- ) %epilogue BLR ;
 
-: %peek ( vreg loc -- ) >r v>operand r> loc>operand LWZ ;
+: compile-dlsym ( symbol dll register -- )
+    >r 2dup dlsym r> LOAD32 rel-2/2 rel-dlsym ;
 
-: %replace ( vreg loc -- ) >r v>operand r> loc>operand STW ;
+M: int-regs (%peek) ( vreg loc -- )
+    drop >r v>operand r> loc>operand LWZ ;
+
+M: float-regs (%peek) ( vreg loc -- )
+    drop 11 swap loc>operand LWZ
+    v>operand 11 float-offset LFD ;
+
+M: int-regs (%replace) ( vreg loc -- )
+    drop >r v>operand r> loc>operand STW ;
+
+: %move-int>int ( dst src -- )
+    [ v>operand ] 2apply MR ;
+
+: %move-int>float ( dst src -- )
+    [ v>operand ] 2apply float-offset LFD ;
+
+: load-zone-ptr ( reg -- )
+    "generations" f pick compile-dlsym dup 0 LWZ ;
+
+: load-allot-ptr ( -- ) 12 load-zone-ptr 12 12 cell LWZ ;
+
+: save-allot-ptr ( -- ) 11 load-zone-ptr 12 11 cell STW ;
+
+: with-inline-alloc ( vreg prequot postquot spec -- )
+    #! both quotations are called with the vreg
+    load-allot-ptr [
+        >r >r v>operand dup 12 MR
+        \ tag-header get call tag-header 11 LI
+        11 12 0 STW
+        r> over slip dup dup \ tag get call ORI
+        r> call 12 12 \ size get call ADDI
+    ] bind save-allot-ptr ; inline
+
+M: float-regs (%replace) ( vreg loc reg-class -- )
+    drop swap fp-scratch
+    [ >r v>operand r> 8 STFD ]
+    [ swap loc>operand STW ] H{
+        { tag-header [ float-tag ] }
+        { tag [ float-tag ] }
+        { size [ 16 ] }
+    } with-inline-alloc ;
 
 : %inc-d ( n -- ) 14 14 rot cells ADDI ;
 
@@ -118,11 +161,11 @@ M: stack-params stack>freg
 M: stack-params freg>stack
    >r stack-increment + swap r> stack>freg ;
 
-: (%move) [ fastcall-regs nth ] keep ;
+: %stack>freg ( n reg reg-class -- )
+    [ fastcall-regs nth ] keep stack>freg ;
 
-: %stack>freg ( n reg reg-class -- ) (%move) stack>freg ;
-
-: %freg>stack ( n reg reg-class -- ) (%move) freg>stack ;
+: %freg>stack ( n reg reg-class -- )
+    [ fastcall-regs nth ] keep freg>stack ;
 
 : %unbox ( n reg-class func -- )
     ! Call the unboxer
@@ -155,9 +198,6 @@ M: stack-params freg>stack
 : %box-struct ( n reg-class size -- )
     "box_value_struct" struct-ptr/size ;
 
-: compile-dlsym ( symbol dll register -- )
-    >r 2dup dlsym r> LOAD32 rel-2/2 rel-dlsym ;
-
 : %alien-invoke ( symbol dll -- )
     11 [ compile-dlsym ] keep MTLR BLRL ;
 
diff --git a/library/compiler/ppc/assembler.factor b/library/compiler/ppc/assembler.factor
index 2c64e2b6c8..30e5067675 100644
--- a/library/compiler/ppc/assembler.factor
+++ b/library/compiler/ppc/assembler.factor
@@ -16,6 +16,10 @@ USING: compiler errors generic kernel math memory words ;
 
 : insn ( operand opcode -- ) 26 shift bitor assemble-cell ;
 
+: a-form ( d a b c xo rc -- n )
+    >r 1 shift >r 6 shift >r 11 shift >r 16 shift >r 21 shift
+    r> bitor r> bitor r> bitor r> bitor r> bitor ;
+
 : b-form ( bo bi bd aa lk -- n )
     >r 1 shift >r 2 shift >r 16 shift >r 21 shift
     r> bitor r> bitor r> bitor r> bitor ;
@@ -26,10 +30,6 @@ USING: compiler errors generic kernel math memory words ;
 : i-form ( li aa lk -- n )
     >r 1 shift bitor r> bitor ;
 
-: m-form ( s a b mb me -- n )
-    >r 1 shift >r 6 shift >r 11 shift >r 16 shift >r 21 shift
-    r> bitor r> bitor r> bitor r> bitor r> bitor ;
-
 : x-form ( a s b xo rc -- n )
     swap
     >r 1 shift >r 11 shift >r swap 16 shift >r 21 shift
@@ -144,7 +144,7 @@ USING: compiler errors generic kernel math memory words ;
 : CMP 0 0 x-form 31 insn ;
 : CMPL 0 32 x-form 31 insn ;
 
-: (RLWINM) m-form 21 insn ;
+: (RLWINM) a-form 21 insn ;
 : RLWINM 0 (RLWINM) ;  : RLWINM. 1 (RLWINM) ;
 
 : SLWI 0 31 pick - RLWINM ;  : SLWI. 0 31 pick - RLWINM. ;
@@ -193,10 +193,31 @@ M: word BC >r 0 BC r> relative-2 ;
    >r dup -32768 32767 between? [ r> LI ] [ r> LOAD32 ] if ;
 
 ! Floating point
-: (FMR) >r 0 -rot 72 r> x-form 63 insn ;
-: FMR 0 (FMR) ;  : FMR. 1 (FMR) ;
-
 : LFS d-form 48 insn ;  : LFSU d-form 49 insn ;
 : LFD d-form 50 insn ;  : LFDU d-form 51 insn ;
 : STFS d-form 52 insn ; : STFSU d-form 53 insn ;
 : STFD d-form 54 insn ; : STFDU d-form 55 insn ;
+
+: (FMR) >r 0 -rot 72 r> x-form 63 insn ;
+: FMR 0 (FMR) ;  : FMR. 1 (FMR) ;
+
+: (FCTIWZ) >r 0 -rot 15 r> x-form 63 insn ;
+: FCTIWZ 0 (FCTIWZ) ;  : FCTIWZ. 1 (FCTIWZ) ;
+
+: (FADD) >r 0 21 r> a-form 63 insn ;
+: FADD 0 (FADD) ;  : FADD. 1 (FADD) ;
+
+: (FSUB) >r 0 20 r> a-form 63 insn ;
+: FSUB 0 (FSUB) ;  : FSUB. 1 (FSUB) ;
+
+: (FMUL) >r 0 swap 25 r> a-form 63 insn ;
+: FMUL 0 (FMUL) ;  : FMUL. 1 (FMUL) ;
+
+: (FDIV) >r 0 18 r> a-form 63 insn ;
+: FDIV 0 (FDIV) ;  : FDIV. 1 (FDIV) ;
+
+: (FSQRT) >r 0 swap 0 22 r> a-form 63 insn ;
+: FSQRT 0 (FSQRT) ;  : FSQRT. 1 (FSQRT) ;
+
+: FCMPU 0 0 x-form 63 insn ;
+: FCMPO 0 32 x-form 63 insn ;
diff --git a/library/compiler/ppc/intrinsics.factor b/library/compiler/ppc/intrinsics.factor
index 9432aee2eb..b6da21f4bb 100644
--- a/library/compiler/ppc/intrinsics.factor
+++ b/library/compiler/ppc/intrinsics.factor
@@ -10,15 +10,6 @@ math-internals namespaces sequences words ;
 
 : untag-fixnum ( src dest -- ) tag-bits SRAWI ;
 
-\ tag [
-    "in" operand "out" operand tag-mask ANDI
-    "out" operand dup tag-fixnum
-] H{
-    { +input { { f "in" } } }
-    { +scratch { { f "out" } } }
-    { +output { "out" } }
-} define-intrinsic
-
 : generate-slot ( size quot -- )
     >r >r
     ! turn tagged fixnum slot # into an offset, multiple of 4
@@ -80,7 +71,7 @@ math-internals namespaces sequences words ;
     { +clobber { "val" "slot" "obj" } }
 } define-intrinsic
 
-: define-binary-op ( word op -- )
+: define-fixnum-op ( word op -- )
     [ [ "x" operand "y" operand "x" operand ] % , ] [ ] make H{
         { +input { { f "x" } { f "y" } } }
         { +output { "x" } }
@@ -93,7 +84,7 @@ math-internals namespaces sequences words ;
     { fixnum-bitor OR }
     { fixnum-bitxor XOR }
 } [
-    first2 define-binary-op
+    first2 define-fixnum-op
 ] each
 
 : generate-fixnum-mod
@@ -120,7 +111,7 @@ math-internals namespaces sequences words ;
     { +output { "x" } }
 } define-intrinsic
 
-: define-binary-jump ( word op -- )
+: define-fixnum-jump ( word op -- )
     [
         [ end-basic-block "x" operand 0 "y" operand CMP ] % ,
      ] [ ] make H{ { +input { { f "x" } { f "y" } } } }
@@ -133,38 +124,9 @@ math-internals namespaces sequences words ;
     { fixnum>= BGE }
     { eq? BEQ }
 } [
-    first2 define-binary-jump
+    first2 define-fixnum-jump
 ] each
 
-\ type [
-    <label> "f" set
-    <label> "end" set
-    ! Get the tag
-    "obj" operand "y" operand tag-mask ANDI
-    ! Tag the tag
-    "y" operand "x" operand tag-fixnum
-    ! Compare with object tag number (3).
-    0 "y" operand object-tag CMPI
-    ! Jump if the object doesn't store type info in its header
-    "end" get BNE
-    ! It does store type info in its header
-    ! Is the pointer itself equal to 3? Then its F_TYPE (9).
-    0 "obj" operand object-tag CMPI
-    "f" get BEQ
-    ! The pointer is not equal to 3. Load the object header.
-    "x" operand "obj" operand object-tag neg LWZ
-    "x" operand dup untag
-    "end" get B
-    "f" get save-xt
-    ! The pointer is equal to 3. Load F_TYPE (9).
-    f type tag-bits shift "x" operand LI
-    "end" get save-xt
-] H{
-    { +input { { f "obj" } } }
-    { +scratch { { f "x" } { f "y" } } }
-    { +output { "x" } }
-} define-intrinsic
-
 : simple-overflow ( word -- )
     >r
     <label> "end" set
@@ -200,8 +162,6 @@ math-internals namespaces sequences words ;
     { +clobber { "x" "y" } }
 } define-intrinsic
 
-: ?MR 2dup = [ 2drop ] [ MR ] if ;
-
 \ fixnum* [
     finalize-contents
     <label> "end" set
@@ -210,7 +170,7 @@ math-internals namespaces sequences words ;
     11 "y" operand "r" operand MULLWO.
     "end" get BNO
     4 "y" operand "r" operand MULHW
-    3 11 ?MR
+    3 11 MR
     "s48_fixnum_pair_to_bignum" f %alien-invoke
     ! now we have to shift it by three bits to remove the second
     ! tag
@@ -275,6 +235,75 @@ math-internals namespaces sequences words ;
     { +clobber { "y" } }
 } define-intrinsic
 
+: define-float-op ( word op -- )
+    [ [ "x" operand "x" operand "y" operand ] % , ] [ ] make H{
+        { +input { { float "x" } { float "y" } } }
+        { +output { "x" } }
+    } define-intrinsic ;
+
+{
+    { float+ FADD }
+    { float- FSUB }
+    { float* FMUL }
+    { float/f FDIV }
+} [
+    first2 define-float-op
+] each
+
+: define-float-jump ( word op -- )
+    [
+        [ end-basic-block "x" operand 0 "y" operand FCMPU ] % ,
+     ] [ ] make H{ { +input { { float "x" } { float "y" } } } }
+    define-if-intrinsic ;
+
+{
+    { float< BLT }
+    { float<= BLE }
+    { float> BGT }
+    { float>= BGE }
+    { float= BEQ }
+} [
+    first2 define-float-jump
+] each
+
+\ tag [
+    "in" operand "out" operand tag-mask ANDI
+    "out" operand dup tag-fixnum
+] H{
+    { +input { { f "in" } } }
+    { +scratch { { f "out" } } }
+    { +output { "out" } }
+} define-intrinsic
+
+\ type [
+    <label> "f" set
+    <label> "end" set
+    ! Get the tag
+    "obj" operand "y" operand tag-mask ANDI
+    ! Tag the tag
+    "y" operand "x" operand tag-fixnum
+    ! Compare with object tag number (3).
+    0 "y" operand object-tag CMPI
+    ! Jump if the object doesn't store type info in its header
+    "end" get BNE
+    ! It does store type info in its header
+    ! Is the pointer itself equal to 3? Then its F_TYPE (9).
+    0 "obj" operand object-tag CMPI
+    "f" get BEQ
+    ! The pointer is not equal to 3. Load the object header.
+    "x" operand "obj" operand object-tag neg LWZ
+    "x" operand dup untag
+    "end" get B
+    "f" get save-xt
+    ! The pointer is equal to 3. Load F_TYPE (9).
+    f type tag-bits shift "x" operand LI
+    "end" get save-xt
+] H{
+    { +input { { f "obj" } } }
+    { +scratch { { f "x" } { f "y" } } }
+    { +output { "x" } }
+} define-intrinsic
+
 : userenv ( reg -- )
     #! Load the userenv pointer in a register.
     "userenv" f dlsym swap LOAD32 0 rel-2/2 rel-userenv ;
diff --git a/library/compiler/x86/architecture.factor b/library/compiler/x86/architecture.factor
index f5c798cf37..3460de4cc9 100644
--- a/library/compiler/x86/architecture.factor
+++ b/library/compiler/x86/architecture.factor
@@ -91,18 +91,10 @@ M: object load-literal ( literal vreg -- )
 : %move-int>float ( dst src -- )
     [ v>operand ] 2apply float-offset [+] MOVSD ;
 
-GENERIC: (%peek) ( vreg loc reg-class -- )
-
 M: int-regs (%peek) drop %move-int>int ;
 
-: %peek ( vreg loc -- ) over (%peek) ;
-
-GENERIC: (%replace) ( vreg loc reg-class -- )
-
 M: int-regs (%replace) drop swap %move-int>int ;
 
-: %replace ( vreg loc -- ) over (%replace) ;
-
 : (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
 
 : %inc-d ( n -- ) ds-reg (%inc) ;
diff --git a/library/compiler/x86/intrinsics-sse2.factor b/library/compiler/x86/intrinsics-sse2.factor
index 60ab472423..57825790a6 100644
--- a/library/compiler/x86/intrinsics-sse2.factor
+++ b/library/compiler/x86/intrinsics-sse2.factor
@@ -4,11 +4,6 @@ USING: alien arrays assembler generic kernel kernel-internals
 lists math math-internals memory namespaces sequences words ;
 IN: compiler
 
-: fp-scratch ( -- vreg )
-    "fp-scratch" get [
-        T{ int-regs } alloc-reg dup "fp-scratch" set
-    ] unless* ;
-
 M: float-regs (%peek) ( vreg loc reg-class -- )
     drop
     fp-scratch swap %move-int>int
@@ -16,7 +11,7 @@ M: float-regs (%peek) ( vreg loc reg-class -- )
 
 : load-zone-ptr ( vreg -- )
     #! Load pointer to start of zone array
-    "generations" f dlsym [] MOV ;
+    "generations" f 2dup dlsym [] MOV rel-dlsym ;
 
 : load-allot-ptr ( vreg -- )
     dup load-zone-ptr dup cell [+] MOV ;
@@ -24,9 +19,9 @@ M: float-regs (%peek) ( vreg loc reg-class -- )
 : inc-allot-ptr ( vreg n -- )
     >r dup load-zone-ptr cell [+] r> ADD ;
 
-: with-inline-alloc ( vreg spec prequot postquot -- )
+: with-inline-alloc ( vreg prequot postquot spec -- )
     #! both quotations are called with the vreg
-    rot [
+    [
         >r >r v>operand dup load-allot-ptr
         dup [] \ tag-header get call tag-header MOV
         r> over slip dup \ tag get call OR
@@ -34,12 +29,13 @@ M: float-regs (%peek) ( vreg loc reg-class -- )
     ] bind ; inline
 
 M: float-regs (%replace) ( vreg loc reg-class -- )
-    drop fp-scratch H{
+    drop fp-scratch
+    [ 8 [+] rot v>operand MOVSD ]
+    [ >r v>operand r> MOV ] H{
         { tag-header [ float-tag ] }
         { tag [ float-tag ] }
         { size [ 16 ] }
-    } [ 8 [+] rot v>operand MOVSD ]
-    [ >r v>operand r> MOV ] with-inline-alloc ;
+    } with-inline-alloc ;
 
 ! Floats
 : define-float-op ( word op -- )
diff --git a/library/test/compiler/assembler-x86.factor b/library/test/compiler/assembler-x86.factor
deleted file mode 100644
index ac12addb2e..0000000000
--- a/library/test/compiler/assembler-x86.factor
+++ /dev/null
@@ -1,9 +0,0 @@
-IN: temporary
-USING: assembler kernel test ;
-
-[ t ] [ { EBP } indirect? >boolean ] unit-test
-[ { EBP 0 } ] [ { EBP } canonicalize ] unit-test
-[ t ] [ { EAX 3 } displaced? >boolean ] unit-test
-[ { EAX } ] [ { EAX 0 } canonicalize ] unit-test
-[ { EAX } ] [ { EAX } canonicalize ] unit-test
-[ { EAX 3 } ] [ { EAX 3 } canonicalize ] unit-test
diff --git a/library/unix/io.factor b/library/unix/io.factor
index ae3a6ce90f..7db98c8035 100644
--- a/library/unix/io.factor
+++ b/library/unix/io.factor
@@ -104,7 +104,7 @@ GENERIC: task-container ( task -- vector )
 : add-io-task ( callback task -- )
     [ >r <queue> [ enque ] keep r> set-io-task-callbacks ] keep
     dup io-task-fd over task-container 2dup hash [
-        "Cannot perform multiple I/O ops on the same port" throw
+        "Cannot perform multiple reads from the same port" throw
     ] when set-hash ;
 
 : remove-io-task ( task -- )

From a842703e2f8a31cabdada963c7ce145e9dd72a0f Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Wed, 10 May 2006 02:22:21 +0000
Subject: [PATCH 098/112] Fix typos

---
 library/compiler/x86/intrinsics-sse2.factor | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/library/compiler/x86/intrinsics-sse2.factor b/library/compiler/x86/intrinsics-sse2.factor
index 57825790a6..2ad0b19643 100644
--- a/library/compiler/x86/intrinsics-sse2.factor
+++ b/library/compiler/x86/intrinsics-sse2.factor
@@ -11,7 +11,8 @@ M: float-regs (%peek) ( vreg loc reg-class -- )
 
 : load-zone-ptr ( vreg -- )
     #! Load pointer to start of zone array
-    "generations" f 2dup dlsym [] MOV rel-dlsym ;
+    "generations" f [ dlsym [] MOV ] 2keep
+    rel-absolute rel-dlsym ;
 
 : load-allot-ptr ( vreg -- )
     dup load-zone-ptr dup cell [+] MOV ;
@@ -55,7 +56,7 @@ M: float-regs (%replace) ( vreg loc reg-class -- )
 
 : define-float-jump ( word op -- )
     [
-        [ end-basic-block "x" operand "y" operand COMISD ] % ,
+        [ end-basic-block "x" operand "y" operand UCOMISD ] % ,
     ] [ ] make H{
         { +input { { float "x" } { float "y" } } }
     } define-if-intrinsic ;

From fd8a3062e3d791bba8aed93d7447bcfeb560c4f0 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Wed, 10 May 2006 06:18:25 +0000
Subject: [PATCH 099/112] Bootstrap performance improvement and assorted
 cleanups

---
 Makefile                                      |  2 +-
 TODO.FACTOR.txt                               |  2 +-
 library/bootstrap/boot-stage2.factor          | 19 +++----
 library/compiler/compiler.factor              |  7 +--
 library/compiler/inference/dataflow.factor    | 15 ++---
 library/compiler/inference/inference.factor   |  2 +-
 library/compiler/inference/words.factor       |  2 +-
 .../compiler/optimizer/inline-methods.factor  | 19 +------
 library/generic/generic.factor                | 36 ++++++++----
 library/generic/tuple.factor                  | 23 ++++----
 library/test/generic.factor                   | 57 ++++++++++---------
 library/tools/interpreter.factor              |  2 +
 12 files changed, 96 insertions(+), 90 deletions(-)

diff --git a/Makefile b/Makefile
index 3c54e66962..e0ae857600 100644
--- a/Makefile
+++ b/Makefile
@@ -111,7 +111,7 @@ macosx.app:
 	cp -R fonts/*.ttf $(BUNDLE)/Contents/Resources/fonts/
 
 	chmod +x cp_dir
-	find doc library contrib \( -name '*.factor' \
+	find doc library contrib examples \( -name '*.factor' \
 		-o -name '*.facts' \
 		-o -name '*.txt' \
 		-o -name '*.html' \
diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 3ae4c2acc8..98489f1e8a 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -3,7 +3,7 @@ should fix in 0.82:
 - clean up fp-scratch
 - intrinsic fixnum>float float>fixnum
 - update amd64 backend
-
+- float= on powerpc doesn't consider nans equal
 - amd64 %box-struct
 - when generating a 32-bit image on a 64-bit system, large numbers which should
   be bignums become fixnums
diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor
index 0b5ee6173f..09acfeaaae 100644
--- a/library/bootstrap/boot-stage2.factor
+++ b/library/bootstrap/boot-stage2.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler help io io-internals kernel
+USING: compiler generic help io io-internals kernel
 kernel-internals lists math memory namespaces optimizer parser
 sequences sequences-internals words ;
 
@@ -23,15 +23,14 @@ H{ } clone help-graph set-global xref-articles
 
     "Compiling base..." print flush
 
-    \ slot \ set-slot [ usage ] 2apply append
-    [ try-compile ] each
-
-    \ + compile
-    \ = compile
-    { "kernel" "sequences" "assembler" } compile-vocabs
-
-    "Compiling system..." print flush
-    compile-all
+    [
+        \ + compile
+        \ = compile
+        { "kernel" "sequences" "assembler" } compile-vocabs
+    
+        "Compiling system..." print flush
+        compile-all
+    ] with-class<cache
     
     terpri
     "Unless you're working on the compiler, ignore the errors above." print
diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor
index 9381b12507..f89403be91 100644
--- a/library/compiler/compiler.factor
+++ b/library/compiler/compiler.factor
@@ -6,11 +6,8 @@ namespaces optimizer prettyprint sequences test words ;
 
 : (compile) ( word -- )
     [
-        [
-            dup specialized-def dataflow optimize generate
-        ] keep
-    ] benchmark nip
-    "compile-time" set-word-prop ;
+        [ dup specialized-def dataflow optimize generate ] keep
+    ] benchmark nip "compile-time" set-word-prop ;
 
 : inform-compile ( word -- ) "Compiling " write . flush ;
 
diff --git a/library/compiler/inference/dataflow.factor b/library/compiler/inference/dataflow.factor
index ae37bf2d08..f50e1e1cb5 100644
--- a/library/compiler/inference/dataflow.factor
+++ b/library/compiler/inference/dataflow.factor
@@ -31,6 +31,7 @@ M: node = eq? ;
 : param-node ( label) { } { } { } { } ;
 : in-node ( inputs) >r f r> { } { } { } ;
 : out-node ( outputs) >r f { } r> { } { } ;
+: meta-d-node meta-d get clone in-node ;
 
 : d-tail ( n -- list ) meta-d get tail* ;
 : r-tail ( n -- list ) meta-r get tail* ;
@@ -43,7 +44,8 @@ C: #label make-node ;
 
 TUPLE: #entry ;
 C: #entry make-node ;
-: #entry ( -- node ) meta-d get clone in-node <#entry> ;
+
+: #entry ( -- node ) meta-d-node <#entry> ;
 
 TUPLE: #call ;
 C: #call make-node ;
@@ -55,7 +57,7 @@ C: #call-label make-node ;
 
 TUPLE: #push ;
 C: #push make-node ;
-: #push ( outputs -- node ) d-tail out-node <#push> ;
+: #push ( -- node ) peek-d out-node <#push> ;
 : >#push< ( node -- seq ) node-out-d [ value-literal ] map ;
 
 TUPLE: #shuffle ;
@@ -64,23 +66,22 @@ C: #shuffle make-node ;
 
 TUPLE: #values ;
 C: #values make-node ;
-: #values ( -- node ) meta-d get clone in-node <#values> ;
+: #values ( -- node ) meta-d-node <#values> ;
 
 TUPLE: #return ;
 C: #return make-node ;
 : #return ( label -- node )
     #! The parameter is the label we are returning from, or if
     #! f, this is a top-level return.
-    meta-d get clone in-node <#return>
-    [ set-node-param ] keep ;
+    meta-d-node <#return> [ set-node-param ] keep ;
 
 TUPLE: #if ;
 C: #if make-node ;
-: #if ( in -- node ) 1 d-tail in-node <#if> ;
+: #if ( in -- node ) peek-d in-node <#if> ;
 
 TUPLE: #dispatch ;
 C: #dispatch make-node ;
-: #dispatch ( in -- node ) 1 d-tail in-node <#dispatch> ;
+: #dispatch ( in -- node ) peek-d in-node <#dispatch> ;
 
 TUPLE: #merge ;
 C: #merge make-node ;
diff --git a/library/compiler/inference/inference.factor b/library/compiler/inference/inference.factor
index af22fb903e..818b204d52 100644
--- a/library/compiler/inference/inference.factor
+++ b/library/compiler/inference/inference.factor
@@ -76,7 +76,7 @@ GENERIC: apply-object
 : apply-literal ( obj -- )
     #! Literals are annotated with the current recursive
     #! state.
-    <value> push-d  1 #push node, ;
+    <value> push-d #push node, ;
 
 M: object apply-object apply-literal ;
 
diff --git a/library/compiler/inference/words.factor b/library/compiler/inference/words.factor
index 3b14dd4d84..4e2a150b9d 100644
--- a/library/compiler/inference/words.factor
+++ b/library/compiler/inference/words.factor
@@ -104,7 +104,7 @@ M: #call-label collect-recursion* ( label node -- )
 
 : infer-compound ( word base-case -- terminates? effect )
     #! Infer a word's stack effect in a separate inferencer
-    #! instance. Outputs a boolean if the word terminates
+    #! instance. Outputs a true boolean if the word terminates
     #! control flow by throwing an exception or restoring a
     #! continuation.
     [
diff --git a/library/compiler/optimizer/inline-methods.factor b/library/compiler/optimizer/inline-methods.factor
index 4873389ded..44f6918b5d 100644
--- a/library/compiler/optimizer/inline-methods.factor
+++ b/library/compiler/optimizer/inline-methods.factor
@@ -66,26 +66,9 @@ kernel-internals lists math namespaces sequences words ;
 : math-both-known? ( word left right -- ? )
     math-class-max specific-method ;
 
-: max-tag ( class -- n ) types peek 1+ num-tags min ;
-
-: left-partial-math ( word left right -- quot/t )
-    #! The left type is known; dispatch on right
-    \ dup swap max-tag
-    [ >r 2dup r> math-method ] math-vtable* 2nip ;
-
-: right-partial-math ( word left right -- quot/t )
-    #! The right type is known; dispatch on left
-    \ over rot max-tag
-    [ >r 2dup r> swap math-method ] math-vtable* 2nip ;
-
 : will-inline-math-method ( word left right -- quot/t )
     #! t indicates failure
-    {
-        { [ 3dup math-both-known? ] [ math-method ] }
-        ! { [ 3dup drop specific-method ] [ left-partial-math ] }
-        ! { [ 3dup nip specific-method ] [ right-partial-math ] }
-        { [ t ] [ 3drop t ] }
-    } cond ;
+    3dup math-both-known? [ math-method ] [ 3drop t ] if ;
 
 : inline-math-method ( #call -- node )
     dup node-param over 1 node-class# pick 0 node-class#
diff --git a/library/generic/generic.factor b/library/generic/generic.factor
index 50dd653699..125410510f 100644
--- a/library/generic/generic.factor
+++ b/library/generic/generic.factor
@@ -1,10 +1,14 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! Copyright (C) 2004, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 IN: generic
 USING: arrays errors hashtables kernel kernel-internals lists
 namespaces parser sequences strings words vectors math
 math-internals ;
 
+: class? ( word -- ? ) "class" word-prop ;
+
+: classes ( -- list ) [ class? ] word-subset ;
+
 SYMBOL: typemap
 SYMBOL: builtins
 
@@ -41,19 +45,19 @@ SYMBOL: builtins
 : types ( class -- types )
     [ (types) ] make-hash hash-keys natural-sort ;
 
-DEFER: class<
+DEFER: (class<)
 
 : superclass< ( cls1 cls2 -- ? )
-    >r superclass r> 2dup and [ class< ] [ 2drop f ] if ;
+    >r superclass r> 2dup and [ (class<) ] [ 2drop f ] if ;
 
 : union-class< ( cls1 cls2 -- ? )
     >r flatten-class r> flatten-class hash-keys swap
-    [ drop swap [ class< ] contains-with? ] hash-all-with? ;
+    [ drop swap [ (class<) ] contains-with? ] hash-all-with? ;
 
 : class-empty? ( class -- ? )
     members dup [ empty? ] when ;
 
-: class< ( cls1 cls2 -- ? )
+: (class<) ( cls1 cls2 -- ? )
     {
         { [ 2dup eq? ] [ 2drop t ] }
         { [ over class-empty? ] [ 2drop t ] }
@@ -62,6 +66,21 @@ DEFER: class<
         { [ t ] [ union-class< ] }
     } cond ;
 
+SYMBOL: class<cache
+
+: class< ( cls1 cls2 -- ? )
+    class<cache get [ hash hash-member? ] [ (class<) ] if* ;
+
+: smaller-classes ( class -- )
+    classes [ swap (class<) ] subset-with ;
+
+: make-class<cache ( -- hash )
+    classes [ dup smaller-classes [ dup ] map>hash ] map>hash ;
+
+: with-class<cache ( quot -- )
+    [ make-class<cache class<cache set call ] with-scope ;
+    inline
+
 : class-compare ( cls1 cls2 -- -1/0/1 )
     2dup eq? [ 2drop 0 ] [ class< 1 -1 ? ] if ;
 
@@ -80,8 +99,6 @@ M: generic definer drop \ G: ;
 : make-generic ( word -- )
     dup dup "combination" word-prop call define-compound ;
 
-: class? ( word -- ? ) "class" word-prop ;
-
 : check-method ( class generic -- )
     dup generic? [
         dup word-name " is not a generic word" append throw
@@ -146,13 +163,12 @@ M: generic definer drop \ G: ;
 
 : define-class ( class -- )
     dup t "class" set-word-prop
+    dup H{ } clone "class<" set-word-prop
     dup flatten-class typemap get set-hash ;
 
 : implementors ( class -- list )
     [ "methods" word-prop ?hash* nip ] word-subset-with ;
 
-: classes ( -- list ) [ class? ] word-subset ;
-
 ! Predicate classes for generalized predicate dispatch.
 : define-predicate-class ( class predicate definition -- )
     pick define-class
diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor
index 767c0932c9..13ff6990a7 100644
--- a/library/generic/tuple.factor
+++ b/library/generic/tuple.factor
@@ -1,11 +1,18 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: kernel-internals
-USING: arrays errors hashtables kernel lists math namespaces parser sequences sequences-internals strings vectors words ;
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: generic
+USING: arrays errors hashtables kernel kernel-internals lists
+math namespaces parser sequences sequences-internals strings
+vectors words ;
+
+: class ( object -- class )
+    dup tuple? [ 2 slot ] [ type type>class ] if ; inline
 
 : class-tuple ( object -- class )
     dup tuple? [ 2 slot ] [ drop f ] if ; inline
 
+IN: kernel-internals
+
 : tuple= ( tuple tuple -- ? )
     2dup [ array-capacity ] 2apply number= [
         dup array-capacity
@@ -15,14 +22,10 @@ USING: arrays errors hashtables kernel lists math namespaces parser sequences se
     ] if ; inline
 
 : tuple-hashcode ( n tuple -- n )
-    dup class-tuple hashcode >r >r 1- r>
-    4 slot hashcode* r> bitxor ;
+    dup class hashcode >r >r 1- r> 4 slot hashcode* r> bitxor ;
 
 IN: generic
 
-: class ( object -- class )
-    dup tuple? [ 2 slot ] [ type type>class ] if ; inline
-
 : tuple-predicate ( word -- )
     dup predicate-word
     [ \ class-tuple , over literalize , \ eq? , ] [ ] make
@@ -80,7 +83,7 @@ M: tuple clone ( tuple -- tuple )
 M: tuple hashcode* ( n tuple -- n )
     {
         { [ over 0 <= ] [ 2drop 0 ] }
-        { [ dup array-capacity 2 <= ] [ nip class-tuple hashcode ] }
+        { [ dup array-capacity 2 <= ] [ nip class hashcode ] }
         { [ t ] [ tuple-hashcode ] }
     } cond ;
 
diff --git a/library/test/generic.factor b/library/test/generic.factor
index c1075377e2..7ba806f6bd 100644
--- a/library/test/generic.factor
+++ b/library/test/generic.factor
@@ -69,34 +69,39 @@ M: very-funny gooey sq ;
 
 [ cons ] [ [ 1 2 ] class ] unit-test
 
-[ object ] [ object object class-and ] unit-test
-[ fixnum ] [ fixnum object class-and ] unit-test
-[ fixnum ] [ object fixnum class-and ] unit-test
-[ fixnum ] [ fixnum fixnum class-and ] unit-test
-[ fixnum ] [ fixnum integer class-and ] unit-test
-[ fixnum ] [ integer fixnum class-and ] unit-test
-[ null ] [ vector fixnum class-and ] unit-test
-[ number ] [ number object class-and ] unit-test
-[ number ] [ object number class-and ] unit-test
+: class<tests
+    [ object ] [ object object class-and ] unit-test
+    [ fixnum ] [ fixnum object class-and ] unit-test
+    [ fixnum ] [ object fixnum class-and ] unit-test
+    [ fixnum ] [ fixnum fixnum class-and ] unit-test
+    [ fixnum ] [ fixnum integer class-and ] unit-test
+    [ fixnum ] [ integer fixnum class-and ] unit-test
+    [ null ] [ vector fixnum class-and ] unit-test
+    [ number ] [ number object class-and ] unit-test
+    [ number ] [ object number class-and ] unit-test
+    
+    [ t ] [ \ fixnum \ integer class< ] unit-test
+    [ t ] [ \ fixnum \ fixnum class< ] unit-test
+    [ f ] [ \ integer \ fixnum class< ] unit-test
+    [ t ] [ \ integer \ object class< ] unit-test
+    [ f ] [ \ integer \ null class< ] unit-test
+    [ t ] [ \ null \ object class< ] unit-test
+    [ t ] [ \ list \ general-list class< ] unit-test
+    [ t ] [ \ list \ object class< ] unit-test
+    [ t ] [ \ null \ list class< ] unit-test
+    
+    [ t ] [ \ generic \ compound class< ] unit-test
+    [ f ] [ \ compound \ generic class< ] unit-test
+    
+    [ f ] [ \ cons \ list class< ] unit-test
+    [ f ] [ \ list \ cons class< ] unit-test
+    
+    [ f ] [ \ reversed \ slice class< ] unit-test
+    [ f ] [ \ slice \ reversed class< ] unit-test ;
 
-[ t ] [ \ fixnum \ integer class< ] unit-test
-[ t ] [ \ fixnum \ fixnum class< ] unit-test
-[ f ] [ \ integer \ fixnum class< ] unit-test
-[ t ] [ \ integer \ object class< ] unit-test
-[ f ] [ \ integer \ null class< ] unit-test
-[ t ] [ \ null \ object class< ] unit-test
-[ t ] [ \ list \ general-list class< ] unit-test
-[ t ] [ \ list \ object class< ] unit-test
-[ t ] [ \ null \ list class< ] unit-test
+class<tests
 
-[ t ] [ \ generic \ compound class< ] unit-test
-[ f ] [ \ compound \ generic class< ] unit-test
-
-[ f ] [ \ cons \ list class< ] unit-test
-[ f ] [ \ list \ cons class< ] unit-test
-
-[ f ] [ \ reversed \ slice class< ] unit-test
-[ f ] [ \ slice \ reversed class< ] unit-test
+[ class<tests ] with-class<cache
 
 PREDICATE: word no-docs "documentation" word-prop not ;
 
diff --git a/library/tools/interpreter.factor b/library/tools/interpreter.factor
index df03029438..27882139df 100644
--- a/library/tools/interpreter.factor
+++ b/library/tools/interpreter.factor
@@ -12,9 +12,11 @@ namespaces prettyprint sequences strings vectors words ;
 SYMBOL: meta-r
 : push-r meta-r get push ;
 : pop-r meta-r get pop ;
+: peek-r meta-r get peek ;
 SYMBOL: meta-d
 : push-d meta-d get push ;
 : pop-d meta-d get pop ;
+: peek-d meta-d get peek ;
 SYMBOL: meta-n
 SYMBOL: meta-c
 

From 72fe1b613442fc83cfb8d299b8f5d36e8c862842 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Wed, 10 May 2006 07:40:03 +0000
Subject: [PATCH 100/112] Optimizer cleanup

---
 library/compiler/inference/dataflow.factor    | 11 +++-----
 .../compiler/optimizer/kill-literals.factor   | 26 +++----------------
 library/generic/tuple.factor                  | 11 ++++----
 3 files changed, 12 insertions(+), 36 deletions(-)

diff --git a/library/compiler/inference/dataflow.factor b/library/compiler/inference/dataflow.factor
index f50e1e1cb5..f5404cd3f6 100644
--- a/library/compiler/inference/dataflow.factor
+++ b/library/compiler/inference/dataflow.factor
@@ -57,7 +57,7 @@ C: #call-label make-node ;
 
 TUPLE: #push ;
 C: #push make-node ;
-: #push ( -- node ) peek-d out-node <#push> ;
+: #push ( -- node ) peek-d 1array out-node <#push> ;
 : >#push< ( node -- seq ) node-out-d [ value-literal ] map ;
 
 TUPLE: #shuffle ;
@@ -77,11 +77,11 @@ C: #return make-node ;
 
 TUPLE: #if ;
 C: #if make-node ;
-: #if ( in -- node ) peek-d in-node <#if> ;
+: #if ( in -- node ) peek-d 1array in-node <#if> ;
 
 TUPLE: #dispatch ;
 C: #dispatch make-node ;
-: #dispatch ( in -- node ) peek-d in-node <#dispatch> ;
+: #dispatch ( in -- node ) peek-d 1array in-node <#dispatch> ;
 
 TUPLE: #merge ;
 C: #merge make-node ;
@@ -124,11 +124,6 @@ SYMBOL: current-node
         dup node-in-r % node-out-r %
     ] { } make ;
 
-: uses-value? ( value node -- ? ) node-values memq? ;
-
-: outputs-value? ( value node -- ? )
-    2dup node-out-d member? >r node-out-r member? r> or ;
-
 : last-node ( node -- last )
     dup node-successor [ last-node ] [ ] ?if ;
 
diff --git a/library/compiler/optimizer/kill-literals.factor b/library/compiler/optimizer/kill-literals.factor
index 15aa355990..fdb970950e 100644
--- a/library/compiler/optimizer/kill-literals.factor
+++ b/library/compiler/optimizer/kill-literals.factor
@@ -14,11 +14,6 @@ GENERIC: literals* ( node -- seq )
 : literals ( node -- hash )
     [ literals* ] node-union ;
 
-! GENERIC: flushable-values* ( node -- seq )
-! 
-! : flushable-values ( node -- hash )
-!     [ flushable-values* ] node-union ;
-
 GENERIC: live-values* ( node -- seq )
 
 : live-values ( node -- hash )
@@ -35,32 +30,17 @@ GENERIC: live-values* ( node -- seq )
     over hash-empty?
     [ 2drop ] [ [ kill-node* ] each-node-with ] if ;
 
-: kill-unused-literals ( node -- )
-    \ live-values get over literals hash-diff swap kill-node ;
-
 : kill-values ( node -- )
     dup live-values over literals hash-diff swap kill-node ;
 
 ! Generic nodes
 M: node literals* ( node -- ) drop { } ;
 
-! M: node flushable-values* ( node -- ) drop { } ;
-
-M: node live-values* ( node -- ) node-values ;
-
-! #shuffle
-M: #shuffle literals* ( node -- seq )
-    dup node-out-d swap node-out-r
-    [ [ value? ] subset ] 2apply append ;
+M: node live-values* ( node -- seq )
+    node-in-d [ value? ] subset ;
 
 ! #push
-M: #push literals* ( node -- seq )
-    node-values ;
-
-! #call
-! M: #call flushable-values* ( node -- )
-!     dup node-param "flushable" word-prop
-!     [ node-out-d ] [ drop { } ] if ;
+M: #push literals* ( node -- seq ) node-out-d ;
 
 ! #return
 M: #return live-values* ( node -- seq )
diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor
index 13ff6990a7..4a29fb6482 100644
--- a/library/generic/tuple.factor
+++ b/library/generic/tuple.factor
@@ -5,14 +5,11 @@ USING: arrays errors hashtables kernel kernel-internals lists
 math namespaces parser sequences sequences-internals strings
 vectors words ;
 
-: class ( object -- class )
-    dup tuple? [ 2 slot ] [ type type>class ] if ; inline
+IN: kernel-internals
 
 : class-tuple ( object -- class )
     dup tuple? [ 2 slot ] [ drop f ] if ; inline
 
-IN: kernel-internals
-
 : tuple= ( tuple tuple -- ? )
     2dup [ array-capacity ] 2apply number= [
         dup array-capacity
@@ -22,10 +19,14 @@ IN: kernel-internals
     ] if ; inline
 
 : tuple-hashcode ( n tuple -- n )
-    dup class hashcode >r >r 1- r> 4 slot hashcode* r> bitxor ;
+    dup class-tuple hashcode >r >r 1-
+    r> 4 slot hashcode* r> bitxor ;
 
 IN: generic
 
+: class ( object -- class )
+    dup tuple? [ 2 slot ] [ type type>class ] if ; inline
+
 : tuple-predicate ( word -- )
     dup predicate-word
     [ \ class-tuple , over literalize , \ eq? , ] [ ] make

From 63703c271376ba023473524a71f155f2f3e14def Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Wed, 10 May 2006 22:51:18 +0000
Subject: [PATCH 101/112] Minor performance improvements in optimizer

---
 library/bootstrap/boot-stage2.factor          |  4 +--
 library/compiler/compiler.factor              |  4 +--
 .../compiler/optimizer/call-optimizers.factor |  9 ++---
 library/compiler/optimizer/class-infer.factor | 20 ++++++++---
 .../compiler/optimizer/inline-methods.factor  | 34 ++++++++++++++-----
 library/compiler/optimizer/optimizer.factor   |  2 +-
 6 files changed, 48 insertions(+), 25 deletions(-)

diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor
index 09acfeaaae..7d5d4d7c4b 100644
--- a/library/bootstrap/boot-stage2.factor
+++ b/library/bootstrap/boot-stage2.factor
@@ -4,7 +4,7 @@ USING: compiler generic help io io-internals kernel
 kernel-internals lists math memory namespaces optimizer parser
 sequences sequences-internals words ;
 
-"Cross-referencing..." print
+"Cross-referencing..." print flush
 H{ } clone crossref set-global xref-words
 H{ } clone help-graph set-global xref-articles
 
@@ -13,8 +13,8 @@ H{ } clone help-graph set-global xref-articles
         unix? [
             "/library/unix/load.factor" run-resource
         ] when
-
     ] when
+
     windows? [
         "/library/windows/load.factor" run-resource
     ] when
diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor
index f89403be91..ad191cb707 100644
--- a/library/compiler/compiler.factor
+++ b/library/compiler/compiler.factor
@@ -5,9 +5,7 @@ USING: errors hashtables inference io kernel lists math
 namespaces optimizer prettyprint sequences test words ;
 
 : (compile) ( word -- )
-    [
-        [ dup specialized-def dataflow optimize generate ] keep
-    ] benchmark nip "compile-time" set-word-prop ;
+    dup specialized-def dataflow optimize generate ;
 
 : inform-compile ( word -- ) "Compiling " write . flush ;
 
diff --git a/library/compiler/optimizer/call-optimizers.factor b/library/compiler/optimizer/call-optimizers.factor
index 26dbf2632c..d98bc25bd4 100644
--- a/library/compiler/optimizer/call-optimizers.factor
+++ b/library/compiler/optimizer/call-optimizers.factor
@@ -36,17 +36,17 @@ math math-internals sequences words ;
     [ with-datastack ] catch
     [ 3drop t ] [ inline-literals ] if ;
 
-: flip-subst ( not -- )
+: call>no-op ( not -- )
     #! Note: cloning the vectors, since subst-values will modify
     #! them.
     [ node-in-d clone ] keep
     [ node-out-d clone ] keep
-    subst-values ;
+    [ subst-values ] keep node-successor ;
 
 : flip-branches ( not -- #if )
     #! If a not is followed by an #if, flip branches and
     #! remove the not.
-    dup flip-subst node-successor dup
+    call>no-op dup
     dup node-children reverse swap set-node-children ;
 
 \ not {
@@ -66,9 +66,6 @@ math math-internals sequences words ;
     dup 0 node-class#
     swap node-param "infer-effect" word-prop second first eq? ;
 
-: call>no-op ( node -- node )
-    [ ] dataflow [ subst-node ] keep ;
-
 { >fixnum >bignum >float } [
     {
         { [ dup useless-coerce? ] [ call>no-op ] }
diff --git a/library/compiler/optimizer/class-infer.factor b/library/compiler/optimizer/class-infer.factor
index 66dea6dd2d..444c34298c 100644
--- a/library/compiler/optimizer/class-infer.factor
+++ b/library/compiler/optimizer/class-infer.factor
@@ -1,5 +1,5 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! Copyright (C) 2004, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 IN: optimizer
 USING: arrays generic hashtables inference kernel
 kernel-internals math namespaces sequences words ;
@@ -166,10 +166,20 @@ DEFER: (infer-classes)
         node-successor (infer-classes)
     ] when* ;
 
-: infer-classes ( node -- )
+: ?<hashtable> [ H{ } clone ] unless* ;
+
+: infer-classes-with ( node classes literals -- )
     [
-        H{ } clone value-classes set
-        H{ } clone value-literals set
+        ?<hashtable> value-literals set
+        ?<hashtable> value-classes set
         H{ } clone ties set
         (infer-classes)
     ] with-scope ;
+
+: infer-classes ( node -- )
+    f f infer-classes-with ;
+
+: infer-classes/node ( existing node -- )
+    #! Infer classes, using the existing node's class info as a
+    #! starting point.
+    over node-classes rot node-literals infer-classes-with ;
diff --git a/library/compiler/optimizer/inline-methods.factor b/library/compiler/optimizer/inline-methods.factor
index 44f6918b5d..23b60df922 100644
--- a/library/compiler/optimizer/inline-methods.factor
+++ b/library/compiler/optimizer/inline-methods.factor
@@ -2,31 +2,49 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: optimizer
 USING: arrays generic hashtables inference kernel
-kernel-internals lists math namespaces sequences words ;
+kernel-internals lists math namespaces prettyprint sequences
+words ;
 
 ! Some utilities for splicing in dataflow IR subtrees
 : post-inline ( #return/#values #call/#merge -- )
+    [
+        >r node-in-d r> node-out-d 2array unify-lengths first2
+    ] keep subst-values ;
+
+: ?hash-union ( hash/f hash -- hash )
+    over [ hash-union ] [ nip ] if ;
+
+: add-node-literals ( hash node -- )
+    [ node-literals ?hash-union ] keep set-node-literals ;
+
+: add-node-classes ( hash node -- )
+    [ node-classes ?hash-union ] keep set-node-classes ;
+
+: (subst-classes) ( literals classes node -- )
     dup [
-        [
-            >r node-in-d r> node-out-d
-            2array unify-lengths first2
-        ] keep subst-values
+        3dup [ add-node-classes ] keep add-node-literals
+        node-successor (subst-classes)
     ] [
-        2drop
+        3drop
     ] if ;
 
+: subst-classes ( #return/#values #call/#merge -- )
+    >r dup node-literals swap node-classes r> (subst-classes) ;
+
 : subst-node ( old new -- )
     #! The last node of 'new' becomes 'old', then values are
     #! substituted. A subsequent optimizer phase kills the
     #! last node of 'new' and the first node of 'old'.
-    last-node 2dup swap post-inline set-node-successor ;
+    last-node 2dup swap 2dup post-inline subst-classes
+    set-node-successor ;
 
 : (inline-method) ( #call quot -- node )
     dup t eq? [
         2drop t
     ] [
         over node-in-d dataflow-with
-        [ >r node-param r> remember-node ] 2keep
+        2dup infer-classes/node
+        over node-param over remember-node
         [ subst-node ] keep
     ] if ;
 
diff --git a/library/compiler/optimizer/optimizer.factor b/library/compiler/optimizer/optimizer.factor
index e8bdfec2a0..e738fa95a1 100644
--- a/library/compiler/optimizer/optimizer.factor
+++ b/library/compiler/optimizer/optimizer.factor
@@ -9,7 +9,7 @@ SYMBOL: optimizer-changed
 GENERIC: optimize-node* ( node -- node/t )
 
 : keep-optimizing ( node -- node ? )
-    dup optimize-node* dup t =
+    dup optimize-node* dup t eq?
     [ drop f ] [ nip keep-optimizing t or ] if ;
 
 : optimize-node ( node -- node )

From 1cce70aad6913fca17be589e9043e6505a7a01c8 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Thu, 11 May 2006 00:32:04 +0000
Subject: [PATCH 102/112] Changing list code to use generic sequence words

---
 TODO.FACTOR.txt                               |  3 +-
 library/collections/sequences-epilogue.factor |  7 +++-
 library/compiler/alien/alien-callback.factor  |  2 +-
 library/compiler/alien/alien-invoke.factor    |  5 ++-
 library/compiler/alien/c-types.factor         |  8 ++--
 library/compiler/alien/structs.factor         |  4 +-
 library/generic/generic.factor                |  5 +--
 library/generic/slots.factor                  |  4 +-
 library/generic/standard-combination.factor   | 40 +++++++++++--------
 library/generic/tuple.factor                  |  2 +-
 library/syntax/prettyprint.factor             |  6 +--
 library/threads.factor                        | 14 +++----
 library/tools/annotations.factor              |  2 +-
 13 files changed, 56 insertions(+), 46 deletions(-)

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 98489f1e8a..60f02b2ab0 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -75,10 +75,9 @@ should fix in 0.82:
 
 + misc:
 
+- make-image then compiler-tests sometimes reveals weird ghost words
 - 3 >n fep
 - code walker & exceptions
 - slice: if sequence or seq start is changed, abstraction violation
 - make 3.4 bits>double an error
-- colorcoded prettyprinting for vocabularies
-- signal handler should not lose stack pointers
 - code walker and callbacks is broken?
diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor
index 5d6de06034..e2450e434e 100644
--- a/library/collections/sequences-epilogue.factor
+++ b/library/collections/sequences-epilogue.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: sequences
-USING: errors generic kernel kernel-internals math
+USING: arrays errors generic kernel kernel-internals math
 sequences-internals strings vectors words ;
 
 : first2 ( { x y } -- x y )
@@ -82,6 +82,11 @@ M: object like drop ;
 : add ( seq elt -- seq )
     swap [ push ] immutable ; flushable
 
+: add* ( seq elt -- seq )
+    over >r
+    over thaw [ push ] keep [ swap nappend ] keep
+    r> like ; flushable
+
 : diff ( seq1 seq2 -- seq2-seq1 )
     [ swap member? not ] subset-with ; flushable
 
diff --git a/library/compiler/alien/alien-callback.factor b/library/compiler/alien/alien-callback.factor
index 633b7a86ec..375b982020 100644
--- a/library/compiler/alien/alien-callback.factor
+++ b/library/compiler/alien/alien-callback.factor
@@ -52,7 +52,7 @@ M: alien-callback-error summary ( error -- )
 : generate-callback ( node -- )
     [ alien-callback-xt ] keep [
         dup alien-callback-parameters registers>objects
-        dup alien-callback-quot \ init-error-handler swons
+        dup alien-callback-quot \ init-error-handler add*
         %alien-callback
         unbox-return
         %return
diff --git a/library/compiler/alien/alien-invoke.factor b/library/compiler/alien/alien-invoke.factor
index 213ff16c67..096826f9ba 100644
--- a/library/compiler/alien/alien-invoke.factor
+++ b/library/compiler/alien/alien-invoke.factor
@@ -80,8 +80,9 @@ M: alien-invoke stack-reserve*
 
 : (define-c-word) ( type lib func types stack-effect -- )
     >r over create-in >r 
-    [ alien-invoke ] cons cons cons cons r> swap define-compound
-    word r> "stack-effect" set-word-prop ;
+    [ alien-invoke ] curry curry curry curry
+    r> swap define-compound word r>
+    "stack-effect" set-word-prop ;
 
 : define-c-word ( return library function parameters -- )
     [ "()" subseq? not ] subset >r pick r> parse-arglist
diff --git a/library/compiler/alien/c-types.factor b/library/compiler/alien/c-types.factor
index b6f88d41cb..d720775670 100644
--- a/library/compiler/alien/c-types.factor
+++ b/library/compiler/alien/c-types.factor
@@ -53,10 +53,10 @@ SYMBOL: c-types
 
 : define-deref ( name vocab -- )
     >r dup "*" swap append r> create
-    swap c-getter 0 swons define-compound ;
+    swap c-getter 0 add* define-compound ;
 
 : (define-nth) ( word type quot -- )
-    >r c-size [ rot * ] curry r> append define-compound ;
+    >r c-size [ rot * ] swap add* r> append define-compound ;
 
 : define-nth ( name vocab -- )
     >r dup "-nth" append r> create
@@ -67,8 +67,8 @@ SYMBOL: c-types
     swap dup c-setter (define-nth) ;
 
 : define-out ( name vocab -- )
-    over [ <c-object> tuck 0 ] over c-setter append
-    >r >r constructor-word r> r> cons define-compound ;
+    over [ <c-object> tuck 0 ] over c-setter append swap
+    >r >r constructor-word r> r> add* define-compound ;
 
 : init-c-type ( name vocab -- )
     over define-pointer define-nth ;
diff --git a/library/compiler/alien/structs.factor b/library/compiler/alien/structs.factor
index c2253d1a98..b86ca7973d 100644
--- a/library/compiler/alien/structs.factor
+++ b/library/compiler/alien/structs.factor
@@ -10,12 +10,12 @@ sequences strings words ;
 : define-getter ( offset type name -- )
     #! Define a word with stack effect ( alien -- obj ) in the
     #! current 'in' vocabulary.
-    create-in >r c-getter cons r> swap define-compound ;
+    create-in >r c-getter swap add* r> swap define-compound ;
 
 : define-setter ( offset type name -- )
     #! Define a word with stack effect ( obj alien -- ) in the
     #! current 'in' vocabulary.
-    "set-" swap append create-in >r c-setter cons r>
+    "set-" swap append create-in >r c-setter swap add* r>
     swap define-compound ;
 
 : define-field ( offset type name -- offset )
diff --git a/library/generic/generic.factor b/library/generic/generic.factor
index 125410510f..b86315eb12 100644
--- a/library/generic/generic.factor
+++ b/library/generic/generic.factor
@@ -181,9 +181,8 @@ PREDICATE: word predicate "definition" word-prop ;
 
 ! Union classes for dispatch on multiple classes.
 : union-predicate ( members -- list )
-    [
-        "predicate" word-prop \ dup swons [ drop t ] 2array
-    ] map [ drop f ] swap alist>quot ;
+    [ dup ] swap [ "predicate" word-prop append ] map-with
+    [ [ drop t ] 2array ] map [ drop f ] swap alist>quot ;
 
 : set-members ( class members -- )
     [ bootstrap-word ] map "members" set-word-prop ;
diff --git a/library/generic/slots.factor b/library/generic/slots.factor
index 4ce26c9aa2..7b83fb4d7c 100644
--- a/library/generic/slots.factor
+++ b/library/generic/slots.factor
@@ -10,7 +10,7 @@ parser sequences strings words ;
 
 : define-slot-word ( class slot word quot -- )
     over [
-        >r swap >fixnum r> cons define-typecheck
+        rot >fixnum add* define-typecheck
     ] [
         2drop 2drop
     ] if ;
@@ -19,7 +19,7 @@ parser sequences strings words ;
     [ slot ] rot dup object eq? [
         drop
     ] [
-        1array [ declare ] curry append
+        1array [ declare ] swap add* append
     ] if define-slot-word ;
 
 : define-writer ( class slot writer -- )
diff --git a/library/generic/standard-combination.factor b/library/generic/standard-combination.factor
index 36a183faa8..0eb222ce75 100644
--- a/library/generic/standard-combination.factor
+++ b/library/generic/standard-combination.factor
@@ -32,34 +32,40 @@ math namespaces sequences vectors words ;
         swap [ first classes-intersect? ] subset-with
     ] map-with ;
 
-: simplify-alist ( class assoc -- default assoc )
-    dup cdr [
-        2dup cdr car first class< [
-            cdr simplify-alist
-        ] [
-            uncons >r second nip r>
-        ] if
+: (simplify-alist) ( class i assoc -- default assoc )
+    2dup length 1- = [
+        nth second [ ] rot drop
     ] [
-        nip car second [ ]
+        3dup >r 1+ r> nth first class< [
+            >r 1+ r> (simplify-alist)
+        ] [
+            [ nth second ] 2keep >r 1+ r> tail rot drop
+        ] if
     ] if ;
 
+: simplify-alist ( class assoc -- default assoc )
+    0 swap (simplify-alist) ;
+
+: methods* ( dispatch# word -- assoc )
+    #! Make a class->method association, together with a
+    #! default delegating method at the end.
+    empty-method object bootstrap-word swap 2array 1array
+    swap methods append ;
+
+: small-generic ( dispatch# word -- def )
+    2dup methods* object bootstrap-word swap simplify-alist
+    swapd class-predicates alist>quot ;
+
 : vtable-methods ( dispatch# alist-seq -- alist-seq )
     dup length [
         type>class
-        [ swap simplify-alist ] [ car second [ ] ] if*
+        [ swap simplify-alist ] [ first second [ ] ] if*
         >r over r> class-predicates alist>quot
     ] 2map nip ;
 
 : <vtable> ( dispatch# word n -- vtable )
     #! n is vtable size; either num-types or num-tags.
-    >r 2dup empty-method \ object bootstrap-word swap 2array
-    >r methods >list r> swons r> sort-methods vtable-methods ;
-
-: small-generic ( dispatch# word -- def )
-    2dup empty-method object bootstrap-word swap 2array
-    swap methods >list cons
-    object bootstrap-word swap simplify-alist
-    swapd class-predicates alist>quot ;
+    >r 2dup methods* r> sort-methods vtable-methods ;
 
 : big-generic ( dispatch# word n dispatcher -- def )
     [ >r pick picker % r> , <vtable> , \ dispatch , ] [ ] make ;
diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor
index 4a29fb6482..92fefeec20 100644
--- a/library/generic/tuple.factor
+++ b/library/generic/tuple.factor
@@ -33,7 +33,7 @@ IN: generic
     define-predicate ;
 
 : forget-tuple ( class -- )
-    dup forget "predicate" word-prop car [ forget ] when* ;
+    dup forget "predicate" word-prop first [ forget ] when* ;
 
 : check-shape ( word slots -- )
     >r in get lookup dup [
diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor
index b2a86d8509..1c89cab400 100644
--- a/library/syntax/prettyprint.factor
+++ b/library/syntax/prettyprint.factor
@@ -24,7 +24,6 @@ SYMBOL: string-limit
 global [
     4 tab-size set
     64 margin set
-    recursion-check off
     0 position set
     0 indent set
     0 last-newline set
@@ -230,9 +229,9 @@ M: dll pprint* ( obj -- str ) dll-path "DLL\" " pprint-string ;
         over recursion-check get memq? [
             2drop "&" plain-text
         ] [
-            over recursion-check [ cons ] change
+            over recursion-check get push
             call
-            recursion-check [ cdr ] change
+            recursion-check get pop*
         ] if
     ] if ; inline
 
@@ -294,6 +293,7 @@ M: wrapper pprint* ( wrapper -- )
 
 : with-pprint ( quot -- )
     [
+        V{ } clone recursion-check set
         <block> f ?push pprinter-stack set
         call end-blocks do-pprint
     ] with-scope ; inline
diff --git a/library/threads.factor b/library/threads.factor
index a9a901c819..ce2c265129 100644
--- a/library/threads.factor
+++ b/library/threads.factor
@@ -1,8 +1,8 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
+! Copyright (C) 2004, 2006 Slava Pestov.
 ! Copyright (C) 2005 Mackenzie Straight.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
 IN: threads
-USING: errors hashtables io-internals kernel lists math
+USING: arrays errors hashtables io-internals kernel math
 namespaces queues sequences vectors ;
 
 ! Co-operative multitasker.
@@ -14,16 +14,16 @@ namespaces queues sequences vectors ;
 : sleep-queue ( -- vec ) \ sleep-queue get-global ;
 
 : sleep-queue* ( -- vec )
-    sleep-queue dup [ 2car swap - ] nsort ;
+    sleep-queue dup [ [ first ] 2apply swap - ] nsort ;
 
 : sleep-time ( sorted-queue -- ms )
-    dup empty? [ drop -1 ] [ peek car millis - 0 max ] if ;
+    dup empty? [ drop -1 ] [ peek first millis - 0 max ] if ;
 
 DEFER: next-thread
 
 : do-sleep ( -- continuation )
     sleep-queue* dup sleep-time dup zero?
-    [ drop pop cdr ] [ nip io-multiplex next-thread ] if ;
+    [ drop pop second ] [ nip io-multiplex next-thread ] if ;
 
 : next-thread ( -- continuation )
     run-queue dup queue-empty? [ drop do-sleep ] [ deque ] if ;
@@ -33,7 +33,7 @@ DEFER: next-thread
 : yield ( -- ) [ schedule-thread stop ] callcc0 ;
 
 : sleep ( ms -- )
-    millis + [ cons sleep-queue push stop ] callcc0 drop ;
+    millis + [ 2array sleep-queue push stop ] callcc0 drop ;
 
 : in-thread ( quot -- )
     [
diff --git a/library/tools/annotations.factor b/library/tools/annotations.factor
index b8109123d5..939eafa816 100644
--- a/library/tools/annotations.factor
+++ b/library/tools/annotations.factor
@@ -28,4 +28,4 @@ sequences strings walker ;
     ] annotate ;
 
 : profile ( word -- )
-    [ swap [ global [ inc ] bind call ] curry cons ] annotate ;
+    [ swap [ global [ inc ] bind ] curry swap append ] annotate ;

From e06e42bbba1d8a7196431475b191a507326bbde6 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Thu, 11 May 2006 05:46:32 +0000
Subject: [PATCH 103/112] Some minor I/O fixes

---
 TODO.FACTOR.txt                     |  2 --
 library/bootstrap/primitives.factor |  5 +++--
 library/threads.factor              |  2 +-
 library/unix/io.factor              | 21 ++++++++++++---------
 library/unix/syscalls.factor        | 12 ++++--------
 5 files changed, 20 insertions(+), 22 deletions(-)

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 60f02b2ab0..0abc024d41 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -16,7 +16,6 @@ should fix in 0.82:
 - better i/o scheduler
 - yield in a loop starves i/o
 - "localhost" 50 <client> won't fail
-- issues with timeouts
 
 + ui/help:
 
@@ -75,7 +74,6 @@ should fix in 0.82:
 
 + misc:
 
-- make-image then compiler-tests sometimes reveals weird ghost words
 - 3 >n fep
 - code walker & exceptions
 - slice: if sequence or seq start is changed, abstraction violation
diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor
index 6e4911ea2c..7b2757e9cb 100644
--- a/library/bootstrap/primitives.factor
+++ b/library/bootstrap/primitives.factor
@@ -14,10 +14,11 @@ H{ } clone c-types set
 "/library/compiler/alien/primitive-types.factor" parse-resource
 
 ! These symbols need the same hashcode in the target as in the
-! host.
+! host. They must be symbols -- colon definitions are not
+! permitted to be carried over
 {
     vocabularies typemap builtins c-types
-    cell crossref articles terms
+    crossref articles terms
 }
 
 ! Bring up a bare cross-compiling vocabulary.
diff --git a/library/threads.factor b/library/threads.factor
index ce2c265129..1534c9a42e 100644
--- a/library/threads.factor
+++ b/library/threads.factor
@@ -17,7 +17,7 @@ namespaces queues sequences vectors ;
     sleep-queue dup [ [ first ] 2apply swap - ] nsort ;
 
 : sleep-time ( sorted-queue -- ms )
-    dup empty? [ drop -1 ] [ peek first millis - 0 max ] if ;
+    dup empty? [ drop 1000 ] [ peek first millis - 0 max ] if ;
 
 DEFER: next-thread
 
diff --git a/library/unix/io.factor b/library/unix/io.factor
index 7db98c8035..623b3e70f1 100644
--- a/library/unix/io.factor
+++ b/library/unix/io.factor
@@ -133,20 +133,23 @@ GENERIC: task-container ( task -- vector )
     ] hash-each-with ;
 
 : init-fdset ( fdset tasks -- )
-    >r dup FD_SETSIZE clear-bits r>
+    >r dup dup FD_SETSIZE clear-bits r>
     [ drop t swap rot set-bit-nth ] hash-each-with ;
 
+: read-fdset/tasks
+    read-fdset get-global read-tasks get-global ;
+
+: write-fdset/tasks
+    write-fdset get-global write-tasks get-global ;
+
 : init-fdsets ( -- read write except )
-    read-fdset get-global
-    [ read-tasks get-global init-fdset ] keep
-    write-fdset get-global
-    [ write-tasks get-global init-fdset ] keep
-    f ;
+    read-fdset/tasks init-fdset
+    write-fdset/tasks init-fdset f ;
 
 : io-multiplex ( timeout -- )
     >r FD_SETSIZE init-fdsets r> make-timeval select io-error
-    read-fdset get-global read-tasks get-global handle-fdset
-    write-fdset get-global write-tasks get-global handle-fdset ;
+    read-fdset/tasks handle-fdset
+    write-fdset/tasks handle-fdset ;
 
 ! Readers
 
@@ -210,7 +213,7 @@ M: read-task task-container drop read-tasks get-global ;
 : wait-to-read ( count port -- )
     2dup can-read-count? [
         [ -rot <read-task> add-io-task stop ] callcc0
-    ] unless 2drop ;
+    ] unless pending-error drop ;
 
 M: port stream-read ( count stream -- string )
     dup input check-port
diff --git a/library/unix/syscalls.factor b/library/unix/syscalls.factor
index c859a14f1f..4a73b53929 100644
--- a/library/unix/syscalls.factor
+++ b/library/unix/syscalls.factor
@@ -22,14 +22,10 @@ BEGIN-STRUCT: timeval
 END-STRUCT
 
 : make-timeval ( ms -- timeval )
-    dup -1 = [
-        drop f
-    ] [
-        1000 /mod 1000 *
-        "timeval" <c-object>
-        [ set-timeval-usec ] keep
-        [ set-timeval-sec ] keep
-    ] if ;
+    1000 /mod 1000 *
+    "timeval" <c-object>
+    [ set-timeval-usec ] keep
+    [ set-timeval-sec ] keep ;
 
 FUNCTION: int select ( int nfds, void* readfds, void* writefds, void* exceptfds, timeval* timeout ) ;
 

From 4cd4db2347889ee185ace762961e34b76cf9ec4b Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Thu, 11 May 2006 06:22:51 +0000
Subject: [PATCH 104/112] Update AMD64 backend and clean up other backends

---
 TODO.FACTOR.txt                               |  7 +-
 library/compiler/alien/compiler.factor        | 14 ++--
 library/compiler/amd64/alien.factor           | 84 +++++++------------
 library/compiler/amd64/architecture.factor    | 35 ++++----
 library/compiler/amd64/generator.factor       |  9 --
 library/compiler/amd64/intrinsics.factor      |  9 ++
 library/compiler/amd64/slots.factor           | 11 ---
 .../compiler/generator/architecture.factor    |  4 +-
 library/compiler/ppc/architecture.factor      | 32 +++----
 library/compiler/x86/architecture.factor      |  4 +-
 10 files changed, 88 insertions(+), 121 deletions(-)
 delete mode 100644 library/compiler/amd64/generator.factor
 create mode 100644 library/compiler/amd64/intrinsics.factor
 delete mode 100644 library/compiler/amd64/slots.factor

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 0abc024d41..36fad242af 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,10 +1,8 @@
 should fix in 0.82:
 
+- test x86 set-slot
 - clean up fp-scratch
-- intrinsic fixnum>float float>fixnum
 - update amd64 backend
-- float= on powerpc doesn't consider nans equal
-- amd64 %box-struct
 - when generating a 32-bit image on a 64-bit system, large numbers which should
   be bignums become fixnums
 - get factor running on mac intel
@@ -51,6 +49,9 @@ should fix in 0.82:
 
 + compiler/ffi:
 
+- amd64 %box-struct
+- float= on powerpc doesn't consider nans equal
+- intrinsic fixnum>float float>fixnum
 - win64 port
 - amd64 %unbox-struct
 - constant branch folding
diff --git a/library/compiler/alien/compiler.factor b/library/compiler/alien/compiler.factor
index 63df3cdd23..76898257fe 100644
--- a/library/compiler/alien/compiler.factor
+++ b/library/compiler/alien/compiler.factor
@@ -27,7 +27,8 @@ kernel-internals math namespaces sequences words ;
     #! n is a stack location, and the value of the class
     #! variable is a register number.
     c-type "reg-class" swap hash dup reg-class-full?
-    [ spill-param ] [ fastcall-param ] if ;
+    [ spill-param ] [ fastcall-param ] if
+    [ fastcall-regs nth ] keep ;
 
 : flatten-value-types ( params -- params )
     #! Convert value type structs to consecutive void*s.
@@ -43,13 +44,16 @@ kernel-internals math namespaces sequences words ;
     >r [ parameter-sizes ] keep
     [ reverse-slice ] 2apply r> 2each ; inline
 
-: move-parameters ( params vop -- )
-    #! Moves values from C stack to registers (if vop is
-    #! %stack>freg) and registers to C stack (if vop is
+: reset-freg-counts ( -- )
+    0 { int-regs float-regs stack-params } [ set ] each-with ;
+
+: move-parameters ( params word -- )
+    #! Moves values from C stack to registers (if word is
+    #! %stack>freg) and registers to C stack (if word is
     #! %freg>stack).
     swap [
         flatten-value-types
-        0 { int-regs float-regs stack-params } [ set ] each-with
+        reset-freg-counts
         [ pick >r alloc-parameter r> execute ] each-parameter
         drop
     ] with-scope ; inline
diff --git a/library/compiler/amd64/alien.factor b/library/compiler/amd64/alien.factor
index 824b31e109..f737885584 100644
--- a/library/compiler/amd64/alien.factor
+++ b/library/compiler/amd64/alien.factor
@@ -4,89 +4,69 @@ IN: compiler
 USING: alien arrays assembler kernel kernel-internals math
 sequences ;
 
-GENERIC: freg>stack ( stack reg reg-class -- )
-
-GENERIC: stack>freg ( stack reg reg-class -- )
-
 : stack@ RSP swap [+] ;
 
-M: int-regs freg>stack drop >r stack@ r> MOV ;
+M: int-regs %freg>stack drop >r stack@ r> MOV ;
 
-M: int-regs stack>freg drop swap stack@ MOV ;
+M: int-regs %stack>freg drop swap stack@ MOV ;
 
 : MOVSS/D float-regs-size 4 = [ MOVSS ] [ MOVSD ] if ;
 
-M: float-regs freg>stack >r >r stack@ r> r> MOVSS/D ;
+M: float-regs %freg>stack >r >r stack@ r> r> MOVSS/D ;
 
-M: float-regs stack>freg >r swap stack@ r> MOVSS/D ;
+M: float-regs %stack>freg >r swap stack@ r> MOVSS/D ;
 
-M: stack-params stack>freg
+M: stack-params %stack>freg
     drop >r R11 swap stack@ MOV r> stack@ R11 MOV ;
 
-M: stack-params freg>stack
-    >r stack-increment + cell + swap r> stack>freg ;
+M: stack-params %freg>stack
+    >r stack-increment + cell + swap r> %stack>freg ;
 
-M: %unbox-struct generate-node ( vop -- )
-    drop
+: %unbox-struct ( n reg-class size -- )
+    nip
     ! Load destination address
     RDI RSP MOV
-    RDI 0 input ADD
+    RDI rot ADD
     ! Load struct size
-    RSI 2 input MOV
+    RSI swap MOV
     ! Copy the struct to the stack
     "unbox_value_struct" f compile-c-call ;
 
-M: %unbox generate-node ( vop -- )
-    drop
+: %unbox ( n reg-class func -- )
     ! Call the unboxer
-    2 input f compile-c-call
+    f compile-c-call
     ! Store the return value on the C stack
-    0 input 1 input [ return-reg ] keep freg>stack ;
-
-: (%move) 0 input 1 input 2 input [ fastcall-regs nth ] keep ;
-
-M: %stack>freg generate-node ( vop -- )
-    ! Move a value from the C stack into the fastcall register
-    drop (%move) stack>freg ;
-
-M: %freg>stack generate-node ( vop -- )
-    ! Move a value from a fastcall register to the C stack
-    drop (%move) freg>stack ;
-
-: reset-sse RAX RAX XOR ;
-
-M: %alien-invoke generate-node
-    reset-sse
-    drop 0 input 1 input load-library compile-c-call ;
+    [ return-reg ] keep %freg>stack ;
 
 : load-return-value ( reg-class -- )
     dup fastcall-regs first swap return-reg
     2dup eq? [ 2drop ] [ MOV ] if ;
 
-M: %box generate-node ( vop -- )
-    drop
-    0 input [
-        1 input [ fastcall-regs first ] keep stack>freg
+: %box ( n reg-class func -- )
+    rot [
+        swap [ fastcall-regs first ] keep %stack>freg
     ] [
-        1 input load-return-value
+        load-return-value
     ] if*
-    2 input f compile-c-call ;
+    f compile-c-call ;
 
-M: %alien-callback generate-node ( vop -- )
-    drop
-    RDI 0 input load-indirect
-    "run_callback" f compile-c-call ;
+: reset-sse RAX RAX XOR ;
 
-: save-return 0 swap [ return-reg ] keep freg>stack ;
-: load-return 0 swap [ return-reg ] keep stack>freg ;
+: %alien-invoke ( symbol dll -- )
+    reset-sse compile-c-call ;
 
-M: %callback-value generate-node ( vop -- )
-    drop
+: %alien-callback ( quot -- )
+    RDI swap load-literal "run_callback" f compile-c-call ;
+
+: save-return 0 swap [ return-reg ] keep %freg>stack ;
+: load-return 0 swap [ return-reg ] keep %stack>freg ;
+
+: %callback-value ( reg-class func -- )
     ! Call the unboxer
-    1 input f compile-c-call
+    f compile-c-call
     ! Save return register
-    0 input save-return
+    dup save-return
     ! Restore data/callstacks
     "unnest_stacks" f compile-c-call
     ! Restore return register
-    0 input load-return ;
+    load-return ;
diff --git a/library/compiler/amd64/architecture.factor b/library/compiler/amd64/architecture.factor
index 9a48d9b571..4147982fa6 100644
--- a/library/compiler/amd64/architecture.factor
+++ b/library/compiler/amd64/architecture.factor
@@ -1,11 +1,11 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: compiler
-USING: alien arrays assembler kernel
-kernel-internals math namespaces sequences ;
+USING: alien arrays assembler generic kernel kernel-internals
+math namespaces sequences ;
 
 ! AMD64 register assignments
-! RAX RCX RDX RSI RDI R8 R9 R10 R11 integer vregs
+! RAX RCX RDX RSI RDI R8 R9 R10 integer vregs
 ! XMM0 - XMM7 float vregs
 ! R13 cards_offset
 ! R14 datastack
@@ -16,21 +16,21 @@ kernel-internals math namespaces sequences ;
 : remainder-reg RDX ; inline
 
 M: int-regs return-reg drop RAX ;
-M: int-regs vregs drop { RAX RCX RDX RSI RDI R8 R9 R10 R11 } ;
+M: int-regs vregs drop { RAX RCX RDX RSI RDI R8 R9 R10 } ;
 M: int-regs fastcall-regs drop { RDI RSI RDX RCX R8 R9 } ;
 
-: compile-c-call ( symbol dll -- )
-    2dup dlsym R10 swap MOV
-    rel-absolute-cell rel-dlsym R10 CALL ;
-
-: compile-c-call* ( symbol dll args -- )
-    T{ int-regs } fastcall-regs
-    swap [ MOV ] 2each compile-c-call ;
-
 M: float-regs return-reg drop XMM0 ;
 M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 M: float-regs fastcall-regs vregs ;
 
+: compile-c-call ( symbol dll -- )
+    2dup dlsym R10 swap MOV rel-absolute-cell rel-dlsym
+    R10 CALL ;
+
+: compile-c-call* ( symbol dll args -- )
+    T{ int-regs } fastcall-regs
+    swap [ MOV ] 2each compile-c-call ;
+
 : address-operand ( address -- operand )
     #! On AMD64, we have to load 64-bit addresses into a
     #! scratch register first. The usage of R11 here is a hack.
@@ -42,12 +42,15 @@ M: float-regs fastcall-regs vregs ;
 
 : prepare-division CQO ; inline
 
-: load-indirect ( dest literal -- )
+M: object load-literal ( literal vreg -- )
     #! We use RIP-relative addressing. The '3' is a hardcoded
     #! instruction length.
-    add-literal from 3 - [] MOV ; inline
+    v>operand swap add-literal from 3 - [] MOV ;
 
 : stack-increment \ stack-reserve get 16 align 8 + ;
 
-: compile-epilogue ( -- )
-    RSP stack-increment ADD ; inline
+: %prologue ( n -- )
+    \ stack-reserve set RSP stack-increment SUB ;
+
+: %epilogue ( -- )
+    RSP stack-increment ADD ;
diff --git a/library/compiler/amd64/generator.factor b/library/compiler/amd64/generator.factor
deleted file mode 100644
index 99a2d26628..0000000000
--- a/library/compiler/amd64/generator.factor
+++ /dev/null
@@ -1,9 +0,0 @@
-! Copyright (C) 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler
-USING: assembler kernel math namespaces ;
-
-M: %prologue generate-node ( vop -- )
-    drop
-    0 input \ stack-reserve set
-    RSP stack-increment SUB ;
diff --git a/library/compiler/amd64/intrinsics.factor b/library/compiler/amd64/intrinsics.factor
new file mode 100644
index 0000000000..5c583dbdda
--- /dev/null
+++ b/library/compiler/amd64/intrinsics.factor
@@ -0,0 +1,9 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler
+USING: assembler ;
+
+: generate-write-barrier ( -- )
+    #! Mark the card pointed to by vreg.
+    "obj" operand card-bits SHR
+    "obj" operand R13 [+] card-mark OR ;
diff --git a/library/compiler/amd64/slots.factor b/library/compiler/amd64/slots.factor
deleted file mode 100644
index 7f2ab2eb4c..0000000000
--- a/library/compiler/amd64/slots.factor
+++ /dev/null
@@ -1,11 +0,0 @@
-! Copyright (C) 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler
-USING: alien arrays assembler inference kernel
-kernel-internals lists math memory namespaces sequences words ;
-
-M: %write-barrier generate-node ( vop -- )
-    #! Mark the card pointed to by vreg.
-    drop
-    0 input-operand card-bits SHR
-    0 input-operand R13 [+] card-mark OR ;
diff --git a/library/compiler/generator/architecture.factor b/library/compiler/generator/architecture.factor
index 987cd6265a..be0263f48a 100644
--- a/library/compiler/generator/architecture.factor
+++ b/library/compiler/generator/architecture.factor
@@ -94,9 +94,9 @@ DEFER: %box ( n reg-class func -- )
 
 DEFER: %box-struct ( n reg-class size -- )
 
-DEFER: %stack>freg ( n reg reg-class -- )
+GENERIC: %freg>stack ( stack reg reg-class -- )
 
-DEFER: %freg>stack ( n reg reg-class -- )
+GENERIC: %stack>freg ( stack reg reg-class -- )
 
 DEFER: %alien-invoke ( library function -- )
 
diff --git a/library/compiler/ppc/architecture.factor b/library/compiler/ppc/architecture.factor
index 88532d0299..adbd5a8adb 100644
--- a/library/compiler/ppc/architecture.factor
+++ b/library/compiler/ppc/architecture.factor
@@ -135,50 +135,40 @@ M: float-regs (%replace) ( vreg loc reg-class -- )
 
 : %inc-r ( n -- ) 15 15 rot cells ADDI ;
 
-GENERIC: freg>stack ( stack reg reg-class -- )
+M: int-regs %freg>stack drop 1 rot stack@ STW ;
 
-GENERIC: stack>freg ( stack reg reg-class -- )
-
-M: int-regs freg>stack drop 1 rot stack@ STW ;
-
-M: int-regs stack>freg drop 1 rot stack@ LWZ ;
+M: int-regs %stack>freg drop 1 rot stack@ LWZ ;
 
 : STF float-regs-size 4 = [ STFS ] [ STFD ] if ;
 
-M: float-regs freg>stack >r 1 rot stack@ r> STF ;
+M: float-regs %freg>stack >r 1 rot stack@ r> STF ;
 
 : LF float-regs-size 4 = [ LFS ] [ LFD ] if ;
 
-M: float-regs stack>freg >r 1 rot stack@ r> LF ;
+M: float-regs %stack>freg >r 1 rot stack@ r> LF ;
 
-M: stack-params stack>freg
+M: stack-params %stack>freg
     drop 2dup = [
         2drop
     ] [
         >r 0 1 rot stack@ LWZ 0 1 r> stack@ STW
     ] if ;
 
-M: stack-params freg>stack
-   >r stack-increment + swap r> stack>freg ;
-
-: %stack>freg ( n reg reg-class -- )
-    [ fastcall-regs nth ] keep stack>freg ;
-
-: %freg>stack ( n reg reg-class -- )
-    [ fastcall-regs nth ] keep freg>stack ;
+M: stack-params %freg>stack
+   >r stack-increment + swap r> %stack>freg ;
 
 : %unbox ( n reg-class func -- )
     ! Call the unboxer
     f %alien-invoke
     ! Store the return value on the C stack
-    [ return-reg ] keep freg>stack ;
+    [ return-reg ] keep %freg>stack ;
 
 : %box ( n reg-class func -- )
     ! If the source is a stack location, load it into freg #0.
     ! If the source is f, then we assume the value is already in
     ! freg #0.
     pick [
-        >r [ fastcall-regs first ] keep stack>freg r>
+        >r [ fastcall-regs first ] keep %stack>freg r>
     ] [
         2nip
     ] if
@@ -204,8 +194,8 @@ M: stack-params freg>stack
 : %alien-callback ( quot -- )
     0 <int-vreg> load-literal "run_callback" f %alien-invoke ;
 
-: save-return 0 swap [ return-reg ] keep freg>stack ;
-: load-return 0 swap [ return-reg ] keep stack>freg ;
+: save-return 0 swap [ return-reg ] keep %freg>stack ;
+: load-return 0 swap [ return-reg ] keep %stack>freg ;
 
 : %callback-value ( reg-class func -- )
     ! Call the unboxer
diff --git a/library/compiler/x86/architecture.factor b/library/compiler/x86/architecture.factor
index 3460de4cc9..c323f8cb31 100644
--- a/library/compiler/x86/architecture.factor
+++ b/library/compiler/x86/architecture.factor
@@ -101,6 +101,6 @@ M: int-regs (%replace) drop swap %move-int>int ;
 
 : %inc-r ( n -- ) cs-reg (%inc) ;
 
-: %stack>freg ( n reg reg-class -- ) 3drop ;
+M: object %stack>freg ( n reg reg-class -- ) 3drop ;
 
-: %freg>stack ( n reg reg-class -- ) 3drop ;
+M: object %freg>stack ( n reg reg-class -- ) 3drop ;

From b6336040816c7c77ab8f8efa52486014cefcdb91 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Thu, 11 May 2006 06:25:23 +0000
Subject: [PATCH 105/112] Update boot-stage1 for AMD64 backend changes

---
 library/bootstrap/boot-stage1.factor | 10 ++++------
 1 file changed, 4 insertions(+), 6 deletions(-)

diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor
index cbb2d3b72c..c34d189715 100644
--- a/library/bootstrap/boot-stage1.factor
+++ b/library/bootstrap/boot-stage1.factor
@@ -307,14 +307,12 @@ vectors words ;
 
     { "amd64" } {
         "/library/compiler/x86/assembler.factor"
+        "/library/compiler/x86/architecture.factor"
         "/library/compiler/amd64/architecture.factor"
-        "/library/compiler/x86/generator.factor"
-        "/library/compiler/amd64/generator.factor"
-        "/library/compiler/x86/slots.factor"
-        "/library/compiler/amd64/slots.factor"
-        "/library/compiler/x86/stack.factor"
-        "/library/compiler/x86/fixnum.factor"
         "/library/compiler/amd64/alien.factor"
+        "/library/compiler/x86/intrinsics.factor"
+        "/library/compiler/x86/intrinsics-sse2.factor"
+        "/library/compiler/amd64/intrinsics.factor"
     } if-arch
     
     [

From 30e1f0fc2b6f19c4505ae3d31d52531dc2596f2f Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Thu, 11 May 2006 23:46:19 +0000
Subject: [PATCH 106/112] Fix set-slot on x86

---
 TODO.FACTOR.txt                        |  1 -
 library/compiler/x86/intrinsics.factor | 26 +++++++++++++-------------
 2 files changed, 13 insertions(+), 14 deletions(-)

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 36fad242af..78cdbb7e26 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,6 +1,5 @@
 should fix in 0.82:
 
-- test x86 set-slot
 - clean up fp-scratch
 - update amd64 backend
 - when generating a 32-bit image on a 64-bit system, large numbers which should
diff --git a/library/compiler/x86/intrinsics.factor b/library/compiler/x86/intrinsics.factor
index c4aea1c22d..d790835902 100644
--- a/library/compiler/x86/intrinsics.factor
+++ b/library/compiler/x86/intrinsics.factor
@@ -74,19 +74,19 @@ IN: compiler
     "obj" operand card-offset ADD rel-absolute-cell rel-cards
     "obj" operand [] card-mark OR ;
 
-! \ set-slot [
-!     "obj" operand untag
-!     ! turn tagged fixnum slot # into an offset
-!     "slot" operand fixnum>slot@
-!     ! compute slot address
-!     "obj" operand "slot" operand ADD
-!     ! store new slot value
-!     "obj" operand [] "val" operand MOV
-!     generate-write-barrier
-! ] H{
-!     { +input { { f "val" } { f "obj" } { f "slot" } } }
-!     { +clobber { "obj" "slot" } }
-! } define-intrinsic
+\ set-slot [
+    "obj" operand untag
+    ! turn tagged fixnum slot # into an offset
+    "slot" operand fixnum>slot@
+    ! compute slot address
+    "slot" operand "obj" operand ADD
+    ! store new slot value
+    "slot" operand [] "val" operand MOV
+    generate-write-barrier
+] H{
+    { +input { { f "val" } { f "obj" } { f "slot" } } }
+    { +clobber { "obj" "slot" } }
+} define-intrinsic
 
 \ char-slot [
     EBX PUSH

From 22eae0be151018fd5be325625371e022cd9ab3c9 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Fri, 12 May 2006 21:07:56 +0000
Subject: [PATCH 107/112] Compiler cleanups and bootstrap speedup

---
 TODO.FACTOR.txt                             |  2 ++
 library/collections/sequence-eq.factor      |  2 +-
 library/compiler/amd64/architecture.factor  | 19 ++++++------
 library/compiler/generator/templates.factor | 13 +++-----
 library/compiler/ppc/architecture.factor    | 34 ++++++++++-----------
 library/compiler/ppc/intrinsics.factor      |  8 ++---
 library/generic/generic.factor              |  2 +-
 library/generic/tuple.factor                |  2 +-
 8 files changed, 40 insertions(+), 42 deletions(-)

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 78cdbb7e26..ea123425c2 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,5 +1,6 @@
 should fix in 0.82:
 
+- another i/o bug: on factorcode eventually all i/o times out
 - clean up fp-scratch
 - update amd64 backend
 - when generating a 32-bit image on a 64-bit system, large numbers which should
@@ -48,6 +49,7 @@ should fix in 0.82:
 
 + compiler/ffi:
 
+- free up r12 as a vreg on ppc
 - amd64 %box-struct
 - float= on powerpc doesn't consider nans equal
 - intrinsic fixnum>float float>fixnum
diff --git a/library/collections/sequence-eq.factor b/library/collections/sequence-eq.factor
index 563bc0d93b..ac28e1644c 100644
--- a/library/collections/sequence-eq.factor
+++ b/library/collections/sequence-eq.factor
@@ -13,7 +13,7 @@ UNION: sequence array string sbuf vector ;
         dup length [ >r 2dup r> 2nth-unsafe = ] all? 2nip
     ] [
         2drop f
-    ] if ; inline
+    ] if ;
 
 M: sequence = ( obj seq -- ? )
     2dup eq? [
diff --git a/library/compiler/amd64/architecture.factor b/library/compiler/amd64/architecture.factor
index 4147982fa6..5b4336bdad 100644
--- a/library/compiler/amd64/architecture.factor
+++ b/library/compiler/amd64/architecture.factor
@@ -16,28 +16,27 @@ math namespaces sequences ;
 : remainder-reg RDX ; inline
 
 M: int-regs return-reg drop RAX ;
-M: int-regs vregs drop { RAX RCX RDX RSI RDI R8 R9 R10 } ;
+M: int-regs vregs drop { RAX RCX RDX RSI RDI R8 R9 R10 R11 } ;
 M: int-regs fastcall-regs drop { RDI RSI RDX RCX R8 R9 } ;
 
 M: float-regs return-reg drop XMM0 ;
 M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 M: float-regs fastcall-regs vregs ;
 
+: address-operand ( address -- operand )
+    #! On AMD64, we have to load 64-bit addresses into a
+    #! scratch register first. The usage of R11 here is a hack.
+    #! This word can only be called right before a subroutine
+    #! call, where all vregs have been flushed anyway.
+    R11 [ swap MOV ] keep ; inline
+
 : compile-c-call ( symbol dll -- )
-    2dup dlsym R10 swap MOV rel-absolute-cell rel-dlsym
-    R10 CALL ;
+    2dup dlsym address-operand rel-absolute-cell rel-dlsym CALL ;
 
 : compile-c-call* ( symbol dll args -- )
     T{ int-regs } fastcall-regs
     swap [ MOV ] 2each compile-c-call ;
 
-: address-operand ( address -- operand )
-    #! On AMD64, we have to load 64-bit addresses into a
-    #! scratch register first. The usage of R11 here is a hack.
-    #! We cannot write '0 scratch' since scratch registers are
-    #! not permitted inside basic-block VOPs.
-    R11 [ swap MOV ] keep ; inline
-
 : fixnum>slot@ drop ; inline
 
 : prepare-division CQO ; inline
diff --git a/library/compiler/generator/templates.factor b/library/compiler/generator/templates.factor
index ac370698a2..728586439d 100644
--- a/library/compiler/generator/templates.factor
+++ b/library/compiler/generator/templates.factor
@@ -102,9 +102,6 @@ SYMBOL: phantom-r
 : finalize-heights ( -- )
     phantoms [ finalize-height ] 2apply ;
 
-: stack>new-vreg ( loc spec -- vreg )
-    spec>vreg [ swap %peek ] keep ;
-
 : vreg>stack ( value loc -- )
     over loc? over not or [ 2drop ] [ %replace ] if ;
 
@@ -118,17 +115,17 @@ SYMBOL: phantom-r
     [ first2 over loc? >r = not r> and ] subset
     [ first ] map ;
 
+: stack>new-vreg ( loc spec -- vreg )
+    spec>vreg [ swap %peek ] keep ;
+
 : live-locs ( phantom phantom -- hash )
     [ (live-locs) ] 2apply append prune
     [ dup f stack>new-vreg ] map>hash ;
 
 : lazy-store ( value loc -- )
     over loc? [
-        2dup = [
-            2drop
-        ] [
-            >r \ live-locs get hash r> vreg>stack 
-        ] if
+        2dup =
+        [ 2drop ] [ >r \ live-locs get hash r> vreg>stack ] if
     ] [
         2drop
     ] if ;
diff --git a/library/compiler/ppc/architecture.factor b/library/compiler/ppc/architecture.factor
index adbd5a8adb..4b5af4bdfc 100644
--- a/library/compiler/ppc/architecture.factor
+++ b/library/compiler/ppc/architecture.factor
@@ -5,15 +5,15 @@ USING: alien assembler generic kernel kernel-internals math
 memory namespaces sequences words ;
 
 ! PowerPC register assignments
-! r3-r10 integer vregs
+! r3-r11 integer vregs
 ! f0-f13 float vregs
-! r11 linkage
+! r12 linkage
 ! r14 data stack
 ! r15 call stack
 
 M: int-regs return-reg drop 3 ;
 M: int-regs fastcall-regs drop { 3 4 5 6 7 8 9 10 } ;
-M: int-regs vregs drop { 3 4 5 6 7 8 9 10 } ;
+M: int-regs vregs drop { 3 4 5 6 7 8 9 10 11 } ;
 
 M: float-regs return-reg drop 1 ;
 M: float-regs fastcall-regs drop { 1 2 3 4 5 6 7 8 } ;
@@ -93,8 +93,8 @@ M: int-regs (%peek) ( vreg loc -- )
     drop >r v>operand r> loc>operand LWZ ;
 
 M: float-regs (%peek) ( vreg loc -- )
-    drop 11 swap loc>operand LWZ
-    v>operand 11 float-offset LFD ;
+    drop fp-scratch v>operand swap loc>operand LWZ
+    fp-scratch [ v>operand ] 2apply float-offset LFD ;
 
 M: int-regs (%replace) ( vreg loc -- )
     drop >r v>operand r> loc>operand STW ;
@@ -108,24 +108,24 @@ M: int-regs (%replace) ( vreg loc -- )
 : load-zone-ptr ( reg -- )
     "generations" f pick compile-dlsym dup 0 LWZ ;
 
-: load-allot-ptr ( -- ) 12 load-zone-ptr 12 12 cell LWZ ;
+: load-allot-ptr ( -- )
+    12 load-zone-ptr 12 12 cell LWZ ;
 
-: save-allot-ptr ( -- ) 11 load-zone-ptr 12 11 cell STW ;
+: save-allot-ptr ( -- )
+    fp-scratch v>operand [ load-zone-ptr 12 ] keep cell STW ;
 
-: with-inline-alloc ( vreg prequot postquot spec -- )
-    #! both quotations are called with the vreg
+: with-inline-alloc ( prequot postquot spec -- )
     load-allot-ptr [
-        >r >r v>operand dup 12 MR
-        \ tag-header get call tag-header 11 LI
-        11 12 0 STW
-        r> over slip dup dup \ tag get call ORI
+        \ tag-header get call tag-header fp-scratch v>operand LI
+        fp-scratch v>operand 12 0 STW
+        >r call 12 fp-scratch v>operand \ tag get call ORI
         r> call 12 12 \ size get call ADDI
     ] bind save-allot-ptr ; inline
 
 M: float-regs (%replace) ( vreg loc reg-class -- )
-    drop swap fp-scratch
-    [ >r v>operand r> 8 STFD ]
-    [ swap loc>operand STW ] H{
+    drop swap
+    [ v>operand 12 8 STFD ]
+    [ fp-scratch v>operand swap loc>operand STW ] H{
         { tag-header [ float-tag ] }
         { tag [ float-tag ] }
         { size [ 16 ] }
@@ -189,7 +189,7 @@ M: stack-params %freg>stack
     "box_value_struct" struct-ptr/size ;
 
 : %alien-invoke ( symbol dll -- )
-    11 [ compile-dlsym ] keep MTLR BLRL ;
+    12 [ compile-dlsym ] keep MTLR BLRL ;
 
 : %alien-callback ( quot -- )
     0 <int-vreg> load-literal "run_callback" f %alien-invoke ;
diff --git a/library/compiler/ppc/intrinsics.factor b/library/compiler/ppc/intrinsics.factor
index b6da21f4bb..a958c3768d 100644
--- a/library/compiler/ppc/intrinsics.factor
+++ b/library/compiler/ppc/intrinsics.factor
@@ -167,19 +167,19 @@ math-internals namespaces sequences words ;
     <label> "end" set
     "r" operand "x" operand untag-fixnum
     0 MTXER
-    11 "y" operand "r" operand MULLWO.
+    12 "y" operand "r" operand MULLWO.
     "end" get BNO
     4 "y" operand "r" operand MULHW
-    3 11 MR
+    3 12 MR
     "s48_fixnum_pair_to_bignum" f %alien-invoke
     ! now we have to shift it by three bits to remove the second
     ! tag
     tag-bits neg 4 LI
     "s48_bignum_arithmetic_shift" f %alien-invoke
     ! An untagged pointer to the bignum is now in r3; tag it
-    3 11 bignum-tag ORI
+    3 12 bignum-tag ORI
     "end" get save-xt
-    "s" operand 11 MR
+    "s" operand 12 MR
 ] H{
     { +input { { f "x" } { f "y" } } }
     { +scratch { { f "r" } { f "s" } } }
diff --git a/library/generic/generic.factor b/library/generic/generic.factor
index b86315eb12..7afb3a48e9 100644
--- a/library/generic/generic.factor
+++ b/library/generic/generic.factor
@@ -51,7 +51,7 @@ DEFER: (class<)
     >r superclass r> 2dup and [ (class<) ] [ 2drop f ] if ;
 
 : union-class< ( cls1 cls2 -- ? )
-    >r flatten-class r> flatten-class hash-keys swap
+    [ flatten-class ] 2apply hash-keys swap
     [ drop swap [ (class<) ] contains-with? ] hash-all-with? ;
 
 : class-empty? ( class -- ? )
diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor
index 92fefeec20..1a30491092 100644
--- a/library/generic/tuple.factor
+++ b/library/generic/tuple.factor
@@ -16,7 +16,7 @@ IN: kernel-internals
         [ 2dup swap array-nth >r pick array-nth r> = ] all? 2nip
     ] [
         2drop f
-    ] if ; inline
+    ] if ;
 
 : tuple-hashcode ( n tuple -- n )
     dup class-tuple hashcode >r >r 1-

From 4513192968e5f3f986a48956abe770cdc6d06420 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sun, 14 May 2006 19:44:07 +0000
Subject: [PATCH 108/112] Minor fixes

---
 library/compiler/generator/generator.factor |  5 -----
 library/compiler/generator/templates.factor | 25 ++++++++++++++++++++-
 library/compiler/ppc/architecture.factor    |  2 +-
 library/test/compiler/float.factor          |  3 +++
 4 files changed, 28 insertions(+), 7 deletions(-)

diff --git a/library/compiler/generator/generator.factor b/library/compiler/generator/generator.factor
index 35f8fcf475..0fa40bf02a 100644
--- a/library/compiler/generator/generator.factor
+++ b/library/compiler/generator/generator.factor
@@ -240,8 +240,3 @@ M: #return generate-node drop end-basic-block %return f ;
 
 : float-offset 8 float-tag - ;
 : string-offset 3 cells object-tag - ;
-
-: fp-scratch ( -- vreg )
-    "fp-scratch" get [
-        T{ int-regs } alloc-reg dup "fp-scratch" set
-    ] unless* ;
diff --git a/library/compiler/generator/templates.factor b/library/compiler/generator/templates.factor
index 728586439d..5f95e17e0f 100644
--- a/library/compiler/generator/templates.factor
+++ b/library/compiler/generator/templates.factor
@@ -242,8 +242,31 @@ SYMBOL: +clobber
 : requested-vregs ( template -- int# float# )
     dup length swap [ float eq? ] subset length [ - ] keep ;
 
+: (holds-class?) ( class phantom -- ? )
+    [ delegate class eq? ] contains-with? ;
+
+: holds-class? ( class -- ? )
+    dup phantom-d get (holds-class?) swap
+    phantom-r get (holds-class?) or ;
+
+: (requests-class?) ( class template -- )
+    [ second reg-spec>class eq? ] contains-with? ;
+
+: requests-class? ( class -- ? )
+    dup +input get (requests-class?) swap
+    +scratch get (requests-class?) or ;
+
+: ?fp-scratch ( -- n )
+    T{ float-regs f 8 } dup holds-class? >r requests-class? r>
+    or 1 0 ? ;
+
+: fp-scratch ( -- vreg )
+    "fp-scratch" get [
+        T{ int-regs } alloc-reg dup "fp-scratch" set
+    ] unless* ;
+
 : guess-vregs ( -- int# float# )
-    +input get { } additional-vregs
+    +input get { } additional-vregs ?fp-scratch +
     +scratch get [ first ] map requested-vregs >r + r> ;
 
 : alloc-scratch ( -- )
diff --git a/library/compiler/ppc/architecture.factor b/library/compiler/ppc/architecture.factor
index 4b5af4bdfc..f0eee28761 100644
--- a/library/compiler/ppc/architecture.factor
+++ b/library/compiler/ppc/architecture.factor
@@ -123,7 +123,7 @@ M: int-regs (%replace) ( vreg loc -- )
     ] bind save-allot-ptr ; inline
 
 M: float-regs (%replace) ( vreg loc reg-class -- )
-    drop swap
+    drop swap fp-scratch drop
     [ v>operand 12 8 STFD ]
     [ fp-scratch v>operand swap loc>operand STW ] H{
         { tag-header [ float-tag ] }
diff --git a/library/test/compiler/float.factor b/library/test/compiler/float.factor
index 49cb4b51b5..7589a1a2be 100644
--- a/library/test/compiler/float.factor
+++ b/library/test/compiler/float.factor
@@ -6,6 +6,9 @@ math-internals test ;
 [ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-1 ] unit-test
 
 [ 1 2 3 4.0 ] [ [ 1 2 3 4.0 ] compile-1 ] unit-test
+
+[ 3.0 1 2 3 ] [ 1.0 2.0 [ float+ 1 2 3 ] compile-1 ] unit-test
+
 [ 5 ] [ 1.0 [ 2.0 float+ tag ] compile-1 ] unit-test
 
 [ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-1 ] unit-test

From b1681213f0ce84f6ddccd4bc3faa438202c751a9 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sun, 14 May 2006 20:44:47 +0000
Subject: [PATCH 109/112] fp-scratch cleanup

---
 TODO.FACTOR.txt                             |  1 -
 library/compiler/generator/generator.factor |  6 +++---
 library/compiler/generator/templates.factor | 10 +---------
 library/compiler/ppc/architecture.factor    | 18 +++++++++---------
 library/compiler/x86/intrinsics-sse2.factor | 18 ++++++++++--------
 5 files changed, 23 insertions(+), 30 deletions(-)

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index ea123425c2..27b1c8f1b5 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,7 +1,6 @@
 should fix in 0.82:
 
 - another i/o bug: on factorcode eventually all i/o times out
-- clean up fp-scratch
 - update amd64 backend
 - when generating a 32-bit image on a 64-bit system, large numbers which should
   be bignums become fixnums
diff --git a/library/compiler/generator/generator.factor b/library/compiler/generator/generator.factor
index 0fa40bf02a..088f1851bd 100644
--- a/library/compiler/generator/generator.factor
+++ b/library/compiler/generator/generator.factor
@@ -194,9 +194,9 @@ M: #dispatch generate-node ( node -- next )
 UNION: immediate fixnum POSTPONE: f ;
 
 : generate-push ( node -- )
-    >#push< dup length f <array>
-    dup requested-vregs ensure-vregs
-    [ spec>vreg [ load-literal ] keep ] 2map
+    >#push<
+    dup length ?fp-scratch + 0 ensure-vregs
+    [ f spec>vreg [ load-literal ] keep ] map
     phantom-d get phantom-append ;
 
 M: #push generate-node ( #push -- )
diff --git a/library/compiler/generator/templates.factor b/library/compiler/generator/templates.factor
index 5f95e17e0f..54ef930aac 100644
--- a/library/compiler/generator/templates.factor
+++ b/library/compiler/generator/templates.factor
@@ -242,13 +242,6 @@ SYMBOL: +clobber
 : requested-vregs ( template -- int# float# )
     dup length swap [ float eq? ] subset length [ - ] keep ;
 
-: (holds-class?) ( class phantom -- ? )
-    [ delegate class eq? ] contains-with? ;
-
-: holds-class? ( class -- ? )
-    dup phantom-d get (holds-class?) swap
-    phantom-r get (holds-class?) or ;
-
 : (requests-class?) ( class template -- )
     [ second reg-spec>class eq? ] contains-with? ;
 
@@ -257,8 +250,7 @@ SYMBOL: +clobber
     +scratch get (requests-class?) or ;
 
 : ?fp-scratch ( -- n )
-    T{ float-regs f 8 } dup holds-class? >r requests-class? r>
-    or 1 0 ? ;
+    T{ float-regs f 8 } requests-class? 1 0 ? ;
 
 : fp-scratch ( -- vreg )
     "fp-scratch" get [
diff --git a/library/compiler/ppc/architecture.factor b/library/compiler/ppc/architecture.factor
index f0eee28761..42087dcbc2 100644
--- a/library/compiler/ppc/architecture.factor
+++ b/library/compiler/ppc/architecture.factor
@@ -5,15 +5,15 @@ USING: alien assembler generic kernel kernel-internals math
 memory namespaces sequences words ;
 
 ! PowerPC register assignments
-! r3-r11 integer vregs
+! r3-r10 integer vregs
 ! f0-f13 float vregs
-! r12 linkage
+! r11, r12 scratch
 ! r14 data stack
 ! r15 call stack
 
 M: int-regs return-reg drop 3 ;
 M: int-regs fastcall-regs drop { 3 4 5 6 7 8 9 10 } ;
-M: int-regs vregs drop { 3 4 5 6 7 8 9 10 11 } ;
+M: int-regs vregs drop { 3 4 5 6 7 8 9 10 } ;
 
 M: float-regs return-reg drop 1 ;
 M: float-regs fastcall-regs drop { 1 2 3 4 5 6 7 8 } ;
@@ -112,20 +112,20 @@ M: int-regs (%replace) ( vreg loc -- )
     12 load-zone-ptr 12 12 cell LWZ ;
 
 : save-allot-ptr ( -- )
-    fp-scratch v>operand [ load-zone-ptr 12 ] keep cell STW ;
+    11 [ load-zone-ptr 12 ] keep cell STW ;
 
 : with-inline-alloc ( prequot postquot spec -- )
     load-allot-ptr [
-        \ tag-header get call tag-header fp-scratch v>operand LI
-        fp-scratch v>operand 12 0 STW
-        >r call 12 fp-scratch v>operand \ tag get call ORI
+        \ tag-header get call tag-header 11 LI
+        11 12 0 STW
+        >r call 12 11 \ tag get call ORI
         r> call 12 12 \ size get call ADDI
     ] bind save-allot-ptr ; inline
 
 M: float-regs (%replace) ( vreg loc reg-class -- )
-    drop swap fp-scratch drop
+    drop swap
     [ v>operand 12 8 STFD ]
-    [ fp-scratch v>operand swap loc>operand STW ] H{
+    [ 11 swap loc>operand STW ] H{
         { tag-header [ float-tag ] }
         { tag [ float-tag ] }
         { size [ 16 ] }
diff --git a/library/compiler/x86/intrinsics-sse2.factor b/library/compiler/x86/intrinsics-sse2.factor
index 2ad0b19643..f360098522 100644
--- a/library/compiler/x86/intrinsics-sse2.factor
+++ b/library/compiler/x86/intrinsics-sse2.factor
@@ -20,19 +20,21 @@ M: float-regs (%peek) ( vreg loc reg-class -- )
 : inc-allot-ptr ( vreg n -- )
     >r dup load-zone-ptr cell [+] r> ADD ;
 
-: with-inline-alloc ( vreg prequot postquot spec -- )
+: with-inline-alloc ( prequot postquot spec -- )
     #! both quotations are called with the vreg
     [
-        >r >r v>operand dup load-allot-ptr
-        dup [] \ tag-header get call tag-header MOV
-        r> over slip dup \ tag get call OR
-        r> over slip \ size get call inc-allot-ptr
+        EBX PUSH
+        EBX load-allot-ptr
+        EBX [] \ tag-header get call tag-header MOV
+        >r call EBX \ tag get call OR
+        r> call EBX \ size get call inc-allot-ptr
+        EBX POP
     ] bind ; inline
 
 M: float-regs (%replace) ( vreg loc reg-class -- )
-    drop fp-scratch
-    [ 8 [+] rot v>operand MOVSD ]
-    [ >r v>operand r> MOV ] H{
+    drop
+    [ EBX 8 [+] rot v>operand MOVSD ]
+    [ v>operand EBX MOV ] H{
         { tag-header [ float-tag ] }
         { tag [ float-tag ] }
         { size [ 16 ] }

From c3f37f956fb4ab0f5471f264b8726650b5c63638 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Mon, 15 May 2006 00:05:57 +0000
Subject: [PATCH 110/112] AMD64 fixes

---
 TODO.FACTOR.txt                             |  3 ---
 library/bootstrap/image.factor              | 15 ++++++++++----
 library/compiler/amd64/alien.factor         | 22 ++++++++++++++-------
 library/compiler/amd64/architecture.factor  |  9 +++++++--
 library/compiler/amd64/intrinsics.factor    |  2 +-
 library/compiler/x86/architecture.factor    |  1 +
 library/compiler/x86/intrinsics-sse2.factor | 21 ++++++++++----------
 library/compiler/x86/intrinsics.factor      |  9 +++------
 library/math/constants.factor               |  6 +++---
 9 files changed, 52 insertions(+), 36 deletions(-)

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 27b1c8f1b5..6b9396e4b3 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,9 +1,6 @@
 should fix in 0.82:
 
 - another i/o bug: on factorcode eventually all i/o times out
-- update amd64 backend
-- when generating a 32-bit image on a 64-bit system, large numbers which should
-  be bignums become fixnums
 - get factor running on mac intel
 
 + io:
diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor
index 5d6f02f281..79bfff5635 100644
--- a/library/bootstrap/image.factor
+++ b/library/bootstrap/image.factor
@@ -101,12 +101,8 @@ GENERIC: ' ( obj -- ptr )
 : align-here ( -- )
     here 8 mod 4 = [ 0 emit ] when ;
 
-( Fixnums )
-
 : emit-fixnum ( n -- ) fixnum-tag tag-address emit ;
 
-M: fixnum ' ( n -- tagged ) fixnum-tag tag-address ;
-
 ( Bignums )
 
 : bignum-bits bootstrap-cell-bits 2 - ;
@@ -136,6 +132,17 @@ M: bignum ' ( bignum -- tagged )
     bignum-tag tag-header emit
     emit-bignum align-here r> ;
 
+( Fixnums )
+
+M: fixnum ' ( n -- tagged )
+    #! When generating a 32-bit image on a 64-bit system,
+    #! some fixnums should be bignums.
+    dup most-negative-fixnum most-positive-fixnum between? [
+        fixnum-tag tag-address
+    ] [
+        >bignum '
+    ] if ;
+
 ( Floats )
 
 M: float ' ( float -- tagged )
diff --git a/library/compiler/amd64/alien.factor b/library/compiler/amd64/alien.factor
index f737885584..6b26137a75 100644
--- a/library/compiler/amd64/alien.factor
+++ b/library/compiler/amd64/alien.factor
@@ -22,15 +22,18 @@ M: stack-params %stack>freg
 M: stack-params %freg>stack
     >r stack-increment + cell + swap r> %stack>freg ;
 
-: %unbox-struct ( n reg-class size -- )
-    nip
+: struct-ptr/size ( n reg-class size func -- )
+    rot drop
     ! Load destination address
-    RDI RSP MOV
+    >r RDI RSP MOV
     RDI rot ADD
     ! Load struct size
     RSI swap MOV
     ! Copy the struct to the stack
-    "unbox_value_struct" f compile-c-call ;
+    r> f compile-c-call ;
+
+: %unbox-struct ( n reg-class size -- )
+    "unbox_value_struct" struct-ptr/size ;
 
 : %unbox ( n reg-class func -- )
     ! Call the unboxer
@@ -38,15 +41,18 @@ M: stack-params %freg>stack
     ! Store the return value on the C stack
     [ return-reg ] keep %freg>stack ;
 
+: %box-struct ( n reg-class size -- )
+    "box_value_struct" struct-ptr/size ;
+
 : load-return-value ( reg-class -- )
     dup fastcall-regs first swap return-reg
     2dup eq? [ 2drop ] [ MOV ] if ;
 
 : %box ( n reg-class func -- )
     rot [
-        swap [ fastcall-regs first ] keep %stack>freg
+        rot [ fastcall-regs first ] keep %stack>freg
     ] [
-        load-return-value
+        swap load-return-value
     ] if*
     f compile-c-call ;
 
@@ -56,7 +62,7 @@ M: stack-params %freg>stack
     reset-sse compile-c-call ;
 
 : %alien-callback ( quot -- )
-    RDI swap load-literal "run_callback" f compile-c-call ;
+    RDI load-indirect "run_callback" f compile-c-call ;
 
 : save-return 0 swap [ return-reg ] keep %freg>stack ;
 : load-return 0 swap [ return-reg ] keep %stack>freg ;
@@ -70,3 +76,5 @@ M: stack-params %freg>stack
     "unnest_stacks" f compile-c-call
     ! Restore return register
     load-return ;
+
+: %cleanup ( n -- ) drop ;
diff --git a/library/compiler/amd64/architecture.factor b/library/compiler/amd64/architecture.factor
index 5b4336bdad..632a6c3d83 100644
--- a/library/compiler/amd64/architecture.factor
+++ b/library/compiler/amd64/architecture.factor
@@ -14,6 +14,7 @@ math namespaces sequences ;
 : ds-reg R14 ; inline
 : cs-reg R15 ; inline
 : remainder-reg RDX ; inline
+: alloc-tmp-reg RBX ; inline
 
 M: int-regs return-reg drop RAX ;
 M: int-regs vregs drop { RAX RCX RDX RSI RDI R8 R9 R10 R11 } ;
@@ -31,7 +32,8 @@ M: float-regs fastcall-regs vregs ;
     R11 [ swap MOV ] keep ; inline
 
 : compile-c-call ( symbol dll -- )
-    2dup dlsym address-operand rel-absolute-cell rel-dlsym CALL ;
+    2dup dlsym address-operand
+    >r rel-absolute-cell rel-dlsym r> CALL ;
 
 : compile-c-call* ( symbol dll args -- )
     T{ int-regs } fastcall-regs
@@ -41,10 +43,13 @@ M: float-regs fastcall-regs vregs ;
 
 : prepare-division CQO ; inline
 
+: load-indirect ( vreg literal -- )
+    swap add-literal from 3 - [] MOV ;
+
 M: object load-literal ( literal vreg -- )
     #! We use RIP-relative addressing. The '3' is a hardcoded
     #! instruction length.
-    v>operand swap add-literal from 3 - [] MOV ;
+    v>operand load-indirect ;
 
 : stack-increment \ stack-reserve get 16 align 8 + ;
 
diff --git a/library/compiler/amd64/intrinsics.factor b/library/compiler/amd64/intrinsics.factor
index 5c583dbdda..b95d82f645 100644
--- a/library/compiler/amd64/intrinsics.factor
+++ b/library/compiler/amd64/intrinsics.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: compiler
 USING: assembler ;
+IN: compiler
 
 : generate-write-barrier ( -- )
     #! Mark the card pointed to by vreg.
diff --git a/library/compiler/x86/architecture.factor b/library/compiler/x86/architecture.factor
index c323f8cb31..aeb4c52030 100644
--- a/library/compiler/x86/architecture.factor
+++ b/library/compiler/x86/architecture.factor
@@ -15,6 +15,7 @@ IN: compiler
 : ds-reg ESI ; inline
 : cs-reg EBX ; inline
 : remainder-reg EDX ; inline
+: alloc-tmp-reg EDI ; inline
 
 : reg-stack ( n reg -- op ) swap cells neg [+] ;
 
diff --git a/library/compiler/x86/intrinsics-sse2.factor b/library/compiler/x86/intrinsics-sse2.factor
index f360098522..b5b1ea0642 100644
--- a/library/compiler/x86/intrinsics-sse2.factor
+++ b/library/compiler/x86/intrinsics-sse2.factor
@@ -11,8 +11,9 @@ M: float-regs (%peek) ( vreg loc reg-class -- )
 
 : load-zone-ptr ( vreg -- )
     #! Load pointer to start of zone array
-    "generations" f [ dlsym [] MOV ] 2keep
-    rel-absolute rel-dlsym ;
+    dup "generations" f [ dlsym MOV ] 2keep
+    rel-absolute-cell rel-dlsym
+    dup [] MOV ;
 
 : load-allot-ptr ( vreg -- )
     dup load-zone-ptr dup cell [+] MOV ;
@@ -23,18 +24,18 @@ M: float-regs (%peek) ( vreg loc reg-class -- )
 : with-inline-alloc ( prequot postquot spec -- )
     #! both quotations are called with the vreg
     [
-        EBX PUSH
-        EBX load-allot-ptr
-        EBX [] \ tag-header get call tag-header MOV
-        >r call EBX \ tag get call OR
-        r> call EBX \ size get call inc-allot-ptr
-        EBX POP
+        alloc-tmp-reg PUSH
+        alloc-tmp-reg load-allot-ptr
+        alloc-tmp-reg [] \ tag-header get call tag-header MOV
+        >r call alloc-tmp-reg \ tag get call OR
+        r> call alloc-tmp-reg \ size get call inc-allot-ptr
+        alloc-tmp-reg POP
     ] bind ; inline
 
 M: float-regs (%replace) ( vreg loc reg-class -- )
     drop
-    [ EBX 8 [+] rot v>operand MOVSD ]
-    [ v>operand EBX MOV ] H{
+    [ alloc-tmp-reg 8 [+] rot v>operand MOVSD ]
+    [ v>operand alloc-tmp-reg MOV ] H{
         { tag-header [ float-tag ] }
         { tag [ float-tag ] }
         { size [ 16 ] }
diff --git a/library/compiler/x86/intrinsics.factor b/library/compiler/x86/intrinsics.factor
index d790835902..32edad6c85 100644
--- a/library/compiler/x86/intrinsics.factor
+++ b/library/compiler/x86/intrinsics.factor
@@ -245,11 +245,8 @@ IN: compiler
 } define-intrinsic
 
 : define-fixnum-jump ( word op -- )
-    [
-        [ end-basic-block "x" operand "y" operand CMP ] % ,
-    ] [ ] make H{
-        { +input { { f "x" } { f "y" } } }
-    } define-if-intrinsic ;
+    [ end-basic-block "x" operand "y" operand CMP ] swap add
+    H{ { +input { { f "x" } { f "y" } } } } define-if-intrinsic ;
 
 {
     { fixnum< JL }
@@ -265,7 +262,7 @@ IN: compiler
 : %userenv ( -- )
     "x" operand "userenv" f dlsym MOV
     0 rel-absolute-cell rel-userenv
-    "n" operand 1 SHR
+    "n" operand fixnum>slot@
     "n" operand "x" operand ADD ;
 
 \ getenv [
diff --git a/library/math/constants.factor b/library/math/constants.factor
index 0220a5f69d..518f3ccec3 100644
--- a/library/math/constants.factor
+++ b/library/math/constants.factor
@@ -20,6 +20,6 @@ IN: math
 : e 2.7182818284590452354 ; inline
 : pi 3.14159265358979323846 ; inline
 : epsilon 2.2204460492503131e-16 ; inline
-: first-bignum 1 cell-bits tag-bits - 1- shift ; inline
-: most-positive-fixnum first-bignum 1- >fixnum ; inline
-: most-negative-fixnum first-bignum neg >fixnum ; inline
+: first-bignum 1 bootstrap-cell-bits tag-bits - 1- shift ;
+: most-positive-fixnum first-bignum 1- >fixnum ;
+: most-negative-fixnum first-bignum neg >fixnum ;

From 8932ea08fadfc24bfff1f13b55b4d24d3036df63 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Mon, 15 May 2006 00:08:16 +0000
Subject: [PATCH 111/112] Remove done item from to do list

---
 TODO.FACTOR.txt | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 6b9396e4b3..5dd3e978bf 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -45,8 +45,7 @@ should fix in 0.82:
 
 + compiler/ffi:
 
-- free up r12 as a vreg on ppc
-- amd64 %box-struct
+- free up r11, r12 as a vreg on ppc
 - float= on powerpc doesn't consider nans equal
 - intrinsic fixnum>float float>fixnum
 - win64 port

From f5efb9635e93d63de01987f4bb92df7a7e01f2a9 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Mon, 15 May 2006 01:31:16 +0000
Subject: [PATCH 112/112] Update change log for 0.82 changes

---
 doc/handbook/changes.facts | 10 ++++++++++
 1 file changed, 10 insertions(+)

diff --git a/doc/handbook/changes.facts b/doc/handbook/changes.facts
index b8d98523f7..fdf85b462d 100644
--- a/doc/handbook/changes.facts
+++ b/doc/handbook/changes.facts
@@ -1,6 +1,16 @@
 USING: generic help inspector memory sequences ;
 
 ARTICLE: "changes" "Changes in the latest release"
+{ $subheading "Factor 0.82" }
+{ $list
+    "New code generator framework in compiler"
+    "Floating point operations are now open-coded, resulting in a performance gain"
+    { "Remove " { $snippet "unswons" } " word" }
+    "Implement value type struct inputs to callbacks on AMD64"
+    "Fix some Unix I/O bugs"
+    "Standard OS X-style menu bar in the Cocoa UI (Kevin Reid)"
+    "Objective C methods defined in Factor can now return C structures by value"
+}
 { $subheading "Factor 0.81" }
 { $subtopic "UI"
     { $list