CFG IR is now pure SSA

db4
Slava Pestov 2008-10-20 01:56:28 -05:00
parent 2db8628cad
commit f092622fac
30 changed files with 923 additions and 710 deletions

View File

@ -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.
{
[ ]

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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