Floating point fixes

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index c2a6d560136ead66773d4a7ab40f544a2327aa2d..4061265c644a94a3100b0d5f23aa858227d2549c 100644 (file)
--- 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 (file)
index 0000000..daa47e4
--- /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 70e067ced42893161f4ea69ebf06c77c660474bd..2fa70abfad2f13bd453681372fa83e1755fbb9c7 100644 (file)
--- 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 d089ce1ec55b2c518c94041e5ac644cab7b1d987..2a4b29058824aae96610019f4ec543a35556001c 100644 (file)
--- 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 c56a6249d14ef9a1a5b88137faa510b04235ad12..47c38a63dbf0a9037a500551337b59fedf71470e 100644 (file)
--- 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 a35b5754f0ef385f290b8d7aba8fcf94cde60266..10751ff9cfa7b1b12b52e92798caa2c4a779abf4 100644 (file)
--- 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 6c9379892d9a2c739294895c5eebe440f3a3f2a5..767c0932c919985253ce71341fd80b504eda701b 100644 (file)
--- 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 8c54939ab372ed6373dec0510e5e563f5fd8b7ae..0e473d75d6ac5c944d3c16f140f7c09eee410523 100644 (file)
--- 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 90547d7598eb78c0079d784450962cead161ef8e..0166d64db2f2be40a826388b9ff154b4ce3a0d03 100644 (file)
--- 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 7ed04d23d7a616cff66fddd1aabfc93227137525..0220a5f69dedab0605964fc196ed2a0ada1ddf57 100644 (file)
--- 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 b17fc6c0fdc32d6ff9f1368afcc85f325a5dcdc7..911c193e2505215e1440d434f53a6e758a9befe4 100644 (file)
--- 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 605a909478e1c010ba744266773d1b2cc636fc7c..118f276e73aec1952f367d7040df539db03ce480 100644 (file)
--- 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 7812df3032db8ed77124ce89713688d2098da20c..480689b4026dcdc01cc6d33407604c351b658579 100644 (file)
--- 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 1c61c56f83eee246d5e3d6682a7ee7d5c6fcbc55..70907a563b077ac0532b3617d447aec700e7fbae 100644 (file)
--- 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 0fa16b20128445f988e64af6d75130b6d8764193..b4600cd277bff65cdbc5a3c0b0e1641a86065acb 100644 (file)
--- 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 0ee94dd17cff2762f142a11d9d5b80af4598a6f0..2674f6a3ddcc1277237c6228f0faf98d8303f693 100644 (file)
--- 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 5dc1e92c37462fc36599abebeaab2d6376200ff9..650f1d02f3c5df492118df0b0ae5b0ed36c35625 100644 (file)
--- 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