steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/compiler/cfg/builder/builder-tests.factor
View File

@ -4,6 +4,8 @@ words sequences.private fry prettyprint alien
math.private compiler.tree.builder compiler.tree.optimizer math.private compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.debugger ; compiler.cfg.builder compiler.cfg.debugger ;
\ build-cfg must-infer
! Just ensure that various CFGs build correctly. ! Just ensure that various CFGs build correctly.
{ {
[ ] [ ]

125
basis/compiler/cfg/builder/builder.factor
View File

@ -2,24 +2,23 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators hashtables kernel USING: accessors arrays assocs combinators hashtables kernel
math fry namespaces make sequences words byte-arrays math fry namespaces make sequences words byte-arrays
locals layouts alien.c-types alien.structs layouts alien.c-types alien.structs
stack-checker.inlining stack-checker.inlining cpu.architecture
cpu.architecture
compiler.intrinsics
compiler.tree compiler.tree
compiler.tree.builder compiler.tree.builder
compiler.tree.combinators compiler.tree.combinators
compiler.tree.propagation.info compiler.tree.propagation.info
compiler.cfg compiler.cfg
compiler.cfg.stacks
compiler.cfg.templates
compiler.cfg.iterator compiler.cfg.iterator
compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.builder.hats
compiler.cfg.builder.calls
compiler.cfg.builder.stacks
compiler.alien ; compiler.alien ;
IN: compiler.cfg.builder 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 -- ) : set-basic-block ( basic-block -- )
[ basic-block set ] [ instructions>> building set ] bi ; [ basic-block set ] [ instructions>> building set ] bi ;
@ -93,12 +92,6 @@ GENERIC: emit-node ( node -- next )
] with-variable ] with-variable
] keep ; ] keep ;
SYMBOL: +intrinsics+
SYMBOL: +if-intrinsics+
: if-intrinsics ( #call -- quot )
word>> +if-intrinsics+ word-prop ;
: local-recursive-call ( basic-block -- next ) : local-recursive-call ( basic-block -- next )
##branch ##branch
basic-block get successors>> push basic-block get successors>> push
@ -131,22 +124,22 @@ M: #recursive emit-node
dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ; dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
! #if ! #if
: emit-branch ( obj quot -- final-bb ) : emit-branch ( obj -- final-bb )
'[ [
begin-basic-block copy-phantoms begin-basic-block copy-phantoms
@ emit-nodes
basic-block get dup [ ##branch ] when basic-block get dup [ ##branch ] when
] with-scope ; ] with-scope ;
: emit-branches ( seq quot -- ) : emit-if ( node -- )
'[ _ emit-branch ] map children>> [ emit-branch ] map
end-basic-block end-basic-block
begin-basic-block begin-basic-block
basic-block get '[ [ _ swap successors>> push ] when* ] each basic-block get '[ [ _ swap successors>> push ] when* ] each
init-phantoms ; init-phantoms ;
: emit-if ( node -- next ) : ##branch-t ( vreg -- )
children>> [ emit-nodes ] emit-branches ; \ f tag-number cc/= ##binary-imm-branch ;
M: #if emit-node M: #if emit-node
phantom-pop ##branch-t emit-if iterate-next ; phantom-pop ##branch-t emit-if iterate-next ;
@ -194,100 +187,16 @@ M: #dispatch emit-node
] if ; ] if ;
! #call ! #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 M: #call emit-node
dup setup-value-classes dup word>> dup "intrinsic" word-prop
dup find-if-intrinsic [ do-if-intrinsic ] [ [ emit-intrinsic iterate-next ] [ nip emit-call ] if ;
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 ;
! #call-recursive ! #call-recursive
M: #call-recursive emit-node label>> id>> emit-call ; M: #call-recursive emit-node label>> id>> emit-call ;
! #push ! #push
M: #push emit-node M: #push emit-node
literal>> <constant> phantom-push iterate-next ; literal>> ^^load-literal phantom-push iterate-next ;
! #shuffle ! #shuffle
M: #shuffle emit-node M: #shuffle emit-node

360
basis/compiler/cfg/builder/calls/calls.factor Normal file
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 ;

62
basis/compiler/cfg/builder/hats/hats.factor Normal file
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

0
basis/compiler/cfg/stacks/authors.txt → basis/compiler/cfg/builder/stacks/authors.txt
View File

177
basis/compiler/cfg/stacks/stacks.factor → basis/compiler/cfg/builder/stacks/stacks.factor
View File

@ -3,9 +3,11 @@
USING: arrays assocs classes classes.private classes.algebra USING: arrays assocs classes classes.private classes.algebra
combinators hashtables kernel layouts math fry namespaces combinators hashtables kernel layouts math fry namespaces
quotations sequences system vectors words effects alien quotations sequences system vectors words effects alien
byte-arrays accessors sets math.order cpu.architecture byte-arrays accessors sets math.order
compiler.cfg.instructions compiler.cfg.registers ; combinators.short-circuit cpu.architecture
IN: compiler.cfg.stacks compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.builder.hats ;
IN: compiler.cfg.builder.stacks
! Converting stack operations into register operations, while ! Converting stack operations into register operations, while
! doing a bit of optimization along the way. ! 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? ; 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 ! Operands holding pointers to freshly-allocated objects which
! are guaranteed to be in the nursery ! are guaranteed to be in the nursery
SYMBOL: fresh-objects SYMBOL: fresh-objects
@ -90,34 +23,6 @@ SYMBOL: fresh-objects
: fresh-object? ( vreg -- ? ) fresh-objects get memq? ; : 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 ! A compile-time stack
TUPLE: phantom-stack height stack ; TUPLE: phantom-stack height stack ;
@ -204,42 +109,13 @@ M: phantom-retainstack finalize-height
: finalize-heights ( -- ) [ finalize-height ] each-phantom ; : finalize-heights ( -- ) [ finalize-height ] each-phantom ;
: reg-spec>class ( spec -- class ) GENERIC: lazy-load ( loc/vreg -- vreg )
float eq? double-float-regs int-regs ? ; M: loc lazy-load ^^peek ;
M: vreg lazy-load ;
: alloc-vreg ( spec -- reg ) GENERIC: live-loc? ( actual current -- ? )
[ reg-spec>class next-vreg ] keep { M: vreg live-loc? 2drop f ;
{ f [ <tagged> ] } M: loc live-loc? { [ [ class ] bi@ = ] [ [ n>> ] bi@ = not ] } 2&& ;
{ 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 ;
: (live-locs) ( phantom -- seq ) : (live-locs) ( phantom -- seq )
#! Discard locs which haven't moved #! Discard locs which haven't moved
@ -250,19 +126,26 @@ M: phantom-retainstack finalize-height
: live-locs ( -- seq ) : live-locs ( -- seq )
[ (live-locs) ] each-phantom append prune ; [ (live-locs) ] each-phantom append prune ;
GENERIC: lazy-store ( dst src -- )
M: vreg lazy-store 2drop ;
M: loc lazy-store 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 ( -- ) : finalize-locs ( -- )
#! Perform any deferred stack shuffling. #! 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 ] [ dup assoc-empty? [ drop ] [
"live-locs" set [ lazy-store ] each-loc \ live-locs set
[ lazy-store ] each-loc
] if ; ] if ;
: finalize-vregs ( -- ) : finalize-vregs ( -- )
#! Store any vregs to their final stack locations. #! 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 ( -- ) : clear-phantoms ( -- )
[ stack>> delete-all ] each-phantom ; [ stack>> delete-all ] each-phantom ;
@ -271,11 +154,6 @@ M: loc lazy-store
finalize-locs finalize-vregs clear-phantoms ; finalize-locs finalize-vregs clear-phantoms ;
! Loading stacks to vregs ! Loading stacks to vregs
: set-value-classes ( classes -- )
phantom-datastack get
over length over add-locs
stack>> [ set-value-class ] 2reverse-each ;
: finalize-phantoms ( -- ) : finalize-phantoms ( -- )
#! Commit all deferred stacking shuffling, and ensure the #! Commit all deferred stacking shuffling, and ensure the
#! in-memory data and retain stacks are up to date with #! in-memory data and retain stacks are up to date with
@ -318,5 +196,14 @@ M: loc lazy-store
: phantom-rdrop ( n -- ) : phantom-rdrop ( n -- )
phantom-retainstack get phantom-input drop ; phantom-retainstack get phantom-input drop ;
: phantom-load ( n -- vreg )
phantom-datastack get phantom-input [ lazy-load ] map ;
: phantom-pop ( -- vreg ) : 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 ;

17
basis/compiler/cfg/debugger/debugger.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel words sequences quotations namespaces io USING: kernel words sequences quotations namespaces io
accessors prettyprint prettyprint.config classes.tuple accessors prettyprint prettyprint.config
compiler.tree.builder compiler.tree.optimizer compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.linearization compiler.cfg.builder compiler.cfg.linearization
compiler.cfg.stack-frame compiler.cfg.linear-scan ; compiler.cfg.stack-frame compiler.cfg.linear-scan ;
@ -15,16 +15,25 @@ M: callable test-cfg
M: word test-cfg M: word test-cfg
[ build-tree-from-word nip optimize-tree ] keep build-cfg ; [ build-tree-from-word nip optimize-tree ] keep build-cfg ;
SYMBOL: allocate-registers?
: test-mr ( quot -- mrs ) : 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 -- ) : mr. ( mrs -- )
[ [
boa-tuples? on
"=== word: " write "=== word: " write
dup word>> pprint dup word>> pprint
", label: " write ", label: " write
dup label>> pprint nl nl dup label>> pprint nl nl
instructions>> . instructions>> [ insn. ] each
nl nl
] each ; ] each ;

31
basis/compiler/cfg/def-use/def-use.factor Normal file
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 ;

192
basis/compiler/cfg/instructions/instructions.factor
View File

@ -1,19 +1,49 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors arrays kernel sequences namespaces words 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 IN: compiler.cfg.instructions
! Virtual CPU instructions, used by CFG and machine IRs ! Virtual CPU instructions, used by CFG and machine IRs
TUPLE: ##cond-branch < insn { src vreg } ; ! Instruction with no side effects; if 'out' is never read, we
TUPLE: ##unary < insn { dst vreg } { src vreg } ; ! can eliminate it.
TUPLE: ##nullary < insn { dst vreg } ; 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 ! Stack operations
INSN: ##load-literal < ##nullary obj ; INSN: ##load-immediate < ##pure { val integer } ;
INSN: ##peek < ##nullary { loc loc } ; INSN: ##load-indirect < ##pure obj ;
INSN: ##replace { src vreg } { loc loc } ;
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-d { n integer } ;
INSN: ##inc-r { n integer } ; INSN: ##inc-r { n integer } ;
@ -30,12 +60,48 @@ INSN: ##call word ;
INSN: ##jump word ; INSN: ##jump word ;
INSN: ##return ; INSN: ##return ;
INSN: ##intrinsic quot defs-vregs uses-vregs ;
! Jump tables ! Jump tables
INSN: ##dispatch src temp ; INSN: ##dispatch src temp ;
INSN: ##dispatch-label label ; 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 ! Boxing and unboxing
INSN: ##copy < ##unary ; INSN: ##copy < ##unary ;
INSN: ##copy-float < ##unary ; INSN: ##copy-float < ##unary ;
@ -44,12 +110,38 @@ INSN: ##unbox-f < ##unary ;
INSN: ##unbox-alien < ##unary ; INSN: ##unbox-alien < ##unary ;
INSN: ##unbox-byte-array < ##unary ; INSN: ##unbox-byte-array < ##unary ;
INSN: ##unbox-any-c-ptr < ##unary ; INSN: ##unbox-any-c-ptr < ##unary ;
INSN: ##box-float < ##unary { temp vreg } ; INSN: ##box-float < ##boxer ;
INSN: ##box-alien < ##unary { temp vreg } ; 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 ! Memory allocation
INSN: ##allot < ##nullary size type tag { temp vreg } ; INSN: ##allot < ##flushable size type tag { temp vreg } ;
INSN: ##write-barrier { src vreg } card# table ; INSN: ##write-barrier < ##effect card# table ;
INSN: ##gc ; INSN: ##gc ;
! FFI ! FFI
@ -58,54 +150,35 @@ INSN: ##alien-indirect params ;
INSN: ##alien-callback params ; INSN: ##alien-callback params ;
INSN: ##callback-return 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. ! Instructions used by CFG IR only.
INSN: ##prologue ; INSN: ##prologue ;
INSN: ##epilogue ; INSN: ##epilogue ;
INSN: ##branch ; 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 ; : evaluate-cc ( result cc -- ? )
M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ; 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. ! Instructions used by machine IR only.
INSN: _prologue stack-frame ; INSN: _prologue stack-frame ;
@ -113,17 +186,10 @@ INSN: _epilogue stack-frame ;
INSN: _label id ; INSN: _label id ;
TUPLE: _cond-branch < insn { src vreg } label ;
INSN: _branch 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 ; INSN: _binary-branch label { src1 vreg } { src2 vreg } cc ;
INSN: _binary-imm-branch label { src1 vreg } { src2 integer } cc ;
M: _if-intrinsic defs-vregs intrinsic-defs-vregs ;
M: _if-intrinsic uses-vregs intrinsic-uses-vregs ;
! These instructions operate on machine registers and not ! These instructions operate on machine registers and not
! virtual registers ! virtual registers

1
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -3,6 +3,7 @@
USING: accessors kernel math assocs namespaces sequences heaps USING: accessors kernel math assocs namespaces sequences heaps
fry make combinators fry make combinators
cpu.architecture cpu.architecture
compiler.cfg.def-use
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.linear-scan.live-intervals ; compiler.cfg.linear-scan.live-intervals ;

3
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs accessors sequences math fry 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 IN: compiler.cfg.linear-scan.live-intervals
TUPLE: live-interval TUPLE: live-interval

19
basis/compiler/cfg/linearization/linearization.factor
View File

@ -40,21 +40,14 @@ M: ##branch linearize-insn
: conditional ( basic-block -- basic-block successor1 label2 ) : conditional ( basic-block -- basic-block successor1 label2 )
dup successors>> first2 swap number>> ; inline dup successors>> first2 swap number>> ; inline
: boolean-conditional ( basic-block insn -- basic-block successor vreg label2 ) : binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
[ conditional ] [ src>> ] bi* swap ; inline [ conditional ] [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
M: ##branch-f linearize-insn M: ##binary-branch linearize-insn
boolean-conditional _branch-f emit-branch ; binary-conditional _binary-branch emit-branch ;
M: ##branch-t linearize-insn M: ##binary-imm-branch linearize-insn
boolean-conditional _branch-t emit-branch ; binary-conditional _binary-imm-branch 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 ;
: linearize-basic-block ( bb -- ) : linearize-basic-block ( bb -- )
[ number>> _label ] [ linearize-insns ] bi ; [ number>> _label ] [ linearize-insns ] bi ;

88
basis/compiler/cfg/registers/registers.factor
View File

@ -1,91 +1,37 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces math kernel alien classes ; USING: accessors namespaces kernel arrays
parser prettyprint.backend prettyprint.sections ;
IN: compiler.cfg.registers IN: compiler.cfg.registers
! Virtual CPU registers, used by CFG and machine IRs ! Virtual 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
TUPLE: vreg reg-class n ; TUPLE: vreg reg-class n ;
SYMBOL: vreg-counter SYMBOL: vreg-counter
: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ; : next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
M: vreg >vreg ;
INSTANCE: vreg value
! Stack locations ! Stack locations
TUPLE: loc n class ; TUPLE: loc n ;
M: loc >vreg drop f ;
! A data stack location.
TUPLE: ds-loc < loc ; TUPLE: ds-loc < loc ;
: <ds-loc> ( n -- loc ) f ds-loc boa ; C: <ds-loc> ds-loc
TUPLE: rs-loc < 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 M: vreg pprint*
TUPLE: tagged vreg class ; <block
: <tagged> ( vreg -- tagged ) f tagged boa ; \ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
block> ;
M: tagged set-value-class (>>class) ; : pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
M: tagged value-class* class>> ;
M: tagged >vreg vreg>> ;
INSTANCE: tagged value : D scan-word <ds-loc> parsed ; parsing
! Unboxed value M: ds-loc pprint* \ D pprint-loc ;
TUPLE: unboxed vreg ;
C: <unboxed> unboxed
M: unboxed >vreg vreg>> ; : R scan-word <rs-loc> parsed ; parsing
INSTANCE: unboxed value M: rs-loc pprint* \ R pprint-loc ;
! 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

86
basis/compiler/cfg/templates/templates.factor
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 ;

2
basis/compiler/cfg/value-numbering/liveness/liveness.factor
View File

@ -30,7 +30,7 @@ M: load-literal-expr live-expr in>> live-vn ;
GENERIC: eliminate ( insn -- insn/f ) GENERIC: eliminate ( insn -- insn/f )
: (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: ##peek eliminate (eliminate) ;
M: ##unary eliminate (eliminate) ; M: ##unary eliminate (eliminate) ;

4
basis/compiler/cfg/value-numbering/propagate/propagate.factor
View File

@ -9,11 +9,11 @@ IN: compiler.cfg.value-numbering.propagate
GENERIC: propogate ( insn -- insn ) 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: ##unary propogate [ resolve ] change-src ;
M: ##nullary propagate ; M: ##flushable propagate ;
M: ##replace propagate [ resolve ] change-src ; M: ##replace propagate [ resolve ] change-src ;

4
basis/compiler/cfg/value-numbering/value-numbering.factor
View File

@ -6,9 +6,9 @@ IN: compiler.cfg.value-numbering
GENERIC: make-value-node ( insn -- ) 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: ##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: ##load-literal make-value-node [ insn>vn ] [ dst>> ] bi set-vn ;
M: ##peek 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 ; M: ##replace make-value-node reset-value-graph ;

219
basis/compiler/codegen/codegen.factor
View File

@ -4,26 +4,21 @@ USING: namespaces make math math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types alien.structs combinators classes.algebra alien alien.c-types alien.structs
alien.strings alien.arrays sets threads libc continuations.private alien.strings alien.arrays sets threads libc continuations.private
cpu.architecture fry cpu.architecture
compiler.errors compiler.errors
compiler.alien compiler.alien
compiler.codegen.fixup
compiler.cfg compiler.cfg
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.builder ; compiler.cfg.builder
compiler.codegen.fixup ;
IN: compiler.codegen IN: compiler.codegen
GENERIC: generate-insn ( insn -- ) GENERIC: generate-insn ( insn -- )
GENERIC: v>operand ( obj -- operand )
SYMBOL: registers SYMBOL: registers
M: constant v>operand : register ( vreg -- operand )
value>> [ tag-fixnum ] [ \ f tag-number ] if* ;
M: value v>operand
registers get at [ "Bad value" throw ] unless* ; registers get at [ "Bad value" throw ] unless* ;
: generate-insns ( insns -- code ) : generate-insns ( insns -- code )
@ -68,124 +63,142 @@ SYMBOL: labels
: lookup-label ( id -- label ) : lookup-label ( id -- label )
labels get [ drop <label> ] cache ; labels get [ drop <label> ] cache ;
M: _label generate-insn M: ##load-immediate generate-insn
id>> lookup-label , ; [ dst>> register ] [ obj>> ] bi %load-immediate ;
M: _prologue generate-insn M: ##load-indirect generate-insn
stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ; [ dst>> register ] [ obj>> ] bi %load-indirect ;
M: _epilogue generate-insn
stack-frame>> total-size>> %epilogue ;
M: ##load-literal generate-insn
[ obj>> ] [ dst>> v>operand ] bi load-literal ;
M: ##peek generate-insn M: ##peek generate-insn
[ dst>> v>operand ] [ loc>> ] bi %peek ; [ dst>> register ] [ loc>> ] bi %peek ;
M: ##replace generate-insn 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-d generate-insn n>> %inc-d ;
M: ##inc-r generate-insn n>> %inc-r ; M: ##inc-r generate-insn n>> %inc-r ;
M: ##return generate-insn drop %return ;
M: ##call generate-insn word>> [ add-call ] [ %call ] bi ; M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ; M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
SYMBOL: operands M: ##return generate-insn drop %return ;
: 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: ##dispatch-label generate-insn label>> %dispatch-label ; M: ##dispatch-label generate-insn label>> %dispatch-label ;
M: ##dispatch generate-insn 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/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: ##add generate-insn dst/src1/src2 %add ;
M: ##add-imm generate-insn dst/src1/src2 %add-imm ;
M: ##unbox-float generate-insn dst/src %unbox-float ; M: ##sub generate-insn dst/src1/src2 %sub ;
M: ##sub-imm generate-insn dst/src1/src2 %sub-imm ;
M: ##unbox-f generate-insn dst/src %unbox-f ; M: ##mul generate-insn dst/src1/src2 %mul ;
M: ##mul-imm generate-insn dst/src1/src2 %mul-imm ;
M: ##unbox-alien generate-insn dst/src %unbox-alien ; M: ##and generate-insn dst/src1/src2 %and ;
M: ##and-imm generate-insn dst/src1/src2 %and-imm ;
M: ##unbox-byte-array generate-insn dst/src %unbox-byte-array ; M: ##or generate-insn dst/src1/src2 %or ;
M: ##or-imm generate-insn dst/src1/src2 %or-imm ;
M: ##unbox-any-c-ptr generate-insn dst/src %unbox-any-c-ptr ; 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 ( 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 M: ##allot generate-insn
{ {
[ dst>> v>operand ] [ dst>> register ]
[ size>> ] [ size>> ]
[ type>> ] [ type>> ]
[ tag>> ] [ tag>> ]
[ temp>> v>operand ] [ temp>> register ]
} cleave } cleave
%allot ; %allot ;
M: ##write-barrier generate-insn M: ##write-barrier generate-insn
[ src>> v>operand ] [ src>> register ]
[ card#>> v>operand ] [ card#>> register ]
[ table>> v>operand ] [ table>> register ]
tri %write-barrier ; tri %write-barrier ;
M: ##gc generate-insn drop %gc ; M: ##gc generate-insn drop %gc ;
! #alien-invoke ! ##alien-invoke
GENERIC: reg-size ( register-class -- n ) GENERIC: reg-size ( register-class -- n )
M: int-regs reg-size drop cell ; M: int-regs reg-size drop cell ;
@ -276,7 +289,7 @@ M: long-long-type flatten-value-type ( type -- types )
>r >r
alien-parameters alien-parameters
flatten-value-types flatten-value-types
r> [ >r alloc-parameter r> execute ] curry each-parameter ; r> '[ alloc-parameter _ execute ] each-parameter ;
inline inline
: unbox-parameters ( offset node -- ) : unbox-parameters ( offset node -- )
@ -331,7 +344,7 @@ M: no-such-symbol compiler-error-type
: check-dlsym ( symbols dll -- ) : check-dlsym ( symbols dll -- )
dup dll-valid? [ dup dll-valid? [
dupd [ dlsym ] curry contains? dupd '[ _ dlsym ] contains?
[ drop ] [ no-such-symbol ] if [ drop ] [ no-such-symbol ] if
] [ ] [
dll-path no-such-library drop dll-path no-such-library drop
@ -407,7 +420,7 @@ TUPLE: callback-context ;
: callback-return-quot ( ctype -- quot ) : callback-return-quot ( ctype -- quot )
return>> { return>> {
{ [ dup "void" = ] [ drop [ ] ] } { [ dup "void" = ] [ drop [ ] ] }
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] } { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
[ c-type c-type-unboxer-quot ] [ c-type c-type-unboxer-quot ]
} cond ; } cond ;
@ -436,6 +449,32 @@ M: ##alien-callback generate-insn
[ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ] [ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ]
tri ; 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 M: _spill generate-insn
[ src>> ] [ n>> ] [ class>> ] tri { [ src>> ] [ n>> ] [ class>> ] tri {
{ int-regs [ %spill-integer ] } { int-regs [ %spill-integer ] }

5
basis/compiler/codegen/fixup/fixup.factor
View File

@ -43,9 +43,10 @@ M: rel-fixup fixup*
M: integer fixup* , ; M: integer fixup* , ;
: indq ( elt seq -- n ) [ eq? ] with find drop ;
: adjoin* ( obj table -- n ) : adjoin* ( obj table -- n )
2dup swap [ eq? ] curry find drop 2dup indq [ 2nip ] [ dup length >r push r> ] if* ;
[ 2nip ] [ dup length >r push r> ] if* ;
SYMBOL: literal-table SYMBOL: literal-table

8
basis/compiler/tests/simple.factor
View File

@ -1,8 +1,10 @@
USING: compiler.units tools.test kernel kernel.private USING: compiler compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings sequences.private math.private math combinators strings alien
alien arrays memory vocabs parser eval ; arrays memory vocabs parser eval ;
IN: compiler.tests IN: compiler.tests
\ (compile) must-infer
! Test empty word ! Test empty word
[ ] [ [ ] compile-call ] unit-test [ ] [ [ ] compile-call ] unit-test

5
basis/compiler/tests/templates.factor
View File

@ -375,3 +375,8 @@ TUPLE: my-tuple ;
[ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test [ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test
[ vector ] [ dispatch-alignment-regression ] 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

2
basis/compiler/tree/builder/builder.factor
View File

@ -7,7 +7,7 @@ stack-checker.backend compiler.tree ;
IN: compiler.tree.builder IN: compiler.tree.builder
: with-tree-builder ( quot -- nodes ) : with-tree-builder ( quot -- nodes )
[ V{ } clone stack-visitor set ] prepose '[ V{ } clone stack-visitor set @ ]
with-infer ; inline with-infer ; inline
: build-tree ( quot -- nodes ) : build-tree ( quot -- nodes )

2
basis/compiler/tree/combinators/combinators.factor
View File

@ -48,7 +48,7 @@ IN: compiler.tree.combinators
: sift-children ( seq flags -- seq' ) : sift-children ( seq flags -- seq' )
zip [ nip ] assoc-filter keys ; 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 : 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline

2
basis/compiler/tree/debugger/debugger.factor
View File

@ -24,7 +24,7 @@ IN: compiler.tree.debugger
GENERIC: node>quot ( node -- ) GENERIC: node>quot ( node -- )
MACRO: match-choose ( alist -- ) MACRO: match-choose ( alist -- )
[ [ ] curry ] assoc-map [ match-cond ] curry ; [ '[ _ ] ] assoc-map '[ _ match-cond ] ;
MATCH-VARS: ?a ?b ?c ; MATCH-VARS: ?a ?b ?c ;

2
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -277,7 +277,7 @@ generic-comparison-ops [
} }
} cond } cond
[ fixnum fits? fixnum integer ? ] keep <class/interval-info> [ fixnum fits? fixnum integer ? ] keep <class/interval-info>
[ 2nip ] curry "outputs" set-word-prop '[ 2drop _ ] "outputs" set-word-prop
] each ] each
{ <tuple> <tuple-boa> (tuple) } [ { <tuple> <tuple-boa> (tuple) } [

180
basis/cpu/architecture/architecture.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays generic kernel kernel.private math USING: accessors arrays generic kernel kernel.private math
memory namespaces make sequences layouts system hashtables 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 IN: cpu.architecture
! Labels ! Labels
@ -35,60 +35,96 @@ GENERIC: param-reg ( n register-class -- reg )
M: object param-reg param-regs nth ; M: object param-reg param-regs nth ;
! Sequence mapping vreg-n to native assembler registers HOOK: %load-immediate cpu ( reg obj -- )
GENERIC: vregs ( register-class -- regs ) HOOK: %load-indirect cpu ( reg obj -- )
! Load a literal (immediate or indirect) HOOK: %peek cpu ( vreg loc -- )
GENERIC# load-literal 1 ( obj reg -- ) HOOK: %replace cpu ( vreg loc -- )
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: %inc-d cpu ( n -- ) HOOK: %inc-d cpu ( n -- )
! Change callstack height
HOOK: %inc-r cpu ( n -- ) HOOK: %inc-r cpu ( n -- )
! Load stack into vreg HOOK: stack-frame-size cpu ( stack-frame -- n )
HOOK: %peek cpu ( vreg loc -- ) HOOK: %call cpu ( word -- )
HOOK: %jump-label cpu ( label -- )
HOOK: %return cpu ( -- )
! Store vreg to stack HOOK: %dispatch cpu ( src temp -- )
HOOK: %replace cpu ( vreg loc -- ) 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 cpu ( dst src -- )
HOOK: %copy-float cpu ( dst src -- ) HOOK: %copy-float cpu ( dst src -- )
! Box and unbox floats
HOOK: %unbox-float cpu ( dst src -- ) 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-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 ! FFI stuff
@ -141,6 +177,10 @@ HOOK: %cleanup cpu ( params -- )
M: object %cleanup ( params -- ) drop ; M: object %cleanup ( params -- ) drop ;
HOOK: %prepare-alien-indirect cpu ( -- )
HOOK: %alien-indirect cpu ( -- )
HOOK: %alien-callback cpu ( quot -- ) HOOK: %alien-callback cpu ( quot -- )
HOOK: %callback-value cpu ( ctype -- ) HOOK: %callback-value cpu ( ctype -- )
@ -150,59 +190,17 @@ HOOK: %callback-return cpu ( params -- )
M: object %callback-return drop %return ; 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-reg drop ;
M: stack-params param-regs drop f ; M: stack-params param-regs drop f ;
M: object load-literal load-indirect ;
: if-small-struct ( n size true false -- ? ) : if-small-struct ( n size true false -- ? )
[ over not over struct-small-enough? and ] 2dip [ 2dup [ not ] [ struct-small-enough? ] bi and ] 2dip
[ [ nip ] prepose ] dip if ; [ '[ nip @ ] ] dip if ;
inline inline
: %unbox-struct ( n c-type -- ) : %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-struct ( n c-type -- )
[ [ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
%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 -- )

2
basis/cpu/ppc/allot/allot.factor
View File

@ -66,7 +66,7 @@ M: ppc %box-float ( dst src -- )
! is it zero? ! is it zero?
0 over v>operand 0 CMPI 0 over v>operand 0 CMPI
"non-zero" get BNE "non-zero" get BNE
0 >bignum over load-literal dup 0 >bignum %load-literal
"end" get B "end" get B
! it is non-zero ! it is non-zero
"non-zero" resolve-label "non-zero" resolve-label

6
basis/cpu/x86/32/32.factor
View File

@ -41,7 +41,6 @@ M: x86.32 struct-small-enough? ( size -- ? )
! On x86, parameters are never passed in registers. ! On x86, parameters are never passed in registers.
M: int-regs return-reg drop EAX ; M: int-regs return-reg drop EAX ;
M: int-regs param-regs drop { } ; 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 push-return-reg return-reg PUSH ;
M: int-regs load-return-reg M: int-regs load-return-reg
@ -51,7 +50,6 @@ M: int-regs store-return-reg
[ stack@ ] [ return-reg ] bi* MOV ; [ stack@ ] [ return-reg ] bi* MOV ;
M: float-regs param-regs drop { } ; 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 ; : 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 prepare-division CDQ ;
M: x86.32 load-indirect M: x86.32 %load-indirect
0 [] MOV rc-absolute-cell rel-literal ; swap 0 [] MOV rc-absolute-cell rel-literal ;
M: object %load-param-reg 3drop ; M: object %load-param-reg 3drop ;

11
basis/cpu/x86/64/64.factor
View File

@ -26,17 +26,10 @@ M: x86.64 temp-reg-1 RAX ;
M: x86.64 temp-reg-2 RCX ; M: x86.64 temp-reg-2 RCX ;
M: int-regs return-reg drop RAX ; 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: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
M: float-regs return-reg drop XMM0 ; M: float-regs return-reg drop XMM0 ;
M: float-regs vregs
drop {
XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
} ;
M: float-regs param-regs M: float-regs param-regs
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ; 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 prepare-division CQO ;
M: x86.64 load-indirect ( literal reg -- ) M: x86.64 %load-indirect ( literal reg -- )
0 [] MOV rc-relative rel-literal ; swap 0 [] MOV rc-relative rel-literal ;
M: stack-params %load-param-reg M: stack-params %load-param-reg
drop drop

16
basis/cpu/x86/architecture/architecture.factor
View File

@ -71,11 +71,7 @@ HOOK: temp-reg-2 cpu ( -- reg )
HOOK: fixnum>slot@ cpu ( op -- ) HOOK: fixnum>slot@ cpu ( op -- )
HOOK: prepare-division cpu ( -- ) HOOK: prepare-division cpu ( -- )
M: f load-literal M: x86 %load-immediate MOV ;
\ f tag-number MOV drop ;
M: fixnum load-literal
swap tag-fixnum MOV ;
: align-stack ( n -- n' ) : align-stack ( n -- n' )
os macosx? cpu x86.64? or [ 16 align ] when ; os macosx? cpu x86.64? or [ 16 align ] when ;
@ -118,11 +114,11 @@ M: x86 %call ( label -- ) CALL ;
M: x86 %jump-label ( label -- ) JMP ; M: x86 %jump-label ( label -- ) JMP ;
M: x86 %jump-f ( label reg -- ) ! M: x86 %jump-f ( label reg -- )
\ f tag-number CMP JE ; ! \ f tag-number CMP JE ;
!
M: x86 %jump-t ( label reg -- ) ! M: x86 %jump-t ( label reg -- )
\ f tag-number CMP JNE ; ! \ f tag-number CMP JNE ;
: code-alignment ( -- n ) : code-alignment ( -- n )
building get length dup cell align swap - ; building get length dup cell align swap - ;