Merge branch 'master' of git://factorcode.org/git/factor into json
commit
bca998bba5
2
Makefile
2
Makefile
|
@ -170,7 +170,7 @@ vm/resources.o:
|
||||||
$(CC) -c $(CFLAGS) -o $@ $<
|
$(CC) -c $(CFLAGS) -o $@ $<
|
||||||
|
|
||||||
.S.o:
|
.S.o:
|
||||||
$(CC) -c $(CFLAGS) -o $@ $<
|
$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
|
||||||
|
|
||||||
.m.o:
|
.m.o:
|
||||||
$(CC) -c $(CFLAGS) -o $@ $<
|
$(CC) -c $(CFLAGS) -o $@ $<
|
||||||
|
|
|
@ -435,7 +435,7 @@ M: long-long-type box-return ( type -- )
|
||||||
[ >float ] >>unboxer-quot
|
[ >float ] >>unboxer-quot
|
||||||
"double" define-primitive-type
|
"double" define-primitive-type
|
||||||
|
|
||||||
os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
|
"long" "ptrdiff_t" typedef
|
||||||
|
|
||||||
"ulong" "size_t" typedef
|
"ulong" "size_t" typedef
|
||||||
] with-compilation-unit
|
] with-compilation-unit
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
USING: alien.strings tools.test kernel libc
|
USING: alien.strings tools.test kernel libc
|
||||||
io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
|
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
|
IN: alien.strings.tests
|
||||||
|
|
||||||
[ "\u0000ff" ]
|
[ "\u0000ff" ]
|
||||||
|
@ -28,3 +28,7 @@ unit-test
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ f ] [ f utf8 alien>string ] 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
|
||||||
|
|
|
@ -12,9 +12,15 @@ io.encodings.binary math.order math.private accessors
|
||||||
slots.private compiler.units ;
|
slots.private compiler.units ;
|
||||||
IN: bootstrap.image
|
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 )
|
: my-arch ( -- arch )
|
||||||
cpu name>>
|
os name>> cpu name>> arch ;
|
||||||
dup "ppc" = [ >r os name>> "-" r> 3append ] when ;
|
|
||||||
|
|
||||||
: boot-image-name ( arch -- string )
|
: boot-image-name ( arch -- string )
|
||||||
"boot." swap ".image" 3append ;
|
"boot." swap ".image" 3append ;
|
||||||
|
@ -25,7 +31,7 @@ IN: bootstrap.image
|
||||||
: images ( -- seq )
|
: images ( -- seq )
|
||||||
{
|
{
|
||||||
"x86.32"
|
"x86.32"
|
||||||
"x86.64"
|
"winnt-x86.64" "unix-x86.64"
|
||||||
"linux-ppc" "macosx-ppc"
|
"linux-ppc" "macosx-ppc"
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
|
|
|
@ -125,23 +125,61 @@ M: #recursive emit-node
|
||||||
: ##branch-t ( vreg -- )
|
: ##branch-t ( vreg -- )
|
||||||
\ f tag-number cc/= ##compare-imm-branch ;
|
\ 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
|
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
|
! #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 )
|
: dispatch-branch ( nodes word -- label )
|
||||||
gensym [
|
over trivial-dispatch-branch? [
|
||||||
[
|
drop first word>>
|
||||||
V{ } clone node-stack set
|
] [
|
||||||
##prologue
|
gensym [
|
||||||
emit-nodes
|
[
|
||||||
basic-block get [
|
V{ } clone node-stack set
|
||||||
##epilogue
|
##prologue
|
||||||
##return
|
emit-nodes
|
||||||
end-basic-block
|
basic-block get [
|
||||||
] when
|
##epilogue
|
||||||
] with-cfg-builder
|
##return
|
||||||
] keep ;
|
end-basic-block
|
||||||
|
] when
|
||||||
|
] with-cfg-builder
|
||||||
|
] keep
|
||||||
|
] if ;
|
||||||
|
|
||||||
: dispatch-branches ( node -- )
|
: dispatch-branches ( node -- )
|
||||||
children>> [
|
children>> [
|
||||||
|
|
|
@ -15,7 +15,7 @@ IN: compiler.cfg.intrinsics.alien
|
||||||
|
|
||||||
: prepare-alien-accessor ( infos -- offset-vreg )
|
: prepare-alien-accessor ( infos -- offset-vreg )
|
||||||
<reversed> [ second class>> ] [ first ] bi
|
<reversed> [ second class>> ] [ first ] bi
|
||||||
dup value-info-small-tagged? [
|
dup value-info-small-fixnum? [
|
||||||
literal>> (prepare-alien-accessor-imm)
|
literal>> (prepare-alien-accessor-imm)
|
||||||
] [ drop (prepare-alien-accessor) ] if ;
|
] [ drop (prepare-alien-accessor) ] if ;
|
||||||
|
|
||||||
|
|
|
@ -9,7 +9,10 @@ IN: compiler.cfg.intrinsics.fixnum
|
||||||
|
|
||||||
: (emit-fixnum-imm-op) ( infos insn -- dst )
|
: (emit-fixnum-imm-op) ( infos insn -- dst )
|
||||||
ds-drop
|
ds-drop
|
||||||
[ ds-pop ] [ second literal>> tag-fixnum ] [ ] tri*
|
[ ds-pop ]
|
||||||
|
[ second literal>> [ tag-fixnum ] [ \ f tag-number ] if* ]
|
||||||
|
[ ]
|
||||||
|
tri*
|
||||||
call ; inline
|
call ; inline
|
||||||
|
|
||||||
: (emit-fixnum-op) ( insn -- dst )
|
: (emit-fixnum-op) ( insn -- dst )
|
||||||
|
@ -25,7 +28,7 @@ IN: compiler.cfg.intrinsics.fixnum
|
||||||
] ; inline
|
] ; inline
|
||||||
|
|
||||||
: emit-fixnum-shift-fast ( node -- )
|
: 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
|
nip
|
||||||
[ ds-drop ds-pop ] dip
|
[ ds-drop ds-pop ] dip
|
||||||
second literal>> dup sgn {
|
second literal>> dup sgn {
|
||||||
|
@ -48,7 +51,7 @@ IN: compiler.cfg.intrinsics.fixnum
|
||||||
|
|
||||||
: emit-fixnum*fast ( node -- )
|
: emit-fixnum*fast ( node -- )
|
||||||
node-input-infos
|
node-input-infos
|
||||||
dup second value-info-small-tagged?
|
dup second value-info-small-fixnum?
|
||||||
[ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
|
[ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
|
||||||
ds-push ;
|
ds-push ;
|
||||||
|
|
||||||
|
|
|
@ -25,7 +25,7 @@ IN: compiler.cfg.intrinsics.slots
|
||||||
dup node-input-infos
|
dup node-input-infos
|
||||||
dup first value-tag [
|
dup first value-tag [
|
||||||
nip
|
nip
|
||||||
dup second value-info-small-tagged?
|
dup second value-info-small-fixnum?
|
||||||
[ (emit-slot-imm) ] [ (emit-slot) ] if
|
[ (emit-slot-imm) ] [ (emit-slot) ] if
|
||||||
ds-push
|
ds-push
|
||||||
] [ drop emit-primitive ] if ;
|
] [ drop emit-primitive ] if ;
|
||||||
|
@ -46,7 +46,7 @@ IN: compiler.cfg.intrinsics.slots
|
||||||
dup second value-tag [
|
dup second value-tag [
|
||||||
nip
|
nip
|
||||||
[
|
[
|
||||||
dup third value-info-small-tagged?
|
dup third value-info-small-fixnum?
|
||||||
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
|
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
|
||||||
] [ first class>> immediate class<= ] bi
|
] [ first class>> immediate class<= ] bi
|
||||||
[ drop ] [ i i ##write-barrier ] if
|
[ drop ] [ i i ##write-barrier ] if
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: namespaces accessors math.order assocs kernel sequences
|
USING: namespaces accessors math.order assocs kernel sequences
|
||||||
combinators make cpu.architecture compiler.cfg.instructions
|
combinators make classes words cpu.architecture
|
||||||
compiler.cfg.registers ;
|
compiler.cfg.instructions compiler.cfg.registers ;
|
||||||
IN: compiler.cfg.stack-frame
|
IN: compiler.cfg.stack-frame
|
||||||
|
|
||||||
SYMBOL: frame-required?
|
SYMBOL: frame-required?
|
||||||
|
@ -24,16 +24,16 @@ M: ##stack-frame compute-stack-frame*
|
||||||
M: ##call compute-stack-frame*
|
M: ##call compute-stack-frame*
|
||||||
word>> sub-primitive>> [ frame-required? on ] unless ;
|
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*
|
M: _spill-counts compute-stack-frame*
|
||||||
counts>> stack-frame get (>>spill-counts) ;
|
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 -- )
|
: compute-stack-frame ( insns -- )
|
||||||
frame-required? off
|
frame-required? off
|
||||||
|
|
|
@ -1,12 +1,24 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
cpu.architecture namespaces compiler.cfg
|
||||||
compiler.cfg.instructions ;
|
compiler.cfg.instructions ;
|
||||||
IN: compiler.cfg.utilities
|
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 -- ? )
|
: 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 -- )
|
: set-basic-block ( basic-block -- )
|
||||||
[ basic-block set ] [ instructions>> building set ] bi ;
|
[ basic-block set ] [ instructions>> building set ] bi ;
|
||||||
|
|
|
@ -42,25 +42,75 @@ M: ##mul-imm rewrite
|
||||||
|
|
||||||
: tag-fixnum-expr? ( expr -- ? )
|
: tag-fixnum-expr? ( expr -- ? )
|
||||||
dup op>> \ ##shl-imm eq?
|
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 -- ? )
|
: rewrite-tagged-comparison? ( insn -- ? )
|
||||||
#! Are we comparing two tagged fixnums? Then untag them.
|
#! Are we comparing two tagged fixnums? Then untag them.
|
||||||
dup ##compare-imm-branch? [
|
[ src1>> vreg>expr tag-fixnum-expr? ]
|
||||||
[ src1>> vreg>expr tag-fixnum-expr? ]
|
[ src2>> tag-mask get bitand 0 = ]
|
||||||
[ src2>> tag-mask get bitand 0 = ]
|
bi and ; inline
|
||||||
bi and
|
|
||||||
] [ drop f ] if ; inline
|
|
||||||
|
|
||||||
: rewrite-tagged-comparison ( insn -- insn' )
|
: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
|
||||||
[ src1>> vreg>expr in1>> vn>vreg ]
|
[ src1>> vreg>expr in1>> vn>vreg ]
|
||||||
[ src2>> tag-bits get neg shift ]
|
[ src2>> tag-bits get neg shift ]
|
||||||
[ cc>> ]
|
[ cc>> ]
|
||||||
tri
|
tri ; inline
|
||||||
f \ ##compare-imm-branch boa ;
|
|
||||||
|
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
|
M: ##compare-imm-branch rewrite
|
||||||
dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
|
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 ;
|
M: insn rewrite ;
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
IN: compiler.cfg.value-numbering.tests
|
IN: compiler.cfg.value-numbering.tests
|
||||||
USING: compiler.cfg.value-numbering compiler.cfg.instructions
|
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 }
|
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 }
|
T{ ##replace f V int-regs 3 D 0 }
|
||||||
} value-numbering
|
} value-numbering
|
||||||
] unit-test
|
] 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
|
||||||
|
|
|
@ -1,49 +1,50 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: math kernel layouts system ;
|
USING: math kernel layouts system strings ;
|
||||||
IN: compiler.constants
|
IN: compiler.constants
|
||||||
|
|
||||||
! These constants must match vm/memory.h
|
! These constants must match vm/memory.h
|
||||||
: card-bits 8 ;
|
: card-bits 8 ; inline
|
||||||
: deck-bits 18 ;
|
: deck-bits 18 ; inline
|
||||||
: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ;
|
: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ; inline
|
||||||
|
|
||||||
! These constants must match vm/layouts.h
|
! These constants must match vm/layouts.h
|
||||||
: header-offset ( -- n ) object tag-number neg ;
|
: header-offset ( -- n ) object tag-number neg ; inline
|
||||||
: float-offset ( -- n ) 8 float tag-number - ;
|
: float-offset ( -- n ) 8 float tag-number - ; inline
|
||||||
: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ;
|
: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline
|
||||||
: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ;
|
: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
|
||||||
: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
|
: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline
|
||||||
: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
|
: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
|
||||||
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
|
: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
|
||||||
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
|
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline
|
||||||
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
|
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
|
||||||
: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
|
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline
|
||||||
: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
|
: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
|
||||||
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
|
: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
|
||||||
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
|
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
|
||||||
: compiled-header-size ( -- n ) 4 bootstrap-cells ;
|
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
|
||||||
|
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
|
||||||
|
|
||||||
! Relocation classes
|
! Relocation classes
|
||||||
: rc-absolute-cell 0 ;
|
: rc-absolute-cell 0 ; inline
|
||||||
: rc-absolute 1 ;
|
: rc-absolute 1 ; inline
|
||||||
: rc-relative 2 ;
|
: rc-relative 2 ; inline
|
||||||
: rc-absolute-ppc-2/2 3 ;
|
: rc-absolute-ppc-2/2 3 ; inline
|
||||||
: rc-relative-ppc-2 4 ;
|
: rc-relative-ppc-2 4 ; inline
|
||||||
: rc-relative-ppc-3 5 ;
|
: rc-relative-ppc-3 5 ; inline
|
||||||
: rc-relative-arm-3 6 ;
|
: rc-relative-arm-3 6 ; inline
|
||||||
: rc-indirect-arm 7 ;
|
: rc-indirect-arm 7 ; inline
|
||||||
: rc-indirect-arm-pc 8 ;
|
: rc-indirect-arm-pc 8 ; inline
|
||||||
|
|
||||||
! Relocation types
|
! Relocation types
|
||||||
: rt-primitive 0 ;
|
: rt-primitive 0 ; inline
|
||||||
: rt-dlsym 1 ;
|
: rt-dlsym 1 ; inline
|
||||||
: rt-literal 2 ;
|
: rt-literal 2 ; inline
|
||||||
: rt-dispatch 3 ;
|
: rt-dispatch 3 ; inline
|
||||||
: rt-xt 4 ;
|
: rt-xt 4 ; inline
|
||||||
: rt-here 5 ;
|
: rt-here 5 ; inline
|
||||||
: rt-label 6 ;
|
: rt-label 6 ; inline
|
||||||
: rt-immediate 7 ;
|
: rt-immediate 7 ; inline
|
||||||
|
|
||||||
: rc-absolute? ( n -- ? )
|
: rc-absolute? ( n -- ? )
|
||||||
[ rc-absolute-ppc-2/2 = ]
|
[ rc-absolute-ppc-2/2 = ]
|
||||||
|
|
|
@ -4,7 +4,8 @@ continuations sequences.private hashtables.private byte-arrays
|
||||||
strings.private system random layouts vectors
|
strings.private system random layouts vectors
|
||||||
sbufs strings.private slots.private alien math.order
|
sbufs strings.private slots.private alien math.order
|
||||||
alien.accessors alien.c-types alien.syntax alien.strings
|
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
|
IN: compiler.tests
|
||||||
|
|
||||||
! Make sure that intrinsic ops compile to correct code.
|
! 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
|
||||||
[ 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 [ { 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
|
||||||
[ 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
|
! Write barrier hits on the wrong value were causing segfaults
|
||||||
[ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
|
[ -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: a ] [ 0 "abc" [ string-nth ] compile-call ] unit-test
|
||||||
! [ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test
|
[ CHAR: a ] [ 0 [ "abc" string-nth ] compile-call ] unit-test
|
||||||
! [ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test
|
[ CHAR: a ] [ [ 0 "abc" string-nth ] compile-call ] unit-test
|
||||||
!
|
[ CHAR: b ] [ 1 "abc" [ string-nth ] compile-call ] unit-test
|
||||||
! [ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
|
[ CHAR: b ] [ 1 [ "abc" string-nth ] compile-call ] unit-test
|
||||||
! [ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
|
[ CHAR: b ] [ [ 1 "abc" string-nth ] compile-call ] unit-test
|
||||||
! [ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] 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
|
[ ] [ [ 0 getenv ] compile-call drop ] unit-test
|
||||||
[ ] [ 1 getenv [ 1 setenv ] compile-call ] 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
|
||||||
[ 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
|
[ 30001 ] [ 1 [ 30000 fixnum+fast ] compile-call ] unit-test
|
||||||
|
|
||||||
[ 6 ] [ 2 3 [ 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 ;
|
: compiled-fixnum>bignum fixnum>bignum ;
|
||||||
|
|
||||||
|
[ bignum ] [ 0 compiled-fixnum>bignum class ] unit-test
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
10000 [
|
10000 [
|
||||||
32 random-bits >fixnum
|
32 random-bits >fixnum
|
||||||
|
|
|
@ -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
|
sequences sequences.private tools.test namespaces.private
|
||||||
slots.private sequences.private byte-arrays alien
|
slots.private sequences.private byte-arrays alien
|
||||||
alien.accessors layouts words definitions compiler.units io
|
alien.accessors layouts words definitions compiler.units io
|
||||||
combinators vectors ;
|
combinators vectors float-arrays ;
|
||||||
IN: compiler.tests
|
IN: compiler.tests
|
||||||
|
|
||||||
! Originally, this file did black box testing of templating
|
! Originally, this file did black box testing of templating
|
||||||
|
@ -206,167 +206,6 @@ TUPLE: my-tuple ;
|
||||||
] compile-call
|
] compile-call
|
||||||
] unit-test
|
] 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
|
! Regression
|
||||||
: dispatch-alignment-regression ( -- c )
|
: dispatch-alignment-regression ( -- c )
|
||||||
{ tuple vector } 3 slot { word } declare
|
{ 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
|
|
@ -1,21 +1,10 @@
|
||||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien.c-types
|
USING: accessors assocs sequences kernel combinators make math
|
||||||
accessors
|
math.order math.ranges system namespaces locals layouts words
|
||||||
cpu.architecture
|
alien alien.c-types cpu.architecture cpu.ppc.assembler
|
||||||
compiler.cfg.registers
|
compiler.cfg.registers compiler.cfg.instructions
|
||||||
cpu.ppc.assembler
|
compiler.constants compiler.codegen compiler.codegen.fixup ;
|
||||||
kernel
|
|
||||||
locals
|
|
||||||
layouts
|
|
||||||
combinators
|
|
||||||
make
|
|
||||||
compiler.cfg.instructions
|
|
||||||
math.order
|
|
||||||
system
|
|
||||||
math
|
|
||||||
compiler.constants
|
|
||||||
namespaces compiler.codegen.fixup ;
|
|
||||||
IN: cpu.ppc
|
IN: cpu.ppc
|
||||||
|
|
||||||
! PowerPC register assignments:
|
! PowerPC register assignments:
|
||||||
|
@ -26,18 +15,6 @@ IN: cpu.ppc
|
||||||
! f0-f29: float vregs
|
! f0-f29: float vregs
|
||||||
! f30, f31: float scratch
|
! 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
|
M: ppc machine-registers
|
||||||
{
|
{
|
||||||
{ int-regs T{ range f 2 26 1 } }
|
{ 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
|
obj rc-absolute-ppc-2/2 rel-literal
|
||||||
reg reg 0 LWZ ;
|
reg reg 0 LWZ ;
|
||||||
|
|
||||||
: ds-reg 30 ; inline
|
: ds-reg 29 ; inline
|
||||||
: rs-reg 31 ; inline
|
: rs-reg 30 ; inline
|
||||||
|
|
||||||
GENERIC: loc-reg ( loc -- reg )
|
GENERIC: loc-reg ( loc -- reg )
|
||||||
|
|
||||||
M: ds-loc log-reg drop ds-reg ;
|
M: ds-loc loc-reg drop ds-reg ;
|
||||||
M: rs-loc log-reg drop rs-reg ;
|
M: rs-loc loc-reg drop rs-reg ;
|
||||||
|
|
||||||
: loc>operand ( loc -- reg n )
|
: loc>operand ( loc -- reg n )
|
||||||
[ loc-reg ] [ n>> cells neg ] bi ; inline
|
[ 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-d ( n -- ) ds-reg (%inc) ;
|
||||||
M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
|
M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
|
||||||
|
|
||||||
: reserved-area-size ( -- n )
|
HOOK: reserved-area-size os ( -- n )
|
||||||
os {
|
HOOK: lr-save os ( -- n )
|
||||||
{ linux [ 2 ] }
|
|
||||||
{ macosx [ 6 ] }
|
|
||||||
} case cells ; foldable
|
|
||||||
|
|
||||||
: lr-save ( -- n )
|
|
||||||
os {
|
|
||||||
{ linux [ 1 ] }
|
|
||||||
{ macosx [ 2 ] }
|
|
||||||
} case cells ; foldable
|
|
||||||
|
|
||||||
: param@ ( n -- x ) reserved-area-size + ; inline
|
: 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 ( src obj slot tag temp -- ) (%slot) STW ;
|
||||||
M: ppc %set-slot-imm ( src obj slot tag -- ) (%slot-imm) 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 ADD ;
|
||||||
M: ppc %add-imm ADDI ;
|
M: ppc %add-imm ADDI ;
|
||||||
M: ppc %sub swapd SUBF ;
|
M: ppc %sub swap SUBF ;
|
||||||
M: ppc %sub-imm SUBI ;
|
M: ppc %sub-imm SUBI ;
|
||||||
M: ppc %mul MULLW ;
|
M: ppc %mul MULLW ;
|
||||||
M: ppc %mul-imm MULLI ;
|
M: ppc %mul-imm MULLI ;
|
||||||
|
@ -156,44 +140,42 @@ M: ppc %not NOT ;
|
||||||
|
|
||||||
: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
|
: 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
|
"end" define-label
|
||||||
dst 0 >bignum %load-immediate
|
dst 0 >bignum %load-indirect
|
||||||
! Is it zero? Then just go to the end and return this zero
|
! Is it zero? Then just go to the end and return this zero
|
||||||
0 src 0 CMPI
|
0 src 0 CMPI
|
||||||
"end" get BEQ
|
"end" get BEQ
|
||||||
! Allocate a bignum
|
! Allocate a bignum
|
||||||
dst 4 cells bignum temp %allot
|
dst 4 cells bignum temp %allot
|
||||||
! Write length
|
! Write length
|
||||||
2 temp LI
|
2 tag-fixnum temp LI
|
||||||
dst 1 bignum@ temp STW
|
temp dst 1 bignum@ STW
|
||||||
! Store value
|
|
||||||
dst 3 bignum@ src STW
|
|
||||||
! Compute sign
|
! Compute sign
|
||||||
temp src MR
|
temp src MR
|
||||||
temp cell-bits 1- SRAWI
|
temp temp cell-bits 1- SRAWI
|
||||||
temp temp 1 ANDI
|
temp temp 1 ANDI
|
||||||
! Store sign
|
! Store sign
|
||||||
dst 2 bignum@ temp STW
|
temp dst 2 bignum@ STW
|
||||||
! Make negative value positive
|
! Make negative value positive
|
||||||
temp temp temp ADD
|
temp temp temp ADD
|
||||||
temp temp NEG
|
temp temp NEG
|
||||||
temp temp 1 ADDI
|
temp temp 1 ADDI
|
||||||
temp src temp MULLW
|
temp src temp MULLW
|
||||||
! Store the bignum
|
! Store the bignum
|
||||||
dst 3 bignum@ temp STW
|
temp dst 3 bignum@ STW
|
||||||
"end" resolve-label
|
"end" resolve-label
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
||||||
M:: %bignum>integer ( dst src temp -- )
|
M:: ppc %bignum>integer ( dst src temp -- )
|
||||||
[
|
[
|
||||||
"end" define-label
|
"end" define-label
|
||||||
temp src 1 bignum@ LWZ
|
temp src 1 bignum@ LWZ
|
||||||
! if the length is 1, its just the sign and nothing else,
|
! if the length is 1, its just the sign and nothing else,
|
||||||
! so output 0
|
! so output 0
|
||||||
0 dst LI
|
0 dst LI
|
||||||
0 temp 1 v>operand CMPI
|
0 temp 1 tag-fixnum CMPI
|
||||||
"end" get BEQ
|
"end" get BEQ
|
||||||
! load the value
|
! load the value
|
||||||
dst src 3 bignum@ LWZ
|
dst src 3 bignum@ LWZ
|
||||||
|
@ -203,6 +185,7 @@ M:: %bignum>integer ( dst src temp -- )
|
||||||
! and 1 into -1
|
! and 1 into -1
|
||||||
temp temp temp ADD
|
temp temp temp ADD
|
||||||
temp temp 1 SUBI
|
temp temp 1 SUBI
|
||||||
|
temp temp NEG
|
||||||
! multiply value by sign
|
! multiply value by sign
|
||||||
dst dst temp MULLW
|
dst dst temp MULLW
|
||||||
"end" resolve-label
|
"end" resolve-label
|
||||||
|
@ -213,14 +196,14 @@ M: ppc %sub-float FSUB ;
|
||||||
M: ppc %mul-float FMUL ;
|
M: ppc %mul-float FMUL ;
|
||||||
M: ppc %div-float FDIV ;
|
M: ppc %div-float FDIV ;
|
||||||
|
|
||||||
M: ppc %integer>float ( dst src -- )
|
M:: ppc %integer>float ( dst src -- )
|
||||||
HEX: 4330 scratch-reg LIS
|
HEX: 4330 scratch-reg LIS
|
||||||
scratch-reg 1 0 param@ STW
|
scratch-reg 1 0 param@ STW
|
||||||
scratch-reg src MR
|
scratch-reg src MR
|
||||||
scratch-reg dup HEX: 8000 XORIS
|
scratch-reg dup HEX: 8000 XORIS
|
||||||
scratch-reg 1 cell param@ STW
|
scratch-reg 1 cell param@ STW
|
||||||
fp-scratch-reg-2 1 0 param@ LFD
|
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 scratch-reg float-offset LFD
|
||||||
fp-scratch-reg-2 fp-scratch-reg-2 fp-scratch-reg-2 FSUB ;
|
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 ( 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 ;
|
M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
|
||||||
|
|
||||||
|
@ -277,9 +260,9 @@ M:: ppc %box-alien ( dst src temp -- )
|
||||||
"f" get BEQ
|
"f" get BEQ
|
||||||
dst 4 cells alien temp %allot
|
dst 4 cells alien temp %allot
|
||||||
! Store offset
|
! Store offset
|
||||||
dst src 3 alien@ STW
|
src dst 3 alien@ STW
|
||||||
temp \ f tag-number %load-immediate
|
|
||||||
! Store expired slot
|
! Store expired slot
|
||||||
|
temp \ f tag-number %load-immediate
|
||||||
temp dst 1 alien@ STW
|
temp dst 1 alien@ STW
|
||||||
! Store underlying-alien slot
|
! Store underlying-alien slot
|
||||||
temp dst 2 alien@ STW
|
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-1 0 LBZ ;
|
||||||
M: ppc %alien-unsigned-2 0 LHZ ;
|
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-signed-2 0 LHA ;
|
||||||
|
|
||||||
M: ppc %alien-cell 0 LWZ ;
|
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-float 0 LFS ;
|
||||||
M: ppc %alien-double 0 LFD ;
|
M: ppc %alien-double 0 LFD ;
|
||||||
|
|
||||||
M: ppc %set-alien-integer-1 0 STB ;
|
M: ppc %set-alien-integer-1 swap 0 STB ;
|
||||||
M: ppc %set-alien-integer-2 0 STH ;
|
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-float swap 0 STFS ;
|
||||||
M: ppc %set-alien-double 0 STFD ;
|
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 -- )
|
: load-zone-ptr ( reg -- )
|
||||||
[ "nursery" f ] dip %load-dlsym ;
|
[ "nursery" f ] dip %load-dlsym ;
|
||||||
|
|
||||||
: load-allot-ptr ( nursery-ptr allot-ptr -- )
|
: 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 -- )
|
:: inc-allot-ptr ( nursery-ptr allot-ptr n -- )
|
||||||
scratch-reg inc-allot-ptr 4 LWZ
|
scratch-reg allot-ptr n 8 align ADDI
|
||||||
scratch-reg scratch-reg n 8 align ADD
|
scratch-reg nursery-ptr 4 STW ;
|
||||||
scratch-reg inc-allot-ptr 4 STW ;
|
|
||||||
|
|
||||||
:: store-header ( temp class -- )
|
:: store-header ( dst class -- )
|
||||||
class type-number tag-fixnum scratch-reg LI
|
class type-number tag-fixnum scratch-reg LI
|
||||||
temp scratch-reg 0 STW ;
|
scratch-reg dst 0 STW ;
|
||||||
|
|
||||||
: store-tagged ( dst tag -- )
|
: store-tagged ( dst tag -- )
|
||||||
dupd tag-number ORI ;
|
dupd tag-number ORI ;
|
||||||
|
|
||||||
M:: ppc %allot ( dst size class nursery-ptr -- )
|
M:: ppc %allot ( dst size class nursery-ptr -- )
|
||||||
nursery-ptr dst load-allot-ptr
|
nursery-ptr dst load-allot-ptr
|
||||||
|
nursery-ptr dst size inc-allot-ptr
|
||||||
dst class store-header
|
dst class store-header
|
||||||
dst class store-tagged
|
dst class store-tagged ;
|
||||||
nursery-ptr size inc-allot-ptr ;
|
|
||||||
|
|
||||||
: %alien-global ( dest name -- )
|
: %alien-global ( dst name -- )
|
||||||
[ f swap %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
|
[ f rot %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
|
||||||
|
|
||||||
: load-cards-offset ( dest -- )
|
: load-cards-offset ( dst -- )
|
||||||
"cards_offset" %alien-global ;
|
"cards_offset" %alien-global ;
|
||||||
|
|
||||||
: load-decks-offset ( dest -- )
|
: load-decks-offset ( dst -- )
|
||||||
"decks_offset" %alien-global ;
|
"decks_offset" %alien-global ;
|
||||||
|
|
||||||
M:: ppc %write-barrier ( src card# table -- )
|
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 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
|
||||||
11 0 12 CMP ! is here >= end?
|
11 0 12 CMP ! is here >= end?
|
||||||
"end" get BLE
|
"end" get BLE
|
||||||
0 frame-required
|
|
||||||
%prepare-alien-invoke
|
%prepare-alien-invoke
|
||||||
"minor_gc" f %alien-invoke
|
"minor_gc" f %alien-invoke
|
||||||
"end" resolve-label ;
|
"end" resolve-label ;
|
||||||
|
|
||||||
M: ppc %prologue ( n -- )
|
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
|
0 MFLR
|
||||||
1 1 pick neg ADDI
|
1 1 pick neg ADDI
|
||||||
scrach-reg 1 pick xt-save STW
|
scratch-reg 1 pick xt-save STW
|
||||||
dup scrach-reg LI
|
dup scratch-reg LI
|
||||||
scrach-reg 1 pick next-save STW
|
scratch-reg 1 pick next-save STW
|
||||||
0 1 rot lr-save + STW ;
|
0 1 rot lr-save + STW ;
|
||||||
|
|
||||||
M: ppc %epilogue ( n -- )
|
M: ppc %epilogue ( n -- )
|
||||||
|
@ -384,19 +368,19 @@ M: ppc %epilogue ( n -- )
|
||||||
|
|
||||||
:: (%boolean) ( dst word -- )
|
:: (%boolean) ( dst word -- )
|
||||||
"end" define-label
|
"end" define-label
|
||||||
\ f tag-number %load-immediate
|
dst \ f tag-number %load-immediate
|
||||||
"end" get word execute
|
"end" get word execute
|
||||||
dst \ t %load-indirect
|
dst \ t %load-indirect
|
||||||
"end" get resolve-label ; inline
|
"end" get resolve-label ; inline
|
||||||
|
|
||||||
: %boolean ( dst cc -- )
|
: %boolean ( dst cc -- )
|
||||||
negate-cc {
|
negate-cc {
|
||||||
{ cc< [ \ BLT %boolean ] }
|
{ cc< [ \ BLT (%boolean) ] }
|
||||||
{ cc<= [ \ BLE %boolean ] }
|
{ cc<= [ \ BLE (%boolean) ] }
|
||||||
{ cc> [ \ BGT %boolean ] }
|
{ cc> [ \ BGT (%boolean) ] }
|
||||||
{ cc>= [ \ BGE %boolean ] }
|
{ cc>= [ \ BGE (%boolean) ] }
|
||||||
{ cc= [ \ BEQ %boolean ] }
|
{ cc= [ \ BEQ (%boolean) ] }
|
||||||
{ cc/= [ \ BNE %boolean ] }
|
{ cc/= [ \ BNE (%boolean) ] }
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
|
: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
|
||||||
|
@ -426,7 +410,7 @@ M: ppc %compare-float-branch (%compare-float) %branch ;
|
||||||
|
|
||||||
: stack@ 1 swap ; inline
|
: stack@ 1 swap ; inline
|
||||||
|
|
||||||
: spill-integer@ ( n -- op )
|
: spill-integer@ ( n -- reg offset )
|
||||||
cells
|
cells
|
||||||
stack-frame get spill-integer-base
|
stack-frame get spill-integer-base
|
||||||
+ stack@ ;
|
+ stack@ ;
|
||||||
|
@ -437,7 +421,7 @@ M: ppc %compare-float-branch (%compare-float) %branch ;
|
||||||
[ return>> ]
|
[ return>> ]
|
||||||
tri + + ;
|
tri + + ;
|
||||||
|
|
||||||
: spill-float@ ( n -- op )
|
: spill-float@ ( n -- reg offset )
|
||||||
double-float-regs reg-size *
|
double-float-regs reg-size *
|
||||||
stack-frame get spill-float-base
|
stack-frame get spill-float-base
|
||||||
+ stack@ ;
|
+ stack@ ;
|
||||||
|
@ -453,11 +437,6 @@ M: ppc %loop-entry ;
|
||||||
M: int-regs return-reg drop 3 ;
|
M: int-regs return-reg drop 3 ;
|
||||||
M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ;
|
M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ;
|
||||||
M: float-regs return-reg drop 1 ;
|
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 %save-param-reg drop 1 rot local@ STW ;
|
||||||
M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
|
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 ;
|
11 %load-dlsym 11 MTLR BLRL ;
|
||||||
|
|
||||||
M: ppc %alien-callback ( quot -- )
|
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 ( -- )
|
M: ppc %prepare-alien-indirect ( -- )
|
||||||
"unbox_alien" f %alien-invoke
|
"unbox_alien" f %alien-invoke
|
||||||
|
@ -580,13 +559,6 @@ M: ppc %callback-value ( ctype -- )
|
||||||
! Unbox former top of data stack to return registers
|
! Unbox former top of data stack to return registers
|
||||||
unbox-return ;
|
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 small-enough? ( n -- ? ) -32768 32767 between? ;
|
||||||
|
|
||||||
M: ppc struct-small-enough? ( size -- ? ) drop f ;
|
M: ppc struct-small-enough? ( size -- ? ) drop f ;
|
||||||
|
@ -596,3 +568,10 @@ M: ppc %box-small-struct
|
||||||
|
|
||||||
M: ppc %unbox-small-struct
|
M: ppc %unbox-small-struct
|
||||||
drop "No small structs" throw ;
|
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-1 EAX ;
|
||||||
M: x86.32 temp-reg-2 ECX ;
|
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-global 0 [] MOV rc-absolute-cell rel-dlsym ;
|
||||||
|
|
||||||
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
|
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
|
||||||
|
|
|
@ -6,6 +6,7 @@ IN: bootstrap.x86
|
||||||
|
|
||||||
4 \ cell set
|
4 \ cell set
|
||||||
|
|
||||||
|
: stack-frame-size ( -- n ) 4 bootstrap-cells ;
|
||||||
: shift-arg ( -- reg ) ECX ;
|
: shift-arg ( -- reg ) ECX ;
|
||||||
: div-arg ( -- reg ) EAX ;
|
: div-arg ( -- reg ) EAX ;
|
||||||
: mod-arg ( -- reg ) EDX ;
|
: 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-1 RAX ;
|
||||||
M: x86.64 temp-reg-2 RCX ;
|
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 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 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 rel-literal-x86 rc-relative rel-literal ;
|
||||||
|
|
||||||
M: x86.64 %prologue ( n -- )
|
M: x86.64 %prologue ( n -- )
|
||||||
|
@ -90,7 +88,7 @@ M: struct-type flatten-value-type ( type -- seq )
|
||||||
|
|
||||||
M: x86.64 %prepare-unbox ( -- )
|
M: x86.64 %prepare-unbox ( -- )
|
||||||
! First parameter is top of stack
|
! First parameter is top of stack
|
||||||
RDI R14 [] MOV
|
param-reg-1 R14 [] MOV
|
||||||
R14 cell SUB ;
|
R14 cell SUB ;
|
||||||
|
|
||||||
M: x86.64 %unbox ( n reg-class func -- )
|
M: x86.64 %unbox ( n reg-class func -- )
|
||||||
|
@ -103,27 +101,27 @@ M: x86.64 %unbox-long-long ( n func -- )
|
||||||
int-regs swap %unbox ;
|
int-regs swap %unbox ;
|
||||||
|
|
||||||
: %unbox-struct-field ( c-type i -- )
|
: %unbox-struct-field ( c-type i -- )
|
||||||
! Alien must be in RDI.
|
! Alien must be in param-reg-1.
|
||||||
RDI swap cells [+] swap reg-class>> {
|
param-reg-1 swap cells [+] swap reg-class>> {
|
||||||
{ int-regs [ int-regs get pop swap MOV ] }
|
{ int-regs [ int-regs get pop swap MOV ] }
|
||||||
{ double-float-regs [ float-regs get pop swap MOVSD ] }
|
{ double-float-regs [ float-regs get pop swap MOVSD ] }
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
M: x86.64 %unbox-small-struct ( c-type -- )
|
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
|
"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.
|
! clobber it.
|
||||||
RDI RAX MOV
|
param-reg-1 RAX MOV
|
||||||
[
|
[
|
||||||
flatten-small-struct [ %unbox-struct-field ] each-index
|
flatten-small-struct [ %unbox-struct-field ] each-index
|
||||||
] with-return-regs ;
|
] with-return-regs ;
|
||||||
|
|
||||||
M: x86.64 %unbox-large-struct ( n c-type -- )
|
M: x86.64 %unbox-large-struct ( n c-type -- )
|
||||||
! Source is in RDI
|
! Source is in param-reg-1
|
||||||
heap-size
|
heap-size
|
||||||
! Load destination address
|
! Load destination address
|
||||||
RSI rot stack@ LEA
|
param-reg-2 rot stack@ LEA
|
||||||
! Load structure size
|
! Load structure size
|
||||||
RDX swap MOV
|
RDX swap MOV
|
||||||
! Copy the struct to the C stack
|
! 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 ]
|
[ flatten-small-struct [ %box-struct-field ] each-index ]
|
||||||
[ RDX swap heap-size MOV ] bi
|
[ RDX swap heap-size MOV ] bi
|
||||||
RDI 0 box-struct-field@ MOV
|
param-reg-1 0 box-struct-field@ MOV
|
||||||
RSI 1 box-struct-field@ MOV
|
param-reg-2 1 box-struct-field@ MOV
|
||||||
"box_small_struct" f %alien-invoke
|
"box_small_struct" f %alien-invoke
|
||||||
] with-return-regs ;
|
] with-return-regs ;
|
||||||
|
|
||||||
|
@ -170,9 +168,9 @@ M: x86.64 %box-small-struct ( c-type -- )
|
||||||
|
|
||||||
M: x86.64 %box-large-struct ( n c-type -- )
|
M: x86.64 %box-large-struct ( n c-type -- )
|
||||||
! Struct size is parameter 2
|
! Struct size is parameter 2
|
||||||
RSI swap heap-size MOV
|
param-reg-2 swap heap-size MOV
|
||||||
! Compute destination address
|
! Compute destination address
|
||||||
RDI swap struct-return@ LEA
|
param-reg-1 swap struct-return@ LEA
|
||||||
! Copy the struct from the C stack
|
! Copy the struct from the C stack
|
||||||
"box_value_struct" f %alien-invoke ;
|
"box_value_struct" f %alien-invoke ;
|
||||||
|
|
||||||
|
@ -200,7 +198,7 @@ M: x86.64 %alien-indirect ( -- )
|
||||||
RBP CALL ;
|
RBP CALL ;
|
||||||
|
|
||||||
M: x86.64 %alien-callback ( quot -- )
|
M: x86.64 %alien-callback ( quot -- )
|
||||||
RDI swap %load-indirect
|
param-reg-1 swap %load-indirect
|
||||||
"c_to_factor" f %alien-invoke ;
|
"c_to_factor" f %alien-invoke ;
|
||||||
|
|
||||||
M: x86.64 %callback-value ( ctype -- )
|
M: x86.64 %callback-value ( ctype -- )
|
||||||
|
@ -208,11 +206,11 @@ M: x86.64 %callback-value ( ctype -- )
|
||||||
%prepare-unbox
|
%prepare-unbox
|
||||||
! Save top of data stack
|
! Save top of data stack
|
||||||
RSP 8 SUB
|
RSP 8 SUB
|
||||||
RDI PUSH
|
param-reg-1 PUSH
|
||||||
! Restore data/call/retain stacks
|
! Restore data/call/retain stacks
|
||||||
"unnest_stacks" f %alien-invoke
|
"unnest_stacks" f %alien-invoke
|
||||||
! Put former top of data stack in RDI
|
! Put former top of data stack in param-reg-1
|
||||||
RDI POP
|
param-reg-1 POP
|
||||||
RSP 8 ADD
|
RSP 8 ADD
|
||||||
! Unbox former top of data stack to return registers
|
! Unbox former top of data stack to return registers
|
||||||
unbox-return ;
|
unbox-return ;
|
||||||
|
@ -223,3 +221,10 @@ enable-alien-4-intrinsics
|
||||||
|
|
||||||
! SSE2 is always available on x86-64.
|
! SSE2 is always available on x86-64.
|
||||||
enable-float-intrinsics
|
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 ;
|
: shift-arg ( -- reg ) RCX ;
|
||||||
: div-arg ( -- reg ) RAX ;
|
: div-arg ( -- reg ) RAX ;
|
||||||
: mod-arg ( -- reg ) RDX ;
|
: mod-arg ( -- reg ) RDX ;
|
||||||
: arg0 ( -- reg ) RDI ;
|
|
||||||
: arg1 ( -- reg ) RSI ;
|
|
||||||
: temp-reg ( -- reg ) RBX ;
|
: temp-reg ( -- reg ) RBX ;
|
||||||
: stack-reg ( -- reg ) RSP ;
|
: stack-reg ( -- reg ) RSP ;
|
||||||
: ds-reg ( -- reg ) R14 ;
|
: 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,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,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
|
1 jit-code-format set
|
||||||
|
|
||||||
: stack-frame-size ( -- n ) 4 bootstrap-cells ;
|
|
||||||
|
|
||||||
[
|
[
|
||||||
! Load word
|
! Load word
|
||||||
temp-reg 0 MOV
|
temp-reg 0 MOV
|
||||||
|
@ -30,7 +28,7 @@ big-endian off
|
||||||
temp-reg 0 MOV ! load XT
|
temp-reg 0 MOV ! load XT
|
||||||
stack-frame-size PUSH ! save stack frame size
|
stack-frame-size PUSH ! save stack frame size
|
||||||
temp-reg PUSH ! push XT
|
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
|
] 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 ds-reg [] MOV ! load shift count
|
||||||
shift-arg tag-bits get SAR ! untag shift count
|
shift-arg tag-bits get SAR ! untag shift count
|
||||||
ds-reg bootstrap-cell SUB ! adjust stack pointer
|
ds-reg bootstrap-cell SUB ! adjust stack pointer
|
||||||
arg0 ds-reg [] MOV ! load value
|
temp-reg ds-reg [] MOV ! load value
|
||||||
arg1 arg0 MOV ! make a copy
|
arg1 temp-reg MOV ! make a copy
|
||||||
arg1 CL SHL ! compute positive shift value in arg1
|
arg1 CL SHL ! compute positive shift value in arg1
|
||||||
shift-arg NEG ! compute negative shift value in arg0
|
shift-arg NEG ! compute negative shift value in arg0
|
||||||
arg0 CL SAR
|
temp-reg CL SAR
|
||||||
arg0 tag-mask get bitnot AND
|
temp-reg tag-mask get bitnot AND
|
||||||
shift-arg 0 CMP ! if shift count was negative, move arg0 to arg1
|
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
|
ds-reg [] arg1 MOV ! push to stack
|
||||||
] f f f \ fixnum-shift-fast define-sub-primitive
|
] f f f \ fixnum-shift-fast define-sub-primitive
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,2 @@
|
||||||
|
unportable
|
||||||
|
compiler
|
|
@ -39,12 +39,15 @@ M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
|
||||||
: align-stack ( n -- n' )
|
: align-stack ( n -- n' )
|
||||||
os macosx? cpu x86.64? or [ 16 align ] when ;
|
os macosx? cpu x86.64? or [ 16 align ] when ;
|
||||||
|
|
||||||
|
HOOK: reserved-area-size cpu ( -- n )
|
||||||
|
|
||||||
M: x86 stack-frame-size ( stack-frame -- i )
|
M: x86 stack-frame-size ( stack-frame -- i )
|
||||||
[ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
|
[ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
|
||||||
[ params>> ]
|
[ params>> ]
|
||||||
[ return>> ]
|
[ return>> ]
|
||||||
tri + +
|
tri + +
|
||||||
3 cells +
|
3 cells +
|
||||||
|
reserved-area-size +
|
||||||
align-stack ;
|
align-stack ;
|
||||||
|
|
||||||
M: x86 %call ( label -- ) CALL ;
|
M: x86 %call ( label -- ) CALL ;
|
||||||
|
@ -293,15 +296,13 @@ M:: x86 %box-alien ( dst src temp -- )
|
||||||
[ quot call ] with-save/restore
|
[ quot call ] with-save/restore
|
||||||
] if ; inline
|
] if ; inline
|
||||||
|
|
||||||
: aux-offset 2 cells string tag-number - ; inline
|
|
||||||
|
|
||||||
M:: x86 %string-nth ( dst src index temp -- )
|
M:: x86 %string-nth ( dst src index temp -- )
|
||||||
"end" define-label
|
"end" define-label
|
||||||
dst { src index temp } [| new-dst |
|
dst { src index temp } [| new-dst |
|
||||||
temp src index [+] LEA
|
temp src index [+] LEA
|
||||||
new-dst 1 small-reg temp string-offset [+] MOV
|
new-dst 1 small-reg temp string-offset [+] MOV
|
||||||
new-dst new-dst 1 small-reg MOVZX
|
new-dst new-dst 1 small-reg MOVZX
|
||||||
temp src aux-offset [+] MOV
|
temp src string-aux-offset [+] MOV
|
||||||
temp \ f tag-number CMP
|
temp \ f tag-number CMP
|
||||||
"end" get JE
|
"end" get JE
|
||||||
new-dst temp XCHG
|
new-dst temp XCHG
|
||||||
|
@ -467,7 +468,7 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
|
||||||
: stack@ ( n -- op ) stack-reg swap [+] ;
|
: stack@ ( n -- op ) stack-reg swap [+] ;
|
||||||
|
|
||||||
: spill-integer-base ( stack-frame -- n )
|
: spill-integer-base ( stack-frame -- n )
|
||||||
[ params>> ] [ return>> ] bi + ;
|
[ params>> ] [ return>> ] bi + reserved-area-size + ;
|
||||||
|
|
||||||
: spill-integer@ ( n -- op )
|
: spill-integer@ ( n -- op )
|
||||||
cells
|
cells
|
||||||
|
@ -475,10 +476,9 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
|
||||||
+ stack@ ;
|
+ stack@ ;
|
||||||
|
|
||||||
: spill-float-base ( stack-frame -- n )
|
: spill-float-base ( stack-frame -- n )
|
||||||
|
[ spill-integer-base ]
|
||||||
[ spill-counts>> int-regs swap at int-regs reg-size * ]
|
[ spill-counts>> int-regs swap at int-regs reg-size * ]
|
||||||
[ params>> ]
|
bi + ;
|
||||||
[ return>> ]
|
|
||||||
tri + + ;
|
|
||||||
|
|
||||||
: spill-float@ ( n -- op )
|
: spill-float@ ( n -- op )
|
||||||
double-float-regs reg-size *
|
double-float-regs reg-size *
|
||||||
|
|
|
@ -39,7 +39,7 @@ HOOK: (wait-to-read) io-backend ( port -- )
|
||||||
|
|
||||||
M: input-port stream-read1
|
M: input-port stream-read1
|
||||||
dup check-disposed
|
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 )
|
: read-step ( count port -- byte-array/f )
|
||||||
dup wait-to-read [ 2drop f ] [ buffer>> buffer-read ] if ;
|
dup wait-to-read [ 2drop f ] [ buffer>> buffer-read ] if ;
|
||||||
|
@ -105,7 +105,7 @@ TUPLE: output-port < buffered-port ;
|
||||||
M: output-port stream-write1
|
M: output-port stream-write1
|
||||||
dup check-disposed
|
dup check-disposed
|
||||||
1 over wait-to-write
|
1 over wait-to-write
|
||||||
buffer>> byte>buffer ;
|
buffer>> byte>buffer ; inline
|
||||||
|
|
||||||
M: output-port stream-write
|
M: output-port stream-write
|
||||||
dup check-disposed
|
dup check-disposed
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
IN: io.streams.memory
|
||||||
|
|
||||||
TUPLE: memory-stream alien index ;
|
TUPLE: memory-stream alien index ;
|
||||||
|
@ -11,3 +11,9 @@ TUPLE: memory-stream alien index ;
|
||||||
M: memory-stream stream-read1
|
M: memory-stream stream-read1
|
||||||
[ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
|
[ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
|
||||||
[ [ 1+ ] change-index drop ] bi ;
|
[ [ 1+ ] change-index drop ] bi ;
|
||||||
|
|
||||||
|
M: memory-stream stream-read
|
||||||
|
[
|
||||||
|
[ index>> ] [ alien>> ] bi <displaced-alien>
|
||||||
|
swap memory>byte-array
|
||||||
|
] [ [ + ] change-index drop ] 2bi ;
|
||||||
|
|
|
@ -76,6 +76,25 @@ IN: math.functions.tests
|
||||||
gcd nip
|
gcd nip
|
||||||
] unit-test
|
] 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 -- ? )
|
: verify-gcd ( a b -- ? )
|
||||||
2dup gcd
|
2dup gcd
|
||||||
>r rot * swap rem r> = ;
|
>r rot * swap rem r> = ;
|
||||||
|
|
|
@ -83,8 +83,6 @@ IN: math.intervals.tests
|
||||||
0 1 (a,b) 1 2 [a,b] interval-union 0 2 (a,b] =
|
0 1 (a,b) 1 2 [a,b] interval-union 0 2 (a,b] =
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ f ] [ 0 1 (a,b) f interval-union ] unit-test
|
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
0 1 (a,b) 0 1 [a,b] interval-intersect 0 1 (a,b) =
|
0 1 (a,b) 0 1 [a,b] interval-intersect 0 1 (a,b) =
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
@ -115,14 +115,10 @@ TUPLE: interval { from read-only } { to read-only } ;
|
||||||
{ [ dup empty-interval eq? ] [ nip ] }
|
{ [ dup empty-interval eq? ] [ nip ] }
|
||||||
{ [ over empty-interval eq? ] [ drop ] }
|
{ [ over empty-interval eq? ] [ drop ] }
|
||||||
[
|
[
|
||||||
2dup and [
|
[ interval>points ] bi@ swapd
|
||||||
[ interval>points ] bi@ swapd
|
[ [ swap endpoint< ] most ]
|
||||||
[ [ swap endpoint< ] most ]
|
[ [ swap endpoint> ] most ] 2bi*
|
||||||
[ [ swap endpoint> ] most ] 2bi*
|
<interval>
|
||||||
<interval>
|
|
||||||
] [
|
|
||||||
or
|
|
||||||
] if
|
|
||||||
]
|
]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
|
@ -133,13 +129,7 @@ TUPLE: interval { from read-only } { to read-only } ;
|
||||||
{
|
{
|
||||||
{ [ dup empty-interval eq? ] [ drop ] }
|
{ [ dup empty-interval eq? ] [ drop ] }
|
||||||
{ [ over empty-interval eq? ] [ nip ] }
|
{ [ over empty-interval eq? ] [ nip ] }
|
||||||
[
|
[ [ interval>points 2array ] bi@ append points>interval ]
|
||||||
2dup and [
|
|
||||||
[ interval>points 2array ] bi@ append points>interval
|
|
||||||
] [
|
|
||||||
2drop f
|
|
||||||
] if
|
|
||||||
]
|
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: interval-subset? ( i1 i2 -- ? )
|
: interval-subset? ( i1 i2 -- ? )
|
||||||
|
@ -183,7 +173,6 @@ TUPLE: interval { from read-only } { to read-only } ;
|
||||||
: interval-length ( int -- n )
|
: interval-length ( int -- n )
|
||||||
{
|
{
|
||||||
{ [ dup empty-interval eq? ] [ drop 0 ] }
|
{ [ dup empty-interval eq? ] [ drop 0 ] }
|
||||||
{ [ dup not ] [ drop 0 ] }
|
|
||||||
[ interval>points [ first ] bi@ swap - ]
|
[ interval>points [ first ] bi@ swap - ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
|
|
|
@ -233,15 +233,22 @@ ERROR: invalid-range a b ;
|
||||||
SINGLETON: beginning-of-input
|
SINGLETON: beginning-of-input
|
||||||
SINGLETON: end-of-input
|
SINGLETON: end-of-input
|
||||||
|
|
||||||
! : beginning-of-input ( -- obj )
|
: newlines ( -- obj1 obj2 obj3 )
|
||||||
: handle-front-anchor ( -- ) front-anchor push-stack ;
|
|
||||||
: end-of-line ( -- obj )
|
|
||||||
end-of-input
|
|
||||||
CHAR: \r <constant>
|
CHAR: \r <constant>
|
||||||
CHAR: \n <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: bad-character-class obj ;
|
||||||
ERROR: expected-posix-class ;
|
ERROR: expected-posix-class ;
|
||||||
|
@ -412,16 +419,11 @@ DEFER: handle-left-bracket
|
||||||
[ [ push ] keep current-regexp get (>>stack) ]
|
[ [ push ] keep current-regexp get (>>stack) ]
|
||||||
[ finish-regexp-parse push-stack ] bi* ;
|
[ finish-regexp-parse push-stack ] bi* ;
|
||||||
|
|
||||||
|
|
||||||
: parse-regexp-token ( token -- ? )
|
: parse-regexp-token ( token -- ? )
|
||||||
{
|
{
|
||||||
! todo: only match these at beginning/end of regexp
|
{ CHAR: ( [ handle-left-parenthesis t ] } ! handle (?..) at beginning?
|
||||||
{ CHAR: ^ [ handle-front-anchor t ] }
|
|
||||||
{ CHAR: $ [ handle-back-anchor t ] }
|
|
||||||
|
|
||||||
{ CHAR: . [ handle-dot t ] }
|
|
||||||
{ CHAR: ( [ handle-left-parenthesis t ] }
|
|
||||||
{ CHAR: ) [ handle-right-parenthesis f ] }
|
{ CHAR: ) [ handle-right-parenthesis f ] }
|
||||||
|
{ CHAR: . [ handle-dot t ] }
|
||||||
{ CHAR: | [ handle-pipe t ] }
|
{ CHAR: | [ handle-pipe t ] }
|
||||||
{ CHAR: ? [ handle-question t ] }
|
{ CHAR: ? [ handle-question t ] }
|
||||||
{ CHAR: * [ handle-star t ] }
|
{ CHAR: * [ handle-star t ] }
|
||||||
|
@ -429,16 +431,28 @@ DEFER: handle-left-bracket
|
||||||
{ CHAR: { [ handle-left-brace t ] }
|
{ CHAR: { [ handle-left-brace t ] }
|
||||||
{ CHAR: [ [ handle-left-bracket t ] }
|
{ CHAR: [ [ handle-left-bracket t ] }
|
||||||
{ CHAR: \ [ handle-escape 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 ;
|
} case ;
|
||||||
|
|
||||||
: (parse-regexp) ( -- )
|
: (parse-regexp) ( -- )
|
||||||
read1 [ parse-regexp-token [ (parse-regexp) ] when ] when* ;
|
read1 [ parse-regexp-token [ (parse-regexp) ] when ] when* ;
|
||||||
|
|
||||||
|
: parse-regexp-beginning ( -- )
|
||||||
|
peek1 CHAR: ^ = [ drop1 handle-front-anchor ] when ;
|
||||||
|
|
||||||
: parse-regexp ( regexp -- )
|
: parse-regexp ( regexp -- )
|
||||||
dup current-regexp [
|
dup current-regexp [
|
||||||
raw>> [
|
raw>> [
|
||||||
<string-reader> [ (parse-regexp) ] with-input-stream
|
<string-reader> [
|
||||||
|
parse-regexp-beginning (parse-regexp)
|
||||||
|
] with-input-stream
|
||||||
] unless-empty
|
] unless-empty
|
||||||
current-regexp get
|
current-regexp get
|
||||||
stack finish-regexp-parse
|
stack finish-regexp-parse
|
||||||
|
|
|
@ -331,4 +331,3 @@ IN: regexp-tests
|
||||||
[ { 0 3 } ] [ "abc" "(ab|a)(bc)?" <regexp> first-match ] unit-test
|
[ { 0 3 } ] [ "abc" "(ab|a)(bc)?" <regexp> first-match ] unit-test
|
||||||
|
|
||||||
[ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match ] unit-test
|
[ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -92,7 +92,6 @@ IN: regexp
|
||||||
reversed-regexp initial-option
|
reversed-regexp initial-option
|
||||||
construct-regexp ;
|
construct-regexp ;
|
||||||
|
|
||||||
|
|
||||||
: parsing-regexp ( accum end -- accum )
|
: parsing-regexp ( accum end -- accum )
|
||||||
lexer get dup skip-blank
|
lexer get dup skip-blank
|
||||||
[ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
|
[ [ 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
|
||||||
: R| CHAR: | parsing-regexp ; parsing
|
: R| CHAR: | parsing-regexp ; parsing
|
||||||
|
|
||||||
|
|
||||||
: find-regexp-syntax ( string -- prefix suffix )
|
: find-regexp-syntax ( string -- prefix suffix )
|
||||||
{
|
{
|
||||||
{ "R/ " "/" }
|
{ "R/ " "/" }
|
||||||
|
|
|
@ -2,7 +2,8 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors assocs combinators kernel math math.ranges
|
USING: accessors assocs combinators kernel math math.ranges
|
||||||
quotations sequences regexp.parser regexp.classes fry arrays
|
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
|
IN: regexp.traversal
|
||||||
|
|
||||||
TUPLE: dfa-traverser
|
TUPLE: dfa-traverser
|
||||||
|
@ -23,8 +24,7 @@ TUPLE: dfa-traverser
|
||||||
[ dfa-table>> ] [ dfa-traversal-flags>> ] bi
|
[ dfa-table>> ] [ dfa-traversal-flags>> ] bi
|
||||||
dfa-traverser new
|
dfa-traverser new
|
||||||
swap >>traversal-flags
|
swap >>traversal-flags
|
||||||
swap [ start-state>> >>current-state ] keep
|
swap [ start-state>> >>current-state ] [ >>dfa-table ] bi
|
||||||
>>dfa-table
|
|
||||||
swap >>text
|
swap >>text
|
||||||
t >>traverse-forward
|
t >>traverse-forward
|
||||||
0 >>start-index
|
0 >>start-index
|
||||||
|
@ -116,7 +116,7 @@ M: capture-group-off flag-action ( dfa-traverser flag -- )
|
||||||
V{ } clone >>matches ;
|
V{ } clone >>matches ;
|
||||||
|
|
||||||
: match-literal ( transition from-state table -- to-state/f )
|
: 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 )
|
: match-class ( transition from-state table -- to-state/f )
|
||||||
transitions>> at* [
|
transitions>> at* [
|
||||||
|
@ -124,8 +124,7 @@ M: capture-group-off flag-action ( dfa-traverser flag -- )
|
||||||
] [ drop ] if ;
|
] [ drop ] if ;
|
||||||
|
|
||||||
: match-default ( transition from-state table -- to-state/f )
|
: match-default ( transition from-state table -- to-state/f )
|
||||||
[ nip ] dip transitions>> at*
|
nipd transitions>> at t swap at ;
|
||||||
[ t swap at* [ ] [ drop f ] if ] [ drop f ] if ;
|
|
||||||
|
|
||||||
: match-transition ( obj from-state dfa -- to-state/f )
|
: match-transition ( obj from-state dfa -- to-state/f )
|
||||||
{ [ match-literal ] [ match-class ] [ match-default ] } 3|| ;
|
{ [ match-literal ] [ match-class ] [ match-default ] } 3|| ;
|
||||||
|
|
|
@ -60,10 +60,11 @@ check_gcc_version() {
|
||||||
GCC_VERSION=`$CC --version`
|
GCC_VERSION=`$CC --version`
|
||||||
check_ret gcc
|
check_ret gcc
|
||||||
if [[ $GCC_VERSION == *3.3.* ]] ; then
|
if [[ $GCC_VERSION == *3.3.* ]] ; then
|
||||||
$ECHO "bad!"
|
|
||||||
$ECHO "You have a known buggy version of gcc (3.3)"
|
$ECHO "You have a known buggy version of gcc (3.3)"
|
||||||
$ECHO "Install gcc 3.4 or higher and try again."
|
$ECHO "Install gcc 3.4 or higher and try again."
|
||||||
exit 3
|
exit 3
|
||||||
|
elif [[ $GCC_VERSION == *4.3.* ]] ; then
|
||||||
|
MAKE_OPTS="$MAKE_OPTS SITE_CFLAGS=-fno-forward-propagate"
|
||||||
fi
|
fi
|
||||||
$ECHO "ok."
|
$ECHO "ok."
|
||||||
}
|
}
|
||||||
|
@ -271,18 +272,18 @@ check_os_arch_word() {
|
||||||
set_build_info() {
|
set_build_info() {
|
||||||
check_os_arch_word
|
check_os_arch_word
|
||||||
MAKE_TARGET=$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
|
if [[ $OS == macosx && $ARCH == ppc ]] ; then
|
||||||
MAKE_IMAGE_TARGET=$OS-$ARCH
|
MAKE_IMAGE_TARGET=macosx-ppc
|
||||||
MAKE_TARGET=$OS-$ARCH
|
elif [[ $OS == linux && $ARCH == ppc ]] ; then
|
||||||
BOOT_IMAGE=boot.macosx-ppc.image
|
MAKE_IMAGE_TARGET=linux-ppc
|
||||||
fi
|
elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then
|
||||||
if [[ $OS == linux && $ARCH == ppc ]] ; then
|
MAKE_IMAGE_TARGET=winnt-x86.64
|
||||||
MAKE_IMAGE_TARGET=$OS-$ARCH
|
elif [[ $ARCH == x86 && $WORD == 64 ]] ; then
|
||||||
MAKE_TARGET=$OS-$ARCH
|
MAKE_IMAGE_TARGET=unix-x86.64
|
||||||
BOOT_IMAGE=boot.linux-ppc.image
|
else
|
||||||
|
MAKE_IMAGE_TARGET=$ARCH.$WORD
|
||||||
fi
|
fi
|
||||||
|
BOOT_IMAGE=boot.$MAKE_IMAGE_TARGET.image
|
||||||
}
|
}
|
||||||
|
|
||||||
parse_build_info() {
|
parse_build_info() {
|
||||||
|
@ -335,7 +336,7 @@ cd_factor() {
|
||||||
}
|
}
|
||||||
|
|
||||||
invoke_make() {
|
invoke_make() {
|
||||||
$MAKE $*
|
$MAKE $MAKE_OPTS $*
|
||||||
check_ret $MAKE
|
check_ret $MAKE
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
@ -20,7 +20,8 @@ H{ } clone sub-primitives set
|
||||||
|
|
||||||
"resource:basis/cpu/" architecture get {
|
"resource:basis/cpu/" architecture get {
|
||||||
{ "x86.32" "x86/32" }
|
{ "x86.32" "x86/32" }
|
||||||
{ "x86.64" "x86/64" }
|
{ "winnt-x86.64" "x86/64/winnt" }
|
||||||
|
{ "unix-x86.64" "x86/64/unix" }
|
||||||
{ "linux-ppc" "ppc/linux" }
|
{ "linux-ppc" "ppc/linux" }
|
||||||
{ "macosx-ppc" "ppc/macosx" }
|
{ "macosx-ppc" "ppc/macosx" }
|
||||||
{ "arm" "arm" }
|
{ "arm" "arm" }
|
||||||
|
|
|
@ -90,20 +90,29 @@ ERROR: bad-superclass class ;
|
||||||
2drop f
|
2drop f
|
||||||
] if ; inline
|
] if ; inline
|
||||||
|
|
||||||
|
: tuple-instance-1? ( object class -- ? )
|
||||||
|
swap dup tuple? [
|
||||||
|
layout-of 7 slot eq?
|
||||||
|
] [ 2drop f ] if ; inline
|
||||||
|
|
||||||
: tuple-instance? ( object class offset -- ? )
|
: tuple-instance? ( object class offset -- ? )
|
||||||
#! 4 slot == superclasses>>
|
|
||||||
rot dup tuple? [
|
rot dup tuple? [
|
||||||
layout-of
|
layout-of
|
||||||
2dup 1 slot fixnum<=
|
2dup 1 slot fixnum<=
|
||||||
[ swap slot eq? ] [ 3drop f ] if
|
[ swap slot eq? ] [ 3drop f ] if
|
||||||
] [ 3drop f ] if ; inline
|
] [ 3drop f ] if ; inline
|
||||||
|
|
||||||
: layout-class-offset ( class -- n )
|
: layout-class-offset ( echelon -- n )
|
||||||
tuple-layout third 2 * 5 + ;
|
2 * 5 + ;
|
||||||
|
|
||||||
|
: echelon-of ( class -- n )
|
||||||
|
tuple-layout third ;
|
||||||
|
|
||||||
: define-tuple-predicate ( class -- )
|
: define-tuple-predicate ( class -- )
|
||||||
dup dup layout-class-offset
|
dup dup echelon-of {
|
||||||
[ tuple-instance? ] 2curry define-predicate ;
|
{ 1 [ [ tuple-instance-1? ] curry ] }
|
||||||
|
[ layout-class-offset [ tuple-instance? ] 2curry ]
|
||||||
|
} case define-predicate ;
|
||||||
|
|
||||||
: class-size ( class -- n )
|
: class-size ( class -- n )
|
||||||
superclasses [ "slots" word-prop length ] sigma ;
|
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 rank-class drop 0 ;
|
||||||
|
|
||||||
M: tuple-class instance?
|
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 ;
|
M: tuple-class (flatten-class) dup set ;
|
||||||
|
|
||||||
|
|
|
@ -8,7 +8,7 @@ ERROR: not-in-a-method-error ;
|
||||||
: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
|
: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
|
||||||
|
|
||||||
: create-method-in ( class generic -- method )
|
: 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 )
|
: CREATE-METHOD ( -- method )
|
||||||
scan-word bootstrap-word scan-word create-method-in ;
|
scan-word bootstrap-word scan-word create-method-in ;
|
||||||
|
@ -18,11 +18,11 @@ SYMBOL: current-generic
|
||||||
|
|
||||||
: with-method-definition ( quot -- parsed )
|
: with-method-definition ( quot -- parsed )
|
||||||
[
|
[
|
||||||
>r
|
[
|
||||||
[ "method-class" word-prop current-class set ]
|
[ "method-class" word-prop current-class set ]
|
||||||
[ "method-generic" word-prop current-generic set ]
|
[ "method-generic" word-prop current-generic set ]
|
||||||
[ ] tri
|
[ ] tri
|
||||||
r> call
|
] dip call
|
||||||
] with-scope ; inline
|
] with-scope ; inline
|
||||||
|
|
||||||
: (M:) ( method def -- )
|
: (M:) ( method def -- )
|
||||||
|
|
|
@ -27,7 +27,7 @@ M: lo-tag-dispatch-engine engine>quot
|
||||||
[ >r lo-tag-number r> ] assoc-map
|
[ >r lo-tag-number r> ] assoc-map
|
||||||
[
|
[
|
||||||
picker % [ tag ] % [
|
picker % [ tag ] % [
|
||||||
! >alist sort-keys reverse
|
>alist sort-keys reverse
|
||||||
linear-dispatch-quot
|
linear-dispatch-quot
|
||||||
] [
|
] [
|
||||||
num-tags get direct-dispatch-quot
|
num-tags get direct-dispatch-quot
|
||||||
|
|
|
@ -48,10 +48,14 @@ TUPLE: tuple-dispatch-engine echelons ;
|
||||||
\ <tuple-dispatch-engine> convert-methods ;
|
\ <tuple-dispatch-engine> convert-methods ;
|
||||||
|
|
||||||
M: trivial-tuple-dispatch-engine engine>quot
|
M: trivial-tuple-dispatch-engine engine>quot
|
||||||
[
|
[ n>> ] [ methods>> ] bi dup assoc-empty? [
|
||||||
[ n>> nth-superclass% ]
|
2drop default get [ drop ] prepend
|
||||||
[ methods>> engines>quots* linear-dispatch-quot % ] bi
|
] [
|
||||||
] [ ] make ;
|
[
|
||||||
|
[ nth-superclass% ]
|
||||||
|
[ engines>quots* linear-dispatch-quot % ] bi*
|
||||||
|
] [ ] make
|
||||||
|
] if ;
|
||||||
|
|
||||||
: hash-methods ( n methods -- buckets )
|
: hash-methods ( n methods -- buckets )
|
||||||
>alist V{ } clone [ hashcode 1array ] distribute-buckets
|
>alist V{ } clone [ hashcode 1array ] distribute-buckets
|
||||||
|
@ -119,11 +123,19 @@ M: echelon-dispatch-engine engine>quot
|
||||||
] assoc-map
|
] assoc-map
|
||||||
alist>quot ;
|
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 )
|
: echelon-case-quot ( alist -- quot )
|
||||||
#! We don't have to test for echelon 1 since all tuple
|
#! We don't have to test for echelon 1 since all tuple
|
||||||
#! classes are at least at depth 1 in the inheritance
|
#! classes are at least at depth 1 in the inheritance
|
||||||
#! hierarchy.
|
#! hierarchy.
|
||||||
dup first first 1 = [ unclip second ] [ default get ] if swap
|
default get swap simplify-echelon-alist
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
picker %
|
picker %
|
||||||
|
@ -140,8 +152,11 @@ M: tuple-dispatch-engine engine>quot
|
||||||
echelons>> unclip-last
|
echelons>> unclip-last
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
engine>quot define-engine-word
|
engine>quot
|
||||||
[ remember-engine ] [ 1quotation ] bi
|
over 0 = [
|
||||||
|
define-engine-word
|
||||||
|
[ remember-engine ] [ 1quotation ] bi
|
||||||
|
] unless
|
||||||
dup default set
|
dup default set
|
||||||
] assoc-map
|
] assoc-map
|
||||||
]
|
]
|
||||||
|
|
|
@ -167,11 +167,11 @@ GENERIC: boa ( ... class -- tuple )
|
||||||
compose compose ; inline
|
compose compose ; inline
|
||||||
|
|
||||||
! Booleans
|
! Booleans
|
||||||
: not ( obj -- ? ) f t ? ; inline
|
: not ( obj -- ? ) [ f ] [ t ] if ; inline
|
||||||
|
|
||||||
: and ( obj1 obj2 -- ? ) over ? ; inline
|
: and ( obj1 obj2 -- ? ) over ? ; inline
|
||||||
|
|
||||||
: >boolean ( obj -- ? ) t f ? ; inline
|
: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline
|
||||||
|
|
||||||
: or ( obj1 obj2 -- ? ) dupd ? ; inline
|
: or ( obj1 obj2 -- ? ) dupd ? ; inline
|
||||||
|
|
||||||
|
|
|
@ -101,8 +101,13 @@ unit-test
|
||||||
[ 268435456 ] [ -268435456 >fixnum -1 /i ] unit-test
|
[ 268435456 ] [ -268435456 >fixnum -1 /i ] unit-test
|
||||||
[ 268435456 0 ] [ -268435456 >fixnum -1 /mod ] unit-test
|
[ 268435456 0 ] [ -268435456 >fixnum -1 /mod ] unit-test
|
||||||
[ 0 ] [ -1 -268435456 >fixnum /i ] 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 >fixnum /mod ] unit-test
|
||||||
|
[ 0 -1 ] [ -1 -268435456 >bignum /mod ] unit-test
|
||||||
[ 14355 ] [ 1591517158873146351817850880000000 32769 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
|
[ -351382792 ] [ -43922849 3 shift ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -262,7 +262,7 @@ M: word forget*
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
M: word hashcode*
|
M: word hashcode*
|
||||||
nip 1 slot { fixnum } declare ;
|
nip 1 slot { fixnum } declare ; foldable
|
||||||
|
|
||||||
M: word literalize <wrapper> ;
|
M: word literalize <wrapper> ;
|
||||||
|
|
||||||
|
|
|
@ -13,7 +13,7 @@ HELP: make-advised
|
||||||
{ $see-also advised? annotate } ;
|
{ $see-also advised? annotate } ;
|
||||||
|
|
||||||
HELP: advised?
|
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." } ;
|
{ $description "Determines whether or not the given word has any advice on it." } ;
|
||||||
|
|
||||||
ARTICLE: "advice" "Advice"
|
ARTICLE: "advice" "Advice"
|
||||||
|
|
|
@ -6,12 +6,12 @@ continuations debugger ;
|
||||||
IN: benchmark
|
IN: benchmark
|
||||||
|
|
||||||
: run-benchmark ( vocab -- result )
|
: run-benchmark ( vocab -- result )
|
||||||
[ [ require ] [ [ run ] benchmark ] bi ] curry
|
[ [ require ] [ [ run ] benchmark ] bi ] curry
|
||||||
[ error. f ] recover ;
|
[ error. f ] recover ;
|
||||||
|
|
||||||
: run-benchmarks ( -- assoc )
|
: run-benchmarks ( -- assoc )
|
||||||
"benchmark" all-child-vocabs-seq
|
"benchmark" all-child-vocabs-seq
|
||||||
[ dup run-benchmark ] { } map>assoc ;
|
[ dup run-benchmark ] { } map>assoc ;
|
||||||
|
|
||||||
: benchmarks. ( assoc -- )
|
: benchmarks. ( assoc -- )
|
||||||
standard-table-style [
|
standard-table-style [
|
||||||
|
|
|
@ -131,6 +131,9 @@ MACRO: undo ( quot -- ) [undo] ;
|
||||||
\ pick [ >r pick r> =/fail ] define-inverse
|
\ pick [ >r pick r> =/fail ] define-inverse
|
||||||
\ tuck [ swapd [ =/fail ] keep ] 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
|
||||||
\ r> [ >r ] define-inverse
|
\ r> [ >r ] define-inverse
|
||||||
|
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
|
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel system accessors namespaces splitting sequences
|
USING: kernel system accessors namespaces splitting sequences
|
||||||
mason.config ;
|
mason.config bootstrap.image ;
|
||||||
IN: mason.platform
|
IN: mason.platform
|
||||||
|
|
||||||
: platform ( -- string )
|
: platform ( -- string )
|
||||||
|
@ -11,7 +11,7 @@ IN: mason.platform
|
||||||
target-os get { "freebsd" "openbsd" "netbsd" } member? "gmake" "make" ? ;
|
target-os get { "freebsd" "openbsd" "netbsd" } member? "gmake" "make" ? ;
|
||||||
|
|
||||||
: boot-image-arch ( -- string )
|
: 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-image-name ( -- string )
|
||||||
"boot." boot-image-arch ".image" 3append ;
|
"boot." boot-image-arch ".image" 3append ;
|
||||||
|
|
|
@ -44,5 +44,12 @@ PRIVATE>
|
||||||
: all-permutations ( seq -- seq )
|
: all-permutations ( seq -- seq )
|
||||||
[ length factorial ] keep '[ _ permutation ] map ;
|
[ 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 )
|
: inverse-permutation ( seq -- permutation )
|
||||||
<enum> >alist sort-values keys ;
|
<enum> >alist sort-values keys ;
|
||||||
|
|
|
@ -52,8 +52,11 @@ IN: project-euler.043
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: euler043 ( -- answer )
|
: euler043 ( -- answer )
|
||||||
1234567890 number>digits all-permutations
|
1234567890 number>digits 0 [
|
||||||
[ interesting? ] filter [ 10 digits>integer ] map sum ;
|
dup interesting? [
|
||||||
|
10 digits>integer +
|
||||||
|
] [ drop ] if
|
||||||
|
] reduce-permutations ;
|
||||||
|
|
||||||
! [ euler043 ] time
|
! [ euler043 ] time
|
||||||
! 104526 ms run / 42735 ms GC time
|
! 104526 ms run / 42735 ms GC time
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu.
|
! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: definitions io io.files kernel math math.parser project-euler.ave-time
|
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.001 project-euler.002 project-euler.003 project-euler.004
|
||||||
project-euler.005 project-euler.006 project-euler.007 project-euler.008
|
project-euler.005 project-euler.006 project-euler.007 project-euler.008
|
||||||
project-euler.009 project-euler.010 project-euler.011 project-euler.012
|
project-euler.009 project-euler.010 project-euler.011 project-euler.012
|
||||||
|
@ -33,7 +33,7 @@ IN: project-euler
|
||||||
|
|
||||||
: solution-path ( n -- str/f )
|
: solution-path ( n -- str/f )
|
||||||
number>euler "project-euler." prepend
|
number>euler "project-euler." prepend
|
||||||
vocab where dup [ first ] when ;
|
vocab where dup [ first <pathname> ] when ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
@ -43,8 +43,8 @@ PRIVATE>
|
||||||
: run-project-euler ( -- )
|
: run-project-euler ( -- )
|
||||||
problem-prompt dup problem-solved? [
|
problem-prompt dup problem-solved? [
|
||||||
dup number>euler "project-euler." prepend run
|
dup number>euler "project-euler." prepend run
|
||||||
"Answer: " swap dup number? [ number>string ] when append print
|
"Answer: " write dup number? [ number>string ] when print
|
||||||
"Source: " swap solution-path append print
|
"Source: " write solution-path .
|
||||||
] [
|
] [
|
||||||
drop "That problem has not been solved yet..." print
|
drop "That problem has not been solved yet..." print
|
||||||
] if ;
|
] if ;
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
#WIN64_PATH=/k/MinGW/win64/bin
|
#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
|
CC=$(WIN64_PATH)-gcc.exe
|
||||||
WINDRES=$(WIN64_PATH)-windres.exe
|
WINDRES=$(WIN64_PATH)-windres.exe
|
||||||
include vm/Config.windows.nt
|
include vm/Config.windows.nt
|
||||||
|
|
27
vm/bignum.c
27
vm/bignum.c
|
@ -1,7 +1,7 @@
|
||||||
/* :tabSize=2:indentSize=2:noTabs=true:
|
/* :tabSize=2:indentSize=2:noTabs=true:
|
||||||
|
|
||||||
Copyright (C) 1989-94 Massachusetts Institute of Technology
|
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
|
This material was developed by the Scheme project at the Massachusetts
|
||||||
Institute of Technology, Department of Electrical Engineering and
|
Institute of Technology, Department of Electrical Engineering and
|
||||||
|
@ -45,6 +45,7 @@ MIT in each case. */
|
||||||
* - Remove unused functions
|
* - Remove unused functions
|
||||||
* - Add local variable GC root recording
|
* - Add local variable GC root recording
|
||||||
* - Remove s48 prefix from function names
|
* - Remove s48 prefix from function names
|
||||||
|
* - Various fixes for Win64
|
||||||
*/
|
*/
|
||||||
|
|
||||||
#include "master.h"
|
#include "master.h"
|
||||||
|
@ -366,8 +367,6 @@ bignum_remainder(bignum_type numerator, bignum_type denominator)
|
||||||
/* all below allocate memory */
|
/* all below allocate memory */
|
||||||
FOO_TO_BIGNUM(cell,CELL,CELL)
|
FOO_TO_BIGNUM(cell,CELL,CELL)
|
||||||
FOO_TO_BIGNUM(fixnum,F_FIXNUM,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(long_long,s64,u64)
|
||||||
FOO_TO_BIGNUM(ulong_long,u64,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 */
|
/* all of the below allocate memory */
|
||||||
BIGNUM_TO_FOO(cell,CELL,CELL);
|
BIGNUM_TO_FOO(cell,CELL,CELL);
|
||||||
BIGNUM_TO_FOO(fixnum,F_FIXNUM,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(long_long,s64,u64)
|
||||||
BIGNUM_TO_FOO(ulong_long,u64,u64)
|
BIGNUM_TO_FOO(ulong_long,u64,u64)
|
||||||
|
|
||||||
|
@ -435,7 +432,7 @@ double_to_bignum(double x)
|
||||||
bignum_digit_type digit;
|
bignum_digit_type digit;
|
||||||
int odd_bits = (exponent % BIGNUM_DIGIT_LENGTH);
|
int odd_bits = (exponent % BIGNUM_DIGIT_LENGTH);
|
||||||
if (odd_bits > 0)
|
if (odd_bits > 0)
|
||||||
DTB_WRITE_DIGIT (1L << odd_bits);
|
DTB_WRITE_DIGIT ((F_FIXNUM)1 << odd_bits);
|
||||||
while (start < scan)
|
while (start < scan)
|
||||||
{
|
{
|
||||||
if (significand == 0)
|
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_source = (scan_source + (BIGNUM_LENGTH (source)));
|
||||||
bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target)));
|
bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target)));
|
||||||
int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left);
|
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)
|
while (scan_source < end_source)
|
||||||
{
|
{
|
||||||
digit = (*scan_source++);
|
digit = (*scan_source++);
|
||||||
|
@ -1139,7 +1136,7 @@ bignum_destructive_unnormalization(bignum_type bignum, int shift_right)
|
||||||
bignum_digit_type digit;
|
bignum_digit_type digit;
|
||||||
bignum_digit_type carry = 0;
|
bignum_digit_type carry = 0;
|
||||||
int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right);
|
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)
|
while (start < scan)
|
||||||
{
|
{
|
||||||
digit = (*--scan);
|
digit = (*--scan);
|
||||||
|
@ -1489,7 +1486,7 @@ bignum_bitwise_not(bignum_type x)
|
||||||
|
|
||||||
/* allocates memory */
|
/* allocates memory */
|
||||||
bignum_type
|
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)
|
if (BIGNUM_NEGATIVE_P(arg1) && n < 0)
|
||||||
return bignum_bitwise_not(bignum_magnitude_ash(bignum_bitwise_not(arg1), n));
|
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 */
|
/* ash for the magnitude */
|
||||||
/* assume arg1 is a big number, n is a long */
|
/* assume arg1 is a big number, n is a long */
|
||||||
bignum_type
|
bignum_type
|
||||||
bignum_magnitude_ash(bignum_type arg1, long n)
|
bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n)
|
||||||
{
|
{
|
||||||
bignum_type result = NULL;
|
bignum_type result = NULL;
|
||||||
bignum_digit_type *scan1;
|
bignum_digit_type *scan1;
|
||||||
bignum_digit_type *scanr;
|
bignum_digit_type *scanr;
|
||||||
bignum_digit_type *end;
|
bignum_digit_type *end;
|
||||||
|
|
||||||
long digit_offset,bit_offset;
|
F_FIXNUM digit_offset,bit_offset;
|
||||||
|
|
||||||
if (BIGNUM_ZERO_P (arg1)) return (arg1);
|
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) {
|
while (scanr < endr) {
|
||||||
digit1 = (scan1 < end1) ? *scan1++ : 0;
|
digit1 = (scan1 < end1) ? *scan1++ : 0;
|
||||||
digit2 = (scan2 < end2) ? *scan2++ : 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 :
|
*scanr++ = (op == AND_OP) ? digit1 & digit2 :
|
||||||
(op == IOR_OP) ? digit1 | digit2 :
|
(op == IOR_OP) ? digit1 | digit2 :
|
||||||
digit1 ^ digit2;
|
digit1 ^ digit2;
|
||||||
|
@ -1856,8 +1849,8 @@ digit_stream_to_bignum(unsigned int n_digits,
|
||||||
return (BIGNUM_ZERO ());
|
return (BIGNUM_ZERO ());
|
||||||
if (n_digits == 1)
|
if (n_digits == 1)
|
||||||
{
|
{
|
||||||
long digit = ((long) ((*producer) (0)));
|
F_FIXNUM digit = ((F_FIXNUM) ((*producer) (0)));
|
||||||
return (long_to_bignum (negative_p ? (- digit) : digit));
|
return (fixnum_to_bignum (negative_p ? (- digit) : digit));
|
||||||
}
|
}
|
||||||
{
|
{
|
||||||
bignum_length_type length;
|
bignum_length_type length;
|
||||||
|
|
|
@ -55,14 +55,10 @@ bignum_type bignum_quotient(bignum_type, bignum_type);
|
||||||
bignum_type bignum_remainder(bignum_type, bignum_type);
|
bignum_type bignum_remainder(bignum_type, bignum_type);
|
||||||
DLLEXPORT bignum_type fixnum_to_bignum(F_FIXNUM);
|
DLLEXPORT bignum_type fixnum_to_bignum(F_FIXNUM);
|
||||||
DLLEXPORT bignum_type cell_to_bignum(CELL);
|
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 long_long_to_bignum(s64 n);
|
||||||
DLLEXPORT bignum_type ulong_long_to_bignum(u64 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);
|
F_FIXNUM bignum_to_fixnum(bignum_type);
|
||||||
CELL bignum_to_cell(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);
|
s64 bignum_to_long_long(bignum_type);
|
||||||
u64 bignum_to_ulong_long(bignum_type);
|
u64 bignum_to_ulong_long(bignum_type);
|
||||||
bignum_type double_to_bignum(double);
|
bignum_type double_to_bignum(double);
|
||||||
|
@ -71,7 +67,7 @@ double bignum_to_double(bignum_type);
|
||||||
/* Added bitwise operators. */
|
/* Added bitwise operators. */
|
||||||
|
|
||||||
DLLEXPORT bignum_type bignum_bitwise_not(bignum_type),
|
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_and(bignum_type, bignum_type),
|
||||||
bignum_bitwise_ior(bignum_type, bignum_type),
|
bignum_bitwise_ior(bignum_type, bignum_type),
|
||||||
bignum_bitwise_xor(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);
|
void bignum_destructive_copy(bignum_type, bignum_type);
|
||||||
|
|
||||||
/* Added for bitwise operations. */
|
/* 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_pospos_bitwise_op(int op, bignum_type, bignum_type);
|
||||||
bignum_type bignum_posneg_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);
|
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)
|
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);
|
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 RETURN_REG %eax
|
||||||
|
|
||||||
#define CELL_SIZE 4
|
#define CELL_SIZE 4
|
||||||
|
#define STACK_PADDING 12
|
||||||
|
|
||||||
#define PUSH_NONVOLATILE \
|
#define PUSH_NONVOLATILE \
|
||||||
push %ebx ; \
|
push %ebx ; \
|
||||||
|
|
|
@ -1,24 +1,55 @@
|
||||||
#include "asm.h"
|
#include "asm.h"
|
||||||
|
|
||||||
#define ARG0 %rdi
|
|
||||||
#define ARG1 %rsi
|
|
||||||
#define STACK_REG %rsp
|
#define STACK_REG %rsp
|
||||||
#define DS_REG %r14
|
#define DS_REG %r14
|
||||||
#define RETURN_REG %rax
|
#define RETURN_REG %rax
|
||||||
|
|
||||||
#define CELL_SIZE 8
|
#define CELL_SIZE 8
|
||||||
|
#define STACK_PADDING 56
|
||||||
|
|
||||||
#define PUSH_NONVOLATILE \
|
#ifdef WINDOWS
|
||||||
push %rbx ; \
|
|
||||||
push %rbp ; \
|
|
||||||
push %r12 ; \
|
|
||||||
push %r13 ;
|
|
||||||
|
|
||||||
#define POP_NONVOLATILE \
|
#define ARG0 %rcx
|
||||||
pop %r13 ; \
|
#define ARG1 %rdx
|
||||||
pop %r12 ; \
|
#define ARG2 %r8
|
||||||
pop %rbp ; \
|
#define ARG3 %r9
|
||||||
pop %rbx
|
|
||||||
|
#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
|
#define QUOT_XT_OFFSET 21
|
||||||
|
|
||||||
|
@ -26,9 +57,9 @@
|
||||||
ABI limitation which would otherwise require us to do a bizzaro PC-relative
|
ABI limitation which would otherwise require us to do a bizzaro PC-relative
|
||||||
trampoline to retrieve the function address */
|
trampoline to retrieve the function address */
|
||||||
DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)):
|
DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)):
|
||||||
sub %rdx,%rdi /* compute new stack pointer */
|
sub ARG2,ARG0 /* compute new stack pointer */
|
||||||
mov %rdi,%rsp
|
mov ARG0,%rsp
|
||||||
call *%rcx /* call memcpy */
|
call *ARG3 /* call memcpy */
|
||||||
ret /* return _with new stack_ */
|
ret /* return _with new stack_ */
|
||||||
|
|
||||||
#include "cpu-x86.S"
|
#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)):
|
DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
|
||||||
PUSH_NONVOLATILE
|
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)
|
call MANGLE(save_callstack_bottom)
|
||||||
|
add $32,STACK_REG
|
||||||
|
|
||||||
mov (STACK_REG),ARG0 /* Pass quot as arg 1 */
|
/* Call quot-xt */
|
||||||
call *QUOT_XT_OFFSET(ARG0) /* Call quot-xt */
|
mov (STACK_REG),ARG0
|
||||||
|
call *QUOT_XT_OFFSET(ARG0)
|
||||||
|
|
||||||
POP ARG0
|
pop ARG0
|
||||||
POP_NONVOLATILE
|
POP_NONVOLATILE
|
||||||
ret
|
ret
|
||||||
|
|
||||||
DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
|
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)
|
jmp *QUOT_XT_OFFSET(ARG0)
|
||||||
|
|
||||||
DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
|
DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
|
||||||
mov STACK_REG,ARG1 /* Save stack pointer */
|
mov STACK_REG,ARG1 /* Save stack pointer */
|
||||||
push ARG1 /* Alignment */
|
sub $STACK_PADDING,STACK_REG
|
||||||
push ARG1
|
|
||||||
push ARG1
|
|
||||||
call MANGLE(primitive_jit_compile)
|
call MANGLE(primitive_jit_compile)
|
||||||
mov RETURN_REG,ARG0 /* No-op on 32-bit */
|
mov RETURN_REG,ARG0 /* No-op on 32-bit */
|
||||||
pop ARG1 /* OK to clobber ARG1 here */
|
add $STACK_PADDING,STACK_REG
|
||||||
pop ARG1
|
|
||||||
pop ARG1
|
|
||||||
jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
|
jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
|
||||||
|
|
||||||
#ifdef WINDOWS
|
#ifdef WINDOWS
|
||||||
|
|
|
@ -438,6 +438,8 @@ void collect_gen_cards(CELL gen)
|
||||||
old->new references */
|
old->new references */
|
||||||
void collect_cards(void)
|
void collect_cards(void)
|
||||||
{
|
{
|
||||||
|
GC_PRINT("Collect cards\n");
|
||||||
|
|
||||||
int i;
|
int i;
|
||||||
for(i = collecting_gen + 1; i < data_heap->gen_count; i++)
|
for(i = collecting_gen + 1; i < data_heap->gen_count; i++)
|
||||||
collect_gen_cards(i);
|
collect_gen_cards(i);
|
||||||
|
@ -465,7 +467,10 @@ void collect_callstack(F_CONTEXT *stacks)
|
||||||
{
|
{
|
||||||
CELL top = (CELL)stacks->callstack_top;
|
CELL top = (CELL)stacks->callstack_top;
|
||||||
CELL bottom = (CELL)stacks->callstack_bottom;
|
CELL bottom = (CELL)stacks->callstack_bottom;
|
||||||
|
|
||||||
|
GC_PRINT("Collect callstack %ld %ld\n",top,bottom);
|
||||||
iterate_callstack(top,bottom,collect_stack_frame);
|
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 */
|
the user environment and extra roots registered with REGISTER_ROOT */
|
||||||
void collect_roots(void)
|
void collect_roots(void)
|
||||||
{
|
{
|
||||||
|
GC_PRINT("Collect roots\n");
|
||||||
copy_handle(&T);
|
copy_handle(&T);
|
||||||
copy_handle(&bignum_zero);
|
copy_handle(&bignum_zero);
|
||||||
copy_handle(&bignum_pos_one);
|
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)
|
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)
|
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)
|
void misc_signal_handler_impl(void)
|
||||||
{
|
{
|
||||||
signal_error(signal_number,signal_callstack_top);
|
signal_error(signal_number,signal_callstack_top);
|
||||||
}
|
}
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(throw)
|
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);
|
init_factor(&p);
|
||||||
|
|
||||||
nest_stacks();
|
nest_stacks();
|
||||||
|
|
||||||
F_ARRAY *args = allot_array(ARRAY_TYPE,argc,F);
|
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:
|
case BIGNUM_TYPE:
|
||||||
{
|
{
|
||||||
bignum_type zero = untag_object(bignum_zero);
|
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());
|
bignum_type n = untag_object(dpeek());
|
||||||
if(bignum_compare(n,zero) != bignum_comparison_less
|
if(bignum_compare(n,zero) != bignum_comparison_less
|
||||||
&& bignum_compare(n,max) == bignum_comparison_less)
|
&& bignum_compare(n,max) == bignum_comparison_less)
|
||||||
{
|
{
|
||||||
dpop();
|
dpop();
|
||||||
return bignum_to_ulong(n);
|
return bignum_to_cell(n);
|
||||||
}
|
}
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
|
|
Loading…
Reference in New Issue