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:
- 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
+ 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];
- [ [ 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/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
: 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 ;
( 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 )
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> ;
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
M: wrapper ' ( wrapper -- pointer )
wrapped '
object-tag here-as >r
- wrapper-type >header emit
+ wrapper-type tag-header emit
emit r> ;
( Conses )
: 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
: 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> ;
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> ;
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> ;
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 )
! 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 ;
: 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 -- )
: 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 ;
: 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 ;
: 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
: 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 ;
: %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 ;
: 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 ;
! 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{
: 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
! 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 ;
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- ;
--- /dev/null
+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
"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 ;
/* the oldest generation */
#define TENURED (gen_count-1)
-ZONE *generations;
+DLLEXPORT ZONE *generations;
/* used during garbage collection only */
ZONE *newspace;
projects / factor.git / commitdiff