Fix more compiler bugs

diff --git a/basis/compiler/generator/iterator/iterator.factor b/basis/compiler/generator/iterator/iterator.factor
index 34a0cf149f94649e4d306f26b29cadef9b7757ee..473d59c3e45f20d730482a67fe30856e513999e7 100644 (file)
--- 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 42becc5588dcb357d6ed830384b2a77d68cdd372..f5a1a86ae3df185e3beffa47effed1b56d0e30f5 100755 (executable)
--- 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 fd18dcafce7c2632f959c8afaeb602d16ad532a6..9f42ad201f69341e3bf730fc5130af1195160968 100755 (executable)
--- 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 49832bcac0b22603819425d1ae6fe494bb7e458a..79d5d4ed8baf90c99cd55577b0c12dda7d1d2957 100644 (file)
--- 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 da68503c1e23924ec6dafc576242fd3bc6fe129e..503c6330777d9673613d8d6cbc9ab5ed811dcfe1 100644 (file)
--- 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 203fe7ac676b5db2ed76b718616c95b2871b867e..536b914f39e40e4772ce9c6337b2f67c978a108c 100755 (executable)
--- 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 e1da525f92ccaa2fb014eb5f8fae9edfff2f61f0..11e7a0d7fdd97762120bf879b185213a501ed956 100755 (executable)
--- 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 a6fea14fc71e179deb5928e1a5ca19e80618f467..5a496093d56fcb4dd87becb93e677ccda4acd437 100755 (executable)
--- 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