working on PowerPC overflow checks

diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor
index fa089c8af33db63696ab2f155cc7f9bfaa2e8f33..ca2b40d219ac0948be9f711388961618d189b321 100644 (file)
--- a/library/bootstrap/primitives.factor
+++ b/library/bootstrap/primitives.factor
@@ -103,10 +103,21 @@ vocabularies get [ "syntax" set [ reveal ] each ] bind
     { "update-xt" "words"                   }
     { "compiled?" "words"                   }
     { "drop" "kernel"                       }
+    { "2drop" "kernel"                      }
+    { "3drop" "kernel"                      }
     { "dup" "kernel"                        }
-    { "swap" "kernel"                       }
+    { "2dup" "kernel"                       }
+    { "3dup" "kernel"                       }
+    { "rot" "kernel"                        }
+    { "-rot" "kernel"                       }
+    { "dupd" "kernel"                       }
+    { "swapd" "kernel"                      }
+    { "nip" "kernel"                        }
+    { "2nip" "kernel"                       }
+    { "tuck" "kernel"                       }
     { "over" "kernel"                       }
     { "pick" "kernel"                       }
+    { "swap" "kernel"                       }
     { ">r" "kernel"                         }
     { "r>" "kernel"                         }
     { "eq?" "kernel"                        }
@@ -202,10 +213,21 @@ vocabularies get [ "syntax" set [ reveal ] each ] bind
 
 {
     { "drop" "kernel" " x -- " }
+    { "2drop" "kernel" " x y -- " }
+    { "3drop" "kernel" " x y z -- " }
     { "dup" "kernel"  " x -- x x " }
-    { "swap" "kernel" " x y -- y x " }
+    { "2dup" "kernel"  " x y -- x y x y " }
+    { "3dup" "kernel"  " x y z -- x y z x y z " }
+    { "rot" "kernel"  " x y z -- y z x " }
+    { "-rot" "kernel"  " x y z -- z x y " }
+    { "dupd" "kernel"  " x y -- x x y " }
+    { "swapd" "kernel"  " x y z -- y x z " }
+    { "nip" "kernel"  " x y -- y " }
+    { "2nip" "kernel"  " x y z -- z " }
+    { "tuck" "kernel"  " x y -- y x y " }
     { "over" "kernel" " x y -- x y x " }
     { "pick" "kernel" " x y z -- x y z x " }
+    { "swap" "kernel" " x y -- y x " }
     { ">r" "kernel"   " x -- r: x " }
     { "r>" "kernel"   " r: x -- x " }
     { "datastack" "kernel" " -- ds " }

diff --git a/library/collections/hashtables.factor b/library/collections/hashtables.factor
index 88b34ea49db4dbc5988d1352f4ef69e36d76006a..9e6355858fd5481b6a3e5f502a4464697b852187 100644 (file)
--- a/library/collections/hashtables.factor
+++ b/library/collections/hashtables.factor
@@ -13,7 +13,7 @@ kernel-internals ;
 ! if it is somewhat 'implementation detail', is in the
 ! public 'hashtables' vocabulary.
 
-: bucket-count ( hash -- n ) hash-array length ;
+: bucket-count ( hash -- n ) hash-array array-capacity ;
 
 IN: kernel-internals
 

diff --git a/library/compiler/assembler.factor b/library/compiler/assembler.factor
index 31dfc34c345bc3e8a10db883279c3d1e9b6a95af..83a192ccac12f7ef7321c927a896236fb98bfb01 100644 (file)
--- a/library/compiler/assembler.factor
+++ b/library/compiler/assembler.factor
@@ -9,13 +9,13 @@ SYMBOL: interned-literals
 : compiled-header HEX: 01c3babe ; inline
 
 : compiled-byte ( a -- n )
-    <alien> 0 alien-signed-1 ; inline
+    f swap alien-signed-1 ; inline
 : set-compiled-byte ( n a -- )
-    <alien> 0 set-alien-signed-1 ; inline
+    f swap set-alien-signed-1 ; inline
 : compiled-cell ( a -- n )
-    <alien> 0 alien-signed-cell ; inline
+    f swap alien-signed-cell ; inline
 : set-compiled-cell ( n a -- )
-    <alien> 0 set-alien-signed-cell ; inline
+    f swap set-alien-signed-cell ; inline
 
 : compile-aligned ( n -- )
     compiled-offset cell 2 * align set-compiled-offset ; inline

diff --git a/library/compiler/ppc/assembler.factor b/library/compiler/ppc/assembler.factor
index 4e7503e7a1abb435868ce525789c5276a4072b08..c8fff8f58eb6c3da2c0764f0a58f5798eae6495e 100644 (file)
--- a/library/compiler/ppc/assembler.factor
+++ b/library/compiler/ppc/assembler.factor
@@ -70,7 +70,7 @@ USING: compiler errors generic kernel math memory words ;
 
 : (DIVW) 491 xo-form 31 insn ;
 : DIVW 0 0 (DIVW) ;  : DIVW. 0 1 (DIVW) ;
-: DIVWO 1 0 (DIVW) ; : DIVWO 1 1 (DIVW) ;
+: DIVWO 1 0 (DIVW) ; : DIVWO. 1 1 (DIVW) ;
 
 : (DIVWU) 459 xo-form 31 insn ;
 : DIVWU 0 0 (DIVWU) ;  : DIVWU. 0 1 (DIVWU) ;

diff --git a/library/compiler/ppc/fixnum.factor b/library/compiler/ppc/fixnum.factor
index b73fd719c63744eca7e30987c3f6e303822f6f17..23f616a805135842e8001cd512c00b4d9e309983 100644 (file)
--- a/library/compiler/ppc/fixnum.factor
+++ b/library/compiler/ppc/fixnum.factor
@@ -41,22 +41,39 @@ M: %fixnum* generate-node ( vop -- )
     #! Note that this assumes the output will be in r3.
     >3-vop< dup dup tag-bits SRAWI
     0 MTXER
-    [ >r >r drop 4 r> r> MULLWO. 3 ] 2keep
+    [ >r >r drop 6 r> r> MULLWO. 3 ] 2keep
     <label> "end" set
     "end" get BNO
     MULHW
+    4 6 MR
     "s48_long_long_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
-    3 4 bignum-tag ORI
-    "end" get save-xt ;
+    3 6 bignum-tag ORI
+    "end" get save-xt
+    3 6 MR ;
+
+: most-negative-fixnum ( -- n )
+      1 cell 8 * tag-bits - 1 - shift neg ; inline
 
 M: %fixnum/i generate-node ( vop -- )
-    dup >3-vop< swap DIVW
-    vop-out-1 v>operand dup tag-fixnum ;
+    #! This has specific vreg requirements.
+    drop
+    0 MTXER
+    5 3 4 DIVWO.
+    <label> "overflow" set
+    <label> "end" set
+    "overflow" get BO
+    3 5 tag-fixnum
+    "end" get B
+    "overflow" get save-xt
+    most-negative-fixnum neg 3 LOAD
+    "s48_long_to_bignum" f compile-c-call
+    3 3 bignum-tag ORI
+    "end" get save-xt ;
 
 : generate-fixnum/mod ( -- )
     #! The same code is used for %fixnum/i and %fixnum/mod.
@@ -64,7 +81,7 @@ M: %fixnum/i generate-node ( vop -- )
     #! precise vreg requirements.
     6 3 4 DIVW  ! divide in2 by in1, store result in out1
     7 6 4 MULLW ! multiply out1 by in1, store result in in1
-    5 8 3 SUBF  ! subtract in2 from in1, store result in out1.
+    5 7 3 SUBF  ! subtract in2 from in1, store result in out1.
     ;
 
 M: %fixnum-mod generate-node ( vop -- )
@@ -95,22 +112,23 @@ M: %fixnum<< generate-node ( vop -- )
     <label> "end" set
     vop-in-1
     ! check for potential overflow
-    dup shift-add dup 19 LOAD
-    18 17 19 ADD
-    0 18 rot 2 * 1 - CMPLI
+    dup shift-add dup 5 LOAD
+    4 3 5 ADD
+    2 * 1 - 5 LOAD
+    5 0 4 CMPL
     ! is there going to be an overflow?
     "no-overflow" get BGE
     ! there is going to be an overflow, make a bignum
-    3 17 tag-bits SRAWI
+    3 3 tag-bits SRAWI
     "s48_long_to_bignum" f compile-c-call
     dup 4 LI
     "s48_bignum_arithmetic_shift" f compile-c-call
     ! tag the result
-    3 17 bignum-tag ORI
+    3 3 bignum-tag ORI
     "end" get B
     ! there is not going to be an overflow
     "no-overflow" get save-xt
-    17 17 rot SLWI
+    3 3 rot SLWI
     "end" get save-xt ;
 
 M: %fixnum>> generate-node ( vop -- )

diff --git a/library/generic/early-generic.factor b/library/generic/early-generic.factor
index fd421ba55ab315ab5ec156528626e34fa8f2fde2..20ad258b909104684771ba293ce7d6144a76f118 100644 (file)
--- a/library/generic/early-generic.factor
+++ b/library/generic/early-generic.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: generic
-USING: kernel kernel-internals ;
+USING: errors kernel kernel-internals ;
 
 DEFER: standard-combination
 
@@ -11,4 +11,8 @@ DEFER: math-combination
     dup tuple? [ 3 slot ] [ drop f ] ifte ; inline
 
 : set-delegate ( delegate tuple -- )
-    dup tuple? [ 3 set-slot ] [ drop drop ] ifte ; inline
+    dup tuple? [
+        3 set-slot
+    ] [
+        "Only tuples can have delegates" throw
+    ] ifte ; inline

diff --git a/library/io/buffer.factor b/library/io/buffer.factor
index f2a63519dfa385e519908d72f4b69ac340c1a57e..38adc4a82af852ae6734d9378958b75186c77ee6 100644 (file)
--- a/library/io/buffer.factor
+++ b/library/io/buffer.factor
@@ -82,7 +82,7 @@ C: buffer ( size -- buffer )
 
 : ch>buffer ( char buffer -- )
     1 over check-overflow
-    [ buffer-end <alien> 0 set-alien-unsigned-1 ] keep
+    [ buffer-end f swap set-alien-unsigned-1 ] keep
     [ buffer-fill 1 + ] keep set-buffer-fill ;
 
 : n>buffer ( count buffer -- )
@@ -90,7 +90,7 @@ C: buffer ( size -- buffer )
     [ buffer-fill + ] keep set-buffer-fill ;
 
 : buffer-peek ( buffer -- char )
-    buffer@ <alien> 0 alien-unsigned-1 ;
+    buffer@ f swap alien-unsigned-1 ;
 
 : buffer-pop ( buffer -- char )
     [ buffer-peek  1 ] keep buffer-consume ;

diff --git a/library/kernel.factor b/library/kernel.factor
index d591e986cfa2c432385674db30abe1315e76123c..2e6572bd3ecdbf86d6f6ca8c1ac4f91b5de04da1 100644 (file)
--- a/library/kernel.factor
+++ b/library/kernel.factor
@@ -3,18 +3,6 @@
 IN: kernel
 USING: generic kernel-internals vectors ;
 
-: 2drop ( x x -- ) drop drop ;
-: 3drop ( x x x -- ) drop drop drop ;
-: 2dup ( x y -- x y x y ) over over ;
-: 3dup ( x y z -- x y z x y z ) pick pick pick ;
-: rot ( x y z -- y z x ) >r swap r> swap ;
-: -rot ( x y z -- z x y ) swap >r swap r> ;
-: dupd ( x y -- x x y ) >r dup r> ;
-: swapd ( x y z -- y x z ) >r swap r> ;
-: nip ( x y -- y ) swap drop ;
-: 2nip ( x y z -- z ) >r drop drop r> ;
-: tuck ( x y -- y x y ) dup >r swap r> ;
-
 : 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline
 
 : clear ( -- )

diff --git a/native/primitives.c b/native/primitives.c
index c45507643fe5e63edff666520542a36d831a63c3..c332acb29405af0e5c2b07ed97999004fd0f0e69 100644 (file)
--- a/native/primitives.c
+++ b/native/primitives.c
@@ -82,10 +82,21 @@ void* primitives[] = {
        primitive_update_xt,
        primitive_word_compiledp,
        primitive_drop,
+       primitive_2drop,
+       primitive_3drop,
        primitive_dup,
-       primitive_swap,
+       primitive_2dup,
+       primitive_3dup,
+       primitive_rot,
+       primitive__rot,
+       primitive_dupd,
+       primitive_swapd,
+       primitive_nip,
+       primitive_2nip,
+       primitive_tuck,
        primitive_over,
        primitive_pick,
+       primitive_swap,
        primitive_to_r,
        primitive_from_r,
        primitive_eq,

diff --git a/native/stack.c b/native/stack.c
index 7c6a34379d7cf22d0db70657b20b81d52899b4a0..2e8fac991b3f15d0441797f5a38150c0322b57fe 100644 (file)
--- a/native/stack.c
+++ b/native/stack.c
@@ -37,17 +37,98 @@ void primitive_drop(void)
        dpop();
 }
 
+void primitive_2drop(void)
+{
+       ds -= 2 * CELLS;
+}
+
+void primitive_3drop(void)
+{
+       ds -= 3 * CELLS;
+}
+
 void primitive_dup(void)
 {
        dpush(dpeek());
 }
 
-void primitive_swap(void)
+void primitive_2dup(void)
+{
+       CELL top = dpeek();
+       CELL next = get(ds - CELLS);
+       ds += CELLS * 2;
+       put(ds - CELLS,next);
+       put(ds,top);
+}
+
+void primitive_3dup(void)
+{
+       CELL c1 = dpeek();
+       CELL c2 = get(ds - CELLS);
+       CELL c3 = get(ds - CELLS * 2);
+       ds += CELLS * 3;
+       put (ds,c1);
+       put (ds - CELLS,c2);
+       put (ds - CELLS * 2,c3);
+}
+
+void primitive_rot(void)
+{
+       CELL c1 = dpeek();
+       CELL c2 = get(ds - CELLS);
+       CELL c3 = get(ds - CELLS * 2);
+       put(ds,c3);
+       put(ds - CELLS,c1);
+       put(ds - CELLS * 2,c2);
+}
+
+void primitive__rot(void)
+{
+       CELL c1 = dpeek();
+       CELL c2 = get(ds - CELLS);
+       CELL c3 = get(ds - CELLS * 2);
+       put(ds,c2);
+       put(ds - CELLS,c3);
+       put(ds - CELLS * 2,c1);
+}
+
+void primitive_dupd(void)
+{
+       CELL top = dpeek();
+       CELL next = get(ds - CELLS);
+       put(ds,next);
+       put(ds - CELLS,next);
+       dpush(top);
+}
+
+void primitive_swapd(void)
+{
+       CELL top = get(ds - CELLS);
+       CELL next = get(ds - CELLS * 2);
+       put(ds - CELLS,next);
+       put(ds - CELLS * 2,top);
+}
+
+void primitive_nip(void)
+{
+       CELL top = dpop();
+       drepl(top);
+}
+
+void primitive_2nip(void)
+{
+       CELL top = dpeek();
+       ds -= CELLS * 2;
+       drepl(top);
+}
+
+void primitive_tuck(void)
 {
        CELL top = dpeek();
        CELL next = get(ds - CELLS);
        put(ds,next);
        put(ds - CELLS,top);
+       dpush(top);
 }
 
 void primitive_over(void)
@@ -60,6 +141,14 @@ void primitive_pick(void)
        dpush(get(ds - CELLS * 2));
 }
 
+void primitive_swap(void)
+{
+       CELL top = dpeek();
+       CELL next = get(ds - CELLS);
+       put(ds,next);
+       put(ds - CELLS,top);
+}
+
 void primitive_to_r(void)
 {
        cpush(dpop());

diff --git a/native/stack.h b/native/stack.h
index cfa5222336c36d287694688e8cece72d8f2bf84f..034167964ad4af14618db2fed9c5f9d3eb00b77d 100644 (file)
--- a/native/stack.h
+++ b/native/stack.h
@@ -9,10 +9,21 @@ void fix_stacks(void);
 void init_stacks(CELL ds_size, CELL cs_size);
 
 void primitive_drop(void);
+void primitive_2drop(void);
+void primitive_3drop(void);
 void primitive_dup(void);
-void primitive_swap(void);
+void primitive_2dup(void);
+void primitive_3dup(void);
+void primitive_rot(void);
+void primitive__rot(void);
+void primitive_dupd(void);
+void primitive_swapd(void);
+void primitive_nip(void);
+void primitive_2nip(void);
+void primitive_tuck(void);
 void primitive_over(void);
 void primitive_pick(void);
+void primitive_swap(void);
 void primitive_to_r(void);
 void primitive_from_r(void);
 F_VECTOR* stack_to_vector(CELL bottom, CELL top);