Working on float intrinsics

TODO.FACTOR.txt

@@ -1,21 +1,17 @@
 should fix in 0.82:
 
-- constant branch folding
-- fast-slot stuff
-- 3 >n fep
+- 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
-- get factor running on mac intel
 - when generating a 32-bit image on a 64-bit system, large numbers which should
   be bignums become fixnums
-- clicks sent twice
-- speed up ideas:
-  - only do clipping for certain gadgets
-  - use glRect
-
-+ portability:
-
-- win64 port
-- amd64 %unbox-struct
+- get factor running on mac intel
 
 + io:
 
@@ -23,9 +19,14 @@ should fix in 0.82:
 - better i/o scheduler
 - yield in a loop starves i/o
 - "localhost" 50 <client> won't fail
+- issues with timeouts
 
 + ui/help:
 
+- clicks sent twice
+- speed up ideas:
+  - only do clipping for certain gadgets
+  - use glRect
 - polish OS X menu bar code
 - help search
 - reimplement clicking input
@@ -54,16 +55,16 @@ should fix in 0.82:
 
 + compiler/ffi:
 
+- win64 port
+- amd64 %unbox-struct
+- constant branch folding
 - core foundation should use unicode strings
 - alien>utf16-string, utf16-string>alien words
 - can <void*> only be called with an alien?
 - remove <char*>, <ushort*>, set-char*-nth, set-ushort*-nth since they
   have incorrect semantics
-- improve callback efficiency
-- float intrinsics
 - complex float type
 - complex float intrinsics
-- out of memory from overflow check
 - remove literal table
 - C functions returning structs by value
 - FIELD: char key_vector[32];
@@ -73,10 +74,11 @@ should fix in 0.82:
 - [ [ dup call ] dup call ] infer hangs
 - the invalid recursion form case needs to be fixed, for inlines too
 - code gc
-- compiled gc check slows things down
+- fix compiled gc check
 
 + misc:
 
+- 3 >n fep
 - code walker & exceptions
 - slice: if sequence or seq start is changed, abstraction violation
 - make 3.4 bits>double an error

library/bootstrap/boot-stage1.factor

@@ -10,7 +10,7 @@ vectors words ;
 "/library/bootstrap/primitives.factor" run-resource
 
 : if-arch ( arch seq -- )
-    architecture rot member?
+    architecture get rot member?
     [ [ parse-resource % ] each ] [ drop ] if ;
 
 ! The [ ] make form creates a boot quotation

library/bootstrap/image.factor

@@ -62,9 +62,6 @@ SYMBOL: architecture
 : word-type      16 ; inline
 : tuple-type     17 ; inline
 
-: immediate ( x tag -- tagged ) swap tag-bits shift bitor ;
-: >header ( id -- tagged ) object-tag immediate ;
-
 ( Image header )
 
 : base 1024 ;
@@ -106,9 +103,9 @@ GENERIC: ' ( obj -- ptr )
 
 ( Fixnums )
 
-: emit-fixnum ( n -- ) fixnum-tag immediate emit ;
+: emit-fixnum ( n -- ) fixnum-tag tag-address emit ;
 
-M: fixnum ' ( n -- tagged ) fixnum-tag immediate ;
+M: fixnum ' ( n -- tagged ) fixnum-tag tag-address ;
 
 ( Bignums )
 
@@ -136,14 +133,14 @@ M: fixnum ' ( n -- tagged ) fixnum-tag immediate ;
 M: bignum ' ( bignum -- tagged )
     #! This can only emit 0, -1 and 1.
     bignum-tag here-as >r
-    bignum-tag >header emit
+    bignum-tag tag-header emit
     emit-bignum align-here r> ;
 
 ( Floats )
 
 M: float ' ( float -- tagged )
     float-tag here-as >r
-    float-tag >header emit
+    float-tag tag-header emit
     align-here
     double>bits emit-64
     r> ;
@@ -177,7 +174,7 @@ M: f ' ( obj -- ptr )
     dup word-vocabulary ' >r
     dup word-name ' >r
     object-tag here-as over objects get set-hash
-    word-type >header emit
+    word-type tag-header emit
     hashcode emit-fixnum
     r> emit
     r> emit
@@ -209,7 +206,7 @@ M: word ' ( word -- pointer ) ;
 M: wrapper ' ( wrapper -- pointer )
     wrapped '
     object-tag here-as >r
-    wrapper-type >header emit
+    wrapper-type tag-header emit
     emit r> ;
 
 ( Conses )
@@ -234,7 +231,7 @@ M: complex ' ( c -- tagged ) >rect complex-tag emit-cons ;
 
 : emit-string ( string -- ptr )
     object-tag here-as swap
-    string-type >header emit
+    string-type tag-header emit
     dup length emit-fixnum
     dup hashcode emit-fixnum
     pack-string emit-chars
@@ -250,7 +247,7 @@ M: string ' ( string -- pointer )
 : emit-array ( list type -- pointer )
     >r [ ' ] map r>
     object-tag here-as >r
-    >header emit
+    tag-header emit
     dup length emit-fixnum
     ( elements -- ) emit-seq
     align-here r> ;
@@ -270,7 +267,7 @@ M: array ' ( array -- pointer )
 M: vector ' ( vector -- pointer )
     dup underlying ' swap length
     object-tag here-as >r
-    vector-type >header emit
+    vector-type tag-header emit
     emit-fixnum ( length )
     emit ( array ptr )
     align-here r> ;
@@ -278,7 +275,7 @@ M: vector ' ( vector -- pointer )
 M: sbuf ' ( sbuf -- pointer )
     dup underlying ' swap length
     object-tag here-as >r
-    sbuf-type >header emit
+    sbuf-type tag-header emit
     emit-fixnum ( length )
     emit ( array ptr )
     align-here r> ;
@@ -288,7 +285,7 @@ M: sbuf ' ( sbuf -- pointer )
 M: hashtable ' ( hashtable -- pointer )
     [ hash-array ' ] keep
     object-tag here-as >r
-    hashtable-type >header emit
+    hashtable-type tag-header emit
     dup hash-count emit-fixnum
     hash-deleted emit-fixnum
     emit ( array ptr )

library/compiler/generator/architecture.factor

@@ -27,6 +27,9 @@ GENERIC: fastcall-regs ( register-class -- regs )
 ! Sequence mapping vreg-n to native assembler registers
 GENERIC: vregs ( register-class -- regs )
 
+! Map a sequence of literals to f or float
+DEFER: literal-template ( literals -- template )
+
 ! Load a literal (immediate or indirect)
 G: load-literal ( obj vreg -- ) 1 standard-combination ;
 

library/compiler/generator/generator.factor

@@ -195,14 +195,10 @@ 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 [ class ] map requested-vregs ensure-vregs
-!     [ dup alloc-literal-reg [ load-literal ] keep ] map
-!     phantom-d get phantom-append ;
-
 : generate-push ( node -- )
-    >#push< dup length 0 ensure-vregs
-    [ T{ int-regs } alloc-reg [ load-literal ] keep ] map
+    >#push< dup literal-template
+    dup requested-vregs ensure-vregs
+    alloc-vregs [ [ load-literal ] 2each ] keep
     phantom-d get phantom-append ;
 
 M: #push generate-node ( #push -- )

library/compiler/generator/templates.factor

@@ -15,7 +15,7 @@ namespaces prettyprint sequences vectors words ;
 
 : alloc-vregs ( template -- template )
     [
-        first dup
+        dup
         H{ { f T{ int-regs } } { float T{ float-regs f 8 } } }
         hash [ alloc-reg ] [ <int-vreg> dup take-reg ] ?if
     ] map ;
@@ -179,7 +179,7 @@ SYMBOL: phantom-r
 
 : stack>vregs ( phantom template -- values )
     [
-        alloc-vregs dup length rot phantom-locs
+        [ first ] map alloc-vregs dup length rot phantom-locs
         [ dupd %peek ] 2map
     ] 2keep length neg swap adjust-phantom ;
 
@@ -258,10 +258,11 @@ SYMBOL: +clobber
 
 : guess-vregs ( -- int# float# )
     +input get { } additional-vregs#
-    +scratch get requested-vregs >r + r> ;
+    +scratch get [ first ] map requested-vregs >r + r> ;
 
 : alloc-scratch ( -- )
-    +scratch get [ alloc-vregs ] keep phantom-vregs ;
+    +scratch get
+    [ [ first ] map alloc-vregs ] keep phantom-vregs ;
 
 : template-inputs ( -- )
     ! Ensure we have enough to hold any new stack elements we

library/compiler/x86/architecture.factor

@@ -46,16 +46,26 @@ M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 
 : prepare-division CDQ ; inline
 
+: fp-scratch ( -- vreg )
+    "fp-scratch" get [
+        T{ int-regs } alloc-reg dup "fp-scratch" set
+    ] unless* ;
+
 : unboxify-float ( obj vreg quot -- | quot: obj int-vreg )
     #! The SSE2 code here will never be generated unless SSE2
     #! intrinsics are loaded.
     over [ float-regs? ] is? [
-        swap >r T{ int-regs } alloc-reg [ swap call ] keep
+        swap >r fp-scratch [ swap call ] keep
         r> swap [ v>operand ] 2apply float-offset [+] MOVSD
     ] [
         call
     ] if ; inline
 
+: literal-template
+    #! All literals go into integer registers unless SSE2
+    #! intrinsics are loaded.
+    length f <array> ;
+
 M: immediate load-literal ( literal vreg -- )
     v>operand swap v>operand MOV ;
 
@@ -98,24 +108,16 @@ M: object load-literal ( literal vreg -- )
 
 : %return ( -- ) %epilogue RET ;
 
-: vreg-mov [ v>operand ] 2apply MOV ;
+: vreg-mov swap [ v>operand ] 2apply MOV ;
 
 : %peek ( vreg loc -- )
-    swap [ swap vreg-mov ] unboxify-float ;
+    swap [ vreg-mov ] unboxify-float ;
 
-: %replace ( vreg loc -- )
-    #! The SSE2 code here will never be generated unless SSE2
-    #! intrinsics are loaded.
-    over [ float-regs? ] is? [
-        ! >r
-        ! "fp-scratch" operand "allot.here" f dlsym [] MOV
-        ! "fp-scratch" operand [] float-tag >header MOV
-        ! "fp-scratch" operand 8 [+] r> MOVSD
-        ! "allot.here" f dlsym [] 16 ADD
-        vreg-mov
-    ] [
-        vreg-mov
-    ] if ;
+GENERIC: (%replace) ( vreg loc reg-class -- )
+
+M: int-regs (%replace) drop vreg-mov ;
+
+: %replace ( vreg loc -- ) over (%replace) ;
 
 : (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
 

library/compiler/x86/assembler.factor

@@ -376,7 +376,7 @@ M: operand CMP OCT: 071 2-operand ;
 : 2-operand-sse ( dst src op1 op2 -- )
     #! We swap the operands here to make everything consistent
     #! with the integer instructions.
-    swap assemble-1 swapd
+    swap assemble-1 pick register-128? [ swapd ] [ 1 bitor ] if
     >r 2dup t prefix HEX: 0f assemble-1 r>
     assemble-1 reg-code swap addressing ;
 

library/compiler/x86/intrinsics-sse2.factor

@@ -1,9 +1,41 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays assembler kernel kernel-internals lists math
-math-internals namespaces sequences words ;
+USING: alien arrays assembler generic kernel kernel-internals
+lists math math-internals memory namespaces sequences words ;
 IN: compiler
 
+: literal-template
+    #! floats map to 'float' so we put float literals in float
+    #! vregs
+    [ class ] map ;
+
+: load-zone-ptr ( vreg -- )
+    #! Load pointer to start of zone array
+    "generations" f dlsym [] MOV ;
+
+: load-allot-ptr ( vreg -- )
+    dup load-zone-ptr dup cell [+] MOV ;
+
+: inc-allot-ptr ( vreg n -- )
+    >r dup load-zone-ptr cell [+] r> ADD ;
+
+: with-inline-alloc ( vreg spec prequot postquot -- )
+    #! both quotations are called with the vreg
+    rot [
+        >r >r v>operand dup load-allot-ptr
+        dup [] \ tag-header get call tag-header MOV
+        r> over slip dup \ tag get call OR
+        r> over slip \ size get call inc-allot-ptr
+    ] bind ; inline
+
+M: float-regs (%replace) ( vreg loc reg-class -- )
+    drop fp-scratch H{
+        { tag-header [ float-tag ] }
+        { tag [ float-tag ] }
+        { size [ 16 ] }
+    } [ 8 [+] rot v>operand MOVSD ]
+    [ >r v>operand r> MOV ] with-inline-alloc ;
+
 ! Floats
 : define-float-op ( word op -- )
     [ [ "x" operand "y" operand ] % , ] [ ] make H{

library/kernel.factor

@@ -102,6 +102,9 @@ 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

library/math/float.factor

@@ -1,7 +1,13 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+IN: math-internals
+USING: math kernel ;
+
+: float= ( n n -- )
+    #! The compiler replaces this with a better intrinsic.
+    [ double>bits ] 2apply number= ;
+
 IN: math
-USING: generic kernel math-internals ;
 
 UNION: real rational float ;
 
@@ -17,12 +23,11 @@ M: real <=> - ;
 M: float zero?
     double>bits HEX: 8000000000000000 [ bitor ] keep number= ;
 
-M: float number= [ double>bits ] 2apply number= ;
-
 M: float < float< ;
 M: float <= float<= ;
 M: float > float> ;
 M: float >= float>= ;
+M: float number= float= ;
 
 M: float + float+ ;
 M: float - float- ;

library/test/compiler/float.factor

@@ -0,0 +1,25 @@
+IN: temporary
+USING: compiler kernel memory math math-internals test ;
+
+[ 5.0 ] [ [ 5.0 ] compile-1 full-gc full-gc full-gc ] unit-test
+[ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-1 ] unit-test
+
+[ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-1 ] unit-test
+[ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-1 ] unit-test
+[ 3.0 ] [ 1.0 2.0 [ float+ ] compile-1 ] unit-test
+[ 3.0 ] [ 1.0 2.0 [ swap float+ ] compile-1 ] unit-test
+
+[ -1.0 ] [ 1.0 [ 2.0 float- ] compile-1 ] unit-test
+[ 1.0 ] [ 1.0 [ 2.0 swap float- ] compile-1 ] unit-test
+[ -1.0 ] [ 1.0 2.0 [ float- ] compile-1 ] unit-test
+[ 1.0 ] [ 1.0 2.0 [ swap float- ] compile-1 ] unit-test
+
+[ 6.0 ] [ 3.0 [ 2.0 float* ] compile-1 ] unit-test
+[ 6.0 ] [ 3.0 [ 2.0 swap float* ] compile-1 ] unit-test
+[ 6.0 ] [ 3.0 2.0 [ float* ] compile-1 ] unit-test
+[ 6.0 ] [ 3.0 2.0 [ swap float* ] compile-1 ] unit-test
+
+[ 0.5 ] [ 1.0 [ 2.0 float/f ] compile-1 ] unit-test
+[ 2.0 ] [ 1.0 [ 2.0 swap float/f ] compile-1 ] unit-test
+[ 0.5 ] [ 1.0 2.0 [ float/f ] compile-1 ] unit-test
+[ 2.0 ] [ 1.0 2.0 [ swap float/f ] compile-1 ] unit-test

library/test/test.factor

@@ -104,7 +104,7 @@ SYMBOL: failures
         "compiler/simple" "compiler/templates"
         "compiler/stack" "compiler/ifte"
         "compiler/generic" "compiler/bail-out"
-        "compiler/intrinsics"
+        "compiler/intrinsics" "compiler/float"
         "compiler/identities" "compiler/optimizer"
         "compiler/alien" "compiler/callbacks"
     } run-tests ;

native/gc.h

@@ -18,7 +18,7 @@ CELL gen_count;
 /* the oldest generation */
 #define TENURED (gen_count-1)
 
-ZONE *generations;
+DLLEXPORT ZONE *generations;
 
 /* used during garbage collection only */
 ZONE *newspace;