Merge branch 'master' of git://factorcode.org/git/factor
commit
e030baa3a7
2
Makefile
2
Makefile
|
@ -170,7 +170,7 @@ vm/resources.o:
|
|||
$(CC) -c $(CFLAGS) -o $@ $<
|
||||
|
||||
.S.o:
|
||||
$(CC) -c $(CFLAGS) -o $@ $<
|
||||
$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
|
||||
|
||||
.m.o:
|
||||
$(CC) -c $(CFLAGS) -o $@ $<
|
||||
|
|
|
@ -435,7 +435,7 @@ M: long-long-type box-return ( type -- )
|
|||
[ >float ] >>unboxer-quot
|
||||
"double" define-primitive-type
|
||||
|
||||
os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
|
||||
"long" "ptrdiff_t" typedef
|
||||
|
||||
"ulong" "size_t" typedef
|
||||
] with-compilation-unit
|
||||
|
|
|
@ -12,9 +12,15 @@ io.encodings.binary math.order math.private accessors
|
|||
slots.private compiler.units ;
|
||||
IN: bootstrap.image
|
||||
|
||||
: arch ( os cpu -- arch )
|
||||
{
|
||||
{ "ppc" [ "-ppc" append ] }
|
||||
{ "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] }
|
||||
[ nip ]
|
||||
} case ;
|
||||
|
||||
: my-arch ( -- arch )
|
||||
cpu name>>
|
||||
dup "ppc" = [ >r os name>> "-" r> 3append ] when ;
|
||||
os name>> cpu name>> arch ;
|
||||
|
||||
: boot-image-name ( arch -- string )
|
||||
"boot." swap ".image" 3append ;
|
||||
|
@ -25,7 +31,7 @@ IN: bootstrap.image
|
|||
: images ( -- seq )
|
||||
{
|
||||
"x86.32"
|
||||
"x86.64"
|
||||
"winnt-x86.64" "unix-x86.64"
|
||||
"linux-ppc" "macosx-ppc"
|
||||
} ;
|
||||
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces accessors math.order assocs kernel sequences
|
||||
combinators make cpu.architecture compiler.cfg.instructions
|
||||
compiler.cfg.registers ;
|
||||
combinators make classes words cpu.architecture
|
||||
compiler.cfg.instructions compiler.cfg.registers ;
|
||||
IN: compiler.cfg.stack-frame
|
||||
|
||||
SYMBOL: frame-required?
|
||||
|
@ -24,16 +24,16 @@ M: ##stack-frame compute-stack-frame*
|
|||
M: ##call compute-stack-frame*
|
||||
word>> sub-primitive>> [ frame-required? on ] unless ;
|
||||
|
||||
M: _gc compute-stack-frame*
|
||||
drop frame-required? on ;
|
||||
|
||||
M: _spill compute-stack-frame*
|
||||
drop frame-required? on ;
|
||||
|
||||
M: _spill-counts compute-stack-frame*
|
||||
counts>> stack-frame get (>>spill-counts) ;
|
||||
|
||||
M: insn compute-stack-frame* drop ;
|
||||
M: insn compute-stack-frame*
|
||||
class frame-required? word-prop [
|
||||
frame-required? on
|
||||
] when ;
|
||||
|
||||
\ _gc t frame-required? set-word-prop
|
||||
\ _spill t frame-required? set-word-prop
|
||||
|
||||
: compute-stack-frame ( insns -- )
|
||||
frame-required? off
|
||||
|
|
|
@ -0,0 +1,343 @@
|
|||
USING: math.private kernel combinators accessors arrays
|
||||
generalizations float-arrays tools.test ;
|
||||
IN: compiler.tests
|
||||
|
||||
: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
|
||||
{
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
} cleave ;
|
||||
|
||||
[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
|
||||
[ 1.0 float-spill-bug ] unit-test
|
||||
|
||||
[ t ] [ \ float-spill-bug compiled>> ] unit-test
|
||||
|
||||
: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
|
||||
{
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
} cleave ;
|
||||
|
||||
[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
|
||||
[ 1.0 float-fixnum-spill-bug ] unit-test
|
||||
|
||||
[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
|
||||
|
||||
: resolve-spill-bug ( a b -- c )
|
||||
[ 1 fixnum+fast ] bi@ dup 10 fixnum< [
|
||||
nip 2 fixnum+fast
|
||||
] [
|
||||
drop {
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
} cleave
|
||||
16 narray
|
||||
] if ;
|
||||
|
||||
[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
|
||||
|
||||
[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
|
||||
|
||||
! The above don't really test spilling...
|
||||
: spill-test-1 ( a -- b )
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast
|
||||
dup 1 fixnum+fast fixnum>float
|
||||
3array
|
||||
3array [ 8 narray ] dip 2array
|
||||
[ 8 narray [ 8 narray ] dip 2array ] dip 2array
|
||||
2array ;
|
||||
|
||||
[
|
||||
{
|
||||
1
|
||||
{
|
||||
{ { 2 3 4 5 6 7 8 9 } { 10 11 12 13 14 15 16 17 } }
|
||||
{
|
||||
{ 18 19 20 21 22 23 24 25 }
|
||||
{ 26 27 { 28 29 30.0 } }
|
||||
}
|
||||
}
|
||||
}
|
||||
] [ 1 spill-test-1 ] unit-test
|
||||
|
||||
: spill-test-2 ( a -- b )
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
dup 1.0 float+
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float*
|
||||
float* ;
|
||||
|
||||
[ t ] [ 1.0 spill-test-2 1.0 \ spill-test-2 def>> call = ] unit-test
|
|
@ -3,7 +3,7 @@ kernel.private math hashtables.private math.private namespaces
|
|||
sequences sequences.private tools.test namespaces.private
|
||||
slots.private sequences.private byte-arrays alien
|
||||
alien.accessors layouts words definitions compiler.units io
|
||||
combinators vectors ;
|
||||
combinators vectors float-arrays ;
|
||||
IN: compiler.tests
|
||||
|
||||
! Originally, this file did black box testing of templating
|
||||
|
@ -206,167 +206,6 @@ TUPLE: my-tuple ;
|
|||
] compile-call
|
||||
] unit-test
|
||||
|
||||
: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
|
||||
{
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
[ dup float+ ]
|
||||
} cleave ;
|
||||
|
||||
[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
|
||||
[ 1.0 float-spill-bug ] unit-test
|
||||
|
||||
[ t ] [ \ float-spill-bug compiled>> ] unit-test
|
||||
|
||||
: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
|
||||
{
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
[ dup float+ ]
|
||||
[ float>fixnum dup fixnum+fast ]
|
||||
} cleave ;
|
||||
|
||||
[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
|
||||
[ 1.0 float-fixnum-spill-bug ] unit-test
|
||||
|
||||
[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
|
||||
|
||||
: resolve-spill-bug ( a b -- c )
|
||||
[ 1 fixnum+fast ] bi@ dup 10 fixnum< [
|
||||
nip 2 fixnum+fast
|
||||
] [
|
||||
drop {
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
[ dup fixnum+fast ]
|
||||
} cleave
|
||||
16 narray
|
||||
] if ;
|
||||
|
||||
[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
|
||||
|
||||
[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
|
||||
|
||||
! Regression
|
||||
: dispatch-alignment-regression ( -- c )
|
||||
{ tuple vector } 3 slot { word } declare
|
||||
|
|
|
@ -0,0 +1,19 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors system kernel alien.c-types cpu.architecture cpu.ppc ;
|
||||
IN: cpu.ppc.linux
|
||||
|
||||
<<
|
||||
t "longlong" c-type (>>stack-align?)
|
||||
t "ulonglong" c-type (>>stack-align?)
|
||||
>>
|
||||
|
||||
M: linux reserved-area-size 2 ;
|
||||
|
||||
M: linux lr-save 1 ;
|
||||
|
||||
M: float-regs param-regs { 1 2 3 4 5 6 7 8 } ;
|
||||
|
||||
M: ppc value-structs? drop f ;
|
||||
|
||||
M: ppc fp-shadows-int? drop f ;
|
|
@ -0,0 +1 @@
|
|||
unportable
|
|
@ -0,0 +1,20 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors system kernel alien.c-types cpu.architecture cpu.ppc ;
|
||||
IN: cpu.ppc.macosx
|
||||
|
||||
<<
|
||||
4 "longlong" c-type (>>align)
|
||||
4 "ulonglong" c-type (>>align)
|
||||
4 "double" c-type (>>align)
|
||||
>>
|
||||
|
||||
M: macosx reserved-area-size 6 ;
|
||||
|
||||
M: macosx lr-save 2 ;
|
||||
|
||||
M: float-regs param-regs { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
|
||||
|
||||
M: ppc value-structs? drop t ;
|
||||
|
||||
M: ppc fp-shadows-int? drop t ;
|
|
@ -0,0 +1 @@
|
|||
unportable
|
|
@ -15,18 +15,6 @@ IN: cpu.ppc
|
|||
! f0-f29: float vregs
|
||||
! f30, f31: float scratch
|
||||
|
||||
<< {
|
||||
{ [ os macosx? ] [
|
||||
4 "longlong" c-type (>>align)
|
||||
4 "ulonglong" c-type (>>align)
|
||||
4 "double" c-type (>>align)
|
||||
] }
|
||||
{ [ os linux? ] [
|
||||
t "longlong" c-type (>>stack-align?)
|
||||
t "ulonglong" c-type (>>stack-align?)
|
||||
] }
|
||||
} cond >>
|
||||
|
||||
M: ppc machine-registers
|
||||
{
|
||||
{ int-regs T{ range f 2 26 1 } }
|
||||
|
@ -65,17 +53,8 @@ M: ppc %replace loc>operand STW ;
|
|||
M: ppc %inc-d ( n -- ) ds-reg (%inc) ;
|
||||
M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
|
||||
|
||||
: reserved-area-size ( -- n )
|
||||
os {
|
||||
{ linux [ 2 ] }
|
||||
{ macosx [ 6 ] }
|
||||
} case cells ; foldable
|
||||
|
||||
: lr-save ( -- n )
|
||||
os {
|
||||
{ linux [ 1 ] }
|
||||
{ macosx [ 2 ] }
|
||||
} case cells ; foldable
|
||||
HOOK: reserved-area-size os ( -- n )
|
||||
HOOK: lr-save os ( -- n )
|
||||
|
||||
: param@ ( n -- x ) reserved-area-size + ; inline
|
||||
|
||||
|
@ -458,11 +437,6 @@ M: ppc %loop-entry ;
|
|||
M: int-regs return-reg drop 3 ;
|
||||
M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ;
|
||||
M: float-regs return-reg drop 1 ;
|
||||
M: float-regs param-regs
|
||||
drop os H{
|
||||
{ macosx { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
|
||||
{ linux { 1 2 3 4 5 6 7 8 } }
|
||||
} at ;
|
||||
|
||||
M: int-regs %save-param-reg drop 1 rot local@ STW ;
|
||||
M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
|
||||
|
@ -585,13 +559,6 @@ M: ppc %callback-value ( ctype -- )
|
|||
! Unbox former top of data stack to return registers
|
||||
unbox-return ;
|
||||
|
||||
M: ppc value-structs?
|
||||
#! On Linux/PPC, value structs are passed in the same way
|
||||
#! as reference structs, we just have to make a copy first.
|
||||
os linux? not ;
|
||||
|
||||
M: ppc fp-shadows-int? ( -- ? ) os macosx? ;
|
||||
|
||||
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
|
||||
|
||||
M: ppc struct-small-enough? ( size -- ? ) drop f ;
|
||||
|
@ -601,3 +568,10 @@ M: ppc %box-small-struct
|
|||
|
||||
M: ppc %unbox-small-struct
|
||||
drop "No small structs" throw ;
|
||||
|
||||
USE: vocabs.loader
|
||||
|
||||
{
|
||||
{ [ os macosx? ] [ "cpu.ppc.macosx" require ] }
|
||||
{ [ os linux? ] [ "cpu.ppc.linux" require ] }
|
||||
} cond
|
||||
|
|
|
@ -26,6 +26,8 @@ M: x86.32 stack-reg ESP ;
|
|||
M: x86.32 temp-reg-1 EAX ;
|
||||
M: x86.32 temp-reg-2 ECX ;
|
||||
|
||||
M: x86.32 reserved-area-size 0 ;
|
||||
|
||||
M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
|
||||
|
||||
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
|
||||
|
|
|
@ -6,6 +6,7 @@ IN: bootstrap.x86
|
|||
|
||||
4 \ cell set
|
||||
|
||||
: stack-frame-size ( -- n ) 4 bootstrap-cells ;
|
||||
: shift-arg ( -- reg ) ECX ;
|
||||
: div-arg ( -- reg ) EAX ;
|
||||
: mod-arg ( -- reg ) EDX ;
|
||||
|
|
|
@ -24,14 +24,12 @@ M: x86.64 stack-reg RSP ;
|
|||
M: x86.64 temp-reg-1 RAX ;
|
||||
M: x86.64 temp-reg-2 RCX ;
|
||||
|
||||
: param-reg-1 int-regs param-regs first ; inline
|
||||
: param-reg-2 int-regs param-regs second ; inline
|
||||
|
||||
M: int-regs return-reg drop RAX ;
|
||||
M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
|
||||
|
||||
M: float-regs return-reg drop XMM0 ;
|
||||
|
||||
M: float-regs param-regs
|
||||
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
|
||||
|
||||
M: x86.64 rel-literal-x86 rc-relative rel-literal ;
|
||||
|
||||
M: x86.64 %prologue ( n -- )
|
||||
|
@ -90,7 +88,7 @@ M: struct-type flatten-value-type ( type -- seq )
|
|||
|
||||
M: x86.64 %prepare-unbox ( -- )
|
||||
! First parameter is top of stack
|
||||
RDI R14 [] MOV
|
||||
param-reg-1 R14 [] MOV
|
||||
R14 cell SUB ;
|
||||
|
||||
M: x86.64 %unbox ( n reg-class func -- )
|
||||
|
@ -103,27 +101,27 @@ M: x86.64 %unbox-long-long ( n func -- )
|
|||
int-regs swap %unbox ;
|
||||
|
||||
: %unbox-struct-field ( c-type i -- )
|
||||
! Alien must be in RDI.
|
||||
RDI swap cells [+] swap reg-class>> {
|
||||
! Alien must be in param-reg-1.
|
||||
param-reg-1 swap cells [+] swap reg-class>> {
|
||||
{ int-regs [ int-regs get pop swap MOV ] }
|
||||
{ double-float-regs [ float-regs get pop swap MOVSD ] }
|
||||
} case ;
|
||||
|
||||
M: x86.64 %unbox-small-struct ( c-type -- )
|
||||
! Alien must be in RDI.
|
||||
! Alien must be in param-reg-1.
|
||||
"alien_offset" f %alien-invoke
|
||||
! Move alien_offset() return value to RDI so that we don't
|
||||
! Move alien_offset() return value to param-reg-1 so that we don't
|
||||
! clobber it.
|
||||
RDI RAX MOV
|
||||
param-reg-1 RAX MOV
|
||||
[
|
||||
flatten-small-struct [ %unbox-struct-field ] each-index
|
||||
] with-return-regs ;
|
||||
|
||||
M: x86.64 %unbox-large-struct ( n c-type -- )
|
||||
! Source is in RDI
|
||||
! Source is in param-reg-1
|
||||
heap-size
|
||||
! Load destination address
|
||||
RSI rot stack@ LEA
|
||||
param-reg-2 rot stack@ LEA
|
||||
! Load structure size
|
||||
RDX swap MOV
|
||||
! Copy the struct to the C stack
|
||||
|
@ -160,8 +158,8 @@ M: x86.64 %box-small-struct ( c-type -- )
|
|||
[
|
||||
[ flatten-small-struct [ %box-struct-field ] each-index ]
|
||||
[ RDX swap heap-size MOV ] bi
|
||||
RDI 0 box-struct-field@ MOV
|
||||
RSI 1 box-struct-field@ MOV
|
||||
param-reg-1 0 box-struct-field@ MOV
|
||||
param-reg-2 1 box-struct-field@ MOV
|
||||
"box_small_struct" f %alien-invoke
|
||||
] with-return-regs ;
|
||||
|
||||
|
@ -170,9 +168,9 @@ M: x86.64 %box-small-struct ( c-type -- )
|
|||
|
||||
M: x86.64 %box-large-struct ( n c-type -- )
|
||||
! Struct size is parameter 2
|
||||
RSI swap heap-size MOV
|
||||
param-reg-2 swap heap-size MOV
|
||||
! Compute destination address
|
||||
RDI swap struct-return@ LEA
|
||||
param-reg-1 swap struct-return@ LEA
|
||||
! Copy the struct from the C stack
|
||||
"box_value_struct" f %alien-invoke ;
|
||||
|
||||
|
@ -200,7 +198,7 @@ M: x86.64 %alien-indirect ( -- )
|
|||
RBP CALL ;
|
||||
|
||||
M: x86.64 %alien-callback ( quot -- )
|
||||
RDI swap %load-indirect
|
||||
param-reg-1 swap %load-indirect
|
||||
"c_to_factor" f %alien-invoke ;
|
||||
|
||||
M: x86.64 %callback-value ( ctype -- )
|
||||
|
@ -208,11 +206,11 @@ M: x86.64 %callback-value ( ctype -- )
|
|||
%prepare-unbox
|
||||
! Save top of data stack
|
||||
RSP 8 SUB
|
||||
RDI PUSH
|
||||
param-reg-1 PUSH
|
||||
! Restore data/call/retain stacks
|
||||
"unnest_stacks" f %alien-invoke
|
||||
! Put former top of data stack in RDI
|
||||
RDI POP
|
||||
! Put former top of data stack in param-reg-1
|
||||
param-reg-1 POP
|
||||
RSP 8 ADD
|
||||
! Unbox former top of data stack to return registers
|
||||
unbox-return ;
|
||||
|
@ -223,3 +221,10 @@ enable-alien-4-intrinsics
|
|||
|
||||
! SSE2 is always available on x86-64.
|
||||
enable-float-intrinsics
|
||||
|
||||
USE: vocabs.loader
|
||||
|
||||
{
|
||||
{ [ os unix? ] [ "cpu.x86.64.unix" require ] }
|
||||
{ [ os winnt? ] [ "cpu.x86.64.winnt" require ] }
|
||||
} cond
|
||||
|
|
|
@ -9,8 +9,6 @@ IN: bootstrap.x86
|
|||
: shift-arg ( -- reg ) RCX ;
|
||||
: div-arg ( -- reg ) RAX ;
|
||||
: mod-arg ( -- reg ) RDX ;
|
||||
: arg0 ( -- reg ) RDI ;
|
||||
: arg1 ( -- reg ) RSI ;
|
||||
: temp-reg ( -- reg ) RBX ;
|
||||
: stack-reg ( -- reg ) RSP ;
|
||||
: ds-reg ( -- reg ) R14 ;
|
||||
|
|
|
@ -0,0 +1,12 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bootstrap.image.private kernel namespaces system
|
||||
cpu.x86.assembler layouts vocabs parser ;
|
||||
IN: bootstrap.x86
|
||||
|
||||
: stack-frame-size ( -- n ) 4 bootstrap-cells ;
|
||||
: arg0 ( -- reg ) RDI ;
|
||||
: arg1 ( -- reg ) RSI ;
|
||||
|
||||
<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
|
||||
call
|
|
@ -0,0 +1 @@
|
|||
unportable
|
|
@ -0,0 +1,12 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel layouts system compiler.cfg.registers
|
||||
cpu.architecture cpu.x86.assembler cpu.x86 ;
|
||||
IN: cpu.x86.64.unix
|
||||
|
||||
M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
|
||||
|
||||
M: float-regs param-regs
|
||||
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
|
||||
|
||||
M: x86.64 reserved-area-size 0 ;
|
|
@ -0,0 +1,12 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bootstrap.image.private kernel namespaces system
|
||||
cpu.x86.assembler layouts vocabs parser ;
|
||||
IN: bootstrap.x86
|
||||
|
||||
: stack-frame-size ( -- n ) 8 bootstrap-cells ;
|
||||
: arg0 ( -- reg ) RCX ;
|
||||
: arg1 ( -- reg ) RDX ;
|
||||
|
||||
<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
|
||||
call
|
|
@ -0,0 +1 @@
|
|||
unportable
|
|
@ -0,0 +1,17 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel layouts system alien.c-types compiler.cfg.registers
|
||||
cpu.architecture cpu.x86.assembler cpu.x86 ;
|
||||
IN: cpu.x86.64.winnt
|
||||
|
||||
M: int-regs param-regs drop { RCX RDX R8 R9 } ;
|
||||
|
||||
M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ;
|
||||
|
||||
M: x86.64 reserved-area-size 4 cells ;
|
||||
|
||||
<<
|
||||
"longlong" "ptrdiff_t" typedef
|
||||
"int" "long" typedef
|
||||
"uint" "ulong" typedef
|
||||
>>
|
|
@ -10,8 +10,6 @@ big-endian off
|
|||
|
||||
1 jit-code-format set
|
||||
|
||||
: stack-frame-size ( -- n ) 4 bootstrap-cells ;
|
||||
|
||||
[
|
||||
! Load word
|
||||
temp-reg 0 MOV
|
||||
|
@ -30,7 +28,7 @@ big-endian off
|
|||
temp-reg 0 MOV ! load XT
|
||||
stack-frame-size PUSH ! save stack frame size
|
||||
temp-reg PUSH ! push XT
|
||||
arg1 PUSH ! alignment
|
||||
stack-reg stack-frame-size 3 bootstrap-cells - SUB ! alignment
|
||||
] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define
|
||||
|
||||
[
|
||||
|
@ -302,14 +300,14 @@ big-endian off
|
|||
shift-arg ds-reg [] MOV ! load shift count
|
||||
shift-arg tag-bits get SAR ! untag shift count
|
||||
ds-reg bootstrap-cell SUB ! adjust stack pointer
|
||||
arg0 ds-reg [] MOV ! load value
|
||||
arg1 arg0 MOV ! make a copy
|
||||
temp-reg ds-reg [] MOV ! load value
|
||||
arg1 temp-reg MOV ! make a copy
|
||||
arg1 CL SHL ! compute positive shift value in arg1
|
||||
shift-arg NEG ! compute negative shift value in arg0
|
||||
arg0 CL SAR
|
||||
arg0 tag-mask get bitnot AND
|
||||
temp-reg CL SAR
|
||||
temp-reg tag-mask get bitnot AND
|
||||
shift-arg 0 CMP ! if shift count was negative, move arg0 to arg1
|
||||
arg1 arg0 CMOVGE
|
||||
arg1 temp-reg CMOVGE
|
||||
ds-reg [] arg1 MOV ! push to stack
|
||||
] f f f \ fixnum-shift-fast define-sub-primitive
|
||||
|
||||
|
|
|
@ -39,12 +39,15 @@ M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
|
|||
: align-stack ( n -- n' )
|
||||
os macosx? cpu x86.64? or [ 16 align ] when ;
|
||||
|
||||
HOOK: reserved-area-size cpu ( -- n )
|
||||
|
||||
M: x86 stack-frame-size ( stack-frame -- i )
|
||||
[ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
|
||||
[ params>> ]
|
||||
[ return>> ]
|
||||
tri + +
|
||||
3 cells +
|
||||
reserved-area-size +
|
||||
align-stack ;
|
||||
|
||||
M: x86 %call ( label -- ) CALL ;
|
||||
|
@ -465,7 +468,7 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
|
|||
: stack@ ( n -- op ) stack-reg swap [+] ;
|
||||
|
||||
: spill-integer-base ( stack-frame -- n )
|
||||
[ params>> ] [ return>> ] bi + ;
|
||||
[ params>> ] [ return>> ] bi + reserved-area-size + ;
|
||||
|
||||
: spill-integer@ ( n -- op )
|
||||
cells
|
||||
|
@ -473,10 +476,9 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
|
|||
+ stack@ ;
|
||||
|
||||
: spill-float-base ( stack-frame -- n )
|
||||
[ spill-integer-base ]
|
||||
[ spill-counts>> int-regs swap at int-regs reg-size * ]
|
||||
[ params>> ]
|
||||
[ return>> ]
|
||||
tri + + ;
|
||||
bi + ;
|
||||
|
||||
: spill-float@ ( n -- op )
|
||||
double-float-regs reg-size *
|
||||
|
|
|
@ -76,6 +76,25 @@ IN: math.functions.tests
|
|||
gcd nip
|
||||
] unit-test
|
||||
|
||||
[ 11 ] [
|
||||
13262642990609552931815424
|
||||
159151715887314635181785
|
||||
gcd nip
|
||||
] unit-test
|
||||
|
||||
[ 3 ] [
|
||||
13262642990609552931
|
||||
1591517158873146351
|
||||
gcd nip
|
||||
] unit-test
|
||||
|
||||
[ 26525285981219 ] [
|
||||
132626429906095
|
||||
159151715887314
|
||||
gcd nip
|
||||
] unit-test
|
||||
|
||||
|
||||
: verify-gcd ( a b -- ? )
|
||||
2dup gcd
|
||||
>r rot * swap rem r> = ;
|
||||
|
|
|
@ -60,10 +60,11 @@ check_gcc_version() {
|
|||
GCC_VERSION=`$CC --version`
|
||||
check_ret gcc
|
||||
if [[ $GCC_VERSION == *3.3.* ]] ; then
|
||||
$ECHO "bad!"
|
||||
$ECHO "You have a known buggy version of gcc (3.3)"
|
||||
$ECHO "Install gcc 3.4 or higher and try again."
|
||||
exit 3
|
||||
elif [[ $GCC_VERSION == *4.3.* ]] ; then
|
||||
MAKE_OPTS="$MAKE_OPTS SITE_CFLAGS=-fno-forward-propagate"
|
||||
fi
|
||||
$ECHO "ok."
|
||||
}
|
||||
|
@ -271,18 +272,18 @@ check_os_arch_word() {
|
|||
set_build_info() {
|
||||
check_os_arch_word
|
||||
MAKE_TARGET=$OS-$ARCH-$WORD
|
||||
MAKE_IMAGE_TARGET=$ARCH.$WORD
|
||||
BOOT_IMAGE=boot.$ARCH.$WORD.image
|
||||
if [[ $OS == macosx && $ARCH == ppc ]] ; then
|
||||
MAKE_IMAGE_TARGET=$OS-$ARCH
|
||||
MAKE_TARGET=$OS-$ARCH
|
||||
BOOT_IMAGE=boot.macosx-ppc.image
|
||||
fi
|
||||
if [[ $OS == linux && $ARCH == ppc ]] ; then
|
||||
MAKE_IMAGE_TARGET=$OS-$ARCH
|
||||
MAKE_TARGET=$OS-$ARCH
|
||||
BOOT_IMAGE=boot.linux-ppc.image
|
||||
MAKE_IMAGE_TARGET=macosx-ppc
|
||||
elif [[ $OS == linux && $ARCH == ppc ]] ; then
|
||||
MAKE_IMAGE_TARGET=linux-ppc
|
||||
elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then
|
||||
MAKE_IMAGE_TARGET=winnt-x86.64
|
||||
elif [[ $ARCH == x86 && $WORD == 64 ]] ; then
|
||||
MAKE_IMAGE_TARGET=unix-x86.64
|
||||
else
|
||||
MAKE_IMAGE_TARGET=$ARCH.$WORD
|
||||
fi
|
||||
BOOT_IMAGE=boot.$MAKE_IMAGE_TARGET.image
|
||||
}
|
||||
|
||||
parse_build_info() {
|
||||
|
@ -335,7 +336,7 @@ cd_factor() {
|
|||
}
|
||||
|
||||
invoke_make() {
|
||||
$MAKE $*
|
||||
$MAKE $MAKE_OPTS $*
|
||||
check_ret $MAKE
|
||||
}
|
||||
|
||||
|
|
|
@ -20,7 +20,8 @@ H{ } clone sub-primitives set
|
|||
|
||||
"resource:basis/cpu/" architecture get {
|
||||
{ "x86.32" "x86/32" }
|
||||
{ "x86.64" "x86/64" }
|
||||
{ "winnt-x86.64" "x86/64/winnt" }
|
||||
{ "unix-x86.64" "x86/64/unix" }
|
||||
{ "linux-ppc" "ppc/linux" }
|
||||
{ "macosx-ppc" "ppc/macosx" }
|
||||
{ "arm" "arm" }
|
||||
|
|
|
@ -101,8 +101,13 @@ unit-test
|
|||
[ 268435456 ] [ -268435456 >fixnum -1 /i ] unit-test
|
||||
[ 268435456 0 ] [ -268435456 >fixnum -1 /mod ] unit-test
|
||||
[ 0 ] [ -1 -268435456 >fixnum /i ] unit-test
|
||||
[ 4420880996869850977 ] [ 13262642990609552931 3 /i ] unit-test
|
||||
[ 0 -1 ] [ -1 -268435456 >fixnum /mod ] unit-test
|
||||
[ 0 -1 ] [ -1 -268435456 >bignum /mod ] unit-test
|
||||
[ 14355 ] [ 1591517158873146351817850880000000 32769 mod ] unit-test
|
||||
[ 8 530505719624382123 ] [ 13262642990609552931 1591517158873146351 /mod ] unit-test
|
||||
[ 8 ] [ 13262642990609552931 1591517158873146351 /i ] unit-test
|
||||
[ 530505719624382123 ] [ 13262642990609552931 1591517158873146351 mod ] unit-test
|
||||
|
||||
[ -351382792 ] [ -43922849 3 shift ] unit-test
|
||||
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel system accessors namespaces splitting sequences
|
||||
mason.config ;
|
||||
mason.config bootstrap.image ;
|
||||
IN: mason.platform
|
||||
|
||||
: platform ( -- string )
|
||||
|
@ -11,7 +11,7 @@ IN: mason.platform
|
|||
target-os get { "freebsd" "openbsd" "netbsd" } member? "gmake" "make" ? ;
|
||||
|
||||
: boot-image-arch ( -- string )
|
||||
target-cpu get dup "ppc" = [ target-os get "-" append prepend ] when ;
|
||||
target-os get target-cpu get arch ;
|
||||
|
||||
: boot-image-name ( -- string )
|
||||
"boot." boot-image-arch ".image" 3append ;
|
||||
|
|
|
@ -12,7 +12,7 @@ USING: mason.release.branch mason.config tools.test namespaces ;
|
|||
] with-scope
|
||||
] unit-test
|
||||
|
||||
[ { "scp" "boot.x86.64.image" "joe@blah.com:/stuff/clean/netbsd-x86-64" } ] [
|
||||
[ { "scp" "boot.unix-x86.64.image" "joe@blah.com:/stuff/clean/netbsd-x86-64" } ] [
|
||||
[
|
||||
"joe" image-username set
|
||||
"blah.com" image-host set
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
#WIN64_PATH=/k/MinGW/win64/bin
|
||||
WIN64_PATH=/cygdrive/k/MinGW/win64/bin/x86_64-pc-mingw32
|
||||
#WIN64_PATH=/cygdrive/k/MinGW/win64/bin/x86_64-pc-mingw32
|
||||
CC=$(WIN64_PATH)-gcc.exe
|
||||
WINDRES=$(WIN64_PATH)-windres.exe
|
||||
include vm/Config.windows.nt
|
||||
|
|
27
vm/bignum.c
27
vm/bignum.c
|
@ -1,7 +1,7 @@
|
|||
/* :tabSize=2:indentSize=2:noTabs=true:
|
||||
|
||||
Copyright (C) 1989-94 Massachusetts Institute of Technology
|
||||
Portions copyright (C) 2004-2007 Slava Pestov
|
||||
Portions copyright (C) 2004-2008 Slava Pestov
|
||||
|
||||
This material was developed by the Scheme project at the Massachusetts
|
||||
Institute of Technology, Department of Electrical Engineering and
|
||||
|
@ -45,6 +45,7 @@ MIT in each case. */
|
|||
* - Remove unused functions
|
||||
* - Add local variable GC root recording
|
||||
* - Remove s48 prefix from function names
|
||||
* - Various fixes for Win64
|
||||
*/
|
||||
|
||||
#include "master.h"
|
||||
|
@ -366,8 +367,6 @@ bignum_remainder(bignum_type numerator, bignum_type denominator)
|
|||
/* all below allocate memory */
|
||||
FOO_TO_BIGNUM(cell,CELL,CELL)
|
||||
FOO_TO_BIGNUM(fixnum,F_FIXNUM,CELL)
|
||||
FOO_TO_BIGNUM(long,long,unsigned long)
|
||||
FOO_TO_BIGNUM(ulong,unsigned long,unsigned long)
|
||||
FOO_TO_BIGNUM(long_long,s64,u64)
|
||||
FOO_TO_BIGNUM(ulong_long,u64,u64)
|
||||
|
||||
|
@ -389,8 +388,6 @@ FOO_TO_BIGNUM(ulong_long,u64,u64)
|
|||
/* all of the below allocate memory */
|
||||
BIGNUM_TO_FOO(cell,CELL,CELL);
|
||||
BIGNUM_TO_FOO(fixnum,F_FIXNUM,CELL);
|
||||
BIGNUM_TO_FOO(long,long,unsigned long)
|
||||
BIGNUM_TO_FOO(ulong,unsigned long,unsigned long)
|
||||
BIGNUM_TO_FOO(long_long,s64,u64)
|
||||
BIGNUM_TO_FOO(ulong_long,u64,u64)
|
||||
|
||||
|
@ -435,7 +432,7 @@ double_to_bignum(double x)
|
|||
bignum_digit_type digit;
|
||||
int odd_bits = (exponent % BIGNUM_DIGIT_LENGTH);
|
||||
if (odd_bits > 0)
|
||||
DTB_WRITE_DIGIT (1L << odd_bits);
|
||||
DTB_WRITE_DIGIT ((F_FIXNUM)1 << odd_bits);
|
||||
while (start < scan)
|
||||
{
|
||||
if (significand == 0)
|
||||
|
@ -1117,7 +1114,7 @@ bignum_destructive_normalization(bignum_type source, bignum_type target,
|
|||
bignum_digit_type * end_source = (scan_source + (BIGNUM_LENGTH (source)));
|
||||
bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target)));
|
||||
int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left);
|
||||
bignum_digit_type mask = ((1L << shift_right) - 1);
|
||||
bignum_digit_type mask = (((CELL)1 << shift_right) - 1);
|
||||
while (scan_source < end_source)
|
||||
{
|
||||
digit = (*scan_source++);
|
||||
|
@ -1139,7 +1136,7 @@ bignum_destructive_unnormalization(bignum_type bignum, int shift_right)
|
|||
bignum_digit_type digit;
|
||||
bignum_digit_type carry = 0;
|
||||
int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right);
|
||||
bignum_digit_type mask = ((1L << shift_right) - 1);
|
||||
bignum_digit_type mask = (((F_FIXNUM)1 << shift_right) - 1);
|
||||
while (start < scan)
|
||||
{
|
||||
digit = (*--scan);
|
||||
|
@ -1489,7 +1486,7 @@ bignum_bitwise_not(bignum_type x)
|
|||
|
||||
/* allocates memory */
|
||||
bignum_type
|
||||
bignum_arithmetic_shift(bignum_type arg1, long n)
|
||||
bignum_arithmetic_shift(bignum_type arg1, F_FIXNUM n)
|
||||
{
|
||||
if (BIGNUM_NEGATIVE_P(arg1) && n < 0)
|
||||
return bignum_bitwise_not(bignum_magnitude_ash(bignum_bitwise_not(arg1), n));
|
||||
|
@ -1550,14 +1547,14 @@ bignum_bitwise_xor(bignum_type arg1, bignum_type arg2)
|
|||
/* ash for the magnitude */
|
||||
/* assume arg1 is a big number, n is a long */
|
||||
bignum_type
|
||||
bignum_magnitude_ash(bignum_type arg1, long n)
|
||||
bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n)
|
||||
{
|
||||
bignum_type result = NULL;
|
||||
bignum_digit_type *scan1;
|
||||
bignum_digit_type *scanr;
|
||||
bignum_digit_type *end;
|
||||
|
||||
long digit_offset,bit_offset;
|
||||
F_FIXNUM digit_offset,bit_offset;
|
||||
|
||||
if (BIGNUM_ZERO_P (arg1)) return (arg1);
|
||||
|
||||
|
@ -1642,10 +1639,6 @@ bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
|
|||
while (scanr < endr) {
|
||||
digit1 = (scan1 < end1) ? *scan1++ : 0;
|
||||
digit2 = (scan2 < end2) ? *scan2++ : 0;
|
||||
/*
|
||||
fprintf(stderr, "[pospos op = %d, i = %ld, d1 = %lx, d2 = %lx]\n",
|
||||
op, endr - scanr, digit1, digit2);
|
||||
*/
|
||||
*scanr++ = (op == AND_OP) ? digit1 & digit2 :
|
||||
(op == IOR_OP) ? digit1 | digit2 :
|
||||
digit1 ^ digit2;
|
||||
|
@ -1856,8 +1849,8 @@ digit_stream_to_bignum(unsigned int n_digits,
|
|||
return (BIGNUM_ZERO ());
|
||||
if (n_digits == 1)
|
||||
{
|
||||
long digit = ((long) ((*producer) (0)));
|
||||
return (long_to_bignum (negative_p ? (- digit) : digit));
|
||||
F_FIXNUM digit = ((F_FIXNUM) ((*producer) (0)));
|
||||
return (fixnum_to_bignum (negative_p ? (- digit) : digit));
|
||||
}
|
||||
{
|
||||
bignum_length_type length;
|
||||
|
|
|
@ -55,14 +55,10 @@ bignum_type bignum_quotient(bignum_type, bignum_type);
|
|||
bignum_type bignum_remainder(bignum_type, bignum_type);
|
||||
DLLEXPORT bignum_type fixnum_to_bignum(F_FIXNUM);
|
||||
DLLEXPORT bignum_type cell_to_bignum(CELL);
|
||||
DLLEXPORT bignum_type long_to_bignum(long);
|
||||
DLLEXPORT bignum_type long_long_to_bignum(s64 n);
|
||||
DLLEXPORT bignum_type ulong_long_to_bignum(u64 n);
|
||||
DLLEXPORT bignum_type ulong_to_bignum(unsigned long);
|
||||
F_FIXNUM bignum_to_fixnum(bignum_type);
|
||||
CELL bignum_to_cell(bignum_type);
|
||||
long bignum_to_long(bignum_type);
|
||||
unsigned long bignum_to_ulong(bignum_type);
|
||||
s64 bignum_to_long_long(bignum_type);
|
||||
u64 bignum_to_ulong_long(bignum_type);
|
||||
bignum_type double_to_bignum(double);
|
||||
|
@ -71,7 +67,7 @@ double bignum_to_double(bignum_type);
|
|||
/* Added bitwise operators. */
|
||||
|
||||
DLLEXPORT bignum_type bignum_bitwise_not(bignum_type),
|
||||
bignum_arithmetic_shift(bignum_type, long),
|
||||
bignum_arithmetic_shift(bignum_type, F_FIXNUM),
|
||||
bignum_bitwise_and(bignum_type, bignum_type),
|
||||
bignum_bitwise_ior(bignum_type, bignum_type),
|
||||
bignum_bitwise_xor(bignum_type, bignum_type);
|
||||
|
@ -116,7 +112,7 @@ bignum_type bignum_maybe_new_sign(bignum_type, int);
|
|||
void bignum_destructive_copy(bignum_type, bignum_type);
|
||||
|
||||
/* Added for bitwise operations. */
|
||||
bignum_type bignum_magnitude_ash(bignum_type arg1, long n);
|
||||
bignum_type bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n);
|
||||
bignum_type bignum_pospos_bitwise_op(int op, bignum_type, bignum_type);
|
||||
bignum_type bignum_posneg_bitwise_op(int op, bignum_type, bignum_type);
|
||||
bignum_type bignum_negneg_bitwise_op(int op, bignum_type, bignum_type);
|
||||
|
|
|
@ -116,6 +116,8 @@ CELL frame_executing(F_STACK_FRAME *frame)
|
|||
|
||||
F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame)
|
||||
{
|
||||
if(frame->size == 0)
|
||||
critical_error("Stack frame has zero size",frame);
|
||||
return (F_STACK_FRAME *)((CELL)frame - frame->size);
|
||||
}
|
||||
|
||||
|
|
|
@ -11,6 +11,7 @@ and the callstack top is passed in EDX */
|
|||
#define RETURN_REG %eax
|
||||
|
||||
#define CELL_SIZE 4
|
||||
#define STACK_PADDING 12
|
||||
|
||||
#define PUSH_NONVOLATILE \
|
||||
push %ebx ; \
|
||||
|
|
|
@ -1,24 +1,55 @@
|
|||
#include "asm.h"
|
||||
|
||||
#define ARG0 %rdi
|
||||
#define ARG1 %rsi
|
||||
#define STACK_REG %rsp
|
||||
#define DS_REG %r14
|
||||
#define RETURN_REG %rax
|
||||
|
||||
#define CELL_SIZE 8
|
||||
#define STACK_PADDING 56
|
||||
|
||||
#define PUSH_NONVOLATILE \
|
||||
push %rbx ; \
|
||||
push %rbp ; \
|
||||
push %r12 ; \
|
||||
push %r13 ;
|
||||
#ifdef WINDOWS
|
||||
|
||||
#define POP_NONVOLATILE \
|
||||
pop %r13 ; \
|
||||
pop %r12 ; \
|
||||
pop %rbp ; \
|
||||
pop %rbx
|
||||
#define ARG0 %rcx
|
||||
#define ARG1 %rdx
|
||||
#define ARG2 %r8
|
||||
#define ARG3 %r9
|
||||
|
||||
#define PUSH_NONVOLATILE \
|
||||
push %r12 ; \
|
||||
push %r13 ; \
|
||||
push %rdi ; \
|
||||
push %rsi ; \
|
||||
push %rbx ; \
|
||||
push %rbp
|
||||
|
||||
#define POP_NONVOLATILE \
|
||||
pop %rbp ; \
|
||||
pop %rbx ; \
|
||||
pop %rsi ; \
|
||||
pop %rdi ; \
|
||||
pop %r13 ; \
|
||||
pop %r12
|
||||
|
||||
#else
|
||||
|
||||
#define ARG0 %rdi
|
||||
#define ARG1 %rsi
|
||||
#define ARG2 %rdx
|
||||
#define ARG3 %rcx
|
||||
|
||||
#define PUSH_NONVOLATILE \
|
||||
push %rbx ; \
|
||||
push %rbp ; \
|
||||
push %r12 ; \
|
||||
push %r13
|
||||
|
||||
#define POP_NONVOLATILE \
|
||||
pop %r13 ; \
|
||||
pop %r12 ; \
|
||||
pop %rbp ; \
|
||||
pop %rbx
|
||||
|
||||
#endif
|
||||
|
||||
#define QUOT_XT_OFFSET 21
|
||||
|
||||
|
@ -26,9 +57,9 @@
|
|||
ABI limitation which would otherwise require us to do a bizzaro PC-relative
|
||||
trampoline to retrieve the function address */
|
||||
DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)):
|
||||
sub %rdx,%rdi /* compute new stack pointer */
|
||||
mov %rdi,%rsp
|
||||
call *%rcx /* call memcpy */
|
||||
sub ARG2,ARG0 /* compute new stack pointer */
|
||||
mov ARG0,%rsp
|
||||
call *ARG3 /* call memcpy */
|
||||
ret /* return _with new stack_ */
|
||||
|
||||
#include "cpu-x86.S"
|
||||
|
|
27
vm/cpu-x86.S
27
vm/cpu-x86.S
|
@ -1,31 +1,34 @@
|
|||
DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
|
||||
PUSH_NONVOLATILE
|
||||
push ARG0 /* Save quot */
|
||||
push ARG0
|
||||
|
||||
lea -CELL_SIZE(STACK_REG),ARG0 /* Save stack pointer */
|
||||
/* Save stack pointer */
|
||||
lea -CELL_SIZE(STACK_REG),ARG0
|
||||
|
||||
/* Create register shadow area for Win64 */
|
||||
sub $32,STACK_REG
|
||||
call MANGLE(save_callstack_bottom)
|
||||
add $32,STACK_REG
|
||||
|
||||
mov (STACK_REG),ARG0 /* Pass quot as arg 1 */
|
||||
call *QUOT_XT_OFFSET(ARG0) /* Call quot-xt */
|
||||
/* Call quot-xt */
|
||||
mov (STACK_REG),ARG0
|
||||
call *QUOT_XT_OFFSET(ARG0)
|
||||
|
||||
POP ARG0
|
||||
pop ARG0
|
||||
POP_NONVOLATILE
|
||||
ret
|
||||
|
||||
DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
|
||||
mov ARG1,STACK_REG /* rewind_to */
|
||||
/* rewind_to */
|
||||
mov ARG1,STACK_REG
|
||||
jmp *QUOT_XT_OFFSET(ARG0)
|
||||
|
||||
DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
|
||||
mov STACK_REG,ARG1 /* Save stack pointer */
|
||||
push ARG1 /* Alignment */
|
||||
push ARG1
|
||||
push ARG1
|
||||
sub $STACK_PADDING,STACK_REG
|
||||
call MANGLE(primitive_jit_compile)
|
||||
mov RETURN_REG,ARG0 /* No-op on 32-bit */
|
||||
pop ARG1 /* OK to clobber ARG1 here */
|
||||
pop ARG1
|
||||
pop ARG1
|
||||
add $STACK_PADDING,STACK_REG
|
||||
jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
|
||||
|
||||
#ifdef WINDOWS
|
||||
|
|
|
@ -438,6 +438,8 @@ void collect_gen_cards(CELL gen)
|
|||
old->new references */
|
||||
void collect_cards(void)
|
||||
{
|
||||
GC_PRINT("Collect cards\n");
|
||||
|
||||
int i;
|
||||
for(i = collecting_gen + 1; i < data_heap->gen_count; i++)
|
||||
collect_gen_cards(i);
|
||||
|
@ -465,7 +467,10 @@ void collect_callstack(F_CONTEXT *stacks)
|
|||
{
|
||||
CELL top = (CELL)stacks->callstack_top;
|
||||
CELL bottom = (CELL)stacks->callstack_bottom;
|
||||
|
||||
GC_PRINT("Collect callstack %ld %ld\n",top,bottom);
|
||||
iterate_callstack(top,bottom,collect_stack_frame);
|
||||
GC_PRINT("Done\n");
|
||||
}
|
||||
}
|
||||
|
||||
|
@ -481,6 +486,7 @@ void collect_gc_locals(void)
|
|||
the user environment and extra roots registered with REGISTER_ROOT */
|
||||
void collect_roots(void)
|
||||
{
|
||||
GC_PRINT("Collect roots\n");
|
||||
copy_handle(&T);
|
||||
copy_handle(&bignum_zero);
|
||||
copy_handle(&bignum_pos_one);
|
||||
|
|
|
@ -129,17 +129,17 @@ void divide_by_zero_error(F_STACK_FRAME *native_stack)
|
|||
|
||||
void memory_signal_handler_impl(void)
|
||||
{
|
||||
memory_protection_error(signal_fault_addr,signal_callstack_top);
|
||||
memory_protection_error(signal_fault_addr,signal_callstack_top);
|
||||
}
|
||||
|
||||
void divide_by_zero_signal_handler_impl(void)
|
||||
{
|
||||
divide_by_zero_error(signal_callstack_top);
|
||||
divide_by_zero_error(signal_callstack_top);
|
||||
}
|
||||
|
||||
void misc_signal_handler_impl(void)
|
||||
{
|
||||
signal_error(signal_number,signal_callstack_top);
|
||||
signal_error(signal_number,signal_callstack_top);
|
||||
}
|
||||
|
||||
DEFINE_PRIMITIVE(throw)
|
||||
|
|
|
@ -167,7 +167,6 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
|
|||
}
|
||||
|
||||
init_factor(&p);
|
||||
|
||||
nest_stacks();
|
||||
|
||||
F_ARRAY *args = allot_array(ARRAY_TYPE,argc,F);
|
||||
|
|
|
@ -1,2 +1,2 @@
|
|||
fraptor ICON "misc/icons/Factor.ico"
|
||||
|
||||
fraptor ICON "misc/icons/Factor.ico"
|
||||
|
||||
|
|
|
@ -363,13 +363,13 @@ CELL unbox_array_size(void)
|
|||
case BIGNUM_TYPE:
|
||||
{
|
||||
bignum_type zero = untag_object(bignum_zero);
|
||||
bignum_type max = ulong_to_bignum(ARRAY_SIZE_MAX);
|
||||
bignum_type max = cell_to_bignum(ARRAY_SIZE_MAX);
|
||||
bignum_type n = untag_object(dpeek());
|
||||
if(bignum_compare(n,zero) != bignum_comparison_less
|
||||
&& bignum_compare(n,max) == bignum_comparison_less)
|
||||
{
|
||||
dpop();
|
||||
return bignum_to_ulong(n);
|
||||
return bignum_to_cell(n);
|
||||
}
|
||||
break;
|
||||
}
|
||||
|
|
Loading…
Reference in New Issue