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

db4
Peter Burns 2008-11-07 20:00:42 -08:00
commit bca998bba5
69 changed files with 1112 additions and 550 deletions

View File

@ -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 $@ $<

View File

@ -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

View File

@ -1,6 +1,6 @@
USING: alien.strings tools.test kernel libc
io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
io.encodings.ascii alien ;
io.encodings.ascii alien io.encodings.string ;
IN: alien.strings.tests
[ "\u0000ff" ]
@ -28,3 +28,7 @@ unit-test
] unit-test
[ f ] [ f utf8 alien>string ] unit-test
[ "hello" ] [ "hello" utf16 encode utf16 decode ] unit-test
[ "hello" ] [ "hello" utf16 string>alien utf16 alien>string ] unit-test

View File

@ -12,9 +12,15 @@ io.encodings.binary math.order math.private accessors
slots.private compiler.units ;
IN: bootstrap.image
: arch ( os cpu -- arch )
{
{ "ppc" [ name>> "-ppc" append ] }
{ "x86.64" [ name>> "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"
} ;

View File

@ -125,23 +125,61 @@ M: #recursive emit-node
: ##branch-t ( vreg -- )
\ f tag-number cc/= ##compare-imm-branch ;
: trivial-branch? ( nodes -- value ? )
dup length 1 = [
first dup #push? [ literal>> t ] [ drop f f ] if
] [ drop f f ] if ;
: trivial-if? ( #if -- ? )
children>> first2
[ trivial-branch? [ t eq? ] when ]
[ trivial-branch? [ f eq? ] when ] bi*
and ;
: emit-trivial-if ( -- )
ds-pop \ f tag-number cc/= ^^compare-imm ds-push ;
: trivial-not-if? ( #if -- ? )
children>> first2
[ trivial-branch? [ f eq? ] when ]
[ trivial-branch? [ t eq? ] when ] bi*
and ;
: emit-trivial-not-if ( -- )
ds-pop \ f tag-number cc= ^^compare-imm ds-push ;
M: #if emit-node
ds-pop ##branch-t emit-if iterate-next ;
{
{ [ dup trivial-if? ] [ drop emit-trivial-if ] }
{ [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
[ ds-pop ##branch-t emit-if ]
} cond iterate-next ;
! #dispatch
: trivial-dispatch-branch? ( nodes -- ? )
dup length 1 = [
first dup #call? [
word>> "intrinsic" word-prop not
] [ drop f ] if
] [ drop f ] if ;
: dispatch-branch ( nodes word -- label )
gensym [
[
V{ } clone node-stack set
##prologue
emit-nodes
basic-block get [
##epilogue
##return
end-basic-block
] when
] with-cfg-builder
] keep ;
over trivial-dispatch-branch? [
drop first word>>
] [
gensym [
[
V{ } clone node-stack set
##prologue
emit-nodes
basic-block get [
##epilogue
##return
end-basic-block
] when
] with-cfg-builder
] keep
] if ;
: dispatch-branches ( node -- )
children>> [

View File

@ -15,7 +15,7 @@ IN: compiler.cfg.intrinsics.alien
: prepare-alien-accessor ( infos -- offset-vreg )
<reversed> [ second class>> ] [ first ] bi
dup value-info-small-tagged? [
dup value-info-small-fixnum? [
literal>> (prepare-alien-accessor-imm)
] [ drop (prepare-alien-accessor) ] if ;

View File

@ -9,7 +9,10 @@ IN: compiler.cfg.intrinsics.fixnum
: (emit-fixnum-imm-op) ( infos insn -- dst )
ds-drop
[ ds-pop ] [ second literal>> tag-fixnum ] [ ] tri*
[ ds-pop ]
[ second literal>> [ tag-fixnum ] [ \ f tag-number ] if* ]
[ ]
tri*
call ; inline
: (emit-fixnum-op) ( insn -- dst )
@ -25,7 +28,7 @@ IN: compiler.cfg.intrinsics.fixnum
] ; inline
: emit-fixnum-shift-fast ( node -- )
dup node-input-infos dup second value-info-small-tagged? [
dup node-input-infos dup second value-info-small-fixnum? [
nip
[ ds-drop ds-pop ] dip
second literal>> dup sgn {
@ -48,7 +51,7 @@ IN: compiler.cfg.intrinsics.fixnum
: emit-fixnum*fast ( node -- )
node-input-infos
dup second value-info-small-tagged?
dup second value-info-small-fixnum?
[ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
ds-push ;

View File

@ -25,7 +25,7 @@ IN: compiler.cfg.intrinsics.slots
dup node-input-infos
dup first value-tag [
nip
dup second value-info-small-tagged?
dup second value-info-small-fixnum?
[ (emit-slot-imm) ] [ (emit-slot) ] if
ds-push
] [ drop emit-primitive ] if ;
@ -46,7 +46,7 @@ IN: compiler.cfg.intrinsics.slots
dup second value-tag [
nip
[
dup third value-info-small-tagged?
dup third value-info-small-fixnum?
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
] [ first class>> immediate class<= ] bi
[ drop ] [ i i ##write-barrier ] if

View File

@ -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

View File

@ -1,12 +1,24 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math layouts make sequences
USING: accessors kernel math layouts make sequences combinators
cpu.architecture namespaces compiler.cfg
compiler.cfg.instructions ;
IN: compiler.cfg.utilities
: value-info-small-fixnum? ( value-info -- ? )
literal>> {
{ [ dup fixnum? ] [ tag-fixnum small-enough? ] }
[ drop f ]
} cond ;
: value-info-small-tagged? ( value-info -- ? )
literal>> dup fixnum? [ tag-fixnum small-enough? ] [ drop f ] if ;
dup literal?>> [
literal>> {
{ [ dup fixnum? ] [ tag-fixnum small-enough? ] }
{ [ dup not ] [ drop t ] }
[ drop f ]
} cond
] [ drop f ] if ;
: set-basic-block ( basic-block -- )
[ basic-block set ] [ instructions>> building set ] bi ;

View File

@ -42,25 +42,75 @@ M: ##mul-imm rewrite
: tag-fixnum-expr? ( expr -- ? )
dup op>> \ ##shl-imm eq?
[ in2>> vn>expr value>> tag-bits get = ] [ drop f ] if ;
[ in2>> vn>constant tag-bits get = ] [ drop f ] if ;
: rewrite-tagged-comparison? ( insn -- ? )
#! Are we comparing two tagged fixnums? Then untag them.
dup ##compare-imm-branch? [
[ src1>> vreg>expr tag-fixnum-expr? ]
[ src2>> tag-mask get bitand 0 = ]
bi and
] [ drop f ] if ; inline
[ src1>> vreg>expr tag-fixnum-expr? ]
[ src2>> tag-mask get bitand 0 = ]
bi and ; inline
: rewrite-tagged-comparison ( insn -- insn' )
: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
[ src1>> vreg>expr in1>> vn>vreg ]
[ src2>> tag-bits get neg shift ]
[ cc>> ]
tri
f \ ##compare-imm-branch boa ;
tri ; inline
GENERIC: rewrite-tagged-comparison ( insn -- insn' )
M: ##compare-imm-branch rewrite-tagged-comparison
(rewrite-tagged-comparison) f \ ##compare-imm-branch boa ;
M: ##compare-imm rewrite-tagged-comparison
[ dst>> ] [ (rewrite-tagged-comparison) ] bi
f \ ##compare-imm boa ;
M: ##compare-imm-branch rewrite
dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when ;
dup ##compare-imm-branch? [
dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when
] when ;
: flip-comparison? ( insn -- ? )
dup cc>> cc= eq? [ src1>> vreg>expr constant-expr? ] [ drop f ] if ;
: flip-comparison ( insn -- insn' )
[ dst>> ]
[ src2>> ]
[ src1>> vreg>vn vn>constant ] tri
cc= f \ ##compare-imm boa ;
M: ##compare rewrite
dup flip-comparison? [
flip-comparison
dup number-values
rewrite
] when ;
: rewrite-redundant-comparison? ( insn -- ? )
[ src1>> vreg>expr compare-expr? ]
[ src2>> \ f tag-number = ]
[ cc>> { cc= cc/= } memq? ]
tri and and ; inline
: rewrite-redundant-comparison ( insn -- insn' )
[ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
{ \ ##compare [ >compare-expr< f \ ##compare boa ] }
{ \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm boa ] }
{ \ ##compare-float [ >compare-expr< f \ ##compare-float boa ] }
} case
swap cc= eq? [ [ negate-cc ] change-cc ] when ;
M: ##compare-imm rewrite
dup rewrite-redundant-comparison? [
rewrite-redundant-comparison
dup number-values rewrite
] when
dup ##compare-imm? [
dup rewrite-tagged-comparison? [
rewrite-tagged-comparison
dup number-values rewrite
] when
] when ;
M: insn rewrite ;

View File

@ -1,6 +1,6 @@
IN: compiler.cfg.value-numbering.tests
USING: compiler.cfg.value-numbering compiler.cfg.instructions
compiler.cfg.registers cpu.architecture tools.test kernel ;
compiler.cfg.registers cpu.architecture tools.test kernel math ;
[
{
T{ ##peek f V int-regs 45 D 1 }
@ -66,3 +66,77 @@ compiler.cfg.registers cpu.architecture tools.test kernel ;
T{ ##replace f V int-regs 3 D 0 }
} value-numbering
] unit-test
[
{
T{ ##load-indirect f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
T{ ##replace f V int-regs 4 D 0 }
}
] [
{
T{ ##load-indirect f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
T{ ##replace f V int-regs 6 D 0 }
} value-numbering
] unit-test
[
{
T{ ##load-indirect f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
T{ ##replace f V int-regs 6 D 0 }
}
] [
{
T{ ##load-indirect f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }
T{ ##replace f V int-regs 6 D 0 }
} value-numbering
] unit-test
[
{
T{ ##peek f V int-regs 8 D 0 }
T{ ##peek f V int-regs 9 D -1 }
T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
T{ ##compare-float f V int-regs 14 V double-float-regs 10 V double-float-regs 11 cc>= }
T{ ##replace f V int-regs 14 D 0 }
}
] [
{
T{ ##peek f V int-regs 8 D 0 }
T{ ##peek f V int-regs 9 D -1 }
T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= }
T{ ##replace f V int-regs 14 D 0 }
} value-numbering
] unit-test
[
{
T{ ##peek f V int-regs 29 D -1 }
T{ ##peek f V int-regs 30 D -2 }
T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
T{ ##compare-branch f V int-regs 29 V int-regs 30 cc<= }
}
] [
{
T{ ##peek f V int-regs 29 D -1 }
T{ ##peek f V int-regs 30 D -2 }
T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
T{ ##compare-imm-branch f V int-regs 33 7 cc/= }
} value-numbering
] unit-test

View File

@ -1,49 +1,50 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel layouts system ;
USING: math kernel layouts system strings ;
IN: compiler.constants
! These constants must match vm/memory.h
: card-bits 8 ;
: deck-bits 18 ;
: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ;
: card-bits 8 ; inline
: deck-bits 18 ; inline
: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ; inline
! These constants must match vm/layouts.h
: header-offset ( -- n ) object tag-number neg ;
: float-offset ( -- n ) 8 float tag-number - ;
: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ;
: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ;
: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
: compiled-header-size ( -- n ) 4 bootstrap-cells ;
: header-offset ( -- n ) object tag-number neg ; inline
: float-offset ( -- n ) 8 float tag-number - ; inline
: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline
: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline
: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline
: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
! Relocation classes
: rc-absolute-cell 0 ;
: rc-absolute 1 ;
: rc-relative 2 ;
: rc-absolute-ppc-2/2 3 ;
: rc-relative-ppc-2 4 ;
: rc-relative-ppc-3 5 ;
: rc-relative-arm-3 6 ;
: rc-indirect-arm 7 ;
: rc-indirect-arm-pc 8 ;
: rc-absolute-cell 0 ; inline
: rc-absolute 1 ; inline
: rc-relative 2 ; inline
: rc-absolute-ppc-2/2 3 ; inline
: rc-relative-ppc-2 4 ; inline
: rc-relative-ppc-3 5 ; inline
: rc-relative-arm-3 6 ; inline
: rc-indirect-arm 7 ; inline
: rc-indirect-arm-pc 8 ; inline
! Relocation types
: rt-primitive 0 ;
: rt-dlsym 1 ;
: rt-literal 2 ;
: rt-dispatch 3 ;
: rt-xt 4 ;
: rt-here 5 ;
: rt-label 6 ;
: rt-immediate 7 ;
: rt-primitive 0 ; inline
: rt-dlsym 1 ; inline
: rt-literal 2 ; inline
: rt-dispatch 3 ; inline
: rt-xt 4 ; inline
: rt-here 5 ; inline
: rt-label 6 ; inline
: rt-immediate 7 ; inline
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]

View File

@ -4,7 +4,8 @@ continuations sequences.private hashtables.private byte-arrays
strings.private system random layouts vectors
sbufs strings.private slots.private alien math.order
alien.accessors alien.c-types alien.syntax alien.strings
namespaces libc sequences.private io.encodings.ascii ;
namespaces libc sequences.private io.encodings.ascii
classes ;
IN: compiler.tests
! Make sure that intrinsic ops compile to correct code.
@ -27,6 +28,9 @@ IN: compiler.tests
[ 1 ] [ { 1 2 } [ 2 slot ] compile-call ] unit-test
[ 1 ] [ [ { 1 2 } 2 slot ] compile-call ] unit-test
[ { f f } ] [ 2 f <array> ] unit-test
[ 3 ] [ 3 1 2 2array [ { array } declare [ 2 set-slot ] keep ] compile-call first ] unit-test
[ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
[ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
@ -37,13 +41,19 @@ IN: compiler.tests
! Write barrier hits on the wrong value were causing segfaults
[ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
! [ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test
! [ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test
! [ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test
!
! [ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
! [ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
! [ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
[ CHAR: a ] [ 0 "abc" [ string-nth ] compile-call ] unit-test
[ CHAR: a ] [ 0 [ "abc" string-nth ] compile-call ] unit-test
[ CHAR: a ] [ [ 0 "abc" string-nth ] compile-call ] unit-test
[ CHAR: b ] [ 1 "abc" [ string-nth ] compile-call ] unit-test
[ CHAR: b ] [ 1 [ "abc" string-nth ] compile-call ] unit-test
[ CHAR: b ] [ [ 1 "abc" string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ 0 "\u123456bc" [ string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ 0 [ "\u123456bc" string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ [ 0 "\u123456bc" string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ 1 "a\u123456c" [ string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ 1 [ "a\u123456c" string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ [ 1 "a\u123456c" string-nth ] compile-call ] unit-test
[ ] [ [ 0 getenv ] compile-call drop ] unit-test
[ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
@ -158,6 +168,10 @@ IN: compiler.tests
[ 4 ] [ 1 [ 3 fixnum+fast ] compile-call ] unit-test
[ 4 ] [ [ 1 3 fixnum+fast ] compile-call ] unit-test
[ -2 ] [ 1 3 [ fixnum-fast ] compile-call ] unit-test
[ -2 ] [ 1 [ 3 fixnum-fast ] compile-call ] unit-test
[ -2 ] [ [ 1 3 fixnum-fast ] compile-call ] unit-test
[ 30001 ] [ 1 [ 30000 fixnum+fast ] compile-call ] unit-test
[ 6 ] [ 2 3 [ fixnum*fast ] compile-call ] unit-test
@ -263,6 +277,8 @@ cell 8 = [
: compiled-fixnum>bignum fixnum>bignum ;
[ bignum ] [ 0 compiled-fixnum>bignum class ] unit-test
[ ] [
10000 [
32 random-bits >fixnum

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -0,0 +1 @@
unportable

View File

@ -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 ;

View File

@ -0,0 +1 @@
unportable

View File

@ -1,21 +1,10 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types
accessors
cpu.architecture
compiler.cfg.registers
cpu.ppc.assembler
kernel
locals
layouts
combinators
make
compiler.cfg.instructions
math.order
system
math
compiler.constants
namespaces compiler.codegen.fixup ;
USING: accessors assocs sequences kernel combinators make math
math.order math.ranges system namespaces locals layouts words
alien alien.c-types cpu.architecture cpu.ppc.assembler
compiler.cfg.registers compiler.cfg.instructions
compiler.constants compiler.codegen compiler.codegen.fixup ;
IN: cpu.ppc
! PowerPC register assignments:
@ -26,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 } }
@ -57,13 +34,13 @@ M:: ppc %load-indirect ( reg obj -- )
obj rc-absolute-ppc-2/2 rel-literal
reg reg 0 LWZ ;
: ds-reg 30 ; inline
: rs-reg 31 ; inline
: ds-reg 29 ; inline
: rs-reg 30 ; inline
GENERIC: loc-reg ( loc -- reg )
M: ds-loc log-reg drop ds-reg ;
M: rs-loc log-reg drop rs-reg ;
M: ds-loc loc-reg drop ds-reg ;
M: rs-loc loc-reg drop rs-reg ;
: loc>operand ( loc -- reg n )
[ loc-reg ] [ n>> cells neg ] bi ; inline
@ -76,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
@ -137,9 +105,25 @@ M: ppc %slot-imm ( dst obj slot tag -- ) (%slot-imm) LWZ ;
M: ppc %set-slot ( src obj slot tag temp -- ) (%slot) STW ;
M: ppc %set-slot-imm ( src obj slot tag -- ) (%slot-imm) STW ;
M:: ppc %string-nth ( dst src index temp -- )
[
"end" define-label
temp src index ADD
dst temp string-offset LBZ
temp src string-aux-offset LWZ
0 temp \ f tag-number CMPI
"end" get BEQ
temp temp index ADD
temp temp index ADD
temp temp byte-array-offset LHZ
temp temp 8 SLWI
dst dst temp OR
"end" resolve-label
] with-scope ;
M: ppc %add ADD ;
M: ppc %add-imm ADDI ;
M: ppc %sub swapd SUBF ;
M: ppc %sub swap SUBF ;
M: ppc %sub-imm SUBI ;
M: ppc %mul MULLW ;
M: ppc %mul-imm MULLI ;
@ -156,44 +140,42 @@ M: ppc %not NOT ;
: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
M: ppc %integer>bignum ( dst src temp -- )
M:: ppc %integer>bignum ( dst src temp -- )
[
{ "end" "non-zero" "pos" "store" } [ define-label ] each
dst 0 >bignum %load-immediate
"end" define-label
dst 0 >bignum %load-indirect
! Is it zero? Then just go to the end and return this zero
0 src 0 CMPI
"end" get BEQ
! Allocate a bignum
dst 4 cells bignum temp %allot
! Write length
2 temp LI
dst 1 bignum@ temp STW
! Store value
dst 3 bignum@ src STW
2 tag-fixnum temp LI
temp dst 1 bignum@ STW
! Compute sign
temp src MR
temp cell-bits 1- SRAWI
temp temp cell-bits 1- SRAWI
temp temp 1 ANDI
! Store sign
dst 2 bignum@ temp STW
temp dst 2 bignum@ STW
! Make negative value positive
temp temp temp ADD
temp temp NEG
temp temp 1 ADDI
temp src temp MULLW
! Store the bignum
dst 3 bignum@ temp STW
temp dst 3 bignum@ STW
"end" resolve-label
] with-scope ;
M:: %bignum>integer ( dst src temp -- )
M:: ppc %bignum>integer ( dst src temp -- )
[
"end" define-label
temp src 1 bignum@ LWZ
! if the length is 1, its just the sign and nothing else,
! so output 0
0 dst LI
0 temp 1 v>operand CMPI
0 temp 1 tag-fixnum CMPI
"end" get BEQ
! load the value
dst src 3 bignum@ LWZ
@ -203,6 +185,7 @@ M:: %bignum>integer ( dst src temp -- )
! and 1 into -1
temp temp temp ADD
temp temp 1 SUBI
temp temp NEG
! multiply value by sign
dst dst temp MULLW
"end" resolve-label
@ -213,14 +196,14 @@ M: ppc %sub-float FSUB ;
M: ppc %mul-float FMUL ;
M: ppc %div-float FDIV ;
M: ppc %integer>float ( dst src -- )
M:: ppc %integer>float ( dst src -- )
HEX: 4330 scratch-reg LIS
scratch-reg 1 0 param@ STW
scratch-reg src MR
scratch-reg dup HEX: 8000 XORIS
scratch-reg 1 cell param@ STW
fp-scratch-reg-2 1 0 param@ LFD
4503601774854144.0 scratch-reg load-indirect
scratch-reg 4503601774854144.0 %load-indirect
fp-scratch-reg-2 scratch-reg float-offset LFD
fp-scratch-reg-2 fp-scratch-reg-2 fp-scratch-reg-2 FSUB ;
@ -231,7 +214,7 @@ M:: ppc %float>integer ( dst src -- )
M: ppc %copy ( dst src -- ) MR ;
M: ppc %copy-float ( dst src -- ) MFR ;
M: ppc %copy-float ( dst src -- ) FMR ;
M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
@ -277,9 +260,9 @@ M:: ppc %box-alien ( dst src temp -- )
"f" get BEQ
dst 4 cells alien temp %allot
! Store offset
dst src 3 alien@ STW
temp \ f tag-number %load-immediate
src dst 3 alien@ STW
! Store expired slot
temp \ f tag-number %load-immediate
temp dst 1 alien@ STW
! Store underlying-alien slot
temp dst 2 alien@ STW
@ -289,7 +272,7 @@ M:: ppc %box-alien ( dst src temp -- )
M: ppc %alien-unsigned-1 0 LBZ ;
M: ppc %alien-unsigned-2 0 LHZ ;
M: ppc %alien-signed-1 dupd 0 LBZ EXTSB ;
M: ppc %alien-signed-1 dupd 0 LBZ dup EXTSB ;
M: ppc %alien-signed-2 0 LHA ;
M: ppc %alien-cell 0 LWZ ;
@ -297,45 +280,47 @@ M: ppc %alien-cell 0 LWZ ;
M: ppc %alien-float 0 LFS ;
M: ppc %alien-double 0 LFD ;
M: ppc %set-alien-integer-1 0 STB ;
M: ppc %set-alien-integer-2 0 STH ;
M: ppc %set-alien-integer-1 swap 0 STB ;
M: ppc %set-alien-integer-2 swap 0 STH ;
M: ppc %set-alien-cell 0 STW ;
M: ppc %set-alien-cell swap 0 STW ;
M: ppc %set-alien-float 0 STFS ;
M: ppc %set-alien-double 0 STFD ;
M: ppc %set-alien-float swap 0 STFS ;
M: ppc %set-alien-double swap 0 STFD ;
: %load-dlsym ( symbol dll register -- )
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
: load-zone-ptr ( reg -- )
[ "nursery" f ] dip %load-dlsym ;
: load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop load-zone-ptr ] [ swap cell LWZ ] 2bi ;
[ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ;
:: inc-allot-ptr ( nursery-ptr n -- )
scratch-reg inc-allot-ptr 4 LWZ
scratch-reg scratch-reg n 8 align ADD
scratch-reg inc-allot-ptr 4 STW ;
:: inc-allot-ptr ( nursery-ptr allot-ptr n -- )
scratch-reg allot-ptr n 8 align ADDI
scratch-reg nursery-ptr 4 STW ;
:: store-header ( temp class -- )
:: store-header ( dst class -- )
class type-number tag-fixnum scratch-reg LI
temp scratch-reg 0 STW ;
scratch-reg dst 0 STW ;
: store-tagged ( dst tag -- )
dupd tag-number ORI ;
M:: ppc %allot ( dst size class nursery-ptr -- )
nursery-ptr dst load-allot-ptr
nursery-ptr dst size inc-allot-ptr
dst class store-header
dst class store-tagged
nursery-ptr size inc-allot-ptr ;
dst class store-tagged ;
: %alien-global ( dest name -- )
[ f swap %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
: %alien-global ( dst name -- )
[ f rot %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
: load-cards-offset ( dest -- )
: load-cards-offset ( dst -- )
"cards_offset" %alien-global ;
: load-decks-offset ( dest -- )
: load-decks-offset ( dst -- )
"decks_offset" %alien-global ;
M:: ppc %write-barrier ( src card# table -- )
@ -359,18 +344,17 @@ M: ppc %gc
11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
11 0 12 CMP ! is here >= end?
"end" get BLE
0 frame-required
%prepare-alien-invoke
"minor_gc" f %alien-invoke
"end" resolve-label ;
M: ppc %prologue ( n -- )
0 scrach-reg LOAD32 rc-absolute-ppc-2/2 rel-this
0 scratch-reg LOAD32 rc-absolute-ppc-2/2 rel-this
0 MFLR
1 1 pick neg ADDI
scrach-reg 1 pick xt-save STW
dup scrach-reg LI
scrach-reg 1 pick next-save STW
scratch-reg 1 pick xt-save STW
dup scratch-reg LI
scratch-reg 1 pick next-save STW
0 1 rot lr-save + STW ;
M: ppc %epilogue ( n -- )
@ -384,19 +368,19 @@ M: ppc %epilogue ( n -- )
:: (%boolean) ( dst word -- )
"end" define-label
\ f tag-number %load-immediate
dst \ f tag-number %load-immediate
"end" get word execute
dst \ t %load-indirect
"end" get resolve-label ; inline
: %boolean ( dst cc -- )
negate-cc {
{ cc< [ \ BLT %boolean ] }
{ cc<= [ \ BLE %boolean ] }
{ cc> [ \ BGT %boolean ] }
{ cc>= [ \ BGE %boolean ] }
{ cc= [ \ BEQ %boolean ] }
{ cc/= [ \ BNE %boolean ] }
{ cc< [ \ BLT (%boolean) ] }
{ cc<= [ \ BLE (%boolean) ] }
{ cc> [ \ BGT (%boolean) ] }
{ cc>= [ \ BGE (%boolean) ] }
{ cc= [ \ BEQ (%boolean) ] }
{ cc/= [ \ BNE (%boolean) ] }
} case ;
: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
@ -426,7 +410,7 @@ M: ppc %compare-float-branch (%compare-float) %branch ;
: stack@ 1 swap ; inline
: spill-integer@ ( n -- op )
: spill-integer@ ( n -- reg offset )
cells
stack-frame get spill-integer-base
+ stack@ ;
@ -437,7 +421,7 @@ M: ppc %compare-float-branch (%compare-float) %branch ;
[ return>> ]
tri + + ;
: spill-float@ ( n -- op )
: spill-float@ ( n -- reg offset )
double-float-regs reg-size *
stack-frame get spill-float-base
+ stack@ ;
@ -453,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 ;
@ -560,7 +539,7 @@ M: ppc %alien-invoke ( symbol dll -- )
11 %load-dlsym 11 MTLR BLRL ;
M: ppc %alien-callback ( quot -- )
3 load-indirect "c_to_factor" f %alien-invoke ;
3 swap %load-indirect "c_to_factor" f %alien-invoke ;
M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
@ -580,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 ;
@ -596,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

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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
>>

View File

@ -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

2
basis/cpu/x86/tags.txt Normal file
View File

@ -0,0 +1,2 @@
unportable
compiler

View File

@ -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 ;
@ -293,15 +296,13 @@ M:: x86 %box-alien ( dst src temp -- )
[ quot call ] with-save/restore
] if ; inline
: aux-offset 2 cells string tag-number - ; inline
M:: x86 %string-nth ( dst src index temp -- )
"end" define-label
dst { src index temp } [| new-dst |
temp src index [+] LEA
new-dst 1 small-reg temp string-offset [+] MOV
new-dst new-dst 1 small-reg MOVZX
temp src aux-offset [+] MOV
temp src string-aux-offset [+] MOV
temp \ f tag-number CMP
"end" get JE
new-dst temp XCHG
@ -467,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
@ -475,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 *

View File

@ -39,7 +39,7 @@ HOOK: (wait-to-read) io-backend ( port -- )
M: input-port stream-read1
dup check-disposed
dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ;
dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ; inline
: read-step ( count port -- byte-array/f )
dup wait-to-read [ 2drop f ] [ buffer>> buffer-read ] if ;
@ -105,7 +105,7 @@ TUPLE: output-port < buffered-port ;
M: output-port stream-write1
dup check-disposed
1 over wait-to-write
buffer>> byte>buffer ;
buffer>> byte>buffer ; inline
M: output-port stream-write
dup check-disposed

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors alien.accessors math io ;
USING: kernel accessors alien alien.c-types alien.accessors math io ;
IN: io.streams.memory
TUPLE: memory-stream alien index ;
@ -11,3 +11,9 @@ TUPLE: memory-stream alien index ;
M: memory-stream stream-read1
[ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
[ [ 1+ ] change-index drop ] bi ;
M: memory-stream stream-read
[
[ index>> ] [ alien>> ] bi <displaced-alien>
swap memory>byte-array
] [ [ + ] change-index drop ] 2bi ;

View File

@ -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> = ;

View File

@ -83,8 +83,6 @@ IN: math.intervals.tests
0 1 (a,b) 1 2 [a,b] interval-union 0 2 (a,b] =
] unit-test
[ f ] [ 0 1 (a,b) f interval-union ] unit-test
[ t ] [
0 1 (a,b) 0 1 [a,b] interval-intersect 0 1 (a,b) =
] unit-test

View File

@ -115,14 +115,10 @@ TUPLE: interval { from read-only } { to read-only } ;
{ [ dup empty-interval eq? ] [ nip ] }
{ [ over empty-interval eq? ] [ drop ] }
[
2dup and [
[ interval>points ] bi@ swapd
[ [ swap endpoint< ] most ]
[ [ swap endpoint> ] most ] 2bi*
<interval>
] [
or
] if
[ interval>points ] bi@ swapd
[ [ swap endpoint< ] most ]
[ [ swap endpoint> ] most ] 2bi*
<interval>
]
} cond ;
@ -133,13 +129,7 @@ TUPLE: interval { from read-only } { to read-only } ;
{
{ [ dup empty-interval eq? ] [ drop ] }
{ [ over empty-interval eq? ] [ nip ] }
[
2dup and [
[ interval>points 2array ] bi@ append points>interval
] [
2drop f
] if
]
[ [ interval>points 2array ] bi@ append points>interval ]
} cond ;
: interval-subset? ( i1 i2 -- ? )
@ -183,7 +173,6 @@ TUPLE: interval { from read-only } { to read-only } ;
: interval-length ( int -- n )
{
{ [ dup empty-interval eq? ] [ drop 0 ] }
{ [ dup not ] [ drop 0 ] }
[ interval>points [ first ] bi@ swap - ]
} cond ;

View File

@ -233,15 +233,22 @@ ERROR: invalid-range a b ;
SINGLETON: beginning-of-input
SINGLETON: end-of-input
! : beginning-of-input ( -- obj )
: handle-front-anchor ( -- ) front-anchor push-stack ;
: end-of-line ( -- obj )
end-of-input
: newlines ( -- obj1 obj2 obj3 )
CHAR: \r <constant>
CHAR: \n <constant>
2dup 2array <concatenation> 4array <alternation> lookahead boa ;
2dup 2array <concatenation> ;
: handle-back-anchor ( -- ) end-of-line push-stack ;
: beginning-of-line ( -- obj )
beginning-of-input newlines 4array <alternation> lookbehind boa ;
: end-of-line ( -- obj )
end-of-input newlines 4array <alternation> lookahead boa ;
: handle-front-anchor ( -- )
get-multiline beginning-of-line beginning-of-input ? push-stack ;
: handle-back-anchor ( -- )
get-multiline end-of-line end-of-input ? push-stack ;
ERROR: bad-character-class obj ;
ERROR: expected-posix-class ;
@ -412,16 +419,11 @@ DEFER: handle-left-bracket
[ [ push ] keep current-regexp get (>>stack) ]
[ finish-regexp-parse push-stack ] bi* ;
: parse-regexp-token ( token -- ? )
{
! todo: only match these at beginning/end of regexp
{ CHAR: ^ [ handle-front-anchor t ] }
{ CHAR: $ [ handle-back-anchor t ] }
{ CHAR: . [ handle-dot t ] }
{ CHAR: ( [ handle-left-parenthesis t ] }
{ CHAR: ( [ handle-left-parenthesis t ] } ! handle (?..) at beginning?
{ CHAR: ) [ handle-right-parenthesis f ] }
{ CHAR: . [ handle-dot t ] }
{ CHAR: | [ handle-pipe t ] }
{ CHAR: ? [ handle-question t ] }
{ CHAR: * [ handle-star t ] }
@ -429,16 +431,28 @@ DEFER: handle-left-bracket
{ CHAR: { [ handle-left-brace t ] }
{ CHAR: [ [ handle-left-bracket t ] }
{ CHAR: \ [ handle-escape t ] }
[ <constant> push-stack t ]
[
dup CHAR: $ = peek1 f = and [
drop
handle-back-anchor f
] [
<constant> push-stack t
] if
]
} case ;
: (parse-regexp) ( -- )
read1 [ parse-regexp-token [ (parse-regexp) ] when ] when* ;
: parse-regexp-beginning ( -- )
peek1 CHAR: ^ = [ drop1 handle-front-anchor ] when ;
: parse-regexp ( regexp -- )
dup current-regexp [
raw>> [
<string-reader> [ (parse-regexp) ] with-input-stream
<string-reader> [
parse-regexp-beginning (parse-regexp)
] with-input-stream
] unless-empty
current-regexp get
stack finish-regexp-parse

View File

@ -331,4 +331,3 @@ IN: regexp-tests
[ { 0 3 } ] [ "abc" "(ab|a)(bc)?" <regexp> first-match ] unit-test
[ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match ] unit-test

View File

@ -92,7 +92,6 @@ IN: regexp
reversed-regexp initial-option
construct-regexp ;
: parsing-regexp ( accum end -- accum )
lexer get dup skip-blank
[ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
@ -112,7 +111,6 @@ IN: regexp
: R{ CHAR: } parsing-regexp ; parsing
: R| CHAR: | parsing-regexp ; parsing
: find-regexp-syntax ( string -- prefix suffix )
{
{ "R/ " "/" }

View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators kernel math math.ranges
quotations sequences regexp.parser regexp.classes fry arrays
combinators.short-circuit regexp.utils prettyprint regexp.nfa ;
combinators.short-circuit regexp.utils prettyprint regexp.nfa
shuffle ;
IN: regexp.traversal
TUPLE: dfa-traverser
@ -23,8 +24,7 @@ TUPLE: dfa-traverser
[ dfa-table>> ] [ dfa-traversal-flags>> ] bi
dfa-traverser new
swap >>traversal-flags
swap [ start-state>> >>current-state ] keep
>>dfa-table
swap [ start-state>> >>current-state ] [ >>dfa-table ] bi
swap >>text
t >>traverse-forward
0 >>start-index
@ -116,7 +116,7 @@ M: capture-group-off flag-action ( dfa-traverser flag -- )
V{ } clone >>matches ;
: match-literal ( transition from-state table -- to-state/f )
transitions>> at* [ at ] [ 2drop f ] if ;
transitions>> at at ;
: match-class ( transition from-state table -- to-state/f )
transitions>> at* [
@ -124,8 +124,7 @@ M: capture-group-off flag-action ( dfa-traverser flag -- )
] [ drop ] if ;
: match-default ( transition from-state table -- to-state/f )
[ nip ] dip transitions>> at*
[ t swap at* [ ] [ drop f ] if ] [ drop f ] if ;
nipd transitions>> at t swap at ;
: match-transition ( obj from-state dfa -- to-state/f )
{ [ match-literal ] [ match-class ] [ match-default ] } 3|| ;

View File

@ -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
}

View File

@ -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" }

View File

@ -90,20 +90,29 @@ ERROR: bad-superclass class ;
2drop f
] if ; inline
: tuple-instance-1? ( object class -- ? )
swap dup tuple? [
layout-of 7 slot eq?
] [ 2drop f ] if ; inline
: tuple-instance? ( object class offset -- ? )
#! 4 slot == superclasses>>
rot dup tuple? [
layout-of
2dup 1 slot fixnum<=
[ swap slot eq? ] [ 3drop f ] if
] [ 3drop f ] if ; inline
: layout-class-offset ( class -- n )
tuple-layout third 2 * 5 + ;
: layout-class-offset ( echelon -- n )
2 * 5 + ;
: echelon-of ( class -- n )
tuple-layout third ;
: define-tuple-predicate ( class -- )
dup dup layout-class-offset
[ tuple-instance? ] 2curry define-predicate ;
dup dup echelon-of {
{ 1 [ [ tuple-instance-1? ] curry ] }
[ layout-class-offset [ tuple-instance? ] 2curry ]
} case define-predicate ;
: class-size ( class -- n )
superclasses [ "slots" word-prop length ] sigma ;
@ -292,7 +301,7 @@ M: tuple-class reset-class
M: tuple-class rank-class drop 0 ;
M: tuple-class instance?
dup layout-class-offset tuple-instance? ;
dup echelon-of layout-class-offset tuple-instance? ;
M: tuple-class (flatten-class) dup set ;

View File

@ -8,7 +8,7 @@ ERROR: not-in-a-method-error ;
: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
: create-method-in ( class generic -- method )
create-method f set-word dup save-location ;
create-method dup set-word dup save-location ;
: CREATE-METHOD ( -- method )
scan-word bootstrap-word scan-word create-method-in ;
@ -18,11 +18,11 @@ SYMBOL: current-generic
: with-method-definition ( quot -- parsed )
[
>r
[ "method-class" word-prop current-class set ]
[ "method-generic" word-prop current-generic set ]
[ ] tri
r> call
[
[ "method-class" word-prop current-class set ]
[ "method-generic" word-prop current-generic set ]
[ ] tri
] dip call
] with-scope ; inline
: (M:) ( method def -- )

View File

@ -27,7 +27,7 @@ M: lo-tag-dispatch-engine engine>quot
[ >r lo-tag-number r> ] assoc-map
[
picker % [ tag ] % [
! >alist sort-keys reverse
>alist sort-keys reverse
linear-dispatch-quot
] [
num-tags get direct-dispatch-quot

View File

@ -48,10 +48,14 @@ TUPLE: tuple-dispatch-engine echelons ;
\ <tuple-dispatch-engine> convert-methods ;
M: trivial-tuple-dispatch-engine engine>quot
[
[ n>> nth-superclass% ]
[ methods>> engines>quots* linear-dispatch-quot % ] bi
] [ ] make ;
[ n>> ] [ methods>> ] bi dup assoc-empty? [
2drop default get [ drop ] prepend
] [
[
[ nth-superclass% ]
[ engines>quots* linear-dispatch-quot % ] bi*
] [ ] make
] if ;
: hash-methods ( n methods -- buckets )
>alist V{ } clone [ hashcode 1array ] distribute-buckets
@ -119,11 +123,19 @@ M: echelon-dispatch-engine engine>quot
] assoc-map
alist>quot ;
: simplify-echelon-alist ( default alist -- default' alist' )
dup empty? [
dup first first 1 <= [
nip unclip second swap
simplify-echelon-alist
] when
] unless ;
: echelon-case-quot ( alist -- quot )
#! We don't have to test for echelon 1 since all tuple
#! classes are at least at depth 1 in the inheritance
#! hierarchy.
dup first first 1 = [ unclip second ] [ default get ] if swap
default get swap simplify-echelon-alist
[
[
picker %
@ -140,8 +152,11 @@ M: tuple-dispatch-engine engine>quot
echelons>> unclip-last
[
[
engine>quot define-engine-word
[ remember-engine ] [ 1quotation ] bi
engine>quot
over 0 = [
define-engine-word
[ remember-engine ] [ 1quotation ] bi
] unless
dup default set
] assoc-map
]

View File

@ -167,11 +167,11 @@ GENERIC: boa ( ... class -- tuple )
compose compose ; inline
! Booleans
: not ( obj -- ? ) f t ? ; inline
: not ( obj -- ? ) [ f ] [ t ] if ; inline
: and ( obj1 obj2 -- ? ) over ? ; inline
: >boolean ( obj -- ? ) t f ? ; inline
: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline
: or ( obj1 obj2 -- ? ) dupd ? ; inline

View File

@ -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

View File

@ -262,7 +262,7 @@ M: word forget*
] if ;
M: word hashcode*
nip 1 slot { fixnum } declare ;
nip 1 slot { fixnum } declare ; foldable
M: word literalize <wrapper> ;

View File

@ -13,7 +13,7 @@ HELP: make-advised
{ $see-also advised? annotate } ;
HELP: advised?
{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet word } " is advised" } }
{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet "word" } " is advised" } }
{ $description "Determines whether or not the given word has any advice on it." } ;
ARTICLE: "advice" "Advice"

View File

@ -6,12 +6,12 @@ continuations debugger ;
IN: benchmark
: run-benchmark ( vocab -- result )
[ [ require ] [ [ run ] benchmark ] bi ] curry
[ error. f ] recover ;
[ [ require ] [ [ run ] benchmark ] bi ] curry
[ error. f ] recover ;
: run-benchmarks ( -- assoc )
"benchmark" all-child-vocabs-seq
[ dup run-benchmark ] { } map>assoc ;
"benchmark" all-child-vocabs-seq
[ dup run-benchmark ] { } map>assoc ;
: benchmarks. ( assoc -- )
standard-table-style [

View File

@ -131,6 +131,9 @@ MACRO: undo ( quot -- ) [undo] ;
\ pick [ >r pick r> =/fail ] define-inverse
\ tuck [ swapd [ =/fail ] keep ] define-inverse
\ not [ not ] define-inverse
\ >boolean [ { t f } memq? assure ] define-inverse
\ >r [ r> ] define-inverse
\ r> [ >r ] define-inverse

View File

@ -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 ;

View File

@ -44,5 +44,12 @@ PRIVATE>
: all-permutations ( seq -- seq )
[ length factorial ] keep '[ _ permutation ] map ;
: each-permutation ( seq quot -- )
[ [ length factorial ] keep ] dip
'[ _ permutation @ ] each ; inline
: reduce-permutations ( seq initial quot -- result )
swapd each-permutation ; inline
: inverse-permutation ( seq -- permutation )
<enum> >alist sort-values keys ;

View File

@ -52,8 +52,11 @@ IN: project-euler.043
PRIVATE>
: euler043 ( -- answer )
1234567890 number>digits all-permutations
[ interesting? ] filter [ 10 digits>integer ] map sum ;
1234567890 number>digits 0 [
dup interesting? [
10 digits>integer +
] [ drop ] if
] reduce-permutations ;
! [ euler043 ] time
! 104526 ms run / 42735 ms GC time

View File

@ -1,7 +1,7 @@
! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: definitions io io.files kernel math math.parser project-euler.ave-time
sequences vocabs vocabs.loader
sequences vocabs vocabs.loader prettyprint
project-euler.001 project-euler.002 project-euler.003 project-euler.004
project-euler.005 project-euler.006 project-euler.007 project-euler.008
project-euler.009 project-euler.010 project-euler.011 project-euler.012
@ -33,7 +33,7 @@ IN: project-euler
: solution-path ( n -- str/f )
number>euler "project-euler." prepend
vocab where dup [ first ] when ;
vocab where dup [ first <pathname> ] when ;
PRIVATE>
@ -43,8 +43,8 @@ PRIVATE>
: run-project-euler ( -- )
problem-prompt dup problem-solved? [
dup number>euler "project-euler." prepend run
"Answer: " swap dup number? [ number>string ] when append print
"Source: " swap solution-path append print
"Answer: " write dup number? [ number>string ] when print
"Source: " write solution-path .
] [
drop "That problem has not been solved yet..." print
] if ;

View File

@ -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

View File

@ -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;

View File

@ -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);

View File

@ -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);
}

View File

@ -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 ; \

View File

@ -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"

View File

@ -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

View File

@ -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);

View File

@ -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)

View File

@ -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);

View File

@ -1,2 +1,2 @@
fraptor ICON "misc/icons/Factor.ico"
fraptor ICON "misc/icons/Factor.ico"

View File

@ -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;
}