CFG IR is now pure SSA
Slava Pestov
parent
2db8628cad
commit
f092622fac
|
|
@ -4,6 +4,8 @@ words sequences.private fry prettyprint alien
|
|||
math.private compiler.tree.builder compiler.tree.optimizer
|
||||
compiler.cfg.builder compiler.cfg.debugger ;
|
||||
|
||||
\ build-cfg must-infer
|
||||
|
||||
! Just ensure that various CFGs build correctly.
|
||||
{
|
||||
[ ]
|
||||
|
|
|
|||
|
|
@ -2,24 +2,23 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs combinators hashtables kernel
|
||||
math fry namespaces make sequences words byte-arrays
|
||||
locals layouts alien.c-types alien.structs
|
||||
stack-checker.inlining
|
||||
cpu.architecture
|
||||
compiler.intrinsics
|
||||
layouts alien.c-types alien.structs
|
||||
stack-checker.inlining cpu.architecture
|
||||
compiler.tree
|
||||
compiler.tree.builder
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
compiler.cfg
|
||||
compiler.cfg.stacks
|
||||
compiler.cfg.templates
|
||||
compiler.cfg.iterator
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.builder.hats
|
||||
compiler.cfg.builder.calls
|
||||
compiler.cfg.builder.stacks
|
||||
compiler.alien ;
|
||||
IN: compiler.cfg.builder
|
||||
|
||||
! Convert tree SSA IR to CFG (not quite SSA yet) IR.
|
||||
! Convert tree SSA IR to CFG SSA IR.
|
||||
|
||||
: set-basic-block ( basic-block -- )
|
||||
[ basic-block set ] [ instructions>> building set ] bi ;
|
||||
|
|
@ -93,12 +92,6 @@ GENERIC: emit-node ( node -- next )
|
|||
] with-variable
|
||||
] keep ;
|
||||
|
||||
SYMBOL: +intrinsics+
|
||||
SYMBOL: +if-intrinsics+
|
||||
|
||||
: if-intrinsics ( #call -- quot )
|
||||
word>> +if-intrinsics+ word-prop ;
|
||||
|
||||
: local-recursive-call ( basic-block -- next )
|
||||
##branch
|
||||
basic-block get successors>> push
|
||||
|
|
@ -131,22 +124,22 @@ M: #recursive emit-node
|
|||
dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
|
||||
|
||||
! #if
|
||||
: emit-branch ( obj quot -- final-bb )
|
||||
'[
|
||||
: emit-branch ( obj -- final-bb )
|
||||
[
|
||||
begin-basic-block copy-phantoms
|
||||
@
|
||||
emit-nodes
|
||||
basic-block get dup [ ##branch ] when
|
||||
] with-scope ;
|
||||
|
||||
: emit-branches ( seq quot -- )
|
||||
'[ _ emit-branch ] map
|
||||
: emit-if ( node -- )
|
||||
children>> [ emit-branch ] map
|
||||
end-basic-block
|
||||
begin-basic-block
|
||||
basic-block get '[ [ _ swap successors>> push ] when* ] each
|
||||
init-phantoms ;
|
||||
|
||||
: emit-if ( node -- next )
|
||||
children>> [ emit-nodes ] emit-branches ;
|
||||
: ##branch-t ( vreg -- )
|
||||
\ f tag-number cc/= ##binary-imm-branch ;
|
||||
|
||||
M: #if emit-node
|
||||
phantom-pop ##branch-t emit-if iterate-next ;
|
||||
|
|
@ -194,100 +187,16 @@ M: #dispatch emit-node
|
|||
] if ;
|
||||
|
||||
! #call
|
||||
: define-intrinsics ( word intrinsics -- )
|
||||
+intrinsics+ set-word-prop ;
|
||||
|
||||
: define-intrinsic ( word quot assoc -- )
|
||||
2array 1array define-intrinsics ;
|
||||
|
||||
: define-if-intrinsics ( word intrinsics -- )
|
||||
[ template new swap >>input ] assoc-map
|
||||
+if-intrinsics+ set-word-prop ;
|
||||
|
||||
: define-if-intrinsic ( word quot inputs -- )
|
||||
2array 1array define-if-intrinsics ;
|
||||
|
||||
: find-intrinsic ( #call -- pair/f )
|
||||
word>> +intrinsics+ word-prop find-template ;
|
||||
|
||||
: find-boolean-intrinsic ( #call -- pair/f )
|
||||
word>> +if-intrinsics+ word-prop find-template ;
|
||||
|
||||
: find-if-intrinsic ( #call -- pair/f )
|
||||
node@ {
|
||||
{ [ dup length 2 < ] [ 2drop f ] }
|
||||
{ [ dup second #if? ] [ drop find-boolean-intrinsic ] }
|
||||
[ 2drop f ]
|
||||
} cond ;
|
||||
|
||||
: do-if-intrinsic ( pair -- next )
|
||||
[ ##if-intrinsic ] apply-template skip-next emit-if
|
||||
iterate-next ;
|
||||
|
||||
: do-boolean-intrinsic ( pair -- next )
|
||||
[ ##if-intrinsic ] apply-template
|
||||
{ t f } [
|
||||
<constant> phantom-push finalize-phantoms
|
||||
] emit-branches
|
||||
iterate-next ;
|
||||
|
||||
: do-intrinsic ( pair -- next )
|
||||
[ ##intrinsic ] apply-template iterate-next ;
|
||||
|
||||
: setup-value-classes ( #call -- )
|
||||
node-input-infos [ class>> ] map set-value-classes ;
|
||||
|
||||
{
|
||||
(tuple) (array) (byte-array)
|
||||
(complex) (ratio) (wrapper)
|
||||
(write-barrier)
|
||||
} [ t "intrinsic" set-word-prop ] each
|
||||
|
||||
: allot-size ( -- n )
|
||||
1 phantom-datastack get phantom-input first value>> ;
|
||||
|
||||
:: emit-allot ( size type tag -- )
|
||||
int-regs next-vreg
|
||||
dup fresh-object
|
||||
dup size type tag int-regs next-vreg ##allot
|
||||
type tagged boa phantom-push ;
|
||||
|
||||
: emit-write-barrier ( -- )
|
||||
phantom-pop dup fresh-object? [ drop ] [
|
||||
int-regs next-vreg
|
||||
int-regs next-vreg
|
||||
##write-barrier
|
||||
] if ;
|
||||
|
||||
: emit-intrinsic ( word -- next )
|
||||
{
|
||||
{ \ (tuple) [ allot-size 2 + cells tuple tuple emit-allot ] }
|
||||
{ \ (array) [ allot-size 2 + cells array object emit-allot ] }
|
||||
{ \ (byte-array) [ allot-size 2 cells + byte-array object emit-allot ] }
|
||||
{ \ (complex) [ 3 cells complex complex emit-allot ] }
|
||||
{ \ (ratio) [ 3 cells ratio ratio emit-allot ] }
|
||||
{ \ (wrapper) [ 2 cells wrapper object emit-allot ] }
|
||||
{ \ (write-barrier) [ emit-write-barrier ] }
|
||||
} case
|
||||
iterate-next ;
|
||||
|
||||
M: #call emit-node
|
||||
dup setup-value-classes
|
||||
dup find-if-intrinsic [ do-if-intrinsic ] [
|
||||
dup find-boolean-intrinsic [ do-boolean-intrinsic ] [
|
||||
dup find-intrinsic [ do-intrinsic ] [
|
||||
word>> dup "intrinsic" word-prop
|
||||
[ emit-intrinsic ] [ emit-call ] if
|
||||
] ?if
|
||||
] ?if
|
||||
] ?if ;
|
||||
dup word>> dup "intrinsic" word-prop
|
||||
[ emit-intrinsic iterate-next ] [ nip emit-call ] if ;
|
||||
|
||||
! #call-recursive
|
||||
M: #call-recursive emit-node label>> id>> emit-call ;
|
||||
|
||||
! #push
|
||||
M: #push emit-node
|
||||
literal>> <constant> phantom-push iterate-next ;
|
||||
literal>> ^^load-literal phantom-push iterate-next ;
|
||||
|
||||
! #shuffle
|
||||
M: #shuffle emit-node
|
||||
|
|
|
|||
|
|
@ -0,0 +1,360 @@
|
|||
! 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 ;
|
||||
|
||||
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ;
|
||||
|
||||
: (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
|
||||
] ; 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 -- )
|
||||
[ '[ _ ##boolean ] ] [ '[ _ ##boolean-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 ; inline
|
||||
|
||||
: emit-float-comparison ( cc -- )
|
||||
'[ _ ##boolean ] emit-float-op ;
|
||||
|
||||
: 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 ;
|
||||
|
|
@ -0,0 +1,62 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel cpu.architecture compiler.cfg.registers
|
||||
compiler.cfg.instructions ;
|
||||
IN: compiler.cfg.builder.hats
|
||||
|
||||
: i int-regs next-vreg ; inline
|
||||
: ^^i i dup ; inline
|
||||
: ^^i1 [ ^^i ] dip ; inline
|
||||
: ^^i2 [ ^^i ] 2dip ; inline
|
||||
: ^^i3 [ ^^i ] 3dip ; inline
|
||||
|
||||
: d double-float-regs next-vreg ; inline
|
||||
: ^^d d dup ; inline
|
||||
: ^^d1 [ ^^d ] dip ; inline
|
||||
: ^^d2 [ ^^d ] 2dip ; inline
|
||||
: ^^d3 [ ^^d ] 3dip ; inline
|
||||
|
||||
: ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline
|
||||
: ^^peek ( loc -- dst ) ^^i1 ##peek ; inline
|
||||
: ^^slot ( obj slot tag -- dst ) ^^i3 ##slot ; inline
|
||||
: ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
|
||||
: ^^add ( src1 src2 -- dst ) ^^i2 ##add ; inline
|
||||
: ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline
|
||||
: ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline
|
||||
: ^^sub-imm ( src1 src2 -- dst ) ^^i2 ##sub-imm ; inline
|
||||
: ^^mul ( src1 src2 -- dst ) ^^i2 ##mul ; inline
|
||||
: ^^mul-imm ( src1 src2 -- dst ) ^^i2 ##mul-imm ; inline
|
||||
: ^^and ( input mask -- output ) ^^i2 ##and ; inline
|
||||
: ^^and-imm ( input mask -- output ) ^^i2 ##and-imm ; inline
|
||||
: ^^or ( src1 src2 -- dst ) ^^i2 ##or ; inline
|
||||
: ^^or-imm ( src1 src2 -- dst ) ^^i2 ##or-imm ; inline
|
||||
: ^^xor ( src1 src2 -- dst ) ^^i2 ##xor ; inline
|
||||
: ^^xor-imm ( src1 src2 -- dst ) ^^i2 ##xor-imm ; inline
|
||||
: ^^shl-imm ( src1 src2 -- dst ) ^^i2 ##shl-imm ; inline
|
||||
: ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline
|
||||
: ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline
|
||||
: ^^not ( src -- dst ) ^^i1 ##not ; inline
|
||||
: ^^bignum>integer ( src -- dst ) ^^i1 ##bignum>integer ; inline
|
||||
: ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline
|
||||
: ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline
|
||||
: ^^sub-float ( src1 src2 -- dst ) ^^d2 ##sub-float ; inline
|
||||
: ^^mul-float ( src1 src2 -- dst ) ^^d2 ##mul-float ; inline
|
||||
: ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline
|
||||
: ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline
|
||||
: ^^integer>float ( src -- dst ) ^^d1 i ##integer>float ; inline
|
||||
: ^^allot ( size type tag -- dst ) ^^i3 i ##allot ; inline
|
||||
: ^^write-barrier ( src -- ) i i ##write-barrier ; 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
|
||||
: ^^unbox-alien ( src -- dst ) ^^i1 ##unbox-alien ; inline
|
||||
: ^^unbox-c-ptr ( src class -- dst ) ^^i2 ##unbox-c-ptr ;
|
||||
: ^^alien-unsigned-1 ( src -- dst ) ^^i1 ##alien-unsigned-1 ; inline
|
||||
: ^^alien-unsigned-2 ( src -- dst ) ^^i1 ##alien-unsigned-2 ; inline
|
||||
: ^^alien-unsigned-4 ( src -- dst ) ^^i1 ##alien-unsigned-4 ; inline
|
||||
: ^^alien-signed-1 ( src -- dst ) ^^i1 ##alien-signed-1 ; inline
|
||||
: ^^alien-signed-2 ( src -- dst ) ^^i1 ##alien-signed-2 ; inline
|
||||
: ^^alien-signed-4 ( src -- dst ) ^^i1 ##alien-signed-3 ; inline
|
||||
: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
|
||||
: ^^alien-float ( src -- dst ) ^^i1 ##alien-float ; inline
|
||||
: ^^alien-double ( src -- dst ) ^^i1 ##alien-double ; inline
|
||||
|
|
@ -3,9 +3,11 @@
|
|||
USING: arrays assocs classes classes.private classes.algebra
|
||||
combinators hashtables kernel layouts math fry namespaces
|
||||
quotations sequences system vectors words effects alien
|
||||
byte-arrays accessors sets math.order cpu.architecture
|
||||
compiler.cfg.instructions compiler.cfg.registers ;
|
||||
IN: compiler.cfg.stacks
|
||||
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
|
||||
|
||||
! Converting stack operations into register operations, while
|
||||
! doing a bit of optimization along the way.
|
||||
|
|
@ -13,75 +15,6 @@ PREDICATE: small-slot < integer cells small-enough? ;
|
|||
|
||||
PREDICATE: small-tagged < integer tag-fixnum small-enough? ;
|
||||
|
||||
! Value protocol
|
||||
GENERIC: move-spec ( obj -- spec )
|
||||
GENERIC: live-loc? ( actual current -- ? )
|
||||
GENERIC: lazy-store ( dst src -- )
|
||||
|
||||
! This will be a multimethod soon
|
||||
DEFER: ##move
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! Default implementation
|
||||
M: value live-loc? 2drop f ;
|
||||
M: value lazy-store 2drop ;
|
||||
|
||||
M: vreg move-spec reg-class>> move-spec ;
|
||||
M: vreg value-class* reg-class>> value-class* ;
|
||||
|
||||
M: int-regs move-spec drop f ;
|
||||
M: int-regs value-class* drop object ;
|
||||
|
||||
M: float-regs move-spec drop float ;
|
||||
M: float-regs value-class* drop float ;
|
||||
|
||||
M: ds-loc live-loc?
|
||||
over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
|
||||
|
||||
M: rs-loc live-loc?
|
||||
over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
|
||||
|
||||
M: loc value-class* class>> ;
|
||||
M: loc set-value-class (>>class) ;
|
||||
M: loc move-spec drop loc ;
|
||||
|
||||
M: f move-spec drop loc ;
|
||||
M: f value-class* ;
|
||||
|
||||
M: tagged move-spec drop f ;
|
||||
|
||||
M: unboxed-alien move-spec class ;
|
||||
|
||||
M: unboxed-byte-array move-spec class ;
|
||||
|
||||
M: unboxed-f move-spec class ;
|
||||
|
||||
M: unboxed-c-ptr move-spec class ;
|
||||
|
||||
M: constant move-spec class ;
|
||||
|
||||
! Moving values between locations and registers
|
||||
: ##move-bug ( -- * ) "Bug in compiler.cfg.stacks" throw ;
|
||||
|
||||
: ##unbox-c-ptr ( dst src -- )
|
||||
dup value-class {
|
||||
{ [ dup \ f class<= ] [ drop [ >vreg ] bi@ ##unbox-f ] }
|
||||
{ [ dup simple-alien class<= ] [ drop [ >vreg ] bi@ ##unbox-alien ] }
|
||||
{ [ dup byte-array class<= ] [ drop [ >vreg ] bi@ ##unbox-byte-array ] }
|
||||
[ drop [ >vreg ] bi@ ##unbox-any-c-ptr ]
|
||||
} cond ; inline
|
||||
|
||||
: ##move-via-temp ( dst src -- )
|
||||
#! For many transfers, such as loc to unboxed-alien, we
|
||||
#! don't have an intrinsic, so we transfer the source to
|
||||
#! temp then temp to the destination.
|
||||
int-regs next-vreg [ over ##move value-class ] keep
|
||||
tagged new
|
||||
swap >>vreg
|
||||
swap >>class
|
||||
##move ;
|
||||
|
||||
! Operands holding pointers to freshly-allocated objects which
|
||||
! are guaranteed to be in the nursery
|
||||
SYMBOL: fresh-objects
|
||||
|
|
@ -90,34 +23,6 @@ SYMBOL: fresh-objects
|
|||
|
||||
: fresh-object? ( vreg -- ? ) fresh-objects get memq? ;
|
||||
|
||||
: ##move ( dst src -- )
|
||||
2dup [ move-spec ] bi@ 2array {
|
||||
{ { f f } [ [ >vreg ] bi@ ##copy ] }
|
||||
{ { unboxed-alien unboxed-alien } [ [ >vreg ] bi@ ##copy ] }
|
||||
{ { unboxed-byte-array unboxed-byte-array } [ [ >vreg ] bi@ ##copy ] }
|
||||
{ { unboxed-f unboxed-f } [ [ >vreg ] bi@ ##copy ] }
|
||||
{ { unboxed-c-ptr unboxed-c-ptr } [ [ >vreg ] bi@ ##copy ] }
|
||||
{ { float float } [ [ >vreg ] bi@ ##copy-float ] }
|
||||
|
||||
{ { f unboxed-c-ptr } [ ##move-bug ] }
|
||||
{ { f unboxed-byte-array } [ ##move-bug ] }
|
||||
|
||||
{ { f constant } [ [ >vreg ] [ value>> ] bi* ##load-literal ] }
|
||||
|
||||
{ { f float } [ [ >vreg ] bi@ int-regs next-vreg ##box-float t fresh-object ] }
|
||||
{ { f unboxed-alien } [ [ >vreg ] bi@ int-regs next-vreg ##box-alien t fresh-object ] }
|
||||
{ { f loc } [ [ >vreg ] dip ##peek ] }
|
||||
|
||||
{ { float f } [ [ >vreg ] bi@ ##unbox-float ] }
|
||||
{ { unboxed-alien f } [ [ >vreg ] bi@ ##unbox-alien ] }
|
||||
{ { unboxed-byte-array f } [ [ >vreg ] bi@ ##unbox-byte-array ] }
|
||||
{ { unboxed-f f } [ [ >vreg ] bi@ ##unbox-f ] }
|
||||
{ { unboxed-c-ptr f } [ ##unbox-c-ptr ] }
|
||||
{ { loc f } [ >vreg swap ##replace ] }
|
||||
|
||||
[ drop ##move-via-temp ]
|
||||
} case ;
|
||||
|
||||
! A compile-time stack
|
||||
TUPLE: phantom-stack height stack ;
|
||||
|
||||
|
|
@ -204,42 +109,13 @@ M: phantom-retainstack finalize-height
|
|||
|
||||
: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
|
||||
|
||||
: reg-spec>class ( spec -- class )
|
||||
float eq? double-float-regs int-regs ? ;
|
||||
GENERIC: lazy-load ( loc/vreg -- vreg )
|
||||
M: loc lazy-load ^^peek ;
|
||||
M: vreg lazy-load ;
|
||||
|
||||
: alloc-vreg ( spec -- reg )
|
||||
[ reg-spec>class next-vreg ] keep {
|
||||
{ f [ <tagged> ] }
|
||||
{ unboxed-alien [ <unboxed-alien> ] }
|
||||
{ unboxed-byte-array [ <unboxed-byte-array> ] }
|
||||
{ unboxed-f [ <unboxed-f> ] }
|
||||
{ unboxed-c-ptr [ <unboxed-c-ptr> ] }
|
||||
[ drop ]
|
||||
} case ;
|
||||
|
||||
: alloc-vreg-for ( value spec -- vreg )
|
||||
alloc-vreg swap value-class
|
||||
over tagged? [ >>class ] [ drop ] if ;
|
||||
|
||||
: (eager-load) ( value spec -- vreg )
|
||||
[ alloc-vreg-for ] [ drop ] 2bi
|
||||
[ ##move ] [ drop >vreg ] 2bi ;
|
||||
|
||||
: compatible? ( value spec -- ? )
|
||||
>r move-spec r> {
|
||||
{ [ 2dup = ] [ t ] }
|
||||
{ [ dup unboxed-c-ptr eq? ] [
|
||||
over { unboxed-byte-array unboxed-alien } member?
|
||||
] }
|
||||
[ f ]
|
||||
} cond 2nip ;
|
||||
|
||||
: (lazy-load) ( value spec -- value )
|
||||
{
|
||||
{ [ dup { small-slot small-tagged } memq? ] [ drop >vreg ] }
|
||||
{ [ 2dup compatible? ] [ drop >vreg ] }
|
||||
[ (eager-load) ]
|
||||
} cond ;
|
||||
GENERIC: live-loc? ( actual current -- ? )
|
||||
M: vreg live-loc? 2drop f ;
|
||||
M: loc live-loc? { [ [ class ] bi@ = ] [ [ n>> ] bi@ = not ] } 2&& ;
|
||||
|
||||
: (live-locs) ( phantom -- seq )
|
||||
#! Discard locs which haven't moved
|
||||
|
|
@ -250,19 +126,26 @@ M: phantom-retainstack finalize-height
|
|||
: live-locs ( -- seq )
|
||||
[ (live-locs) ] each-phantom append prune ;
|
||||
|
||||
GENERIC: lazy-store ( dst src -- )
|
||||
|
||||
M: vreg lazy-store 2drop ;
|
||||
|
||||
M: loc lazy-store
|
||||
2dup live-loc? [ "live-locs" get at ##move ] [ 2drop ] if ;
|
||||
2dup live-loc? [
|
||||
\ live-locs get at swap ##replace
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: finalize-locs ( -- )
|
||||
#! Perform any deferred stack shuffling.
|
||||
live-locs [ dup f (lazy-load) ] H{ } map>assoc
|
||||
live-locs [ dup lazy-load ] H{ } map>assoc
|
||||
dup assoc-empty? [ drop ] [
|
||||
"live-locs" set [ lazy-store ] each-loc
|
||||
\ live-locs set
|
||||
[ lazy-store ] each-loc
|
||||
] if ;
|
||||
|
||||
: finalize-vregs ( -- )
|
||||
#! Store any vregs to their final stack locations.
|
||||
[ dup loc? [ 2drop ] [ ##move ] if ] each-loc ;
|
||||
[ dup loc? [ 2drop ] [ swap ##replace ] if ] each-loc ;
|
||||
|
||||
: clear-phantoms ( -- )
|
||||
[ stack>> delete-all ] each-phantom ;
|
||||
|
|
@ -271,11 +154,6 @@ M: loc lazy-store
|
|||
finalize-locs finalize-vregs clear-phantoms ;
|
||||
|
||||
! Loading stacks to vregs
|
||||
: set-value-classes ( classes -- )
|
||||
phantom-datastack get
|
||||
over length over add-locs
|
||||
stack>> [ set-value-class ] 2reverse-each ;
|
||||
|
||||
: finalize-phantoms ( -- )
|
||||
#! Commit all deferred stacking shuffling, and ensure the
|
||||
#! in-memory data and retain stacks are up to date with
|
||||
|
|
@ -318,5 +196,14 @@ M: loc lazy-store
|
|||
: phantom-rdrop ( n -- )
|
||||
phantom-retainstack get phantom-input drop ;
|
||||
|
||||
: phantom-load ( n -- vreg )
|
||||
phantom-datastack get phantom-input [ lazy-load ] map ;
|
||||
|
||||
: phantom-pop ( -- vreg )
|
||||
1 phantom-datastack get phantom-input first f (lazy-load) ;
|
||||
1 phantom-load first ;
|
||||
|
||||
: 2phantom-pop ( -- vreg1 vreg2 )
|
||||
2 phantom-load first2 ;
|
||||
|
||||
: 3phantom-pop ( -- vreg1 vreg2 vreg3 )
|
||||
3 phantom-load first3 ;
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel words sequences quotations namespaces io
|
||||
accessors prettyprint prettyprint.config
|
||||
classes.tuple accessors prettyprint prettyprint.config
|
||||
compiler.tree.builder compiler.tree.optimizer
|
||||
compiler.cfg.builder compiler.cfg.linearization
|
||||
compiler.cfg.stack-frame compiler.cfg.linear-scan ;
|
||||
|
|
@ -15,16 +15,25 @@ M: callable test-cfg
|
|||
M: word test-cfg
|
||||
[ build-tree-from-word nip optimize-tree ] keep build-cfg ;
|
||||
|
||||
SYMBOL: allocate-registers?
|
||||
|
||||
: test-mr ( quot -- mrs )
|
||||
test-cfg [ build-mr linear-scan build-stack-frame ] map ;
|
||||
test-cfg [
|
||||
build-mr
|
||||
allocate-registers? get
|
||||
[ linear-scan build-stack-frame ] when
|
||||
] map ;
|
||||
|
||||
: insn. ( insn -- )
|
||||
tuple>array allocate-registers? get [ but-last ] unless
|
||||
[ pprint bl ] each nl ;
|
||||
|
||||
: mr. ( mrs -- )
|
||||
[
|
||||
boa-tuples? on
|
||||
"=== word: " write
|
||||
dup word>> pprint
|
||||
", label: " write
|
||||
dup label>> pprint nl nl
|
||||
instructions>> .
|
||||
instructions>> [ insn. ] each
|
||||
nl
|
||||
] each ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,31 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel compiler.cfg.instructions
|
||||
compiler.cfg.instructions.syntax ;
|
||||
IN: compiler.cfg.def-use
|
||||
|
||||
GENERIC: defs-vregs ( insn -- seq )
|
||||
GENERIC: uses-vregs ( insn -- seq )
|
||||
|
||||
: allot-defs-vregs ( insn -- seq ) [ dst>> ] [ temp>> ] bi 2array ;
|
||||
M: ##flushable defs-vregs dst>> 1array ;
|
||||
M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ;
|
||||
M: ##boxer defs-vregs allot-defs-vregs ;
|
||||
M: ##allot defs-vregs allot-defs-vregs ;
|
||||
M: ##dispatch defs-vregs temp>> 1array ;
|
||||
M: insn defs-vregs drop f ;
|
||||
|
||||
M: ##unary uses-vregs src>> 1array ;
|
||||
M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
|
||||
M: ##binary-imm uses-vregs src1>> 1array ;
|
||||
M: ##effect uses-vregs src>> 1array ;
|
||||
M: ##slot uses-vregs [ obj>> ] [ slot>> ] bi 2array ;
|
||||
M: ##slot-imm uses-vregs obj>> 1array ;
|
||||
M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
|
||||
M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
|
||||
M: ##binary-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
|
||||
M: ##binary-imm-branch uses-vregs src1>> 1array ;
|
||||
M: ##dispatch uses-vregs src>> 1array ;
|
||||
M: _binary-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
|
||||
M: _binary-imm-branch uses-vregs src1>> 1array ;
|
||||
M: insn uses-vregs drop f ;
|
||||
|
|
@ -1,19 +1,49 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs accessors arrays kernel sequences namespaces words
|
||||
math compiler.cfg.registers compiler.cfg.instructions.syntax ;
|
||||
math math.order layouts classes.algebra alien byte-arrays
|
||||
combinators compiler.cfg.registers
|
||||
compiler.cfg.instructions.syntax ;
|
||||
IN: compiler.cfg.instructions
|
||||
|
||||
! Virtual CPU instructions, used by CFG and machine IRs
|
||||
|
||||
TUPLE: ##cond-branch < insn { src vreg } ;
|
||||
TUPLE: ##unary < insn { dst vreg } { src vreg } ;
|
||||
TUPLE: ##nullary < insn { dst vreg } ;
|
||||
! Instruction with no side effects; if 'out' is never read, we
|
||||
! can eliminate it.
|
||||
TUPLE: ##flushable < insn { dst vreg } ;
|
||||
|
||||
! Instruction which is referentially transparent; we can replace
|
||||
! repeated computation with a reference to a previous value
|
||||
TUPLE: ##pure < ##flushable ;
|
||||
|
||||
TUPLE: ##unary < ##pure { src vreg } ;
|
||||
TUPLE: ##boxer < ##unary { temp vreg } ;
|
||||
TUPLE: ##binary < ##pure { src1 vreg } { src2 vreg } ;
|
||||
TUPLE: ##binary-imm < ##pure { src1 vreg } { src2 integer } ;
|
||||
TUPLE: ##commutative < ##binary ;
|
||||
|
||||
! Instruction only used for its side effect, produces no values
|
||||
TUPLE: ##effect < insn { src vreg } ;
|
||||
|
||||
! Read/write ops: candidates for alias analysis
|
||||
TUPLE: ##read < ##flushable ;
|
||||
TUPLE: ##write < ##effect ;
|
||||
|
||||
TUPLE: ##alien-getter < ##read { src vreg } ;
|
||||
TUPLE: ##alien-setter < ##effect { value vreg } ;
|
||||
|
||||
! Stack operations
|
||||
INSN: ##load-literal < ##nullary obj ;
|
||||
INSN: ##peek < ##nullary { loc loc } ;
|
||||
INSN: ##replace { src vreg } { loc loc } ;
|
||||
INSN: ##load-immediate < ##pure { val integer } ;
|
||||
INSN: ##load-indirect < ##pure obj ;
|
||||
|
||||
GENERIC: ##load-literal ( dst value -- )
|
||||
|
||||
M: fixnum ##load-literal tag-fixnum ##load-immediate ;
|
||||
M: f ##load-literal drop \ f tag-number ##load-immediate ;
|
||||
M: object ##load-literal ##load-indirect ;
|
||||
|
||||
INSN: ##peek < ##read { loc loc } ;
|
||||
INSN: ##replace < ##write { loc loc } ;
|
||||
INSN: ##inc-d { n integer } ;
|
||||
INSN: ##inc-r { n integer } ;
|
||||
|
||||
|
|
@ -30,12 +60,48 @@ INSN: ##call word ;
|
|||
INSN: ##jump word ;
|
||||
INSN: ##return ;
|
||||
|
||||
INSN: ##intrinsic quot defs-vregs uses-vregs ;
|
||||
|
||||
! Jump tables
|
||||
INSN: ##dispatch src temp ;
|
||||
INSN: ##dispatch-label label ;
|
||||
|
||||
! Slot access
|
||||
INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } ;
|
||||
INSN: ##slot-imm < ##read { obj vreg } { slot integer } { tag integer } ;
|
||||
INSN: ##set-slot < ##write { obj vreg } { slot vreg } { tag integer } ;
|
||||
INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
|
||||
|
||||
! Integer arithmetic
|
||||
INSN: ##add < ##commutative ;
|
||||
INSN: ##add-imm < ##binary-imm ;
|
||||
INSN: ##sub < ##binary ;
|
||||
INSN: ##sub-imm < ##binary-imm ;
|
||||
INSN: ##mul < ##commutative ;
|
||||
INSN: ##mul-imm < ##binary-imm ;
|
||||
INSN: ##and < ##commutative ;
|
||||
INSN: ##and-imm < ##binary-imm ;
|
||||
INSN: ##or < ##commutative ;
|
||||
INSN: ##or-imm < ##binary-imm ;
|
||||
INSN: ##xor < ##commutative ;
|
||||
INSN: ##xor-imm < ##binary-imm ;
|
||||
INSN: ##shl-imm < ##binary-imm ;
|
||||
INSN: ##shr-imm < ##binary-imm ;
|
||||
INSN: ##sar-imm < ##binary-imm ;
|
||||
INSN: ##not < ##unary ;
|
||||
|
||||
! Bignum/integer conversion
|
||||
INSN: ##integer>bignum < ##boxer ;
|
||||
INSN: ##bignum>integer < ##unary ;
|
||||
|
||||
! Float arithmetic
|
||||
INSN: ##add-float < ##commutative ;
|
||||
INSN: ##sub-float < ##binary ;
|
||||
INSN: ##mul-float < ##commutative ;
|
||||
INSN: ##div-float < ##binary ;
|
||||
|
||||
! Float/integer conversion
|
||||
INSN: ##float>integer < ##unary ;
|
||||
INSN: ##integer>float < ##unary ;
|
||||
|
||||
! Boxing and unboxing
|
||||
INSN: ##copy < ##unary ;
|
||||
INSN: ##copy-float < ##unary ;
|
||||
|
|
@ -44,12 +110,38 @@ INSN: ##unbox-f < ##unary ;
|
|||
INSN: ##unbox-alien < ##unary ;
|
||||
INSN: ##unbox-byte-array < ##unary ;
|
||||
INSN: ##unbox-any-c-ptr < ##unary ;
|
||||
INSN: ##box-float < ##unary { temp vreg } ;
|
||||
INSN: ##box-alien < ##unary { temp vreg } ;
|
||||
INSN: ##box-float < ##boxer ;
|
||||
INSN: ##box-alien < ##boxer ;
|
||||
|
||||
: ##unbox-c-ptr ( dst src class -- )
|
||||
{
|
||||
{ [ dup \ f class<= ] [ drop ##unbox-f ] }
|
||||
{ [ dup simple-alien class<= ] [ drop ##unbox-alien ] }
|
||||
{ [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
|
||||
[ drop ##unbox-any-c-ptr ]
|
||||
} cond ; inline
|
||||
|
||||
! Alien accessors
|
||||
INSN: ##alien-unsigned-1 < ##alien-getter ;
|
||||
INSN: ##alien-unsigned-2 < ##alien-getter ;
|
||||
INSN: ##alien-unsigned-4 < ##alien-getter ;
|
||||
INSN: ##alien-signed-1 < ##alien-getter ;
|
||||
INSN: ##alien-signed-2 < ##alien-getter ;
|
||||
INSN: ##alien-signed-3 < ##alien-getter ;
|
||||
INSN: ##alien-cell < ##alien-getter ;
|
||||
INSN: ##alien-float < ##alien-getter ;
|
||||
INSN: ##alien-double < ##alien-getter ;
|
||||
|
||||
INSN: ##set-alien-integer-1 < ##alien-setter ;
|
||||
INSN: ##set-alien-integer-2 < ##alien-setter ;
|
||||
INSN: ##set-alien-integer-4 < ##alien-setter ;
|
||||
INSN: ##set-alien-cell < ##alien-getter ;
|
||||
INSN: ##set-alien-float < ##alien-setter ;
|
||||
INSN: ##set-alien-double < ##alien-setter ;
|
||||
|
||||
! Memory allocation
|
||||
INSN: ##allot < ##nullary size type tag { temp vreg } ;
|
||||
INSN: ##write-barrier { src vreg } card# table ;
|
||||
INSN: ##allot < ##flushable size type tag { temp vreg } ;
|
||||
INSN: ##write-barrier < ##effect card# table ;
|
||||
INSN: ##gc ;
|
||||
|
||||
! FFI
|
||||
|
|
@ -58,54 +150,35 @@ INSN: ##alien-indirect params ;
|
|||
INSN: ##alien-callback params ;
|
||||
INSN: ##callback-return params ;
|
||||
|
||||
GENERIC: defs-vregs ( insn -- seq )
|
||||
GENERIC: uses-vregs ( insn -- seq )
|
||||
|
||||
M: ##nullary defs-vregs dst>> 1array ;
|
||||
M: ##unary defs-vregs dst>> 1array ;
|
||||
M: ##write-barrier defs-vregs
|
||||
[ card#>> ] [ table>> ] bi 2array ;
|
||||
|
||||
: allot-defs-vregs ( insn -- seq )
|
||||
[ dst>> ] [ temp>> ] bi 2array ;
|
||||
|
||||
M: ##box-float defs-vregs allot-defs-vregs ;
|
||||
M: ##box-alien defs-vregs allot-defs-vregs ;
|
||||
M: ##allot defs-vregs allot-defs-vregs ;
|
||||
M: ##dispatch defs-vregs temp>> 1array ;
|
||||
M: insn defs-vregs drop f ;
|
||||
|
||||
M: ##replace uses-vregs src>> 1array ;
|
||||
M: ##unary uses-vregs src>> 1array ;
|
||||
M: ##write-barrier uses-vregs src>> 1array ;
|
||||
M: ##dispatch uses-vregs src>> 1array ;
|
||||
M: insn uses-vregs drop f ;
|
||||
|
||||
: intrinsic-vregs ( assoc -- seq' )
|
||||
[ nip dup vreg? swap and ] { } assoc>map sift ;
|
||||
|
||||
: intrinsic-defs-vregs ( insn -- seq )
|
||||
defs-vregs>> intrinsic-vregs ;
|
||||
|
||||
: intrinsic-uses-vregs ( insn -- seq )
|
||||
uses-vregs>> intrinsic-vregs ;
|
||||
|
||||
M: ##intrinsic defs-vregs intrinsic-defs-vregs ;
|
||||
M: ##intrinsic uses-vregs intrinsic-uses-vregs ;
|
||||
|
||||
! Instructions used by CFG IR only.
|
||||
INSN: ##prologue ;
|
||||
INSN: ##epilogue ;
|
||||
|
||||
INSN: ##branch ;
|
||||
INSN: ##branch-f < ##cond-branch ;
|
||||
INSN: ##branch-t < ##cond-branch ;
|
||||
INSN: ##if-intrinsic quot defs-vregs uses-vregs ;
|
||||
|
||||
M: ##cond-branch uses-vregs src>> 1array ;
|
||||
! Condition codes
|
||||
SYMBOL: cc<
|
||||
SYMBOL: cc<=
|
||||
SYMBOL: cc=
|
||||
SYMBOL: cc>
|
||||
SYMBOL: cc>=
|
||||
SYMBOL: cc/=
|
||||
|
||||
M: ##if-intrinsic defs-vregs intrinsic-defs-vregs ;
|
||||
M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ;
|
||||
: evaluate-cc ( result cc -- ? )
|
||||
H{
|
||||
{ cc< { +lt+ } }
|
||||
{ cc<= { +lt+ +eq+ } }
|
||||
{ cc= { +eq+ } }
|
||||
{ cc>= { +eq+ +gt+ } }
|
||||
{ cc> { +gt+ } }
|
||||
{ cc/= { +lt+ +gt+ } }
|
||||
} at memq? ;
|
||||
|
||||
INSN: ##binary-branch { src1 vreg } { src2 vreg } cc ;
|
||||
INSN: ##binary-imm-branch { src1 vreg } { src2 integer } cc ;
|
||||
|
||||
INSN: ##boolean < ##binary cc ;
|
||||
INSN: ##boolean-imm < ##binary-imm cc ;
|
||||
|
||||
! Instructions used by machine IR only.
|
||||
INSN: _prologue stack-frame ;
|
||||
|
|
@ -113,17 +186,10 @@ INSN: _epilogue stack-frame ;
|
|||
|
||||
INSN: _label id ;
|
||||
|
||||
TUPLE: _cond-branch < insn { src vreg } label ;
|
||||
|
||||
INSN: _branch label ;
|
||||
INSN: _branch-f < _cond-branch ;
|
||||
INSN: _branch-t < _cond-branch ;
|
||||
INSN: _if-intrinsic label quot defs-vregs uses-vregs ;
|
||||
|
||||
M: _cond-branch uses-vregs src>> 1array ;
|
||||
|
||||
M: _if-intrinsic defs-vregs intrinsic-defs-vregs ;
|
||||
M: _if-intrinsic uses-vregs intrinsic-uses-vregs ;
|
||||
INSN: _binary-branch label { src1 vreg } { src2 vreg } cc ;
|
||||
INSN: _binary-imm-branch label { src1 vreg } { src2 integer } cc ;
|
||||
|
||||
! These instructions operate on machine registers and not
|
||||
! virtual registers
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
USING: accessors kernel math assocs namespaces sequences heaps
|
||||
fry make combinators
|
||||
cpu.architecture
|
||||
compiler.cfg.def-use
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.linear-scan.live-intervals ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces kernel assocs accessors sequences math fry
|
||||
compiler.cfg.instructions compiler.cfg.registers ;
|
||||
compiler.cfg.instructions compiler.cfg.registers
|
||||
compiler.cfg.def-use ;
|
||||
IN: compiler.cfg.linear-scan.live-intervals
|
||||
|
||||
TUPLE: live-interval
|
||||
|
|
|
|||
|
|
@ -40,21 +40,14 @@ M: ##branch linearize-insn
|
|||
: conditional ( basic-block -- basic-block successor1 label2 )
|
||||
dup successors>> first2 swap number>> ; inline
|
||||
|
||||
: boolean-conditional ( basic-block insn -- basic-block successor vreg label2 )
|
||||
[ conditional ] [ src>> ] bi* swap ; inline
|
||||
: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
|
||||
[ conditional ] [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
|
||||
|
||||
M: ##branch-f linearize-insn
|
||||
boolean-conditional _branch-f emit-branch ;
|
||||
M: ##binary-branch linearize-insn
|
||||
binary-conditional _binary-branch emit-branch ;
|
||||
|
||||
M: ##branch-t linearize-insn
|
||||
boolean-conditional _branch-t emit-branch ;
|
||||
|
||||
: >intrinsic< ( insn -- quot defs uses )
|
||||
[ quot>> ] [ defs-vregs>> ] [ uses-vregs>> ] tri ;
|
||||
|
||||
M: ##if-intrinsic linearize-insn
|
||||
[ conditional ] [ >intrinsic< ] bi*
|
||||
_if-intrinsic emit-branch ;
|
||||
M: ##binary-imm-branch linearize-insn
|
||||
binary-conditional _binary-imm-branch emit-branch ;
|
||||
|
||||
: linearize-basic-block ( bb -- )
|
||||
[ number>> _label ] [ linearize-insns ] bi ;
|
||||
|
|
|
|||
|
|
@ -1,91 +1,37 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors namespaces math kernel alien classes ;
|
||||
USING: accessors namespaces kernel arrays
|
||||
parser prettyprint.backend prettyprint.sections ;
|
||||
IN: compiler.cfg.registers
|
||||
|
||||
! Virtual CPU registers, used by CFG and machine IRs
|
||||
|
||||
MIXIN: value
|
||||
|
||||
GENERIC: >vreg ( obj -- vreg )
|
||||
GENERIC: set-value-class ( class obj -- )
|
||||
GENERIC: value-class* ( operand -- class )
|
||||
|
||||
: value-class ( operand -- class ) value-class* object or ;
|
||||
|
||||
M: value set-value-class 2drop ;
|
||||
M: value value-class* drop f ;
|
||||
|
||||
! Virtual registers
|
||||
! Virtual registers, used by CFG and machine IRs
|
||||
TUPLE: vreg reg-class n ;
|
||||
SYMBOL: vreg-counter
|
||||
: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
|
||||
|
||||
M: vreg >vreg ;
|
||||
|
||||
INSTANCE: vreg value
|
||||
|
||||
! Stack locations
|
||||
TUPLE: loc n class ;
|
||||
TUPLE: loc n ;
|
||||
|
||||
M: loc >vreg drop f ;
|
||||
|
||||
! A data stack location.
|
||||
TUPLE: ds-loc < loc ;
|
||||
: <ds-loc> ( n -- loc ) f ds-loc boa ;
|
||||
C: <ds-loc> ds-loc
|
||||
|
||||
TUPLE: rs-loc < loc ;
|
||||
: <rs-loc> ( n -- loc ) f rs-loc boa ;
|
||||
C: <rs-loc> ds-loc
|
||||
|
||||
INSTANCE: loc value
|
||||
! Prettyprinting
|
||||
: V scan-word scan-word vreg boa parsed ; parsing
|
||||
|
||||
! A tagged pointer
|
||||
TUPLE: tagged vreg class ;
|
||||
: <tagged> ( vreg -- tagged ) f tagged boa ;
|
||||
M: vreg pprint*
|
||||
<block
|
||||
\ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
|
||||
block> ;
|
||||
|
||||
M: tagged set-value-class (>>class) ;
|
||||
M: tagged value-class* class>> ;
|
||||
M: tagged >vreg vreg>> ;
|
||||
: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
|
||||
|
||||
INSTANCE: tagged value
|
||||
: D scan-word <ds-loc> parsed ; parsing
|
||||
|
||||
! Unboxed value
|
||||
TUPLE: unboxed vreg ;
|
||||
C: <unboxed> unboxed
|
||||
M: ds-loc pprint* \ D pprint-loc ;
|
||||
|
||||
M: unboxed >vreg vreg>> ;
|
||||
: R scan-word <rs-loc> parsed ; parsing
|
||||
|
||||
INSTANCE: unboxed value
|
||||
|
||||
! Unboxed alien pointer
|
||||
TUPLE: unboxed-alien < unboxed ;
|
||||
C: <unboxed-alien> unboxed-alien
|
||||
|
||||
M: unboxed-alien value-class* drop simple-alien ;
|
||||
|
||||
! Untagged byte array pointer
|
||||
TUPLE: unboxed-byte-array < unboxed ;
|
||||
C: <unboxed-byte-array> unboxed-byte-array
|
||||
|
||||
M: unboxed-byte-array value-class* drop c-ptr ;
|
||||
|
||||
! A register set to f
|
||||
TUPLE: unboxed-f < unboxed ;
|
||||
C: <unboxed-f> unboxed-f
|
||||
|
||||
M: unboxed-f value-class* drop \ f ;
|
||||
|
||||
! An alien, byte array or f
|
||||
TUPLE: unboxed-c-ptr < unboxed ;
|
||||
C: <unboxed-c-ptr> unboxed-c-ptr
|
||||
|
||||
M: unboxed-c-ptr value-class* drop c-ptr ;
|
||||
|
||||
! A constant value
|
||||
TUPLE: constant value ;
|
||||
C: <constant> constant
|
||||
|
||||
M: constant value-class* value>> class ;
|
||||
M: constant >vreg ;
|
||||
|
||||
INSTANCE: constant value
|
||||
M: rs-loc pprint* \ R pprint-loc ;
|
||||
|
|
|
|||
|
|
@ -1,86 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs accessors sequences kernel fry namespaces
|
||||
quotations combinators classes.algebra compiler.cfg.instructions
|
||||
compiler.cfg.registers compiler.cfg.stacks ;
|
||||
IN: compiler.cfg.templates
|
||||
|
||||
TUPLE: template input output scratch clobber gc ;
|
||||
|
||||
: live-vregs ( -- seq )
|
||||
[ stack>> [ >vreg ] map sift ] each-phantom append ;
|
||||
|
||||
: clobbered ( template -- seq )
|
||||
[ output>> ] [ clobber>> ] bi append ;
|
||||
|
||||
: clobbered? ( value name -- ? )
|
||||
\ clobbered get member? [
|
||||
>vreg \ live-vregs get member?
|
||||
] [ drop f ] if ;
|
||||
|
||||
: lazy-load ( specs -- seq )
|
||||
[ length phantom-datastack get phantom-input ] keep
|
||||
[
|
||||
2dup second clobbered?
|
||||
[ first (eager-load) ] [ first (lazy-load) ] if
|
||||
] 2map ;
|
||||
|
||||
: load-inputs ( template -- assoc )
|
||||
[
|
||||
live-vregs \ live-vregs set
|
||||
dup clobbered \ clobbered set
|
||||
input>> [ values ] [ lazy-load ] bi zip
|
||||
] with-scope ;
|
||||
|
||||
: alloc-scratch ( template -- assoc )
|
||||
scratch>> [ swap alloc-vreg ] assoc-map ;
|
||||
|
||||
: do-template-inputs ( template -- defs uses )
|
||||
#! Load input values into registers and allocates scratch
|
||||
#! registers.
|
||||
[ alloc-scratch ] [ load-inputs ] bi ;
|
||||
|
||||
: do-template-outputs ( template defs uses -- )
|
||||
[ output>> ] 2dip assoc-union '[ _ at ] map
|
||||
phantom-datastack get phantom-append ;
|
||||
|
||||
: apply-template ( pair quot -- )
|
||||
[
|
||||
first2
|
||||
dup gc>> [ t fresh-object ] when
|
||||
dup do-template-inputs
|
||||
[ do-template-outputs ]
|
||||
[ [ [ >vreg ] assoc-map ] dip ] 2bi
|
||||
] dip call ; inline
|
||||
|
||||
: phantom&spec ( phantom specs -- phantom' specs' )
|
||||
>r stack>> r>
|
||||
[ length f pad-left ] keep
|
||||
[ <reversed> ] bi@ ; inline
|
||||
|
||||
: value-matches? ( value spec -- ? )
|
||||
#! If the spec is a quotation and the value is a literal
|
||||
#! fixnum, see if the quotation yields true when applied
|
||||
#! to the fixnum. Otherwise, the values don't match. If the
|
||||
#! spec is not a quotation, its a reg-class, in which case
|
||||
#! the value is always good.
|
||||
{
|
||||
{ [ dup small-slot eq? ] [ drop dup constant? [ value>> small-slot? ] [ drop f ] if ] }
|
||||
{ [ dup small-tagged eq? ] [ drop dup constant? [ value>> small-tagged? ] [ drop f ] if ] }
|
||||
[ 2drop t ]
|
||||
} cond ;
|
||||
|
||||
: class-matches? ( actual expected -- ? )
|
||||
dup [ class<= ] [ 2drop t ] if ;
|
||||
|
||||
: spec-matches? ( value spec -- ? )
|
||||
2dup first value-matches?
|
||||
>r >r value-class 2 r> ?nth class-matches? r> and ;
|
||||
|
||||
: template-matches? ( template -- ? )
|
||||
input>> phantom-datastack get swap phantom&spec
|
||||
[ spec-matches? ] 2all? ;
|
||||
|
||||
: find-template ( templates -- pair/f )
|
||||
#! Pair has shape { quot assoc }
|
||||
[ second template-matches? ] find nip ;
|
||||
|
|
@ -30,7 +30,7 @@ M: load-literal-expr live-expr in>> live-vn ;
|
|||
GENERIC: eliminate ( insn -- insn/f )
|
||||
|
||||
: (eliminate) ( insn -- insn/f )
|
||||
dup dst>> >vreg live? [ drop f ] unless ;
|
||||
dup dst>> live? [ drop f ] unless ;
|
||||
|
||||
M: ##peek eliminate (eliminate) ;
|
||||
M: ##unary eliminate (eliminate) ;
|
||||
|
|
|
|||
|
|
@ -9,11 +9,11 @@ IN: compiler.cfg.value-numbering.propagate
|
|||
|
||||
GENERIC: propogate ( insn -- insn )
|
||||
|
||||
M: ##cond-branch propagate [ resolve ] change-src ;
|
||||
M: ##unary-branch propagate [ resolve ] change-src ;
|
||||
|
||||
M: ##unary propogate [ resolve ] change-src ;
|
||||
|
||||
M: ##nullary propagate ;
|
||||
M: ##flushable propagate ;
|
||||
|
||||
M: ##replace propagate [ resolve ] change-src ;
|
||||
|
||||
|
|
|
|||
|
|
@ -6,9 +6,9 @@ IN: compiler.cfg.value-numbering
|
|||
|
||||
GENERIC: make-value-node ( insn -- )
|
||||
|
||||
M: ##cond-branch make-value-node src>> live-vreg ;
|
||||
M: ##unary-branch make-value-node src>> live-vreg ;
|
||||
M: ##unary make-value-node [ insn>vn ] [ dst>> ] bi set-vn ;
|
||||
M: ##nullary make-value-node drop ;
|
||||
M: ##flushable make-value-node drop ;
|
||||
M: ##load-literal make-value-node [ insn>vn ] [ dst>> ] bi set-vn ;
|
||||
M: ##peek make-value-node [ insn>vn ] [ dst>> ] bi set-vn ;
|
||||
M: ##replace make-value-node reset-value-graph ;
|
||||
|
|
|
|||
|
|
@ -4,26 +4,21 @@ USING: namespaces make math math.parser sequences accessors
|
|||
kernel kernel.private layouts assocs words summary arrays
|
||||
combinators classes.algebra alien alien.c-types alien.structs
|
||||
alien.strings alien.arrays sets threads libc continuations.private
|
||||
cpu.architecture
|
||||
fry cpu.architecture
|
||||
compiler.errors
|
||||
compiler.alien
|
||||
compiler.codegen.fixup
|
||||
compiler.cfg
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.builder ;
|
||||
compiler.cfg.builder
|
||||
compiler.codegen.fixup ;
|
||||
IN: compiler.codegen
|
||||
|
||||
GENERIC: generate-insn ( insn -- )
|
||||
|
||||
GENERIC: v>operand ( obj -- operand )
|
||||
|
||||
SYMBOL: registers
|
||||
|
||||
M: constant v>operand
|
||||
value>> [ tag-fixnum ] [ \ f tag-number ] if* ;
|
||||
|
||||
M: value v>operand
|
||||
: register ( vreg -- operand )
|
||||
registers get at [ "Bad value" throw ] unless* ;
|
||||
|
||||
: generate-insns ( insns -- code )
|
||||
|
|
@ -68,124 +63,142 @@ SYMBOL: labels
|
|||
: lookup-label ( id -- label )
|
||||
labels get [ drop <label> ] cache ;
|
||||
|
||||
M: _label generate-insn
|
||||
id>> lookup-label , ;
|
||||
M: ##load-immediate generate-insn
|
||||
[ dst>> register ] [ obj>> ] bi %load-immediate ;
|
||||
|
||||
M: _prologue generate-insn
|
||||
stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
|
||||
|
||||
M: _epilogue generate-insn
|
||||
stack-frame>> total-size>> %epilogue ;
|
||||
|
||||
M: ##load-literal generate-insn
|
||||
[ obj>> ] [ dst>> v>operand ] bi load-literal ;
|
||||
M: ##load-indirect generate-insn
|
||||
[ dst>> register ] [ obj>> ] bi %load-indirect ;
|
||||
|
||||
M: ##peek generate-insn
|
||||
[ dst>> v>operand ] [ loc>> ] bi %peek ;
|
||||
[ dst>> register ] [ loc>> ] bi %peek ;
|
||||
|
||||
M: ##replace generate-insn
|
||||
[ src>> v>operand ] [ loc>> ] bi %replace ;
|
||||
[ src>> register ] [ loc>> ] bi %replace ;
|
||||
|
||||
M: ##inc-d generate-insn n>> %inc-d ;
|
||||
|
||||
M: ##inc-r generate-insn n>> %inc-r ;
|
||||
|
||||
M: ##return generate-insn drop %return ;
|
||||
|
||||
M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
|
||||
|
||||
M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
|
||||
|
||||
SYMBOL: operands
|
||||
|
||||
: init-intrinsic ( insn -- )
|
||||
[ defs-vregs>> ] [ uses-vregs>> ] bi append operands set ;
|
||||
|
||||
M: ##intrinsic generate-insn
|
||||
[ init-intrinsic ] [ quot>> call ] bi ;
|
||||
|
||||
: (operand) ( name -- operand )
|
||||
operands get at* [ "Bad operand name" throw ] unless ;
|
||||
|
||||
: literal ( name -- value )
|
||||
(operand) value>> ;
|
||||
|
||||
: operand ( name -- operand )
|
||||
(operand) v>operand ;
|
||||
|
||||
: operand-class ( var -- class )
|
||||
(operand) value-class ;
|
||||
|
||||
: operand-tag ( operand -- tag/f )
|
||||
operand-class dup [ class-tag ] when ;
|
||||
|
||||
: operand-immediate? ( operand -- ? )
|
||||
operand-class immediate class<= ;
|
||||
|
||||
: unique-operands ( operands quot -- )
|
||||
>r [ operand ] map prune r> each ; inline
|
||||
|
||||
M: _if-intrinsic generate-insn
|
||||
[ init-intrinsic ]
|
||||
[ [ label>> lookup-label ] [ quot>> ] bi call ] bi ;
|
||||
|
||||
M: _branch generate-insn
|
||||
label>> lookup-label %jump-label ;
|
||||
|
||||
M: _branch-f generate-insn
|
||||
[ label>> lookup-label ] [ src>> v>operand ] bi %jump-f ;
|
||||
|
||||
M: _branch-t generate-insn
|
||||
[ label>> lookup-label ] [ src>> v>operand ] bi %jump-t ;
|
||||
M: ##return generate-insn drop %return ;
|
||||
|
||||
M: ##dispatch-label generate-insn label>> %dispatch-label ;
|
||||
|
||||
M: ##dispatch generate-insn
|
||||
[ src>> v>operand ] [ temp>> v>operand ] bi %dispatch ;
|
||||
[ src>> register ] [ temp>> register ] bi %dispatch ;
|
||||
|
||||
: >slot<
|
||||
{
|
||||
[ dst>> register ]
|
||||
[ obj>> register ]
|
||||
[ slot>> dup vreg? [ register ] when ]
|
||||
[ tag>> ]
|
||||
} cleave ; inline
|
||||
|
||||
M: ##slot generate-insn >slot< %slot ;
|
||||
|
||||
M: ##slot-imm generate-insn >slot< %slot-imm ;
|
||||
|
||||
: >set-slot<
|
||||
{
|
||||
[ src>> register ]
|
||||
[ obj>> register ]
|
||||
[ slot>> dup vreg? [ register ] when ]
|
||||
[ tag>> ]
|
||||
} cleave ; inline
|
||||
|
||||
M: ##set-slot generate-insn >set-slot< %set-slot ;
|
||||
|
||||
M: ##set-slot-imm generate-insn >set-slot< %set-slot-imm ;
|
||||
|
||||
: dst/src ( insn -- dst src )
|
||||
[ dst>> v>operand ] [ src>> v>operand ] bi ;
|
||||
[ dst>> register ] [ src>> register ] bi ; inline
|
||||
|
||||
M: ##copy generate-insn dst/src %copy ;
|
||||
: dst/src1/src2 ( insn -- dst src1 src2 )
|
||||
[ dst>> register ] [ src1>> register ] [ src2>> register ] tri ; inline
|
||||
|
||||
M: ##copy-float generate-insn dst/src %copy-float ;
|
||||
|
||||
M: ##unbox-float generate-insn dst/src %unbox-float ;
|
||||
|
||||
M: ##unbox-f generate-insn dst/src %unbox-f ;
|
||||
|
||||
M: ##unbox-alien generate-insn dst/src %unbox-alien ;
|
||||
|
||||
M: ##unbox-byte-array generate-insn dst/src %unbox-byte-array ;
|
||||
|
||||
M: ##unbox-any-c-ptr generate-insn dst/src %unbox-any-c-ptr ;
|
||||
M: ##add generate-insn dst/src1/src2 %add ;
|
||||
M: ##add-imm generate-insn dst/src1/src2 %add-imm ;
|
||||
M: ##sub generate-insn dst/src1/src2 %sub ;
|
||||
M: ##sub-imm generate-insn dst/src1/src2 %sub-imm ;
|
||||
M: ##mul generate-insn dst/src1/src2 %mul ;
|
||||
M: ##mul-imm generate-insn dst/src1/src2 %mul-imm ;
|
||||
M: ##and generate-insn dst/src1/src2 %and ;
|
||||
M: ##and-imm generate-insn dst/src1/src2 %and-imm ;
|
||||
M: ##or generate-insn dst/src1/src2 %or ;
|
||||
M: ##or-imm generate-insn dst/src1/src2 %or-imm ;
|
||||
M: ##xor generate-insn dst/src1/src2 %xor ;
|
||||
M: ##xor-imm generate-insn dst/src1/src2 %xor-imm ;
|
||||
M: ##shl-imm generate-insn dst/src1/src2 %shl-imm ;
|
||||
M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
|
||||
M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
|
||||
M: ##not generate-insn dst/src %not ;
|
||||
|
||||
: dst/src/temp ( insn -- dst src temp )
|
||||
[ dst/src ] [ temp>> v>operand ] bi ;
|
||||
[ dst/src ] [ temp>> register ] bi ; inline
|
||||
|
||||
M: ##box-float generate-insn dst/src/temp %box-float ;
|
||||
M: ##integer>bignum generate-insn dst/src/temp %integer>bignum ;
|
||||
M: ##bignum>integer generate-insn dst/src %bignum>integer ;
|
||||
|
||||
M: ##box-alien generate-insn dst/src/temp %box-alien ;
|
||||
M: ##add-float generate-insn dst/src1/src2 %add-float ;
|
||||
M: ##sub-float generate-insn dst/src1/src2 %sub-float ;
|
||||
M: ##mul-float generate-insn dst/src1/src2 %mul-float ;
|
||||
M: ##div-float generate-insn dst/src1/src2 %div-float ;
|
||||
|
||||
M: ##integer>float generate-insn dst/src/temp %integer>float ;
|
||||
M: ##float>integer generate-insn dst/src %float>integer ;
|
||||
|
||||
M: ##copy generate-insn dst/src %copy ;
|
||||
M: ##copy-float generate-insn dst/src %copy-float ;
|
||||
M: ##unbox-float generate-insn dst/src %unbox-float ;
|
||||
M: ##unbox-f generate-insn dst/src %unbox-f ;
|
||||
M: ##unbox-alien generate-insn dst/src %unbox-alien ;
|
||||
M: ##unbox-byte-array generate-insn dst/src %unbox-byte-array ;
|
||||
M: ##unbox-any-c-ptr generate-insn dst/src %unbox-any-c-ptr ;
|
||||
M: ##box-float generate-insn dst/src/temp %box-float ;
|
||||
M: ##box-alien generate-insn dst/src/temp %box-alien ;
|
||||
|
||||
M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ;
|
||||
M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;
|
||||
M: ##alien-unsigned-4 generate-insn dst/src %alien-unsigned-4 ;
|
||||
M: ##alien-signed-1 generate-insn dst/src %alien-signed-1 ;
|
||||
M: ##alien-signed-2 generate-insn dst/src %alien-signed-2 ;
|
||||
M: ##alien-signed-3 generate-insn dst/src %alien-signed-3 ;
|
||||
M: ##alien-cell generate-insn dst/src %alien-cell ;
|
||||
M: ##alien-float generate-insn dst/src %alien-float ;
|
||||
M: ##alien-double generate-insn dst/src %alien-double ;
|
||||
|
||||
: >alien-setter< [ src>> register ] [ value>> register ] bi ;
|
||||
|
||||
M: ##set-alien-integer-1 generate-insn >alien-setter< %set-alien-integer-1 ;
|
||||
M: ##set-alien-integer-2 generate-insn >alien-setter< %set-alien-integer-2 ;
|
||||
M: ##set-alien-integer-4 generate-insn >alien-setter< %set-alien-integer-4 ;
|
||||
M: ##set-alien-cell generate-insn >alien-setter< %set-alien-cell ;
|
||||
M: ##set-alien-float generate-insn >alien-setter< %set-alien-float ;
|
||||
M: ##set-alien-double generate-insn >alien-setter< %set-alien-double ;
|
||||
|
||||
M: ##allot generate-insn
|
||||
{
|
||||
[ dst>> v>operand ]
|
||||
[ dst>> register ]
|
||||
[ size>> ]
|
||||
[ type>> ]
|
||||
[ tag>> ]
|
||||
[ temp>> v>operand ]
|
||||
[ temp>> register ]
|
||||
} cleave
|
||||
%allot ;
|
||||
|
||||
M: ##write-barrier generate-insn
|
||||
[ src>> v>operand ]
|
||||
[ card#>> v>operand ]
|
||||
[ table>> v>operand ]
|
||||
[ src>> register ]
|
||||
[ card#>> register ]
|
||||
[ table>> register ]
|
||||
tri %write-barrier ;
|
||||
|
||||
M: ##gc generate-insn drop %gc ;
|
||||
|
||||
! #alien-invoke
|
||||
! ##alien-invoke
|
||||
GENERIC: reg-size ( register-class -- n )
|
||||
|
||||
M: int-regs reg-size drop cell ;
|
||||
|
|
@ -276,7 +289,7 @@ M: long-long-type flatten-value-type ( type -- types )
|
|||
>r
|
||||
alien-parameters
|
||||
flatten-value-types
|
||||
r> [ >r alloc-parameter r> execute ] curry each-parameter ;
|
||||
r> '[ alloc-parameter _ execute ] each-parameter ;
|
||||
inline
|
||||
|
||||
: unbox-parameters ( offset node -- )
|
||||
|
|
@ -331,7 +344,7 @@ M: no-such-symbol compiler-error-type
|
|||
|
||||
: check-dlsym ( symbols dll -- )
|
||||
dup dll-valid? [
|
||||
dupd [ dlsym ] curry contains?
|
||||
dupd '[ _ dlsym ] contains?
|
||||
[ drop ] [ no-such-symbol ] if
|
||||
] [
|
||||
dll-path no-such-library drop
|
||||
|
|
@ -407,7 +420,7 @@ TUPLE: callback-context ;
|
|||
: callback-return-quot ( ctype -- quot )
|
||||
return>> {
|
||||
{ [ dup "void" = ] [ drop [ ] ] }
|
||||
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
|
||||
{ [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
|
||||
[ c-type c-type-unboxer-quot ]
|
||||
} cond ;
|
||||
|
||||
|
|
@ -436,6 +449,32 @@ M: ##alien-callback generate-insn
|
|||
[ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ]
|
||||
tri ;
|
||||
|
||||
M: _prologue generate-insn
|
||||
stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
|
||||
|
||||
M: _epilogue generate-insn
|
||||
stack-frame>> total-size>> %epilogue ;
|
||||
|
||||
M: _label generate-insn
|
||||
id>> lookup-label , ;
|
||||
|
||||
M: _branch generate-insn
|
||||
label>> lookup-label %jump-label ;
|
||||
|
||||
: >binary-branch< ( insn -- label src1 src2 cc )
|
||||
{
|
||||
[ label>> lookup-label ]
|
||||
[ src1>> register ]
|
||||
[ src2>> dup vreg? [ register ] when ]
|
||||
[ cc>> ]
|
||||
} cleave ;
|
||||
|
||||
M: _binary-branch generate-insn
|
||||
>binary-branch< %binary-branch ;
|
||||
|
||||
M: _binary-imm-branch generate-insn
|
||||
>binary-branch< %binary-imm-branch ;
|
||||
|
||||
M: _spill generate-insn
|
||||
[ src>> ] [ n>> ] [ class>> ] tri {
|
||||
{ int-regs [ %spill-integer ] }
|
||||
|
|
|
|||
|
|
@ -43,9 +43,10 @@ M: rel-fixup fixup*
|
|||
|
||||
M: integer fixup* , ;
|
||||
|
||||
: indq ( elt seq -- n ) [ eq? ] with find drop ;
|
||||
|
||||
: adjoin* ( obj table -- n )
|
||||
2dup swap [ eq? ] curry find drop
|
||||
[ 2nip ] [ dup length >r push r> ] if* ;
|
||||
2dup indq [ 2nip ] [ dup length >r push r> ] if* ;
|
||||
|
||||
SYMBOL: literal-table
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,10 @@
|
|||
USING: compiler.units tools.test kernel kernel.private
|
||||
sequences.private math.private math combinators strings
|
||||
alien arrays memory vocabs parser eval ;
|
||||
USING: compiler compiler.units tools.test kernel kernel.private
|
||||
sequences.private math.private math combinators strings alien
|
||||
arrays memory vocabs parser eval ;
|
||||
IN: compiler.tests
|
||||
|
||||
\ (compile) must-infer
|
||||
|
||||
! Test empty word
|
||||
[ ] [ [ ] compile-call ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -375,3 +375,8 @@ TUPLE: my-tuple ;
|
|||
[ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test
|
||||
|
||||
[ vector ] [ dispatch-alignment-regression ] unit-test
|
||||
|
||||
! Regression
|
||||
: bad-value-bug ( a -- b ) [ 3 ] [ 3 ] if f <array> ;
|
||||
|
||||
[ { f f f } ] [ t bad-value-bug ] unit-test
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ stack-checker.backend compiler.tree ;
|
|||
IN: compiler.tree.builder
|
||||
|
||||
: with-tree-builder ( quot -- nodes )
|
||||
[ V{ } clone stack-visitor set ] prepose
|
||||
'[ V{ } clone stack-visitor set @ ]
|
||||
with-infer ; inline
|
||||
|
||||
: build-tree ( quot -- nodes )
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@ IN: compiler.tree.combinators
|
|||
: sift-children ( seq flags -- seq' )
|
||||
zip [ nip ] assoc-filter keys ;
|
||||
|
||||
: (3each) [ 3array flip ] dip [ first3 ] prepose ; inline
|
||||
: (3each) [ 3array flip ] dip '[ first3 @ ] ; inline
|
||||
|
||||
: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ IN: compiler.tree.debugger
|
|||
GENERIC: node>quot ( node -- )
|
||||
|
||||
MACRO: match-choose ( alist -- )
|
||||
[ [ ] curry ] assoc-map [ match-cond ] curry ;
|
||||
[ '[ _ ] ] assoc-map '[ _ match-cond ] ;
|
||||
|
||||
MATCH-VARS: ?a ?b ?c ;
|
||||
|
||||
|
|
|
|||
|
|
@ -277,7 +277,7 @@ generic-comparison-ops [
|
|||
}
|
||||
} cond
|
||||
[ fixnum fits? fixnum integer ? ] keep <class/interval-info>
|
||||
[ 2nip ] curry "outputs" set-word-prop
|
||||
'[ 2drop _ ] "outputs" set-word-prop
|
||||
] each
|
||||
|
||||
{ <tuple> <tuple-boa> (tuple) } [
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays generic kernel kernel.private math
|
||||
memory namespaces make sequences layouts system hashtables
|
||||
classes alien byte-arrays combinators words sets ;
|
||||
classes alien byte-arrays combinators words sets fry ;
|
||||
IN: cpu.architecture
|
||||
|
||||
! Labels
|
||||
|
|
@ -35,60 +35,96 @@ GENERIC: param-reg ( n register-class -- reg )
|
|||
|
||||
M: object param-reg param-regs nth ;
|
||||
|
||||
! Sequence mapping vreg-n to native assembler registers
|
||||
GENERIC: vregs ( register-class -- regs )
|
||||
HOOK: %load-immediate cpu ( reg obj -- )
|
||||
HOOK: %load-indirect cpu ( reg obj -- )
|
||||
|
||||
! Load a literal (immediate or indirect)
|
||||
GENERIC# load-literal 1 ( obj reg -- )
|
||||
|
||||
HOOK: load-indirect cpu ( obj reg -- )
|
||||
|
||||
HOOK: stack-frame-size cpu ( stack-frame -- n )
|
||||
|
||||
! Set up caller stack frame
|
||||
HOOK: %prologue cpu ( n -- )
|
||||
|
||||
! Tear down stack frame
|
||||
HOOK: %epilogue cpu ( n -- )
|
||||
|
||||
! Call another word
|
||||
HOOK: %call cpu ( word -- )
|
||||
|
||||
! Local jump for branches
|
||||
HOOK: %jump-label cpu ( label -- )
|
||||
|
||||
! Test if vreg is 'f' or not
|
||||
HOOK: %jump-f cpu ( label vreg -- )
|
||||
|
||||
! Test if vreg is 't' or not
|
||||
HOOK: %jump-t cpu ( label vreg -- )
|
||||
|
||||
HOOK: %dispatch cpu ( src temp -- )
|
||||
|
||||
HOOK: %dispatch-label cpu ( word -- )
|
||||
|
||||
! Return to caller
|
||||
HOOK: %return cpu ( -- )
|
||||
|
||||
! Change datastack height
|
||||
HOOK: %peek cpu ( vreg loc -- )
|
||||
HOOK: %replace cpu ( vreg loc -- )
|
||||
HOOK: %inc-d cpu ( n -- )
|
||||
|
||||
! Change callstack height
|
||||
HOOK: %inc-r cpu ( n -- )
|
||||
|
||||
! Load stack into vreg
|
||||
HOOK: %peek cpu ( vreg loc -- )
|
||||
HOOK: stack-frame-size cpu ( stack-frame -- n )
|
||||
HOOK: %call cpu ( word -- )
|
||||
HOOK: %jump-label cpu ( label -- )
|
||||
HOOK: %return cpu ( -- )
|
||||
|
||||
! Store vreg to stack
|
||||
HOOK: %replace cpu ( vreg loc -- )
|
||||
HOOK: %dispatch cpu ( src temp -- )
|
||||
HOOK: %dispatch-label cpu ( word -- )
|
||||
|
||||
HOOK: %slot cpu ( dst obj slot tag -- )
|
||||
HOOK: %slot-imm cpu ( dst obj slot tag -- )
|
||||
HOOK: %set-slot cpu ( src obj slot tag -- )
|
||||
HOOK: %set-slot-imm cpu ( src obj slot tag -- )
|
||||
|
||||
HOOK: %add cpu ( dst src1 src2 -- )
|
||||
HOOK: %add-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %sub cpu ( dst src1 src2 -- )
|
||||
HOOK: %sub-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %mul cpu ( dst src1 src2 -- )
|
||||
HOOK: %mul-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %and cpu ( dst src1 src2 -- )
|
||||
HOOK: %and-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %or cpu ( dst src1 src2 -- )
|
||||
HOOK: %or-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %xor cpu ( dst src1 src2 -- )
|
||||
HOOK: %xor-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %shl-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %shr-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %sar-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %not cpu ( dst src -- )
|
||||
|
||||
HOOK: %integer>bignum cpu ( dst src -- )
|
||||
HOOK: %bignum>integer cpu ( dst src -- )
|
||||
|
||||
HOOK: %add-float cpu ( dst src1 src2 -- )
|
||||
HOOK: %sub-float cpu ( dst src1 src2 -- )
|
||||
HOOK: %mul-float cpu ( dst src1 src2 -- )
|
||||
HOOK: %div-float cpu ( dst src1 src2 -- )
|
||||
|
||||
HOOK: %integer>float cpu ( dst src -- )
|
||||
HOOK: %float>integer cpu ( dst src -- )
|
||||
|
||||
! Copy values between vregs
|
||||
HOOK: %copy cpu ( dst src -- )
|
||||
HOOK: %copy-float cpu ( dst src -- )
|
||||
|
||||
! Box and unbox floats
|
||||
HOOK: %unbox-float cpu ( dst src -- )
|
||||
HOOK: %unbox-f cpu ( dst src -- )
|
||||
HOOK: %unbox-alien cpu ( dst src -- )
|
||||
HOOK: %unbox-byte-array cpu ( dst src -- )
|
||||
HOOK: %unbox-any-c-ptr cpu ( dst src -- )
|
||||
HOOK: %box-float cpu ( dst src temp -- )
|
||||
HOOK: %box-alien cpu ( dst src temp -- )
|
||||
|
||||
HOOK: %alien-unsigned-1 cpu ( dst src -- )
|
||||
HOOK: %alien-unsigned-2 cpu ( dst src -- )
|
||||
HOOK: %alien-unsigned-4 cpu ( dst src -- )
|
||||
HOOK: %alien-signed-1 cpu ( dst src -- )
|
||||
HOOK: %alien-signed-2 cpu ( dst src -- )
|
||||
HOOK: %alien-signed-3 cpu ( dst src -- )
|
||||
HOOK: %alien-cell cpu ( dst src -- )
|
||||
HOOK: %alien-float cpu ( dst src -- )
|
||||
HOOK: %alien-double cpu ( dst src -- )
|
||||
|
||||
HOOK: %set-alien-integer-1 cpu ( src value -- )
|
||||
HOOK: %set-alien-integer-2 cpu ( src value -- )
|
||||
HOOK: %set-alien-integer-4 cpu ( src value -- )
|
||||
HOOK: %set-alien-cell cpu ( src value -- )
|
||||
HOOK: %set-alien-float cpu ( src value -- )
|
||||
HOOK: %set-alien-double cpu ( src value -- )
|
||||
|
||||
HOOK: %allot cpu ( dst size type tag temp -- )
|
||||
HOOK: %write-barrier cpu ( src card# table -- )
|
||||
HOOK: %gc cpu ( -- )
|
||||
|
||||
HOOK: %prologue cpu ( n -- )
|
||||
HOOK: %epilogue cpu ( n -- )
|
||||
|
||||
HOOK: %binary-branch cpu ( label src1 src2 label cc -- )
|
||||
HOOK: %binary-imm-branch cpu ( label src1 src2 label cc -- )
|
||||
|
||||
HOOK: %spill-integer cpu ( src n -- )
|
||||
HOOK: %spill-float cpu ( src n -- )
|
||||
HOOK: %reload-integer cpu ( dst n -- )
|
||||
HOOK: %reload-float cpu ( dst n -- )
|
||||
|
||||
! FFI stuff
|
||||
|
||||
|
|
@ -141,6 +177,10 @@ HOOK: %cleanup cpu ( params -- )
|
|||
|
||||
M: object %cleanup ( params -- ) drop ;
|
||||
|
||||
HOOK: %prepare-alien-indirect cpu ( -- )
|
||||
|
||||
HOOK: %alien-indirect cpu ( -- )
|
||||
|
||||
HOOK: %alien-callback cpu ( quot -- )
|
||||
|
||||
HOOK: %callback-value cpu ( ctype -- )
|
||||
|
|
@ -150,59 +190,17 @@ HOOK: %callback-return cpu ( params -- )
|
|||
|
||||
M: object %callback-return drop %return ;
|
||||
|
||||
HOOK: %prepare-alien-indirect cpu ( -- )
|
||||
|
||||
HOOK: %alien-indirect cpu ( -- )
|
||||
|
||||
M: stack-params param-reg drop ;
|
||||
|
||||
M: stack-params param-regs drop f ;
|
||||
|
||||
M: object load-literal load-indirect ;
|
||||
|
||||
: if-small-struct ( n size true false -- ? )
|
||||
[ over not over struct-small-enough? and ] 2dip
|
||||
[ [ nip ] prepose ] dip if ;
|
||||
[ 2dup [ not ] [ struct-small-enough? ] bi and ] 2dip
|
||||
[ '[ nip @ ] ] dip if ;
|
||||
inline
|
||||
|
||||
: %unbox-struct ( n c-type -- )
|
||||
[
|
||||
%unbox-small-struct
|
||||
] [
|
||||
%unbox-large-struct
|
||||
] if-small-struct ;
|
||||
[ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
|
||||
|
||||
: %box-struct ( n c-type -- )
|
||||
[
|
||||
%box-small-struct
|
||||
] [
|
||||
%box-large-struct
|
||||
] if-small-struct ;
|
||||
|
||||
! Alien accessors
|
||||
HOOK: %unbox-byte-array cpu ( dst src -- )
|
||||
|
||||
HOOK: %unbox-alien cpu ( dst src -- )
|
||||
|
||||
HOOK: %unbox-f cpu ( dst src -- )
|
||||
|
||||
HOOK: %unbox-any-c-ptr cpu ( dst src -- )
|
||||
|
||||
HOOK: %box-alien cpu ( dst src temp -- )
|
||||
|
||||
! Allocation
|
||||
HOOK: %allot cpu ( dst size type tag temp -- )
|
||||
|
||||
HOOK: %write-barrier cpu ( src card# table -- )
|
||||
|
||||
! GC check
|
||||
HOOK: %gc cpu ( -- )
|
||||
|
||||
! Spilling
|
||||
HOOK: %spill-integer cpu ( src n -- )
|
||||
|
||||
HOOK: %spill-float cpu ( src n -- )
|
||||
|
||||
HOOK: %reload-integer cpu ( dst n -- )
|
||||
|
||||
HOOK: %reload-float cpu ( dst n -- )
|
||||
[ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
|
||||
|
|
|
|||
|
|
@ -66,7 +66,7 @@ M: ppc %box-float ( dst src -- )
|
|||
! is it zero?
|
||||
0 over v>operand 0 CMPI
|
||||
"non-zero" get BNE
|
||||
0 >bignum over load-literal
|
||||
dup 0 >bignum %load-literal
|
||||
"end" get B
|
||||
! it is non-zero
|
||||
"non-zero" resolve-label
|
||||
|
|
|
|||
|
|
@ -41,7 +41,6 @@ M: x86.32 struct-small-enough? ( size -- ? )
|
|||
! On x86, parameters are never passed in registers.
|
||||
M: int-regs return-reg drop EAX ;
|
||||
M: int-regs param-regs drop { } ;
|
||||
M: int-regs vregs drop { EAX ECX EDX EBP } ;
|
||||
M: int-regs push-return-reg return-reg PUSH ;
|
||||
|
||||
M: int-regs load-return-reg
|
||||
|
|
@ -51,7 +50,6 @@ M: int-regs store-return-reg
|
|||
[ stack@ ] [ return-reg ] bi* MOV ;
|
||||
|
||||
M: float-regs param-regs drop { } ;
|
||||
M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
|
||||
|
||||
: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
|
||||
|
||||
|
|
@ -81,8 +79,8 @@ M: x86.32 fixnum>slot@ 1 SHR ;
|
|||
|
||||
M: x86.32 prepare-division CDQ ;
|
||||
|
||||
M: x86.32 load-indirect
|
||||
0 [] MOV rc-absolute-cell rel-literal ;
|
||||
M: x86.32 %load-indirect
|
||||
swap 0 [] MOV rc-absolute-cell rel-literal ;
|
||||
|
||||
M: object %load-param-reg 3drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -26,17 +26,10 @@ M: x86.64 temp-reg-1 RAX ;
|
|||
M: x86.64 temp-reg-2 RCX ;
|
||||
|
||||
M: int-regs return-reg drop RAX ;
|
||||
M: int-regs vregs drop { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } ;
|
||||
M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
|
||||
|
||||
M: float-regs return-reg drop XMM0 ;
|
||||
|
||||
M: float-regs vregs
|
||||
drop {
|
||||
XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
|
||||
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
|
||||
} ;
|
||||
|
||||
M: float-regs param-regs
|
||||
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
|
||||
|
||||
|
|
@ -44,8 +37,8 @@ M: x86.64 fixnum>slot@ drop ;
|
|||
|
||||
M: x86.64 prepare-division CQO ;
|
||||
|
||||
M: x86.64 load-indirect ( literal reg -- )
|
||||
0 [] MOV rc-relative rel-literal ;
|
||||
M: x86.64 %load-indirect ( literal reg -- )
|
||||
swap 0 [] MOV rc-relative rel-literal ;
|
||||
|
||||
M: stack-params %load-param-reg
|
||||
drop
|
||||
|
|
|
|||
|
|
@ -71,11 +71,7 @@ HOOK: temp-reg-2 cpu ( -- reg )
|
|||
HOOK: fixnum>slot@ cpu ( op -- )
|
||||
HOOK: prepare-division cpu ( -- )
|
||||
|
||||
M: f load-literal
|
||||
\ f tag-number MOV drop ;
|
||||
|
||||
M: fixnum load-literal
|
||||
swap tag-fixnum MOV ;
|
||||
M: x86 %load-immediate MOV ;
|
||||
|
||||
: align-stack ( n -- n' )
|
||||
os macosx? cpu x86.64? or [ 16 align ] when ;
|
||||
|
|
@ -118,11 +114,11 @@ M: x86 %call ( label -- ) CALL ;
|
|||
|
||||
M: x86 %jump-label ( label -- ) JMP ;
|
||||
|
||||
M: x86 %jump-f ( label reg -- )
|
||||
\ f tag-number CMP JE ;
|
||||
|
||||
M: x86 %jump-t ( label reg -- )
|
||||
\ f tag-number CMP JNE ;
|
||||
! M: x86 %jump-f ( label reg -- )
|
||||
! \ f tag-number CMP JE ;
|
||||
!
|
||||
! M: x86 %jump-t ( label reg -- )
|
||||
! \ f tag-number CMP JNE ;
|
||||
|
||||
: code-alignment ( -- n )
|
||||
building get length dup cell align swap - ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue