From 1fcbdf9d520360cedbec3cb43fea16d5e0f9a7bf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 29 Aug 2008 00:26:47 -0500
Subject: [PATCH 1/5] Fix more compiler bugs

---
 .../generator/iterator/iterator.factor        |  4 ++--
 basis/compiler/tests/intrinsics.factor        | 11 ++++++++++
 basis/compiler/tests/optimizer.factor         |  4 ++++
 basis/compiler/tree/cleanup/cleanup.factor    | 20 ++++++++++++++-----
 .../tree/propagation/propagation-tests.factor |  2 ++
 basis/cpu/x86/intrinsics/intrinsics.factor    |  4 +---
 .../known-words/known-words.factor            |  2 +-
 core/io/binary/binary-tests.factor            |  2 ++
 8 files changed, 38 insertions(+), 11 deletions(-)

diff --git a/basis/compiler/generator/iterator/iterator.factor b/basis/compiler/generator/iterator/iterator.factor
index 34a0cf149f..473d59c3e4 100644
--- a/basis/compiler/generator/iterator/iterator.factor
+++ b/basis/compiler/generator/iterator/iterator.factor
@@ -37,9 +37,9 @@ DEFER: (tail-call?)
 : tail-call? ( -- ? )
     node-stack get [
         rest-slice
-        dup [
+        dup empty? [ drop t ] [
             [ (tail-call?) ]
             [ first #terminate? not ]
             bi and
-        ] [ drop t ] if
+        ] if
     ] all? ;
diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor
index 42becc5588..f5a1a86ae3 100755
--- a/basis/compiler/tests/intrinsics.factor
+++ b/basis/compiler/tests/intrinsics.factor
@@ -450,3 +450,14 @@ cell 8 = [
 [ 8 ] [
     1 [ 3 fixnum-shift-fast ] compile-call
 ] unit-test
+
+TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ;
+
+[ B{ 0 1 } ] [
+    B{ 0 0 } 1 alien-accessor-regression boa
+    dup [
+        { alien-accessor-regression } declare
+        [ i>> ] [ b>> ] bi over set-alien-unsigned-1
+    ] compile-call
+    b>>
+] unit-test
diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor
index fd18dcafce..9f42ad201f 100755
--- a/basis/compiler/tests/optimizer.factor
+++ b/basis/compiler/tests/optimizer.factor
@@ -358,3 +358,7 @@ TUPLE: some-tuple x ;
 
 [ 5 ] [ { 1 2 { 3 { 4 5 } } } deep-find-test ] unit-test
 [ f ] [ { 1 2 { 3 { 4 } } } deep-find-test ] unit-test
+
+[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 [ ] B{ } map-as ] compile-call ] unit-test
+
+[ 0 ] [ 1234 [ { fixnum } declare -64 shift ] compile-call ] unit-test
diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor
index 49832bcac0..79d5d4ed8b 100644
--- a/basis/compiler/tree/cleanup/cleanup.factor
+++ b/basis/compiler/tree/cleanup/cleanup.factor
@@ -2,9 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences sequences.deep combinators fry
 classes.algebra namespaces assocs words math math.private
-math.partial-dispatch classes classes.tuple classes.tuple.private
-definitions stack-checker.state stack-checker.branches
-compiler.tree
+math.partial-dispatch math.intervals classes classes.tuple
+classes.tuple.private layouts definitions stack-checker.state
+stack-checker.branches compiler.tree
 compiler.tree.intrinsics
 compiler.tree.combinators
 compiler.tree.propagation.info
@@ -64,9 +64,19 @@ GENERIC: cleanup* ( node -- node/nodes )
         { fixnum-shift fixnum-shift-fast }
     } at ;
 
+: (remove-overflow-check?) ( #call -- ? )
+    node-output-infos first class>> fixnum class<= ;
+
+: small-shift? ( #call -- ? )
+    node-input-infos second interval>>
+    0 cell-bits tag-bits get - [a,b] interval-subset? ;
+
 : remove-overflow-check? ( #call -- ? )
-    dup word>> no-overflow-variant
-    [ node-output-infos first class>> fixnum class<= ] [ drop f ] if ;
+    {
+        { [ dup word>> \ fixnum-shift eq? ] [ [ (remove-overflow-check?) ] [ small-shift? ] bi and ] }
+        { [ dup word>> no-overflow-variant ] [ (remove-overflow-check?) ] }
+        [ drop f ]
+    } cond ;
 
 : remove-overflow-check ( #call -- #call )
     [ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ;
diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index da68503c1e..503c633077 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -571,6 +571,8 @@ MIXIN: empty-mixin
 
 [ ] [ [ { empty-mixin } declare empty-mixin? ] final-info drop ] unit-test
 
+[ V{ fixnum } ] [ [ [ bignum-shift drop ] keep ] final-classes ] unit-test
+
 ! [ V{ string } ] [
 !     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
 ! ] unit-test
diff --git a/basis/cpu/x86/intrinsics/intrinsics.factor b/basis/cpu/x86/intrinsics/intrinsics.factor
index 203fe7ac67..536b914f39 100755
--- a/basis/cpu/x86/intrinsics/intrinsics.factor
+++ b/basis/cpu/x86/intrinsics/intrinsics.factor
@@ -404,10 +404,8 @@ IN: cpu.x86.intrinsics
 
 : %alien-integer-set ( quot reg -- )
     small-reg PUSH
-    "offset" get "value" get = [
-        "value" operand %untag-fixnum
-    ] unless
     small-reg "value" operand MOV
+    small-reg %untag-fixnum
     swap %alien-accessor
     small-reg POP ; inline
 
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index e1da525f92..11e7a0d7fd 100755
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -331,7 +331,7 @@ SYMBOL: +primitive+
 \ bignum-bitnot { bignum } { bignum } define-primitive
 \ bignum-bitnot make-foldable
 
-\ bignum-shift { bignum bignum } { bignum } define-primitive
+\ bignum-shift { bignum fixnum } { bignum } define-primitive
 \ bignum-shift make-foldable
 
 \ bignum< { bignum bignum } { object } define-primitive
diff --git a/core/io/binary/binary-tests.factor b/core/io/binary/binary-tests.factor
index a6fea14fc7..5a496093d5 100755
--- a/core/io/binary/binary-tests.factor
+++ b/core/io/binary/binary-tests.factor
@@ -2,7 +2,9 @@ USING: io.binary tools.test classes math ;
 IN: io.binary.tests
 
 [ B{ 0 0 4 HEX: d2 } ] [ 1234 4 >be ] unit-test
+[ B{ 0 0 0 0 0 0 4 HEX: d2 } ] [ 1234 8 >be ] unit-test
 [ B{ HEX: d2 4 0 0 } ] [ 1234 4 >le ] unit-test
+[ B{ HEX: d2 4 0 0 0 0 0 0 } ] [ 1234 8 >le ] unit-test
 
 [ 1234 ] [ 1234 4 >be be> ] unit-test
 [ 1234 ] [ 1234 4 >le le> ] unit-test

From a015de663b12cfa80105ea6798f7c44e3338a7df Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 29 Aug 2008 00:26:56 -0500
Subject: [PATCH 2/5] Inline some words for better optimizations

---
 extra/math/bitfields/lib/lib.factor | 16 ++++++++--------
 1 file changed, 8 insertions(+), 8 deletions(-)

diff --git a/extra/math/bitfields/lib/lib.factor b/extra/math/bitfields/lib/lib.factor
index 72b33b9ae7..1e755d71d9 100644
--- a/extra/math/bitfields/lib/lib.factor
+++ b/extra/math/bitfields/lib/lib.factor
@@ -1,14 +1,14 @@
 USING: hints kernel math ;
 IN: math.bitfields.lib
 
-: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable
-: set-bit ( x n -- y ) 2^ bitor ; foldable
-: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable
-: unmask ( x n -- ? ) bitnot bitand ; foldable
-: unmask? ( x n -- ? ) unmask 0 > ; foldable
-: mask ( x n -- ? ) bitand ; foldable
-: mask? ( x n -- ? ) mask 0 > ; foldable
-: wrap ( m n -- m' ) 1- bitand ; foldable
+: clear-bit ( x n -- y ) 2^ bitnot bitand ; inline
+: set-bit ( x n -- y ) 2^ bitor ; inline
+: bit-clear? ( x n -- ? ) 2^ bitand zero? ; inline
+: unmask ( x n -- ? ) bitnot bitand ; inline
+: unmask? ( x n -- ? ) unmask 0 > ; inline
+: mask ( x n -- ? ) bitand ; inline
+: mask? ( x n -- ? ) mask 0 > ; inline
+: wrap ( m n -- m' ) 1- bitand ; inline
 : bits ( m n -- m' ) 2^ wrap ; inline
 : mask-bit ( m n -- m' ) 1- 2^ mask ; inline
 

From 6ead724b2529d1c9ce972f4ee9143a15d69699ff Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 29 Aug 2008 04:23:39 -0500
Subject: [PATCH 3/5] Fixing bugs

---
 basis/compiler/tree/cleanup/cleanup.factor            |  2 +-
 basis/compiler/tree/dead-code/dead-code-tests.factor  |  6 +++---
 .../tree/escape-analysis/escape-analysis-tests.factor |  6 +++++-
 basis/cpu/x86/64/64.factor                            |  2 +-
 core/generic/standard/standard-tests.factor           | 11 +++++++++++
 extra/html/templates/chloe/syntax/syntax.factor       |  4 ++--
 extra/inverse/inverse-tests.factor                    |  4 ++--
 extra/io/files/unique/unique-tests.factor             |  2 ++
 8 files changed, 27 insertions(+), 10 deletions(-)

diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor
index 79d5d4ed8b..501507bc56 100644
--- a/basis/compiler/tree/cleanup/cleanup.factor
+++ b/basis/compiler/tree/cleanup/cleanup.factor
@@ -69,7 +69,7 @@ GENERIC: cleanup* ( node -- node/nodes )
 
 : small-shift? ( #call -- ? )
     node-input-infos second interval>>
-    0 cell-bits tag-bits get - [a,b] interval-subset? ;
+    cell-bits tag-bits get - [ neg ] keep [a,b] interval-subset? ;
 
 : remove-overflow-check? ( #call -- ? )
     {
diff --git a/basis/compiler/tree/dead-code/dead-code-tests.factor b/basis/compiler/tree/dead-code/dead-code-tests.factor
index 338f397f66..e8d2b29027 100644
--- a/basis/compiler/tree/dead-code/dead-code-tests.factor
+++ b/basis/compiler/tree/dead-code/dead-code-tests.factor
@@ -120,7 +120,7 @@ IN: compiler.tree.dead-code.tests
 : call-recursive-dce-1 ( a -- b )
     [ call-recursive-dce-1 drop ] [ call-recursive-dce-1 ] bi ; inline recursive
 
-[ [ "WRAP" [ dup >r "REC" drop r> "REC" ] label ] ] [
+[ [ drop "WRAP" [ "REC" drop "REC" ] label ] ] [
     [ call-recursive-dce-1 ] optimize-quot squish
 ] unit-test
 
@@ -134,7 +134,7 @@ IN: compiler.tree.dead-code.tests
     [ f call-recursive-dce-2 drop ] optimize-quot squish
 ] unit-test
 
-[ [ "WRAP" [ produce-a-value dup . drop "REC" ] label ] ] [
+[ [ "WRAP" [ produce-a-value . "REC" ] label ] ] [
     [ f call-recursive-dce-2 ] optimize-quot squish
 ] unit-test
 
@@ -152,7 +152,7 @@ IN: compiler.tree.dead-code.tests
 : call-recursive-dce-4 ( a -- b )
     call-recursive-dce-4 ; inline recursive
 
-[ [ "WRAP" [ "REC" ] label ] ] [
+[ [ drop "WRAP" [ "REC" ] label ] ] [
     [ call-recursive-dce-4 ] optimize-quot squish
 ] unit-test
 
diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
index 9267df93ed..0b7db5b36a 100644
--- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -7,7 +7,7 @@ compiler.tree.combinators compiler.tree sequences math math.private
 kernel tools.test accessors slots.private quotations.private
 prettyprint classes.tuple.private classes classes.tuple
 compiler.tree.intrinsics namespaces compiler.tree.propagation.info
-stack-checker.errors ;
+stack-checker.errors kernel.private ;
 
 \ escape-analysis must-infer
 
@@ -316,3 +316,7 @@ C: <ro-box> ro-box
     [ \ too-many->r boa f f \ inference-error boa ]
     count-unboxed-allocations
 ] unit-test
+
+[ 0 ] [
+    [ { null } declare [ 1 ] [ 2 ] if ] count-unboxed-allocations
+] unit-test
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 4528eb3edc..0ba3b93730 100755
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -3,7 +3,7 @@
 USING: accessors alien.c-types arrays cpu.x86.assembler
 cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
 cpu.x86.allot cpu.architecture kernel kernel.private math
-namespaces sequences compiler.generator.registers
+namespaces sequences compiler.generator compiler.generator.registers
 compiler.generator.fixup system layouts alien alien.accessors
 alien.structs slots splitting assocs ;
 IN: cpu.x86.64
diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor
index e5f3ac8394..dd9ca267d2 100644
--- a/core/generic/standard/standard-tests.factor
+++ b/core/generic/standard/standard-tests.factor
@@ -317,3 +317,14 @@ M: xref-tuple-2 xref-test (xref-test) ;
 [ t ] [
     \ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and
 ] unit-test
+
+GENERIC: wide-predicate-bug ( obj -- n )
+
+PREDICATE: b-predicate < object { { } } member? ;
+
+M: b-predicate wide-predicate-bug drop 0 ;
+
+M: array wide-predicate-bug drop 1 ;
+
+[ 0 ] [ { } wide-predicate-bug ] unit-test
+[ 1 ] [ { 1 } wide-predicate-bug ] unit-test
diff --git a/extra/html/templates/chloe/syntax/syntax.factor b/extra/html/templates/chloe/syntax/syntax.factor
index 9412fde423..82309a49b2 100644
--- a/extra/html/templates/chloe/syntax/syntax.factor
+++ b/extra/html/templates/chloe/syntax/syntax.factor
@@ -23,7 +23,7 @@ tags global [ H{ } clone or ] change-at
 
 MEMO: chloe-name ( string -- name )
     name new
-        swap >>tag
+        swap >>main
         chloe-ns >>url ;
 
 : required-attr ( tag name -- value )
@@ -45,7 +45,7 @@ MEMO: chloe-name ( string -- name )
 : attrs>slots ( tag tuple -- )
     [ attrs>> ] [ <mirror> ] bi*
     '[
-        swap tag>> dup "name" =
+        swap main>> dup "name" =
         [ 2drop ] [ , set-at ] if
     ] assoc-each ;
 
diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor
index 0df41cf53f..3206636ea9 100644
--- a/extra/inverse/inverse-tests.factor
+++ b/extra/inverse/inverse-tests.factor
@@ -62,10 +62,10 @@ C: <nil> nil
 [ "Malformed list" ] [ [ f list-sum ] [ ] recover ] unit-test
 
 : empty-cons ( -- cons ) cons new ;
-: cons* ( cdr car -- cons ) { set-cons-cdr set-cons-car } cons construct ;
+: cons* ( cdr car -- cons ) cons boa ;
 
 [ ] [ T{ cons f f f } [ empty-cons ] undo ] unit-test
-[ 1 2 ] [ 2 1 <cons> [ cons* ] undo ] unit-test
+[ 1 2 ] [ 1 2 <cons> [ cons* ] undo ] unit-test
 
 [ t ] [ pi [ pi ] matches? ] unit-test
 [ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test
diff --git a/extra/io/files/unique/unique-tests.factor b/extra/io/files/unique/unique-tests.factor
index 7007f593b6..c29a94f395 100644
--- a/extra/io/files/unique/unique-tests.factor
+++ b/extra/io/files/unique/unique-tests.factor
@@ -1,3 +1,5 @@
+USING: io.encodings.ascii sequences strings io io.files accessors
+tools.test kernel io.files.unique ;
 IN: io.files.unique.tests
 
 [ 123 ] [

From c9df16e931bb1862caf7cdb46dd2e5a5579f0fef Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 29 Aug 2008 04:33:05 -0500
Subject: [PATCH 4/5] Tweak XML-RPC

---
 basis/xml-rpc/xml-rpc.factor                | 14 +++++++-------
 core/generic/standard/standard-tests.factor | 11 -----------
 2 files changed, 7 insertions(+), 18 deletions(-)

diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor
index 4b96d13316..ade9b34d93 100755
--- a/basis/xml-rpc/xml-rpc.factor
+++ b/basis/xml-rpc/xml-rpc.factor
@@ -1,9 +1,9 @@
 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel xml arrays math generic http.client combinators
-    hashtables namespaces io base64 sequences strings calendar
-    xml.data xml.writer xml.utilities assocs math.parser debugger
-    calendar.format math.order ;
+USING: accessors kernel xml arrays math generic http.client
+combinators hashtables namespaces io base64 sequences strings
+calendar xml.data xml.writer xml.utilities assocs math.parser
+debugger calendar.format math.order ;
 IN: xml-rpc
 
 ! * Sending RPC requests
@@ -17,7 +17,7 @@ M: integer item>xml
     [ "Integers must fit in 32 bits" throw ] unless
     number>string "i4" build-tag ;
 
-PREDICATE: boolean < object { t f } member? ;
+UNION: boolean t POSTPONE: f ;
 
 M: boolean item>xml
     "1" "0" ? "boolean" build-tag ;
@@ -147,10 +147,10 @@ TAG: array xml>item
     xml>item [ "faultCode" get "faultString" get ] bind ;
 
 : receive-rpc ( xml -- rpc )
-    dup name-tag dup "methodCall" =
+    dup main>> dup "methodCall" =
     [ drop parse-method <rpc-method> ] [
         "methodResponse" = [
-            dup first-child-tag name-tag "fault" =
+            dup first-child-tag main>> "fault" =
             [ parse-fault <rpc-fault> ]
             [ parse-rpc-response <rpc-response> ] if
         ] [ "Bad main tag name" server-error ] if
diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor
index dd9ca267d2..e5f3ac8394 100644
--- a/core/generic/standard/standard-tests.factor
+++ b/core/generic/standard/standard-tests.factor
@@ -317,14 +317,3 @@ M: xref-tuple-2 xref-test (xref-test) ;
 [ t ] [
     \ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and
 ] unit-test
-
-GENERIC: wide-predicate-bug ( obj -- n )
-
-PREDICATE: b-predicate < object { { } } member? ;
-
-M: b-predicate wide-predicate-bug drop 0 ;
-
-M: array wide-predicate-bug drop 1 ;
-
-[ 0 ] [ { } wide-predicate-bug ] unit-test
-[ 1 ] [ { 1 } wide-predicate-bug ] unit-test

From 783d0fcabf62786a4f1f6246a61340ee8b1cae24 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 29 Aug 2008 04:40:53 -0500
Subject: [PATCH 5/5] Fix cleanup of conditionals with no live branches

---
 basis/compiler/tree/cleanup/cleanup.factor | 14 ++++++++++----
 1 file changed, 10 insertions(+), 4 deletions(-)

diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor
index 501507bc56..c62c12eeef 100644
--- a/basis/compiler/tree/cleanup/cleanup.factor
+++ b/basis/compiler/tree/cleanup/cleanup.factor
@@ -102,8 +102,11 @@ M: #declare cleanup* drop f ;
 : fold-only-branch ( #branch -- node/nodes )
     #! If only one branch is live we don't need to branch at
     #! all; just drop the condition value.
-    dup live-children sift dup length 1 =
-    [ first swap in-d>> #drop prefix ] [ drop ] if ;
+    dup live-children sift dup length {
+        { 0 [ 2drop f ] }
+        { 1 [ first swap in-d>> #drop prefix ] }
+        [ 2drop ]
+    } case ;
 
 SYMBOL: live-branches
 
@@ -118,15 +121,18 @@ M: #branch cleanup*
         [ live-branches>> live-branches set ]
     } cleave ;
 
+: output-fs ( values -- nodes )
+    [ f swap #push ] map ;
+
 : eliminate-single-phi ( #phi -- node )
     [ phi-in-d>> first ] [ out-d>> ] bi over [ +bottom+ eq? ] all?
-    [ [ drop ] [ [ f swap #push ] map ] bi* ]
+    [ [ drop ] [ output-fs ] bi* ]
     [ #copy ]
     if ;
 
 : eliminate-phi ( #phi -- node )
     live-branches get sift length {
-        { 0 [ drop f ] }
+        { 0 [ out-d>> output-fs ] }
         { 1 [ eliminate-single-phi ] }
         [ drop ]
     } case ;