miscellaneous bug fixes and cleanups, powerpc work

TODO.FACTOR.txt

@@ -6,6 +6,7 @@
 <magnus--> http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4764.html
 <magnus--> http://clozure.com/cgi-bin/viewcvs.cgi/ccl/lisp-kernel/lisp-exceptions.c?rev=1.9&content-type=text/vnd.viewcvs-markup
 
+- fix ceiling
 - single-stepper and variable access: wrong namespace?
 - investigate if COPYING_GEN needs a fix
 - faster layout

doc/handbook.tex

@@ -861,7 +861,7 @@ Push the current call frame on the call stack, and set the call stack to the giv
 \textbf{12}
 \end{alltt}
 \wordtable{
-\vocabulary{kernel}
+\vocabulary{words}
 \ordinaryword{execute}{execute ( word -- )}
 }
 Execute a word definition, taking action based on the word definition, as above.

library/bootstrap/image.factor

@@ -298,17 +298,9 @@ M: hashtable ' ( hashtable -- pointer )
 
 : write-word ( word -- )
     "64-bits" get [
-        "big-endian" get [
+        "big-endian" get [ write-be64 ] [ write-le64 ] ifte
-            write-big-endian-64
     ] [
-            write-little-endian-64
+         "big-endian" get [ write-be32 ] [ write-le32 ] ifte
-        ] ifte
-    ] [
-         "big-endian" get [
-            write-big-endian-32
-        ] [
-            write-little-endian-32
-        ] ifte
     ] ifte ;
 
 : write-image ( image file -- )

library/bootstrap/primitives.factor

@@ -54,6 +54,8 @@ vocabularies get [
     [ "(fraction>)" "math-internals"          [ [ integer integer ] [ rational ] ] ]
     [ "str>float" "parser"                    [ [ string ] [ float ] ] ]
     [ "(unparse-float)" "unparser"            [ [ float ] [ string ] ] ]
+    [ "float-bits" "math"                     [ [ real ] [ integer ] ] ]
+    [ "double-bits" "math"                    [ [ real ] [ integer ] ] ]
     [ "<complex>" "math-internals"            [ [ real real ] [ number ] ] ]
     [ "fixnum+" "math-internals"              [ [ fixnum fixnum ] [ integer ] ] ]
     [ "fixnum-" "math-internals"              [ [ fixnum fixnum ] [ integer ] ] ]

library/collections/sequences-epilogue.factor

@@ -102,11 +102,13 @@ M: object contains? ( obj seq -- ? )
     #! Return a new sequence of the same type as s1.
     rot [ [ rot nappend ] keep swap nappend ] immutable ;
 
-: concat ( seq -- seq )
+M: f concat ;
-    #! Append together a sequence of sequences.
+
-    dup empty? [
+M: cons concat
-        unswons [ swap [ nappend ] each-with ] immutable
+    unswons [ swap [ nappend ] each-with ] immutable ;
-    ] unless ;
+
+M: object concat
+    >list concat ;
 
 M: object peek ( sequence -- element )
     #! Get value at end of sequence.

library/collections/sequences.factor

@@ -24,6 +24,7 @@ GENERIC: peek ( seq -- elt )
 GENERIC: contains? ( elt seq -- ? )
 GENERIC: head ( n seq -- seq )
 GENERIC: tail ( n seq -- seq )
+GENERIC: concat ( seq -- seq )
 
 G: each ( seq quot -- | quot: elt -- )
     [ over ] [ type ] ; inline

library/compiler/ppc/assembler.factor

@@ -37,29 +37,98 @@ USING: compiler errors kernel math memory words ;
     >r 1 shift >r 10 shift >r 11 shift >r 16 shift >r 21 shift
     r> bitor r> bitor r> bitor r> bitor r> bitor ;
 
-: ADDI d-form 14 insn ;
+: ADDI d-form 14 insn ;   : LI 0 rot ADDI ;   : SUBI neg ADDI ;
-: LI 0 rot ADDI ;
+: ADDIS d-form 15 insn ;  : LIS 0 rot ADDIS ;
-: ADDIS d-form 15 insn ;
+
-: LIS 0 rot ADDIS ;
+: ADDIC d-form 12 insn ;  : SUBIC neg ADDIC ;
-: ADD 0 266 0 xo-form 31 insn ;
+
-: SUBI neg ADDI ;
+: ADDIC. d-form 13 insn ; : SUBIC. neg ADDIC. ;
+
+: (ADD) 266 swap xo-form 31 insn ;
+: ADD 0 0 (ADD) ;
+: ADD. 0 1 (ADD) ;
+: ADDO 1 0 (ADD) ;
+: ADDO. 1 1 (ADD) ;
+
+: (ADDC) 10 swap xo-form 31 insn ;
+: ADDC 0 0 (ADDC) ;
+: ADDC. 0 1 (ADDC) ;
+: ADDCO 1 0 (ADDC) ;
+: ADDCO. 1 1 (ADDC) ;
+
+: (ADDE) 138 swap xo-form 31 insn ;
+: ADDE 0 0 (ADDE) ;
+: ADDE. 0 1 (ADDE) ;
+: ADDEO 1 0 (ADDE) ;
+: ADDEO. 1 1 (ADDE) ;
+
+: ANDI d-form 28 insn ;
+: ANDIS d-form 29 insn ;
+
+: (AND) 31 swap x-form 31 insn ;
+: AND 0 (AND) ;
+: AND. 0 (AND) ;
+
+: (DIVW) 491 swap xo-form 31 insn ;
+: DIVW 0 0 (DIVW) ;
+: DIVW. 0 1 (DIVW) ;
+: DIVWO 1 0 (DIVW) ;
+: DIVWO 1 1 (DIVW) ;
+
+: (DIVWU) 459 swap xo-form 31 insn ;
+: DIVWU 0 0 (DIVWU) ;
+: DIVWU. 0 1 (DIVWU) ;
+: DIVWUO 1 0 (DIVWU) ;
+: DIVWUO. 1 1 (DIVWU) ;
+
+: (EQV) 284 swap x-form 31 insn ;
+: EQV 0 (EQV) ;
+: EQV. 1 (EQV) ;
+
+: (NAND) 476 swap x-form 31 insn ;
+: NAND 0 (NAND) ;
+: NAND. 1 (NAND) ;
+
+: (NOR) 124 swap x-form 31 insn ;
+: NOR 0 (NOR) ;
+: NOR. 1 (NOR) ;
+
 : ORI d-form 24 insn ;
+: ORIS d-form 25 insn ;
+
+: (OR) 444 swap x-form 31 insn ;
+: OR 0 (OR) ;
+: OR. 1 (OR) ;
+
+: (ORC) 412 swap x-form 31 insn ;
+: ORC 0 (ORC) ;
+: ORC. 1 (ORC) ;
+
+: XORI d-form 26 insn ;
+: XORIS d-form 27 insn ;
+
+: (XOR) 316 swap x-form 31 insn ;
+: XOR 0 (XOR) ;
+: XOR. 1 (XOR) ;
+
 : SRAWI 824 0 x-form 31 insn ;
 
-GENERIC: BL
+: LWZ d-form 32 insn ;
-M: integer BL 0 1 i-form 18 insn ;
+: STW d-form 36 insn ;
-M: word BL 0 BL relative-24 ;
+: STWU d-form 37 insn ;
 
-GENERIC: B
+G: (B) ( dest aa lk -- ) [ pick ] [ type ] ;
-M: integer B 0 0 i-form 18 insn ;
+M: integer (B) i-form 18 insn ;
-M: word B 0 B relative-24 ;
+M: word (B) 0 -rot (B) relative-24 ;
+
+: B 0 0 (B) ; : BA 1 0 (B) ; : BL 0 1 (B) ; : BLA 1 1 (B) ;
 
 GENERIC: BC
 M: integer BC 0 0 b-form 16 insn ;
 M: word BC >r 0 BC r> relative-14 ;
 
-: BEQ 12 2 rot BC ;
+: BEQ 12 2 rot BC ;  : BNE 4 2 rot BC ;
-: BNE 4 2 rot BC ;
+
 : BCLR 0 8 0 0 b-form 19 insn ;
 : BLR 20 BCLR ;
 : BCLRL 0 8 0 1 b-form 19 insn ;
@@ -72,9 +141,6 @@ M: word BC >r 0 BC r> relative-14 ;
 : MTSPR 5 shift 467 xfx-form 31 insn ;
 : MTLR 8 MTSPR ;
 : MTCTR 9 MTSPR ;
-: LWZ d-form 32 insn ;
-: STW d-form 36 insn ;
-: STWU d-form 37 insn ;
 : CMPI d-form 11 insn ;
 
 : LOAD32 >r w>h/h r> tuck LIS dup rot ORI ;

library/compiler/ppc/slots.factor

@@ -0,0 +1,18 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: compiler-backend
+USING: alien assembler compiler inference kernel
+kernel-internals lists math memory namespaces sequences words ;
+
+: userenv ( vreg -- )
+    #! Load the userenv pointer in a virtual register.
+    v>operand "userenv" f dlsym swap LOAD32 0 1 rel-userenv ;
+
+M: %getenv generate-node ( vop -- )
+    dup vop-out-1 v>operand swap vop-in-1
+    [ userenv@ unit MOV ] keep 0 rel-userenv ;
+
+M: %setenv generate-node ( vop -- )
+    dup vop-in-2
+    [ userenv@ unit swap vop-in-1 v>operand MOV ] keep
+    0 rel-userenv ;

library/compiler/ppc/stack.factor

@@ -32,4 +32,4 @@ M: %peek-r generate-node ( vop -- )
     dup vop-out-1 v>operand swap vop-in-1 cs-op LWZ ;
 
 M: %replace-r generate-node ( vop -- )
-    dup vop-in-2 v>operand swap vop-in-2 cs-op STW ;
+    dup vop-in-2 v>operand swap vop-in-1 cs-op STW ;

library/io/stdio-binary.factor

@@ -3,13 +3,13 @@
 IN: stdio
 USING: kernel math ;
 
-: read-little-endian-32 ( -- word )
+: read-le32 ( -- word )
     read1
     read1 8  shift bitor
     read1 16 shift bitor
     read1 24 shift bitor ;
 
-: read-big-endian-32 ( -- word )
+: read-be32 ( -- word )
     read1 24 shift
     read1 16 shift bitor
     read1 8  shift bitor
@@ -24,7 +24,7 @@ USING: kernel math ;
 : byte1 ( num -- byte )  -8 shift HEX: ff bitand ;
 : byte0 ( num -- byte )           HEX: ff bitand ;
 
-: write-little-endian-64 ( word -- )
+: write-le64 ( word -- )
     dup byte0 write
     dup byte1 write
     dup byte2 write
@@ -34,7 +34,7 @@ USING: kernel math ;
     dup byte6 write
         byte7 write ;
 
-: write-big-endian-64 ( word -- )
+: write-be64 ( word -- )
     dup byte7 write
     dup byte6 write
     dup byte5 write
@@ -44,22 +44,22 @@ USING: kernel math ;
     dup byte1 write
         byte0 write ;
 
-: write-little-endian-32 ( word -- )
+: write-le32 ( word -- )
     dup byte0 write
     dup byte1 write
     dup byte2 write
         byte3 write ;
 
-: write-big-endian-32 ( word -- )
+: write-be32 ( word -- )
     dup byte3 write
     dup byte2 write
     dup byte1 write
         byte0 write ;
 
-: write-little-endian-16 ( char -- )
+: write-le16 ( char -- )
     dup byte0 write
         byte1 write ;
 
-: write-big-endian-16 ( char -- )
+: write-be16 ( char -- )
     dup byte1 write
         byte0 write ;

library/math/ratio.factor

@@ -40,5 +40,5 @@ M: ratio /i scale /i ;
 M: ratio /f scale /f ;
 
 M: ratio truncate >fraction /i ;
-M: ratio floor >fraction /i dup 0 < [ 1 - ] when ;
+M: ratio floor [ truncate ] keep 0 < [ 1 - ] when ;
-M: ratio ceiling >fraction /i dup 0 > [ 1 + ] when ;
+M: ratio ceiling [ truncate ] keep 0 > [ 1 + ] when ;

library/test/image.factor

@@ -23,7 +23,7 @@ USE: math
 
 [ "\0\0\0\0\u000f\u000e\r\u000c" ]
 [
-    [ image-magic write-big-endian-64 ] with-string
+    [ image-magic write-be64 ] with-string
 ] unit-test
 
 [

library/test/math/integer.factor

@@ -87,3 +87,8 @@ unit-test
 [ f ] [ 123 power-of-2? ] unit-test
 [ 8 ] [ 256 log2 ] unit-test
 [ 0 ] [ 1 log2 ] unit-test
+
+[ 1 ] [ 7/8 ceiling ] unit-test
+[ 2 ] [ 3/2 ceiling ] unit-test
+[ 0 ] [ -7/8 ceiling ] unit-test
+[ -1 ] [ -3/2 ceiling ] unit-test

library/tools/jedit-wire.factor

@@ -14,10 +14,10 @@ prettyprint sequences stdio streams strings words ;
 ! captured with with-string.
 
 : write-packet ( string -- )
-    dup length write-big-endian-32 write flush ;
+    dup length write-be32 write flush ;
 
 : read-packet ( -- string )
-    read-big-endian-32 read ;
+    read-be32 read ;
 
 : wire-server ( -- )
     #! Repeatedly read jEdit requests and execute them. Return
@@ -40,15 +40,13 @@ prettyprint sequences stdio streams strings words ;
 : jedit-write-attr ( str style -- )
     CHAR: w write
     [ swap . . ] with-string
-    dup length write-big-endian-32
+    dup length write-be32
     write ;
 
 TUPLE: jedit-stream ;
 
 M: jedit-stream stream-readln ( stream -- str )
-    [
+    [ CHAR: r write flush read-be32 read ] with-wrapper ;
-        CHAR: r write flush read-big-endian-32 read
-    ] with-wrapper ;
 
 M: jedit-stream stream-write-attr ( str style stream -- )
     [ jedit-write-attr ] with-wrapper ;

library/tools/jedit.factor

@@ -25,8 +25,8 @@ streams strings unparser words ;
 
 : send-jedit-request ( request -- )
     jedit-server-info swap "localhost" swap <client> [
-        write-big-endian-32
+        write-be32
-        dup length write-big-endian-16
+        dup length write-be16
         write flush
     ] with-stream ;
 

native/float.c

@@ -197,6 +197,21 @@ void primitive_fsqrt(void)
 	drepl(tag_float(sqrt(to_float(dpeek()))));
 }
 
+void primitive_float_bits(void)
+{
+	double x = to_float(dpeek());
+	float x_ = (float)x;
+	CELL x_bits = *(CELL*)(&x_);
+	drepl(tag_cell(x_bits));
+}
+
+void primitive_double_bits(void)
+{
+	double x = to_float(dpeek());
+	u64 x_bits = *(u64*)(&x);
+	drepl(tag_bignum(s48_long_long_to_bignum(x_bits)));
+}
+
 #define DEFBOX(name,type)                                                      \
 void name (type flo)                                                       \
 {                                                                              \

native/float.h

@@ -49,6 +49,9 @@ void primitive_fsin(void);
 void primitive_fsinh(void);
 void primitive_fsqrt(void);
 
+void primitive_float_bits(void);
+void primitive_double_bits(void);
+
 void box_float(float flo);
 float unbox_float(void);
 void box_double(double flo);

native/primitives.c

@@ -20,6 +20,8 @@ void* primitives[] = {
 	primitive_from_fraction,
 	primitive_str_to_float,
 	primitive_float_to_str,
+	primitive_float_bits,
+	primitive_double_bits,
 	primitive_from_rect,
 	primitive_fixnum_add,
 	primitive_fixnum_subtract,

native/s48_bignum.c

@@ -412,6 +412,34 @@ s48_long_long_to_bignum(s64 n)
   }
 }
 
+bignum_type
+s48_ulong_long_to_bignum(u64 n)
+{
+  bignum_digit_type result_digits [BIGNUM_DIGITS_FOR_LONG_LONG];
+  bignum_digit_type * end_digits = result_digits;
+  /* Special cases win when these small constants are cached. */
+  if (n == 0) return (BIGNUM_ZERO ());
+  if (n == 1) return (BIGNUM_ONE (0));
+  {
+    u64 accumulator = n;
+    do
+      {
+	(*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK);
+	accumulator >>= BIGNUM_DIGIT_LENGTH;
+      }
+    while (accumulator != 0);
+  }
+  {
+    bignum_type result =
+      (bignum_allocate ((end_digits - result_digits), 0));
+    bignum_digit_type * scan_digits = result_digits;
+    bignum_digit_type * scan_result = (BIGNUM_START_PTR (result));
+    while (scan_digits < end_digits)
+      (*scan_result++) = (*scan_digits++);
+    return (result);
+  }
+}
+
 long
 s48_bignum_to_long(bignum_type bignum)
 {

native/s48_bignum.h

@@ -67,7 +67,8 @@ bignum_type s48_bignum_quotient(bignum_type, bignum_type);
 bignum_type s48_bignum_remainder(bignum_type, bignum_type);
 DLLEXPORT bignum_type s48_long_to_bignum(long);
 DLLEXPORT bignum_type s48_long_long_to_bignum(s64 n);
-bignum_type s48_ulong_to_bignum(unsigned long);
+DLLEXPORT bignum_type s48_ulong_long_to_bignum(u64 n);
+DLLEXPORT bignum_type s48_ulong_to_bignum(unsigned long);
 long s48_bignum_to_long(bignum_type);
 unsigned long s48_bignum_to_ulong(bignum_type);
 bignum_type s48_double_to_bignum(double);