More work on intrinsics; memory allocation and slot access now expands correctly
parent
0c89575632
commit
e92f795a76
|
@ -9,12 +9,12 @@ compiler.tree.builder
|
|||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
compiler.cfg
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.stacks
|
||||
compiler.cfg.iterator
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.intrinsics
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.builder.hats
|
||||
compiler.cfg.builder.calls
|
||||
compiler.cfg.builder.stacks
|
||||
compiler.alien ;
|
||||
IN: compiler.cfg.builder
|
||||
|
||||
|
|
|
@ -1,361 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: qualified kernel words sequences layouts namespaces
|
||||
accessors fry arrays byte-arrays locals math combinators alien
|
||||
classes.algebra cpu.architecture compiler.tree.propagation.info
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.builder.hats
|
||||
compiler.cfg.builder.stacks ;
|
||||
QUALIFIED: compiler.intrinsics
|
||||
QUALIFIED: kernel.private
|
||||
QUALIFIED: slots.private
|
||||
QUALIFIED: math.private
|
||||
QUALIFIED: alien.accessors
|
||||
IN: compiler.cfg.builder.calls
|
||||
|
||||
{
|
||||
kernel.private:tag
|
||||
math.private:fixnum+fast
|
||||
math.private:fixnum-fast
|
||||
math.private:fixnum-bitand
|
||||
math.private:fixnum-bitor
|
||||
math.private:fixnum-bitxor
|
||||
math.private:fixnum-shift-fast
|
||||
math.private:fixnum-bitnot
|
||||
math.private:fixnum*fast
|
||||
math.private:fixnum<
|
||||
math.private:fixnum<=
|
||||
math.private:fixnum>=
|
||||
math.private:fixnum>
|
||||
math.private:bignum>fixnum
|
||||
math.private:fixnum>bignum
|
||||
eq?
|
||||
compiler.intrinsics:(slot)
|
||||
compiler.intrinsics:(set-slot)
|
||||
compiler.intrinsics:(tuple)
|
||||
compiler.intrinsics:(array)
|
||||
compiler.intrinsics:(byte-array)
|
||||
compiler.intrinsics:(complex)
|
||||
compiler.intrinsics:(ratio)
|
||||
compiler.intrinsics:(wrapper)
|
||||
compiler.intrinsics:(write-barrier)
|
||||
alien.accessors:alien-unsigned-1
|
||||
alien.accessors:set-alien-unsigned-1
|
||||
alien.accessors:alien-signed-1
|
||||
alien.accessors:set-alien-signed-1
|
||||
alien.accessors:alien-unsigned-2
|
||||
alien.accessors:set-alien-unsigned-2
|
||||
alien.accessors:alien-signed-2
|
||||
alien.accessors:set-alien-signed-2
|
||||
alien.accessors:alien-cell
|
||||
alien.accessors:set-alien-cell
|
||||
} [ t "intrinsic" set-word-prop ] each
|
||||
|
||||
: enable-alien-4-intrinsics ( -- )
|
||||
{
|
||||
alien.accessors:alien-unsigned-4
|
||||
alien.accessors:set-alien-unsigned-4
|
||||
alien.accessors:alien-signed-4
|
||||
alien.accessors:set-alien-signed-4
|
||||
} [ t "intrinsic" set-word-prop ] each ;
|
||||
|
||||
: enable-float-intrinsics ( -- )
|
||||
{
|
||||
math.private:float+
|
||||
math.private:float-
|
||||
math.private:float*
|
||||
math.private:float/f
|
||||
math.private:fixnum>float
|
||||
math.private:float>fixnum
|
||||
alien.accessors:alien-float
|
||||
alien.accessors:set-alien-float
|
||||
alien.accessors:alien-double
|
||||
alien.accessors:set-alien-double
|
||||
} [ t "intrinsic" set-word-prop ] each ;
|
||||
|
||||
: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ;
|
||||
|
||||
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ;
|
||||
|
||||
: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ;
|
||||
|
||||
: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ;
|
||||
|
||||
: emit-tag ( -- )
|
||||
phantom-pop tag-mask get ^^and-imm ^^tag-fixnum phantom-push ;
|
||||
|
||||
: (emit-slot) ( infos -- dst )
|
||||
[ 2phantom-pop ] [ third literal>> ] bi*
|
||||
^^slot ;
|
||||
|
||||
: (emit-slot-imm) ( infos -- dst )
|
||||
1 phantom-drop
|
||||
[ phantom-pop ^^offset>slot ]
|
||||
[ [ second literal>> ] [ third literal>> ] bi ] bi*
|
||||
^^slot-imm ;
|
||||
|
||||
: value-info-small-tagged? ( value-info -- ? )
|
||||
dup literal?>> [ literal>> small-tagged? ] [ drop f ] if ;
|
||||
|
||||
: emit-slot ( node -- )
|
||||
node-input-infos
|
||||
dup second value-info-small-tagged?
|
||||
[ (emit-slot-imm) ] [ (emit-slot) ] if
|
||||
phantom-push ;
|
||||
|
||||
: (emit-set-slot) ( infos -- )
|
||||
[ 3phantom-pop ] [ fourth literal>> ] bi*
|
||||
^^set-slot ;
|
||||
|
||||
: (emit-set-slot-imm) ( infos -- )
|
||||
1 phantom-drop
|
||||
[ 2phantom-pop ^^offset>slot ]
|
||||
[ [ third literal>> ] [ fourth literal>> ] bi ] bi*
|
||||
##set-slot-imm ;
|
||||
|
||||
: emit-set-slot ( node -- )
|
||||
1 phantom-drop
|
||||
node-input-infos
|
||||
dup third value-info-small-tagged?
|
||||
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if ;
|
||||
|
||||
: (emit-fixnum-imm-op) ( infos insn -- dst )
|
||||
1 phantom-drop
|
||||
[ phantom-pop ] [ second literal>> tag-fixnum ] [ ] tri*
|
||||
call ; inline
|
||||
|
||||
: (emit-fixnum-op) ( insn -- dst )
|
||||
[ 2phantom-pop ] dip call ; inline
|
||||
|
||||
:: emit-fixnum-op ( node insn imm-insn -- )
|
||||
[let | infos [ node node-input-infos ] |
|
||||
infos second value-info-small-tagged?
|
||||
[ infos imm-insn (emit-fixnum-imm-op) ]
|
||||
[ insn (emit-fixnum-op) ]
|
||||
if
|
||||
phantom-push
|
||||
] ; inline
|
||||
|
||||
: emit-primitive ( node -- )
|
||||
word>> ##simple-stack-frame ##call ;
|
||||
|
||||
: emit-fixnum-shift-fast ( node -- )
|
||||
dup node-input-infos dup second value-info-small-tagged? [
|
||||
nip
|
||||
[ 1 phantom-drop phantom-pop ] dip
|
||||
second literal>> dup sgn {
|
||||
{ -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] }
|
||||
{ 0 [ drop ] }
|
||||
{ 1 [ ^^shl-imm ] }
|
||||
} case
|
||||
phantom-push
|
||||
] [ drop emit-primitive ] if ;
|
||||
|
||||
: emit-fixnum-bitnot ( -- )
|
||||
phantom-pop ^^not tag-mask get ^^xor-imm phantom-push ;
|
||||
|
||||
: (emit-fixnum*fast) ( -- dst )
|
||||
2phantom-pop ^^untag-fixnum ^^mul ;
|
||||
|
||||
: (emit-fixnum*fast-imm) ( infos -- dst )
|
||||
1 phantom-drop
|
||||
[ phantom-pop ] [ second literal>> ] bi* ^^mul-imm ;
|
||||
|
||||
: emit-fixnum*fast ( node -- )
|
||||
node-input-infos
|
||||
dup second value-info-small-tagged?
|
||||
[ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
|
||||
phantom-push ;
|
||||
|
||||
: emit-fixnum-comparison ( node cc -- )
|
||||
[ '[ _ ^^compare ] ] [ '[ _ ^^compare-imm ] ] bi
|
||||
emit-fixnum-op ;
|
||||
|
||||
: emit-bignum>fixnum ( -- )
|
||||
phantom-pop ^^bignum>integer ^^tag-fixnum phantom-push ;
|
||||
|
||||
: emit-fixnum>bignum ( -- )
|
||||
phantom-pop ^^untag-fixnum ^^integer>bignum phantom-push ;
|
||||
|
||||
: emit-float-op ( insn -- )
|
||||
[ 2phantom-pop [ ^^unbox-float ] bi@ ] dip call ^^box-float
|
||||
phantom-push ; inline
|
||||
|
||||
: emit-float-comparison ( cc -- )
|
||||
[ 2phantom-pop [ ^^unbox-float ] bi@ ] dip ^^compare-float
|
||||
phantom-push ; inline
|
||||
|
||||
: emit-float>fixnum ( -- )
|
||||
phantom-pop ^^unbox-float ^^float>integer ^^tag-fixnum phantom-push ;
|
||||
|
||||
: emit-fixnum>float ( -- )
|
||||
phantom-pop ^^untag-fixnum ^^integer>float ^^box-float phantom-push ;
|
||||
|
||||
: pop-literal ( node -- n )
|
||||
1 phantom-drop dup in-d>> first node-value-info literal>> ;
|
||||
|
||||
: emit-allot ( size type tag -- )
|
||||
^^allot [ fresh-object ] [ phantom-push ] bi ;
|
||||
|
||||
: emit-write-barrier ( -- )
|
||||
phantom-pop dup fresh-object? [ drop ] [ ^^write-barrier ] if ;
|
||||
|
||||
: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
|
||||
1 phantom-drop [ phantom-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
|
||||
|
||||
: (prepare-alien-accessor) ( class -- offset-vreg )
|
||||
[ 2phantom-pop ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
|
||||
|
||||
: prepare-alien-accessor ( infos -- offset-vreg )
|
||||
<reversed> [ second class>> ] [ first ] bi
|
||||
dup value-info-small-tagged? [
|
||||
1 phantom-drop
|
||||
literal>> (prepare-alien-accessor-imm)
|
||||
] [ drop (prepare-alien-accessor) ] if ;
|
||||
|
||||
:: inline-alien ( node quot test -- )
|
||||
[let | infos [ node node-input-infos ] |
|
||||
infos test call
|
||||
[ infos prepare-alien-accessor quot call ]
|
||||
[ node emit-primitive ]
|
||||
if
|
||||
] ; inline
|
||||
|
||||
: inline-alien-getter? ( infos -- ? )
|
||||
[ first class>> c-ptr class<= ]
|
||||
[ second class>> fixnum class<= ]
|
||||
bi and ;
|
||||
|
||||
: inline-alien-getter ( node quot -- )
|
||||
'[ @ phantom-push ]
|
||||
[ inline-alien-getter? ] inline-alien ; inline
|
||||
|
||||
: inline-alien-setter? ( infos class -- ? )
|
||||
'[ first class>> _ class<= ]
|
||||
[ second class>> c-ptr class<= ]
|
||||
[ third class>> fixnum class<= ]
|
||||
tri and and ;
|
||||
|
||||
: inline-alien-integer-setter ( node quot -- )
|
||||
'[ phantom-pop ^^untag-fixnum @ ]
|
||||
[ fixnum inline-alien-setter? ]
|
||||
inline-alien ; inline
|
||||
|
||||
: inline-alien-cell-setter ( node quot -- )
|
||||
[ dup node-input-infos first class>> ] dip
|
||||
'[ phantom-pop _ ^^unbox-c-ptr @ ]
|
||||
[ pinned-c-ptr inline-alien-setter? ]
|
||||
inline-alien ; inline
|
||||
|
||||
: inline-alien-float-setter ( node quot -- )
|
||||
'[ phantom-pop ^^unbox-float @ ]
|
||||
[ float inline-alien-setter? ]
|
||||
inline-alien ; inline
|
||||
|
||||
: emit-alien-unsigned-getter ( node n -- )
|
||||
'[
|
||||
_ {
|
||||
{ 1 [ ^^alien-unsigned-1 ] }
|
||||
{ 2 [ ^^alien-unsigned-2 ] }
|
||||
{ 4 [ ^^alien-unsigned-4 ] }
|
||||
} case ^^tag-fixnum
|
||||
] inline-alien-getter ;
|
||||
|
||||
: emit-alien-signed-getter ( node n -- )
|
||||
'[
|
||||
_ {
|
||||
{ 1 [ ^^alien-signed-1 ] }
|
||||
{ 2 [ ^^alien-signed-2 ] }
|
||||
{ 4 [ ^^alien-signed-4 ] }
|
||||
} case ^^tag-fixnum
|
||||
] inline-alien-getter ;
|
||||
|
||||
: emit-alien-integer-setter ( node n -- )
|
||||
'[
|
||||
_ {
|
||||
{ 1 [ ##set-alien-integer-1 ] }
|
||||
{ 2 [ ##set-alien-integer-2 ] }
|
||||
{ 4 [ ##set-alien-integer-4 ] }
|
||||
} case
|
||||
] inline-alien-integer-setter ;
|
||||
|
||||
: emit-alien-cell-getter ( node -- )
|
||||
[ ^^alien-cell ^^box-alien ] inline-alien-getter ;
|
||||
|
||||
: emit-alien-cell-setter ( node -- )
|
||||
[ ##set-alien-cell ] inline-alien-cell-setter ;
|
||||
|
||||
: emit-alien-float-getter ( node reg-class -- )
|
||||
'[
|
||||
_ {
|
||||
{ single-float-regs [ ^^alien-float ] }
|
||||
{ double-float-regs [ ^^alien-double ] }
|
||||
} case ^^box-float
|
||||
] inline-alien-getter ;
|
||||
|
||||
: emit-alien-float-setter ( node reg-class -- )
|
||||
'[
|
||||
_ {
|
||||
{ single-float-regs [ ##set-alien-float ] }
|
||||
{ double-float-regs [ ##set-alien-double ] }
|
||||
} case
|
||||
] inline-alien-float-setter ;
|
||||
|
||||
: emit-intrinsic ( node word -- )
|
||||
{
|
||||
{ \ kernel.private:tag [ drop emit-tag ] }
|
||||
{ \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
|
||||
{ \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
|
||||
{ \ math.private:fixnum*fast [ emit-fixnum*fast ] }
|
||||
{ \ math.private:fixnum< [ cc< emit-fixnum-comparison ] }
|
||||
{ \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
|
||||
{ \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
|
||||
{ \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
|
||||
{ \ eq? [ cc= emit-fixnum-comparison ] }
|
||||
{ \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
|
||||
{ \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
|
||||
{ \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
|
||||
{ \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
|
||||
{ \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
|
||||
{ \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
|
||||
{ \ math.private:float< [ drop cc< emit-float-comparison ] }
|
||||
{ \ math.private:float<= [ drop cc<= emit-float-comparison ] }
|
||||
{ \ math.private:float>= [ drop cc>= emit-float-comparison ] }
|
||||
{ \ math.private:float> [ drop cc> emit-float-comparison ] }
|
||||
{ \ math.private:float= [ drop cc> emit-float-comparison ] }
|
||||
{ \ math.private:float>fixnum [ drop emit-float>fixnum ] }
|
||||
{ \ math.private:fixnum>float [ drop emit-fixnum>float ] }
|
||||
{ \ compiler.intrinsics:(slot) [ emit-slot ] }
|
||||
{ \ compiler.intrinsics:(set-slot) [ emit-set-slot ] }
|
||||
{ \ compiler.intrinsics:(tuple) [ pop-literal 2 + cells tuple tuple emit-allot ] }
|
||||
{ \ compiler.intrinsics:(array) [ pop-literal 2 + cells array object emit-allot ] }
|
||||
{ \ compiler.intrinsics:(byte-array) [ pop-literal 2 cells + byte-array object emit-allot ] }
|
||||
{ \ compiler.intrinsics:(complex) [ drop 3 cells complex complex emit-allot ] }
|
||||
{ \ compiler.intrinsics:(ratio) [ drop 3 cells ratio ratio emit-allot ] }
|
||||
{ \ compiler.intrinsics:(wrapper) [ drop 2 cells wrapper object emit-allot ] }
|
||||
{ \ compiler.intrinsics:(write-barrier) [ drop emit-write-barrier ] }
|
||||
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
|
||||
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
|
||||
{ \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
|
||||
{ \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
|
||||
{ \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
|
||||
{ \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
|
||||
{ \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
|
||||
{ \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
|
||||
{ \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
|
||||
{ \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
|
||||
{ \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
|
||||
{ \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
|
||||
} case ;
|
|
@ -1,8 +1,16 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel layouts cpu.architecture compiler.cfg.registers
|
||||
USING: arrays byte-arrays kernel layouts math namespaces
|
||||
sequences classes.tuple cpu.architecture compiler.cfg.registers
|
||||
compiler.cfg.instructions ;
|
||||
IN: compiler.cfg.builder.hats
|
||||
IN: compiler.cfg.hats
|
||||
|
||||
! Operands holding pointers to freshly-allocated objects which
|
||||
! are guaranteed to be in the nursery
|
||||
SYMBOL: fresh-objects
|
||||
|
||||
: fresh-object ( vreg/t -- ) fresh-objects get push ;
|
||||
: fresh-object? ( vreg -- ? ) fresh-objects get memq? ;
|
||||
|
||||
: i int-regs next-vreg ; inline
|
||||
: ^^i i dup ; inline
|
||||
|
@ -45,8 +53,11 @@ IN: compiler.cfg.builder.hats
|
|||
: ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline
|
||||
: ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline
|
||||
: ^^integer>float ( src -- dst ) ^^d1 ##integer>float ; inline
|
||||
: ^^allot ( size type tag -- dst ) ^^i3 i ##allot ; inline
|
||||
: ^^write-barrier ( src -- ) i i ##write-barrier ; inline
|
||||
: ^^allot ( size class -- dst ) ^^i2 i ##allot dup fresh-object ; inline
|
||||
: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
|
||||
: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
|
||||
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
|
||||
: ^^write-barrier ( src -- ) dup fresh-object? [ drop ] [ i i ##write-barrier ] if ; inline
|
||||
: ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline
|
||||
: ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline
|
||||
: ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline
|
||||
|
@ -65,3 +76,5 @@ IN: compiler.cfg.builder.hats
|
|||
: ^^compare-imm ( src1 src2 -- dst ) ^^i2 ##compare-imm ; inline
|
||||
: ^^compare-float ( src1 src2 -- dst ) ^^i2 ##compare-float ; inline
|
||||
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
|
||||
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
|
||||
: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
|
|
@ -88,6 +88,9 @@ INSN: ##shr-imm < ##binary-imm ;
|
|||
INSN: ##sar-imm < ##binary-imm ;
|
||||
INSN: ##not < ##unary ;
|
||||
|
||||
: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline
|
||||
: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline
|
||||
|
||||
! Bignum/integer conversion
|
||||
INSN: ##integer>bignum < ##unary/temp ;
|
||||
INSN: ##bignum>integer < ##unary/temp ;
|
||||
|
@ -141,7 +144,7 @@ INSN: ##set-alien-float < ##alien-setter ;
|
|||
INSN: ##set-alien-double < ##alien-setter ;
|
||||
|
||||
! Memory allocation
|
||||
INSN: ##allot < ##flushable size type tag { temp vreg } ;
|
||||
INSN: ##allot < ##flushable size class { temp vreg } ;
|
||||
INSN: ##write-barrier < ##effect card# table ;
|
||||
INSN: ##gc ;
|
||||
|
||||
|
|
|
@ -0,0 +1,109 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences alien math classes.algebra
|
||||
fry locals combinators cpu.architecture
|
||||
compiler.tree.propagation.info
|
||||
compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions
|
||||
compiler.cfg.intrinsics.utilities ;
|
||||
IN: compiler.cfg.intrinsics.alien
|
||||
|
||||
: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
|
||||
1 phantom-drop [ phantom-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
|
||||
|
||||
: (prepare-alien-accessor) ( class -- offset-vreg )
|
||||
[ 2phantom-pop ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
|
||||
|
||||
: prepare-alien-accessor ( infos -- offset-vreg )
|
||||
<reversed> [ second class>> ] [ first ] bi
|
||||
dup value-info-small-tagged? [
|
||||
1 phantom-drop
|
||||
literal>> (prepare-alien-accessor-imm)
|
||||
] [ drop (prepare-alien-accessor) ] if ;
|
||||
|
||||
:: inline-alien ( node quot test -- )
|
||||
[let | infos [ node node-input-infos ] |
|
||||
infos test call
|
||||
[ infos prepare-alien-accessor quot call ]
|
||||
[ node emit-primitive ]
|
||||
if
|
||||
] ; inline
|
||||
|
||||
: inline-alien-getter? ( infos -- ? )
|
||||
[ first class>> c-ptr class<= ]
|
||||
[ second class>> fixnum class<= ]
|
||||
bi and ;
|
||||
|
||||
: inline-alien-getter ( node quot -- )
|
||||
'[ @ phantom-push ]
|
||||
[ inline-alien-getter? ] inline-alien ; inline
|
||||
|
||||
: inline-alien-setter? ( infos class -- ? )
|
||||
'[ first class>> _ class<= ]
|
||||
[ second class>> c-ptr class<= ]
|
||||
[ third class>> fixnum class<= ]
|
||||
tri and and ;
|
||||
|
||||
: inline-alien-integer-setter ( node quot -- )
|
||||
'[ phantom-pop ^^untag-fixnum @ ]
|
||||
[ fixnum inline-alien-setter? ]
|
||||
inline-alien ; inline
|
||||
|
||||
: inline-alien-cell-setter ( node quot -- )
|
||||
[ dup node-input-infos first class>> ] dip
|
||||
'[ phantom-pop _ ^^unbox-c-ptr @ ]
|
||||
[ pinned-c-ptr inline-alien-setter? ]
|
||||
inline-alien ; inline
|
||||
|
||||
: inline-alien-float-setter ( node quot -- )
|
||||
'[ phantom-pop ^^unbox-float @ ]
|
||||
[ float inline-alien-setter? ]
|
||||
inline-alien ; inline
|
||||
|
||||
: emit-alien-unsigned-getter ( node n -- )
|
||||
'[
|
||||
_ {
|
||||
{ 1 [ ^^alien-unsigned-1 ] }
|
||||
{ 2 [ ^^alien-unsigned-2 ] }
|
||||
{ 4 [ ^^alien-unsigned-4 ] }
|
||||
} case ^^tag-fixnum
|
||||
] inline-alien-getter ;
|
||||
|
||||
: emit-alien-signed-getter ( node n -- )
|
||||
'[
|
||||
_ {
|
||||
{ 1 [ ^^alien-signed-1 ] }
|
||||
{ 2 [ ^^alien-signed-2 ] }
|
||||
{ 4 [ ^^alien-signed-4 ] }
|
||||
} case ^^tag-fixnum
|
||||
] inline-alien-getter ;
|
||||
|
||||
: emit-alien-integer-setter ( node n -- )
|
||||
'[
|
||||
_ {
|
||||
{ 1 [ ##set-alien-integer-1 ] }
|
||||
{ 2 [ ##set-alien-integer-2 ] }
|
||||
{ 4 [ ##set-alien-integer-4 ] }
|
||||
} case
|
||||
] inline-alien-integer-setter ;
|
||||
|
||||
: emit-alien-cell-getter ( node -- )
|
||||
[ ^^alien-cell ^^box-alien ] inline-alien-getter ;
|
||||
|
||||
: emit-alien-cell-setter ( node -- )
|
||||
[ ##set-alien-cell ] inline-alien-cell-setter ;
|
||||
|
||||
: emit-alien-float-getter ( node reg-class -- )
|
||||
'[
|
||||
_ {
|
||||
{ single-float-regs [ ^^alien-float ] }
|
||||
{ double-float-regs [ ^^alien-double ] }
|
||||
} case ^^box-float
|
||||
] inline-alien-getter ;
|
||||
|
||||
: emit-alien-float-setter ( node reg-class -- )
|
||||
'[
|
||||
_ {
|
||||
{ single-float-regs [ ##set-alien-float ] }
|
||||
{ double-float-regs [ ##set-alien-double ] }
|
||||
} case
|
||||
] inline-alien-float-setter ;
|
|
@ -0,0 +1,63 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.order sequences accessors arrays
|
||||
byte-arrays layouts classes.tuple.private fry locals
|
||||
compiler.tree.propagation.info compiler.cfg.hats
|
||||
compiler.cfg.instructions compiler.cfg.stacks ;
|
||||
IN: compiler.cfg.intrinsics.allot
|
||||
|
||||
: ##set-slots ( regs obj class -- )
|
||||
'[ _ swap 1+ _ tag-number ##set-slot-imm ] each-index ;
|
||||
|
||||
: emit-simple-allot ( node -- )
|
||||
[ in-d>> length ] [ node-output-infos first class>> ] bi
|
||||
[ drop phantom-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
|
||||
[ ##set-slots ] [ [ drop ] [ phantom-push ] [ drop ] tri* ] 3bi ;
|
||||
|
||||
: tuple-slot-regs ( layout -- vregs )
|
||||
[ size>> phantom-load ] [ ^^load-literal ] bi prefix ;
|
||||
|
||||
:: emit-<tuple-boa> ( node -- )
|
||||
[let | layout [ node node-input-infos peek literal>> ] |
|
||||
layout tuple-layout? [
|
||||
1 phantom-drop
|
||||
layout tuple-slot-regs
|
||||
layout size>> ^^allot-tuple
|
||||
tuple ##set-slots
|
||||
] [ node emit-primitive ] if
|
||||
] ;
|
||||
|
||||
: store-initial-element ( elt reg len -- )
|
||||
[ 2 + object tag-number ##set-slot-imm ] with with each ;
|
||||
|
||||
: expand-<array>? ( obj -- ? )
|
||||
dup integer? [ 0 8 between? ] [ drop f ] if ;
|
||||
|
||||
:: emit-<array> ( node -- )
|
||||
[let | len [ node node-input-infos first literal>> ] |
|
||||
len expand-<array>? [
|
||||
[let | elt [ phantom-pop ]
|
||||
reg [ len ^^allot-array ] |
|
||||
1 phantom-drop
|
||||
elt reg len store-initial-element
|
||||
reg phantom-push
|
||||
]
|
||||
] [ node emit-primitive ] if
|
||||
] ;
|
||||
|
||||
: expand-<byte-array>? ( obj -- ? )
|
||||
dup integer? [ 0 32 between? ] [ drop f ] if ;
|
||||
|
||||
: bytes>cells ( m -- n ) cell align cell /i ;
|
||||
|
||||
:: emit-<byte-array> ( node -- )
|
||||
[let | len [ node node-input-infos first literal>> ] |
|
||||
len expand-<byte-array>? [
|
||||
[let | elt [ 0 ^^load-literal ]
|
||||
reg [ len ^^allot-byte-array ] |
|
||||
1 phantom-drop
|
||||
elt reg len bytes>cells store-initial-element
|
||||
reg phantom-push
|
||||
]
|
||||
] [ node emit-primitive ] if
|
||||
] ;
|
|
@ -0,0 +1,63 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences accessors layouts kernel math namespaces
|
||||
combinators fry locals
|
||||
compiler.tree.propagation.info
|
||||
compiler.cfg.stacks compiler.cfg.hats
|
||||
compiler.cfg.intrinsics.utilities ;
|
||||
IN: compiler.cfg.intrinsics.fixnum
|
||||
|
||||
: (emit-fixnum-imm-op) ( infos insn -- dst )
|
||||
1 phantom-drop
|
||||
[ phantom-pop ] [ second literal>> tag-fixnum ] [ ] tri*
|
||||
call ; inline
|
||||
|
||||
: (emit-fixnum-op) ( insn -- dst )
|
||||
[ 2phantom-pop ] dip call ; inline
|
||||
|
||||
:: emit-fixnum-op ( node insn imm-insn -- )
|
||||
[let | infos [ node node-input-infos ] |
|
||||
infos second value-info-small-tagged?
|
||||
[ infos imm-insn (emit-fixnum-imm-op) ]
|
||||
[ insn (emit-fixnum-op) ]
|
||||
if
|
||||
phantom-push
|
||||
] ; inline
|
||||
|
||||
: emit-fixnum-shift-fast ( node -- )
|
||||
dup node-input-infos dup second value-info-small-tagged? [
|
||||
nip
|
||||
[ 1 phantom-drop phantom-pop ] dip
|
||||
second literal>> dup sgn {
|
||||
{ -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] }
|
||||
{ 0 [ drop ] }
|
||||
{ 1 [ ^^shl-imm ] }
|
||||
} case
|
||||
phantom-push
|
||||
] [ drop emit-primitive ] if ;
|
||||
|
||||
: emit-fixnum-bitnot ( -- )
|
||||
phantom-pop ^^not tag-mask get ^^xor-imm phantom-push ;
|
||||
|
||||
: (emit-fixnum*fast) ( -- dst )
|
||||
2phantom-pop ^^untag-fixnum ^^mul ;
|
||||
|
||||
: (emit-fixnum*fast-imm) ( infos -- dst )
|
||||
1 phantom-drop
|
||||
[ phantom-pop ] [ second literal>> ] bi* ^^mul-imm ;
|
||||
|
||||
: emit-fixnum*fast ( node -- )
|
||||
node-input-infos
|
||||
dup second value-info-small-tagged?
|
||||
[ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
|
||||
phantom-push ;
|
||||
|
||||
: emit-fixnum-comparison ( node cc -- )
|
||||
[ '[ _ ^^compare ] ] [ '[ _ ^^compare-imm ] ] bi
|
||||
emit-fixnum-op ;
|
||||
|
||||
: emit-bignum>fixnum ( -- )
|
||||
phantom-pop ^^bignum>integer ^^tag-fixnum phantom-push ;
|
||||
|
||||
: emit-fixnum>bignum ( -- )
|
||||
phantom-pop ^^untag-fixnum ^^integer>bignum phantom-push ;
|
|
@ -0,0 +1,18 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel compiler.cfg.stacks compiler.cfg.hats ;
|
||||
IN: compiler.cfg.intrinsics.float
|
||||
|
||||
: emit-float-op ( insn -- )
|
||||
[ 2phantom-pop [ ^^unbox-float ] bi@ ] dip call ^^box-float
|
||||
phantom-push ; inline
|
||||
|
||||
: emit-float-comparison ( cc -- )
|
||||
[ 2phantom-pop [ ^^unbox-float ] bi@ ] dip ^^compare-float
|
||||
phantom-push ; inline
|
||||
|
||||
: emit-float>fixnum ( -- )
|
||||
phantom-pop ^^unbox-float ^^float>integer ^^tag-fixnum phantom-push ;
|
||||
|
||||
: emit-fixnum>float ( -- )
|
||||
phantom-pop ^^untag-fixnum ^^integer>float ^^box-float phantom-push ;
|
|
@ -0,0 +1,137 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: qualified kernel words sequences layouts namespaces
|
||||
accessors fry arrays byte-arrays locals math math.order
|
||||
combinators alien classes.algebra cpu.architecture
|
||||
compiler.tree.propagation.info
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.stacks
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.intrinsics.alien
|
||||
compiler.cfg.intrinsics.allot
|
||||
compiler.cfg.intrinsics.fixnum
|
||||
compiler.cfg.intrinsics.float
|
||||
compiler.cfg.intrinsics.slots ;
|
||||
QUALIFIED: kernel.private
|
||||
QUALIFIED: slots.private
|
||||
QUALIFIED: classes.tuple.private
|
||||
QUALIFIED: math.private
|
||||
QUALIFIED: alien.accessors
|
||||
IN: compiler.cfg.intrinsics
|
||||
|
||||
{
|
||||
kernel.private:tag
|
||||
math.private:fixnum+fast
|
||||
math.private:fixnum-fast
|
||||
math.private:fixnum-bitand
|
||||
math.private:fixnum-bitor
|
||||
math.private:fixnum-bitxor
|
||||
math.private:fixnum-shift-fast
|
||||
math.private:fixnum-bitnot
|
||||
math.private:fixnum*fast
|
||||
math.private:fixnum<
|
||||
math.private:fixnum<=
|
||||
math.private:fixnum>=
|
||||
math.private:fixnum>
|
||||
math.private:bignum>fixnum
|
||||
math.private:fixnum>bignum
|
||||
eq?
|
||||
slots.private:slot
|
||||
slots.private:set-slot
|
||||
classes.tuple.private:<tuple-boa>
|
||||
<array>
|
||||
<byte-array>
|
||||
math.private:<complex>
|
||||
math.private:<ratio>
|
||||
<wrapper>
|
||||
alien.accessors:alien-unsigned-1
|
||||
alien.accessors:set-alien-unsigned-1
|
||||
alien.accessors:alien-signed-1
|
||||
alien.accessors:set-alien-signed-1
|
||||
alien.accessors:alien-unsigned-2
|
||||
alien.accessors:set-alien-unsigned-2
|
||||
alien.accessors:alien-signed-2
|
||||
alien.accessors:set-alien-signed-2
|
||||
alien.accessors:alien-cell
|
||||
alien.accessors:set-alien-cell
|
||||
} [ t "intrinsic" set-word-prop ] each
|
||||
|
||||
: enable-alien-4-intrinsics ( -- )
|
||||
{
|
||||
alien.accessors:alien-unsigned-4
|
||||
alien.accessors:set-alien-unsigned-4
|
||||
alien.accessors:alien-signed-4
|
||||
alien.accessors:set-alien-signed-4
|
||||
} [ t "intrinsic" set-word-prop ] each ;
|
||||
|
||||
: enable-float-intrinsics ( -- )
|
||||
{
|
||||
math.private:float+
|
||||
math.private:float-
|
||||
math.private:float*
|
||||
math.private:float/f
|
||||
math.private:fixnum>float
|
||||
math.private:float>fixnum
|
||||
alien.accessors:alien-float
|
||||
alien.accessors:set-alien-float
|
||||
alien.accessors:alien-double
|
||||
alien.accessors:set-alien-double
|
||||
} [ t "intrinsic" set-word-prop ] each ;
|
||||
|
||||
: emit-intrinsic ( node word -- )
|
||||
{
|
||||
{ \ kernel.private:tag [ drop emit-tag ] }
|
||||
{ \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
|
||||
{ \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
|
||||
{ \ math.private:fixnum*fast [ emit-fixnum*fast ] }
|
||||
{ \ math.private:fixnum< [ cc< emit-fixnum-comparison ] }
|
||||
{ \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
|
||||
{ \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
|
||||
{ \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
|
||||
{ \ eq? [ cc= emit-fixnum-comparison ] }
|
||||
{ \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
|
||||
{ \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
|
||||
{ \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
|
||||
{ \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
|
||||
{ \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
|
||||
{ \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
|
||||
{ \ math.private:float< [ drop cc< emit-float-comparison ] }
|
||||
{ \ math.private:float<= [ drop cc<= emit-float-comparison ] }
|
||||
{ \ math.private:float>= [ drop cc>= emit-float-comparison ] }
|
||||
{ \ math.private:float> [ drop cc> emit-float-comparison ] }
|
||||
{ \ math.private:float= [ drop cc> emit-float-comparison ] }
|
||||
{ \ math.private:float>fixnum [ drop emit-float>fixnum ] }
|
||||
{ \ math.private:fixnum>float [ drop emit-fixnum>float ] }
|
||||
{ \ slots.private:slot [ emit-slot ] }
|
||||
{ \ slots.private:set-slot [ emit-set-slot ] }
|
||||
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
|
||||
{ \ <array> [ emit-<array> ] }
|
||||
{ \ <byte-array> [ emit-<byte-array> ] }
|
||||
{ \ math.private:<complex> [ emit-simple-allot ] }
|
||||
{ \ math.private:<ratio> [ emit-simple-allot ] }
|
||||
{ \ <wrapper> [ emit-simple-allot ] }
|
||||
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
|
||||
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
|
||||
{ \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
|
||||
{ \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
|
||||
{ \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
|
||||
{ \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
|
||||
{ \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
|
||||
{ \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
|
||||
{ \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
|
||||
{ \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
|
||||
{ \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
|
||||
{ \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
|
||||
} case ;
|
|
@ -0,0 +1,54 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: layouts namespaces kernel accessors sequences
|
||||
classes.algebra compiler.tree.propagation.info
|
||||
compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
|
||||
compiler.cfg.intrinsics.utilities ;
|
||||
IN: compiler.cfg.intrinsics.slots
|
||||
|
||||
: emit-tag ( -- )
|
||||
phantom-pop tag-mask get ^^and-imm ^^tag-fixnum phantom-push ;
|
||||
|
||||
: value-tag ( info -- n ) class>> class-tag ; inline
|
||||
|
||||
: (emit-slot) ( infos -- dst )
|
||||
[ 2phantom-pop ] [ first value-tag ] bi*
|
||||
^^slot ;
|
||||
|
||||
: (emit-slot-imm) ( infos -- dst )
|
||||
1 phantom-drop
|
||||
[ phantom-pop ^^offset>slot ]
|
||||
[ [ second literal>> ] [ first value-tag ] bi ] bi*
|
||||
^^slot-imm ;
|
||||
|
||||
: emit-slot ( node -- )
|
||||
dup node-input-infos
|
||||
dup first value-tag [
|
||||
nip
|
||||
dup second value-info-small-tagged?
|
||||
[ (emit-slot-imm) ] [ (emit-slot) ] if
|
||||
phantom-push
|
||||
] [ drop emit-primitive ] if ;
|
||||
|
||||
: (emit-set-slot) ( infos -- obj-reg )
|
||||
[ 3phantom-pop [ tuck ] dip ^^offset>slot ]
|
||||
[ second value-tag ]
|
||||
bi* ^^set-slot ;
|
||||
|
||||
: (emit-set-slot-imm) ( infos -- obj-reg )
|
||||
1 phantom-drop
|
||||
[ 2phantom-pop tuck ]
|
||||
[ [ third literal>> ] [ second value-tag ] bi ] bi*
|
||||
##set-slot-imm ;
|
||||
|
||||
: emit-set-slot ( node -- )
|
||||
dup node-input-infos
|
||||
dup second value-tag [
|
||||
nip
|
||||
1 phantom-drop
|
||||
[
|
||||
dup third value-info-small-tagged?
|
||||
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
|
||||
] [ first class>> immediate class<= ] bi
|
||||
[ drop ] [ ^^write-barrier ] if
|
||||
] [ drop emit-primitive ] if ;
|
|
@ -0,0 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel math layouts cpu.architecture ;
|
||||
IN: compiler.cfg.intrinsics.utilities
|
||||
|
||||
: value-info-small-tagged? ( value-info -- ? )
|
||||
literal>> dup fixnum? [ tag-fixnum small-enough? ] [ drop f ] if ;
|
|
@ -272,7 +272,6 @@ USING: math.private compiler.cfg.debugger ;
|
|||
T{ vreg f int-regs 1 }
|
||||
40
|
||||
array
|
||||
object
|
||||
T{ vreg f int-regs 2 }
|
||||
f
|
||||
} clone
|
||||
|
|
|
@ -6,25 +6,14 @@ quotations sequences system vectors words effects alien
|
|||
byte-arrays accessors sets math.order
|
||||
combinators.short-circuit cpu.architecture
|
||||
compiler.cfg.instructions compiler.cfg.registers
|
||||
compiler.cfg.builder.hats ;
|
||||
IN: compiler.cfg.builder.stacks
|
||||
compiler.cfg.hats ;
|
||||
IN: compiler.cfg.stacks
|
||||
|
||||
! Converting stack operations into register operations, while
|
||||
! doing a bit of optimization along the way.
|
||||
PREDICATE: small-slot < integer cells small-enough? ;
|
||||
|
||||
PREDICATE: small-tagged < integer tag-fixnum small-enough? ;
|
||||
|
||||
! Operands holding pointers to freshly-allocated objects which
|
||||
! are guaranteed to be in the nursery
|
||||
SYMBOL: fresh-objects
|
||||
|
||||
: fresh-object ( vreg/t -- ) fresh-objects get push ;
|
||||
|
||||
: fresh-object? ( vreg -- ? ) fresh-objects get memq? ;
|
||||
|
||||
! A compile-time stack
|
||||
TUPLE: phantom-stack height stack ;
|
||||
TUPLE: phantom-stack { height integer } { stack vector } ;
|
||||
|
||||
M: phantom-stack clone
|
||||
call-next-method [ clone ] change-stack ;
|
||||
|
@ -32,11 +21,11 @@ M: phantom-stack clone
|
|||
GENERIC: finalize-height ( stack -- )
|
||||
|
||||
: new-phantom-stack ( class -- stack )
|
||||
>r 0 V{ } clone r> boa ; inline
|
||||
new V{ } clone >>stack ; inline
|
||||
|
||||
: (loc) ( m stack -- n )
|
||||
#! Utility for methods on <loc>
|
||||
height>> - ;
|
||||
height>> - ; inline
|
||||
|
||||
: (finalize-height) ( stack word -- )
|
||||
#! We consolidate multiple stack height changes until the
|
||||
|
@ -207,3 +196,6 @@ M: loc lazy-store
|
|||
|
||||
: 3phantom-pop ( -- vreg1 vreg2 vreg3 )
|
||||
3 phantom-load first3 ;
|
||||
|
||||
: emit-primitive ( node -- )
|
||||
finalize-phantoms word>> ##simple-stack-frame ##call ;
|
|
@ -1,49 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel classes.tuple classes.tuple.private math arrays
|
||||
byte-arrays words stack-checker.known-words ;
|
||||
IN: compiler.intrinsics
|
||||
|
||||
ERROR: missing-intrinsic ;
|
||||
|
||||
: (tuple) ( n -- tuple ) missing-intrinsic ;
|
||||
|
||||
\ (tuple) { tuple-layout } { tuple } define-primitive
|
||||
\ (tuple) make-flushable
|
||||
|
||||
: (array) ( n -- array ) missing-intrinsic ;
|
||||
|
||||
\ (array) { integer } { array } define-primitive
|
||||
\ (array) make-flushable
|
||||
|
||||
: (byte-array) ( n -- byte-array ) missing-intrinsic ;
|
||||
|
||||
\ (byte-array) { integer } { byte-array } define-primitive
|
||||
\ (byte-array) make-flushable
|
||||
|
||||
: (ratio) ( -- ratio ) missing-intrinsic ;
|
||||
|
||||
\ (ratio) { } { ratio } define-primitive
|
||||
\ (ratio) make-flushable
|
||||
|
||||
: (complex) ( -- complex ) missing-intrinsic ;
|
||||
|
||||
\ (complex) { } { complex } define-primitive
|
||||
\ (complex) make-flushable
|
||||
|
||||
: (wrapper) ( -- wrapper ) missing-intrinsic ;
|
||||
|
||||
\ (wrapper) { } { wrapper } define-primitive
|
||||
\ (wrapper) make-flushable
|
||||
|
||||
: (slot) ( obj n tag# -- val ) missing-intrinsic ;
|
||||
|
||||
\ (slot) { object fixnum fixnum } { object } define-primitive
|
||||
|
||||
: (set-slot) ( val obj n tag# -- ) missing-intrinsic ;
|
||||
|
||||
\ (set-slot) { object object fixnum fixnum } { } define-primitive
|
||||
|
||||
: (write-barrier) ( obj -- ) missing-intrinsic ;
|
||||
|
||||
\ (write-barrier) { object } { } define-primitive
|
|
@ -1,10 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel arrays accessors sequences sequences.private words
|
||||
fry namespaces make math math.private math.order memoize
|
||||
classes.builtin classes.tuple.private classes.algebra
|
||||
slots.private combinators layouts byte-arrays alien.accessors
|
||||
compiler.intrinsics
|
||||
USING: kernel accessors sequences words memoize classes.builtin
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
|
@ -15,7 +11,7 @@ IN: compiler.tree.finalization
|
|||
! See the comment in compiler.tree.late-optimizations.
|
||||
|
||||
! This pass runs after propagation, so that it can expand
|
||||
! built-in type predicates and memory allocation; these cannot
|
||||
! built-in type predicates; these cannot
|
||||
! be expanded before propagation since we need to see 'fixnum?'
|
||||
! instead of 'tag 0 eq?' and so on, for semantic reasoning.
|
||||
! We also delete empty stack shuffles and copies to facilitate
|
||||
|
@ -43,123 +39,7 @@ MEMO: builtin-predicate-expansion ( word -- nodes )
|
|||
: expand-builtin-predicate ( #call -- nodes )
|
||||
word>> builtin-predicate-expansion ;
|
||||
|
||||
: expand-tuple-boa? ( #call -- ? )
|
||||
dup word>> \ <tuple-boa> eq? [
|
||||
last-literal tuple-layout?
|
||||
] [ drop f ] if ;
|
||||
|
||||
MEMO: (tuple-boa-expansion) ( n -- nodes )
|
||||
[
|
||||
[ '[ _ (tuple) ] % ]
|
||||
[
|
||||
[ 2 + ] map <reversed>
|
||||
[ '[ [ _ set-slot ] keep ] % ] each
|
||||
] bi
|
||||
] [ ] make '[ _ dip ] splice-final ;
|
||||
|
||||
: tuple-boa-expansion ( layout -- quot )
|
||||
#! No memoization here since otherwise we'd hang on to
|
||||
#! tuple layout objects.
|
||||
size>> (tuple-boa-expansion)
|
||||
[ over 1 set-slot ] splice-final append ;
|
||||
|
||||
: expand-tuple-boa ( #call -- node )
|
||||
last-literal tuple-boa-expansion ;
|
||||
|
||||
MEMO: <array>-expansion ( n -- quot )
|
||||
[
|
||||
[ swap (array) ] %
|
||||
[ '[ _ over 1 set-slot ] % ]
|
||||
[ [ '[ 2dup _ swap set-array-nth ] % ] each ] bi
|
||||
\ nip ,
|
||||
] [ ] make splice-final ;
|
||||
|
||||
: expand-<array>? ( #call -- ? )
|
||||
dup word>> \ <array> eq? [
|
||||
first-literal dup integer?
|
||||
[ 0 8 between? ] [ drop f ] if
|
||||
] [ drop f ] if ;
|
||||
|
||||
: expand-<array> ( #call -- node )
|
||||
first-literal <array>-expansion ;
|
||||
|
||||
: bytes>cells ( m -- n ) cell align cell /i ;
|
||||
|
||||
MEMO: <byte-array>-expansion ( n -- quot )
|
||||
[
|
||||
[ (byte-array) ] %
|
||||
[ '[ _ over 1 set-slot ] % ]
|
||||
[
|
||||
bytes>cells [
|
||||
cell *
|
||||
'[ 0 over _ set-alien-unsigned-cell ] %
|
||||
] each
|
||||
] bi
|
||||
] [ ] make splice-final ;
|
||||
|
||||
: expand-<byte-array>? ( #call -- ? )
|
||||
dup word>> \ <byte-array> eq? [
|
||||
first-literal dup integer?
|
||||
[ 0 32 between? ] [ drop f ] if
|
||||
] [ drop f ] if ;
|
||||
|
||||
: expand-<byte-array> ( #call -- nodes )
|
||||
first-literal <byte-array>-expansion ;
|
||||
|
||||
MEMO: <ratio>-expansion ( -- quot )
|
||||
[ (ratio) [ 2 set-slot ] keep [ 1 set-slot ] keep ] splice-final ;
|
||||
|
||||
: expand-<ratio> ( #call -- nodes )
|
||||
drop <ratio>-expansion ;
|
||||
|
||||
MEMO: <complex>-expansion ( -- quot )
|
||||
[ (complex) [ 2 set-slot ] keep [ 1 set-slot ] keep ] splice-final ;
|
||||
|
||||
: expand-<complex> ( #call -- nodes )
|
||||
drop <complex>-expansion ;
|
||||
|
||||
MEMO: <wrapper>-expansion ( -- quot )
|
||||
[ (wrapper) [ 1 set-slot ] keep ] splice-final ;
|
||||
|
||||
: expand-<wrapper> ( #call -- nodes )
|
||||
drop <wrapper>-expansion ;
|
||||
|
||||
MEMO: slot-expansion ( tag -- nodes )
|
||||
'[ _ (slot) ] splice-final ;
|
||||
|
||||
: value-tag ( node value -- n )
|
||||
node-value-info class>> class-tag ;
|
||||
|
||||
: expand-slot ( #call -- nodes )
|
||||
dup dup in-d>> first value-tag [ slot-expansion ] [ ] ?if ;
|
||||
|
||||
MEMO: set-slot-expansion ( write-barrier? tag# -- nodes )
|
||||
[ '[ [ _ (set-slot) ] [ drop (write-barrier) ] 2bi ] ]
|
||||
[ '[ _ (set-slot) ] ]
|
||||
bi ? splice-final ;
|
||||
|
||||
: expand-set-slot ( #call -- nodes )
|
||||
dup dup in-d>> second value-tag [
|
||||
[ dup in-d>> first node-value-info class>> immediate class<= not ] dip
|
||||
set-slot-expansion
|
||||
] when* ;
|
||||
|
||||
M: #call finalize*
|
||||
{
|
||||
{ [ dup builtin-predicate? ] [ expand-builtin-predicate ] }
|
||||
{ [ dup expand-tuple-boa? ] [ expand-tuple-boa ] }
|
||||
{ [ dup expand-<array>? ] [ expand-<array> ] }
|
||||
{ [ dup expand-<byte-array>? ] [ expand-<byte-array> ] }
|
||||
[
|
||||
dup word>> {
|
||||
{ \ <ratio> [ expand-<ratio> ] }
|
||||
{ \ <complex> [ expand-<complex> ] }
|
||||
{ \ <wrapper> [ expand-<wrapper> ] }
|
||||
{ \ set-slot [ expand-set-slot ] }
|
||||
{ \ slot [ expand-slot ] }
|
||||
[ drop ]
|
||||
} case
|
||||
]
|
||||
} cond ;
|
||||
dup builtin-predicate? [ expand-builtin-predicate ] when ;
|
||||
|
||||
M: node finalize* ;
|
||||
|
|
|
@ -108,7 +108,7 @@ HOOK: %set-alien-cell cpu ( ptr value -- )
|
|||
HOOK: %set-alien-float cpu ( ptr value -- )
|
||||
HOOK: %set-alien-double cpu ( ptr value -- )
|
||||
|
||||
HOOK: %allot cpu ( dst size type tag temp -- )
|
||||
HOOK: %allot cpu ( dst size class temp -- )
|
||||
HOOK: %write-barrier cpu ( src card# table -- )
|
||||
HOOK: %gc cpu ( -- )
|
||||
|
||||
|
|
|
@ -6,7 +6,7 @@ accessors init combinators command-line cpu.x86.assembler
|
|||
cpu.x86.architecture cpu.architecture compiler compiler.units
|
||||
compiler.constants compiler.alien compiler.codegen
|
||||
compiler.codegen.fixup compiler.cfg.instructions
|
||||
compiler.cfg.builder compiler.cfg.builder.calls ;
|
||||
compiler.cfg.builder compiler.cfg.intrinsics ;
|
||||
IN: cpu.x86.32
|
||||
|
||||
! We implement the FFI for Linux, OS X and Windows all at once.
|
||||
|
|
|
@ -6,7 +6,7 @@ slots splitting assocs combinators cpu.x86.assembler
|
|||
cpu.x86.architecture cpu.architecture compiler.constants
|
||||
compiler.codegen compiler.codegen.fixup
|
||||
compiler.cfg.instructions compiler.cfg.builder
|
||||
compiler.cfg.builder.calls ;
|
||||
compiler.cfg.intrinsics ;
|
||||
IN: cpu.x86.64
|
||||
|
||||
M: x86.64 machine-registers
|
||||
|
|
|
@ -122,7 +122,7 @@ M:: x86 %integer>bignum ( dst src temp -- )
|
|||
"end" get JMP
|
||||
"nonzero" resolve-label
|
||||
! Allocate a bignum
|
||||
dst 4 cells bignum bignum temp %allot
|
||||
dst 4 cells bignum temp %allot
|
||||
! Write length
|
||||
dst 1 bignum@ 2 tag-fixnum MOV
|
||||
! Test sign
|
||||
|
@ -205,7 +205,7 @@ M:: x86 %unbox-any-c-ptr ( dst src dst temp -- )
|
|||
] with-scope ;
|
||||
|
||||
M:: x86 %box-float ( dst src temp -- )
|
||||
dst 16 float float temp %allot
|
||||
dst 16 float temp %allot
|
||||
dst 8 float tag-number - [+] src MOVSD ;
|
||||
|
||||
: alien@ ( reg n -- op ) cells object tag-number - [+] ;
|
||||
|
@ -215,7 +215,7 @@ M:: x86 %box-alien ( dst src temp -- )
|
|||
{ "end" "f" } [ define-label ] each
|
||||
src 0 CMP
|
||||
"f" get JE
|
||||
dst 4 cells alien object temp %allot
|
||||
dst 4 cells alien temp %allot
|
||||
dst 1 alien@ \ f tag-number MOV
|
||||
dst 2 alien@ \ f tag-number MOV
|
||||
! Store src in alien-offset slot
|
||||
|
@ -343,10 +343,10 @@ M: x86 %set-alien-double [ [] ] dip MOVSD ;
|
|||
: store-tagged ( dst tag -- )
|
||||
tag-number OR ;
|
||||
|
||||
M:: x86 %allot ( dst size type tag nursery-ptr -- )
|
||||
M:: x86 %allot ( dst size class nursery-ptr -- )
|
||||
nursery-ptr dst load-allot-ptr
|
||||
dst type store-header
|
||||
dst tag store-tagged
|
||||
dst class store-header
|
||||
dst class store-tagged
|
||||
nursery-ptr size inc-allot-ptr ;
|
||||
|
||||
HOOK: %alien-global cpu ( symbol dll register -- )
|
||||
|
|
Loading…
Reference in New Issue