Merge branch 'master' of git://factorcode.org/git/factor

basis/compiler/cfg/checker/checker.factor

@@ -23,7 +23,8 @@ ERROR: last-insn-not-a-jump bb ;
         [ ##dispatch? ]
         [ ##compare-branch? ]
         [ ##compare-imm-branch? ]
-        [ ##compare-float-branch? ]
+        [ ##compare-float-ordered-branch? ]
+        [ ##compare-float-unordered-branch? ]
         [ ##fixnum-add? ]
         [ ##fixnum-sub? ]
         [ ##fixnum-mul? ]

basis/compiler/cfg/instructions/instructions.factor

@@ -496,11 +496,21 @@ constant: src2
 literal: cc
 temp: temp/int-rep ;
 
-INSN: ##compare-float-branch
+INSN: ##compare-float-ordered-branch
 use: src1/double-rep src2/double-rep
 literal: cc ;
 
-PURE-INSN: ##compare-float
+INSN: ##compare-float-unordered-branch
+use: src1/double-rep src2/double-rep
+literal: cc ;
+
+PURE-INSN: ##compare-float-ordered
+def: dst/int-rep
+use: src1/double-rep src2/double-rep
+literal: cc
+temp: temp/int-rep ;
+
+PURE-INSN: ##compare-float-unordered
 def: dst/int-rep
 use: src1/double-rep src2/double-rep
 literal: cc
@@ -556,7 +566,12 @@ use: src1/int-rep
 constant: src2
 literal: cc ;
 
-INSN: _compare-float-branch
+INSN: _compare-float-unordered-branch
+literal: label
+use: src1/int-rep src2/int-rep
+literal: cc ;
+
+INSN: _compare-float-ordered-branch
 literal: label
 use: src1/int-rep src2/int-rep
 literal: cc ;

basis/compiler/cfg/intrinsics/float/float.factor

@@ -8,7 +8,7 @@ IN: compiler.cfg.intrinsics.float
     [ 2inputs ] dip call ds-push ; inline
 
 : emit-float-comparison ( cc -- )
-    [ 2inputs ] dip ^^compare-float ds-push ; inline
+    [ 2inputs ] dip ^^compare-float-unordered ds-push ; inline
 
 : emit-float>fixnum ( -- )
     ds-pop ^^float>integer ^^tag-fixnum ds-push ;

basis/compiler/cfg/linearization/linearization.factor

@@ -57,8 +57,11 @@ M: ##compare-branch linearize-insn
 M: ##compare-imm-branch linearize-insn
     binary-conditional _compare-imm-branch emit-branch ;
 
-M: ##compare-float-branch linearize-insn
+M: ##compare-float-ordered-branch linearize-insn
-    binary-conditional _compare-float-branch emit-branch ;
+    binary-conditional _compare-float-ordered-branch emit-branch ;
+
+M: ##compare-float-unordered-branch linearize-insn
+    binary-conditional _compare-float-unordered-branch emit-branch ;
 
 : overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
     [ dup successors block-number ]

basis/compiler/cfg/useless-conditionals/useless-conditionals.factor

@@ -7,7 +7,14 @@ IN: compiler.cfg.useless-conditionals
 
 : delete-conditional? ( bb -- ? )
     {
-        [ instructions>> last class { ##compare-branch ##compare-imm-branch ##compare-float-branch } memq? ]
+        [
+            instructions>> last class {
+                ##compare-branch
+                ##compare-imm-branch
+                ##compare-float-ordered-branch
+                ##compare-float-unordered-branch
+            } memq?
+        ]
         [ successors>> first2 [ skip-empty-blocks ] bi@ eq? ]
     } 1&& ;
 

basis/compiler/cfg/value-numbering/rewrite/rewrite.factor

@@ -33,7 +33,12 @@ M: insn rewrite drop f ;
     ] [ drop f ] if ; inline
 
 : general-compare-expr? ( insn -- ? )
-    { [ compare-expr? ] [ compare-imm-expr? ] [ compare-float-expr? ] } 1|| ;
+    {
+        [ compare-expr? ]
+        [ compare-imm-expr? ]
+        [ compare-float-unordered-expr? ]
+        [ compare-float-ordered-expr? ]
+    } 1|| ;
 
 : rewrite-boolean-comparison? ( insn -- ? )
     dup ##branch-t? [
@@ -50,7 +55,8 @@ M: insn rewrite drop f ;
     src1>> vreg>expr {
         { [ dup compare-expr? ] [ >compare-expr< \ ##compare-branch new-insn ] }
         { [ dup compare-imm-expr? ] [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
-        { [ dup compare-float-expr? ] [ >compare-expr< \ ##compare-float-branch new-insn ] }
+        { [ dup compare-float-unordered-expr? ] [ >compare-expr< \ ##compare-float-unordered-branch new-insn ] }
+        { [ dup compare-float-ordered-expr? ] [ >compare-expr< \ ##compare-float-ordered-branch new-insn ] }
     } cond ;
 
 : tag-fixnum-expr? ( expr -- ? )
@@ -93,7 +99,8 @@ M: ##compare-imm rewrite-tagged-comparison
     [ cc>> ] [ dst>> ] [ src1>> vreg>expr ] tri {
         { [ dup compare-expr? ] [ >compare-expr< next-vreg \ ##compare new-insn ] }
         { [ dup compare-imm-expr? ] [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] }
-        { [ dup compare-float-expr? ] [ >compare-expr< next-vreg \ ##compare-float new-insn ] }
+        { [ dup compare-float-unordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-unordered new-insn ] }
+        { [ dup compare-float-ordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-ordered new-insn ] }
     } cond
     swap cc= eq? [ [ negate-cc ] change-cc ] when ;
 

basis/compiler/cfg/value-numbering/value-numbering-tests.factor

@@ -12,7 +12,8 @@ IN: compiler.cfg.value-numbering.tests
         dup {
             [ ##compare? ]
             [ ##compare-imm? ]
-            [ ##compare-float? ]
+            [ ##compare-float-unordered? ]
+            [ ##compare-float-ordered? ]
         } 1|| [ f >>temp ] when
     ] map ;
 
@@ -108,8 +109,8 @@ IN: compiler.cfg.value-numbering.tests
         T{ ##peek f 9 D -1 }
         T{ ##unbox-float f 10 8 }
         T{ ##unbox-float f 11 9 }
-        T{ ##compare-float f 12 10 11 cc< }
+        T{ ##compare-float-unordered f 12 10 11 cc< }
-        T{ ##compare-float f 14 10 11 cc/< }
+        T{ ##compare-float-unordered f 14 10 11 cc/< }
         T{ ##replace f 14 D 0 }
     }
 ] [
@@ -118,7 +119,7 @@ IN: compiler.cfg.value-numbering.tests
         T{ ##peek f 9 D -1 }
         T{ ##unbox-float f 10 8 }
         T{ ##unbox-float f 11 9 }
-        T{ ##compare-float f 12 10 11 cc< }
+        T{ ##compare-float-unordered f 12 10 11 cc< }
         T{ ##compare-imm f 14 12 5 cc= }
         T{ ##replace f 14 D 0 }
     } value-numbering-step trim-temps

basis/compiler/codegen/codegen.factor

@@ -199,7 +199,8 @@ CODEGEN: ##allot %allot
 CODEGEN: ##write-barrier %write-barrier
 CODEGEN: ##compare %compare
 CODEGEN: ##compare-imm %compare-imm
-CODEGEN: ##compare-float %compare-float
+CODEGEN: ##compare-float-ordered %compare-float-ordered
+CODEGEN: ##compare-float-unordered %compare-float-unordered
 
 CODEGEN: _fixnum-add %fixnum-add
 CODEGEN: _fixnum-sub %fixnum-sub
@@ -208,7 +209,8 @@ CODEGEN: _label resolve-label
 CODEGEN: _branch %jump-label
 CODEGEN: _compare-branch %compare-branch
 CODEGEN: _compare-imm-branch %compare-imm-branch
-CODEGEN: _compare-float-branch %compare-float-branch
+CODEGEN: _compare-float-ordered-branch %compare-float-ordered-branch
+CODEGEN: _compare-float-unordered-branch %compare-float-unordered-branch
 CODEGEN: _dispatch %dispatch
 CODEGEN: _spill %spill
 CODEGEN: _reload %reload

basis/cpu/architecture/architecture.factor

@@ -217,11 +217,13 @@ HOOK: %epilogue cpu ( n -- )
 
 HOOK: %compare cpu ( dst temp cc src1 src2 -- )
 HOOK: %compare-imm cpu ( dst temp cc src1 src2 -- )
-HOOK: %compare-float cpu ( dst temp cc src1 src2 -- )
+HOOK: %compare-float-ordered cpu ( dst temp cc src1 src2 -- )
+HOOK: %compare-float-unordered cpu ( dst temp cc src1 src2 -- )
 
 HOOK: %compare-branch cpu ( label cc src1 src2 -- )
 HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )
-HOOK: %compare-float-branch cpu ( label cc src1 src2 -- )
+HOOK: %compare-float-ordered-branch cpu ( label cc src1 src2 -- )
+HOOK: %compare-float-unordered-branch cpu ( label cc src1 src2 -- )
 
 HOOK: %spill cpu ( src rep n -- )
 HOOK: %reload cpu ( dst rep n -- )

basis/cpu/ppc/ppc.factor

@@ -516,30 +516,33 @@ M: ppc %epilogue ( n -- )
 : (%compare-float-unordered) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
 : (%compare-float-ordered) ( src1 src2 -- ) [ 0 ] dip FCMPO ; inline
 
-:: (%compare-float) ( src1 src2 cc -- branch1 branch2 )
+:: (%compare-float) ( src1 src2 cc compare -- branch1 branch2 )
     cc {
-        { cc<    [ src1 src2 (%compare-float-ordered)   \ BLT f     ] }
+        { cc<    [ src1 src2 \ compare execute( a b -- ) \ BLT f     ] }
-        { cc<=   [ src1 src2 (%compare-float-ordered)   \ BLT \ BEQ ] }
+        { cc<=   [ src1 src2 \ compare execute( a b -- ) \ BLT \ BEQ ] }
-        { cc>    [ src1 src2 (%compare-float-ordered)   \ BGT f     ] }
+        { cc>    [ src1 src2 \ compare execute( a b -- ) \ BGT f     ] }
-        { cc>=   [ src1 src2 (%compare-float-ordered)   \ BGT \ BEQ ] }
+        { cc>=   [ src1 src2 \ compare execute( a b -- ) \ BGT \ BEQ ] }
-        { cc=    [ src1 src2 (%compare-float-unordered) \ BEQ f     ] }
+        { cc=    [ src1 src2 \ compare execute( a b -- ) \ BEQ f     ] }
-        { cc<>   [ src1 src2 (%compare-float-ordered)   \ BLT \ BGT ] }
+        { cc<>   [ src1 src2 \ compare execute( a b -- ) \ BLT \ BGT ] }
-        { cc<>=  [ src1 src2 (%compare-float-ordered)   \ BNO f     ] }
+        { cc<>=  [ src1 src2 \ compare execute( a b -- ) \ BNO f     ] }
-        { cc/<   [ src1 src2 (%compare-float-unordered) \ BGE f     ] }
+        { cc/<   [ src1 src2 \ compare execute( a b -- ) \ BGE f     ] }
-        { cc/<=  [ src1 src2 (%compare-float-unordered) \ BGT \ BO  ] }
+        { cc/<=  [ src1 src2 \ compare execute( a b -- ) \ BGT \ BO  ] }
-        { cc/>   [ src1 src2 (%compare-float-unordered) \ BLE f     ] }
+        { cc/>   [ src1 src2 \ compare execute( a b -- ) \ BLE f     ] }
-        { cc/>=  [ src1 src2 (%compare-float-unordered) \ BLT \ BO  ] }
+        { cc/>=  [ src1 src2 \ compare execute( a b -- ) \ BLT \ BO  ] }
-        { cc/=   [ src1 src2 (%compare-float-unordered) \ BNE f     ] }
+        { cc/=   [ src1 src2 \ compare execute( a b -- ) \ BNE f     ] }
-        { cc/<>  [ src1 src2 (%compare-float-unordered) \ BEQ \ BO  ] }
+        { cc/<>  [ src1 src2 \ compare execute( a b -- ) \ BEQ \ BO  ] }
-        { cc/<>= [ src1 src2 (%compare-float-unordered) \ BO  f     ] }
+        { cc/<>= [ src1 src2 \ compare execute( a b -- ) \ BO  f     ] }
     } case ; inline
 
 M: ppc %compare [ (%compare) ] 2dip %boolean ;
 
 M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
 
-M:: ppc %compare-float ( dst src1 src2 cc temp -- )
+M:: ppc %compare-float-ordered ( dst src1 src2 cc temp -- )
-    cc negate-cc src1 src2 (%compare-float) :> branch2 :> branch1
+    src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> branch2 :> branch1
+    dst temp branch1 branch2 (%boolean) ;
+M:: ppc %compare-float-unordered ( dst src1 src2 cc temp -- )
+    src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> branch2 :> branch1
     dst temp branch1 branch2 (%boolean) ;
 
 :: %branch ( label cc -- )
@@ -556,10 +559,17 @@ M: ppc %compare-branch [ (%compare) ] 2dip %branch ;
 
 M: ppc %compare-imm-branch [ (%compare-imm) ] 2dip %branch ;
 
-M:: ppc %compare-float-branch ( label src1 src2 cc -- )
+:: (%branch) ( label branch1 branch2 -- )
-    cc src1 src2 (%compare-float) :> branch2 :> branch1
     label branch1 execute( label -- )
-    branch2 [ label branch2 execute( label -- ) ] when ;
+    branch2 [ label branch2 execute( label -- ) ] when ; inline
+
+M:: ppc %compare-float-ordered-branch ( label src1 src2 cc -- )
+    cc src1 src2 \ (%compare-float-ordered) \ (%compare-float) :> branch2 :> branch1
+    label branch1 branch2 (%branch) ;
+
+M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
+    cc src1 src2 \ (%compare-float-unordered) \ (%compare-float) :> branch2 :> branch1
+    label branch1 branch2 (%branch) ;
 
 : load-from-frame ( dst n rep -- )
     {

basis/cpu/x86/32/32.factor

@@ -295,6 +295,4 @@ os windows? [
     4 "double" c-type (>>align)
 ] unless
 
-USE: vocabs.loader
-
 "cpu.x86.features" require

basis/cpu/x86/x86.factor

@@ -658,23 +658,29 @@ M: x86 %compare-imm ( dst src1 src2 cc temp -- )
         "no-move" resolve-label
     ] with-scope ;
 
-M:: x86 %compare-float ( dst src1 src2 cc temp -- )
+:: (%compare-float) ( dst src1 src2 cc temp compare -- )
     cc {
-        { cc<    [ src2 src1  COMISD dst temp \ CMOVA  %boolean ] }
+        { cc<    [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVA  %boolean ] }
-        { cc<=   [ src2 src1  COMISD dst temp \ CMOVAE %boolean ] }
+        { cc<=   [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVAE %boolean ] }
-        { cc>    [ src1 src2  COMISD dst temp \ CMOVA  %boolean ] }
+        { cc>    [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVA  %boolean ] }
-        { cc>=   [ src1 src2  COMISD dst temp \ CMOVAE %boolean ] }
+        { cc>=   [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVAE %boolean ] }
-        { cc=    [ src1 src2 UCOMISD dst temp \ %cmov-float= %boolean ] }
+        { cc=    [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float= %boolean ] }
-        { cc<>   [ src1 src2  COMISD dst temp \ CMOVNE %boolean ] }
+        { cc<>   [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNE %boolean ] }
-        { cc<>=  [ src1 src2  COMISD dst temp \ CMOVNP %boolean ] }
+        { cc<>=  [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNP %boolean ] }
-        { cc/<   [ src2 src1 UCOMISD dst temp \ CMOVBE %boolean ] }
+        { cc/<   [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVBE %boolean ] }
-        { cc/<=  [ src2 src1 UCOMISD dst temp \ CMOVB  %boolean ] }
+        { cc/<=  [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVB  %boolean ] }
-        { cc/>   [ src1 src2 UCOMISD dst temp \ CMOVBE %boolean ] }
+        { cc/>   [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVBE %boolean ] }
-        { cc/>=  [ src1 src2 UCOMISD dst temp \ CMOVB  %boolean ] }
+        { cc/>=  [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVB  %boolean ] }
-        { cc/=   [ src1 src2 UCOMISD dst temp \ %cmov-float/= %boolean ] }
+        { cc/=   [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float/= %boolean ] }
-        { cc/<>  [ src1 src2 UCOMISD dst temp \ CMOVE  %boolean ] }
+        { cc/<>  [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVE  %boolean ] }
-        { cc/<>= [ src1 src2 UCOMISD dst temp \ CMOVP  %boolean ] }
+        { cc/<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVP  %boolean ] }
-    } case ;
+    } case ; inline
+
+M: x86 %compare-float-ordered ( dst src1 src2 cc temp -- )
+    \ COMISD (%compare-float) ;
+
+M: x86 %compare-float-unordered ( dst src1 src2 cc temp -- )
+    \ UCOMISD (%compare-float) ;
 
 M:: x86 %compare-branch ( label src1 src2 cc -- )
     src1 src2 CMP
@@ -701,24 +707,30 @@ M: x86 %compare-imm-branch ( label src1 src2 cc -- )
 : %jump-float/= ( label -- )
     [ JNE ] [ JP ] bi ;
 
-M:: x86 %compare-float-branch ( label src1 src2 cc -- )
+:: (%compare-float-branch) ( label src1 src2 cc compare -- )
     cc {
-        { cc<    [ src2 src1  COMISD label JA  ] }
+        { cc<    [ src2 src1 \ compare execute( a b -- ) label JA  ] }
-        { cc<=   [ src2 src1  COMISD label JAE ] }
+        { cc<=   [ src2 src1 \ compare execute( a b -- ) label JAE ] }
-        { cc>    [ src1 src2  COMISD label JA  ] }
+        { cc>    [ src1 src2 \ compare execute( a b -- ) label JA  ] }
-        { cc>=   [ src1 src2  COMISD label JAE ] }
+        { cc>=   [ src1 src2 \ compare execute( a b -- ) label JAE ] }
-        { cc=    [ src1 src2 UCOMISD label %jump-float= ] }
+        { cc=    [ src1 src2 \ compare execute( a b -- ) label %jump-float= ] }
-        { cc<>   [ src1 src2  COMISD label JNE ] }
+        { cc<>   [ src1 src2 \ compare execute( a b -- ) label JNE ] }
-        { cc<>=  [ src1 src2  COMISD label JNP ] }
+        { cc<>=  [ src1 src2 \ compare execute( a b -- ) label JNP ] }
-        { cc/<   [ src2 src1 UCOMISD label JBE ] }
+        { cc/<   [ src2 src1 \ compare execute( a b -- ) label JBE ] }
-        { cc/<=  [ src2 src1 UCOMISD label JB  ] }
+        { cc/<=  [ src2 src1 \ compare execute( a b -- ) label JB  ] }
-        { cc/>   [ src1 src2 UCOMISD label JBE ] }
+        { cc/>   [ src1 src2 \ compare execute( a b -- ) label JBE ] }
-        { cc/>=  [ src1 src2 UCOMISD label JB  ] }
+        { cc/>=  [ src1 src2 \ compare execute( a b -- ) label JB  ] }
-        { cc/=   [ src1 src2 UCOMISD label %jump-float/= ] }
+        { cc/=   [ src1 src2 \ compare execute( a b -- ) label %jump-float/= ] }
-        { cc/<>  [ src1 src2 UCOMISD label JE  ] }
+        { cc/<>  [ src1 src2 \ compare execute( a b -- ) label JE  ] }
-        { cc/<>= [ src1 src2 UCOMISD label JP  ] }
+        { cc/<>= [ src1 src2 \ compare execute( a b -- ) label JP  ] }
     } case ;
 
+M: x86 %compare-float-ordered-branch ( label src1 src2 cc -- )
+    \ COMISD (%compare-float-branch) ;
+
+M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- )
+    \ UCOMISD (%compare-float-branch) ;
+
 M:: x86 %spill ( src rep n -- )
     n spill@ src rep copy-register ;
 

basis/io/files/info/windows/windows.factor

@@ -129,8 +129,9 @@ ERROR: not-absolute-path ;
         [ first Letter? ]
     } 1&& [ 2 head "\\" append ] [ not-absolute-path ] if ;
 
-M: winnt file-system-info ( path -- file-system-info )
+<PRIVATE
-    normalize-path root-directory
+
+: (file-system-info) ( path -- file-system-info )
     dup [ volume-information ] [ file-system-space ] bi
     \ win32-file-system-info new
         swap *ulonglong >>free-space
@@ -144,6 +145,11 @@ M: winnt file-system-info ( path -- file-system-info )
         swap >>mount-point
     calculate-file-system-info ;
 
+PRIVATE>
+
+M: winnt file-system-info ( path -- file-system-info )
+    normalize-path root-directory (file-system-info) ;
+
 : volume>paths ( string -- array )
     16384 <ushort-array> tuck dup length
     0 <uint> dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [
@@ -180,7 +186,7 @@ M: winnt file-system-info ( path -- file-system-info )
 M: winnt file-systems ( -- array )
     find-volumes [ volume>paths ] map
     concat [
-        [ file-system-info ]
+        [ (file-system-info) ]
         [ drop \ file-system-info new swap >>mount-point ] recover
     ] map ;