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

compiler.cfg.*: more fixes to pass basic-block on the stack than in a 

dynamic variable
db4
Björn Lindqvist 2015-11-22 01:06:11 +01:00
parent 1421779c9e
commit 63fd4d25cf
8 changed files with 54 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/compiler/cfg/builder/alien/alien.factor
View File

@ -169,7 +169,7 @@ M: #alien-assembly emit-node ( node -- )
M: #alien-callback emit-node M: #alien-callback emit-node
dup params>> xt>> dup dup params>> xt>> dup
[ [
needs-frame-pointer basic-block get begin-word needs-frame-pointer begin-word
{ {
[ params>> callee-parameters ##callback-inputs, ] [ params>> callee-parameters ##callback-inputs, ]
[ params>> box-parameters ] [ params>> box-parameters ]
@ -177,5 +177,5 @@ M: #alien-callback emit-node
[ params>> emit-callback-return ] [ params>> emit-callback-return ]
[ params>> callback-stack-cleanup ] [ params>> callback-stack-cleanup ]
} cleave } cleave
basic-block get [ end-word ] when basic-block get [ end-word ] when*
] with-cfg-builder ; ] with-cfg-builder ;

2
basis/compiler/cfg/builder/blocks/blocks-docs.factor
View File

@ -45,7 +45,7 @@ HELP: call-height
HELP: emit-trivial-block HELP: emit-trivial-block
{ $values { "quot" quotation } } { $values { "quot" quotation } }
{ $description "Combinator that emits a trivial block, constructed by calling the supplied quotation." } { $description "Combinator that emits a new trivial block, constructed by calling the supplied quotation. The quotation should not end the current block -- only add instructions to it." }
{ $examples { $unchecked-example $[ ex-emit-trivial-block ] } } ; { $examples { $unchecked-example $[ ex-emit-trivial-block ] } } ;
HELP: end-branch HELP: end-branch

13
basis/compiler/cfg/builder/blocks/blocks-tests.factor
View File

@ -1,6 +1,7 @@
USING: accessors compiler.cfg compiler.cfg.builder.blocks USING: accessors compiler.cfg compiler.cfg.builder.blocks
compiler.cfg.stacks.local compiler.cfg.utilities compiler.test kernel compiler.cfg.instructions compiler.cfg.stacks.local
namespaces sequences tools.test ; compiler.cfg.utilities compiler.test kernel make namespaces sequences
tools.test ;
IN: compiler.cfg.builder.blocks.tests IN: compiler.cfg.builder.blocks.tests
! (begin-basic-block) ! (begin-basic-block)
@ -14,6 +15,14 @@ IN: compiler.cfg.builder.blocks.tests
height-state get <basic-block> begin-branch height-state get eq? height-state get <basic-block> begin-branch height-state get eq?
] cfg-unit-test ] cfg-unit-test
! emit-trivial-block
{
V{ T{ ##no-tco } T{ ##branch } }
} [
[ [ drop ##no-tco, ] emit-trivial-block ] V{ } make drop
basic-block get successors>> first instructions>>
] cfg-unit-test
! make-kill-block ! make-kill-block
{ t } [ { t } [
<basic-block> [ make-kill-block ] keep kill-block?>> <basic-block> [ make-kill-block ] keep kill-block?>>

17
basis/compiler/cfg/builder/blocks/blocks.factor
View File

@ -23,8 +23,8 @@ IN: compiler.cfg.builder.blocks
: emit-trivial-block ( quot -- ) : emit-trivial-block ( quot -- )
##branch, basic-block get begin-basic-block ##branch, basic-block get begin-basic-block
call basic-block get [ swap call ] keep
##branch, basic-block get begin-basic-block ; inline ##branch, begin-basic-block ; inline
: make-kill-block ( block -- ) : make-kill-block ( block -- )
t swap kill-block?<< ; t swap kill-block?<< ;
@ -32,13 +32,12 @@ IN: compiler.cfg.builder.blocks
: call-height ( #call -- n ) : call-height ( #call -- n )
[ out-d>> length ] [ in-d>> length ] bi - ; [ out-d>> length ] [ in-d>> length ] bi - ;
: emit-call-block ( word height -- ) : emit-call-block ( word height block -- )
adjust-d ##call, basic-block get make-kill-block ; make-kill-block adjust-d ##call, ;
: emit-primitive ( node -- ) : emit-primitive ( node -- )
[ [ word>> ] [ call-height ] bi
[ word>> ] [ call-height ] bi emit-call-block [ emit-call-block ] emit-trivial-block ;
] emit-trivial-block ;
: begin-branch ( block -- ) : begin-branch ( block -- )
height-state [ clone-height-state ] change (begin-basic-block) ; height-state [ clone-height-state ] change (begin-basic-block) ;
@ -57,9 +56,9 @@ IN: compiler.cfg.builder.blocks
basic-block get end-branch basic-block get end-branch
] with-scope ; inline ] with-scope ; inline
: emit-conditional ( branches -- ) : emit-conditional ( branches block -- )
! branches is a sequence of pairs as above ! branches is a sequence of pairs as above
basic-block get end-basic-block end-basic-block
sift [ sift [
dup first second height-state set dup first second height-state set
basic-block get begin-basic-block basic-block get begin-basic-block

14
basis/compiler/cfg/builder/builder-docs.factor
View File

@ -1,6 +1,6 @@
USING: assocs compiler.cfg compiler.cfg.builder.blocks USING: assocs compiler.cfg compiler.cfg.builder.blocks
compiler.cfg.stacks.local compiler.tree help.markup help.syntax compiler.cfg.stacks.local compiler.tree help.markup help.syntax kernel
kernel literals math multiline sequences vectors words ; literals math multiline quotations sequences vectors words ;
IN: compiler.cfg.builder IN: compiler.cfg.builder
<< <<
@ -44,6 +44,10 @@ H{
; ;
>> >>
HELP: build-cfg
{ $values { "nodes" sequence } { "word" word } { "procedures" sequence } }
{ $description "Builds one or more cfgs from the given word." } ;
HELP: procedures HELP: procedures
{ $var-description "A " { $link vector } " used as temporary storage during cfg construction for all procedures being built." } ; { $var-description "A " { $link vector } " used as temporary storage during cfg construction for all procedures being built." } ;
@ -84,9 +88,9 @@ HELP: trivial-branch?
} }
} ; } ;
HELP: build-cfg HELP: with-cfg-builder
{ $values { "nodes" sequence } { "word" word } { "procedures" sequence } } { $values { "nodes" sequence } { "word" word } { "label" word } { "quot" quotation } }
{ $description "Builds one or more cfgs from the given word." } ; { $description "Combinator used to begin and end stack analysis so that the given quotation can build the cfg. The quotation is passed the initial basic block on the stack." } ;
ARTICLE: "compiler.cfg.builder" ARTICLE: "compiler.cfg.builder"
"Final stage of compilation generates machine code from dataflow IR" "Final stage of compilation generates machine code from dataflow IR"

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

@ -23,14 +23,14 @@ SYMBOL: loops
'[ '[
begin-stack-analysis begin-stack-analysis
begin-procedure begin-procedure
@ basic-block get @
end-stack-analysis end-stack-analysis
] with-scope ; inline ] with-scope ; inline
: with-dummy-cfg-builder ( node quot -- ) : with-dummy-cfg-builder ( node quot -- )
[ [
[ V{ } clone procedures ] 2dip [ V{ } clone procedures ] 2dip
'[ _ t t [ _ call( node -- ) ] with-cfg-builder ] with-variable '[ _ t t [ drop _ call( node -- ) ] with-cfg-builder ] with-variable
] { } make drop ; ] { } make drop ;
GENERIC: emit-node ( node -- ) GENERIC: emit-node ( node -- )
@ -44,11 +44,7 @@ GENERIC: emit-node ( node -- )
begin-basic-block ; begin-basic-block ;
: (build-cfg) ( nodes word label -- ) : (build-cfg) ( nodes word label -- )
[ [ begin-word emit-nodes ] with-cfg-builder ;
basic-block get begin-word
emit-nodes
] with-cfg-builder ;
: build-cfg ( nodes word -- procedures ) : build-cfg ( nodes word -- procedures )
V{ } clone [ V{ } clone [
@ -93,7 +89,7 @@ M: #recursive emit-node
[ emit-nodes ] with-branch ; [ emit-nodes ] with-branch ;
: emit-if ( node -- ) : emit-if ( node -- )
children>> [ emit-branch ] map emit-conditional ; children>> [ emit-branch ] map basic-block get emit-conditional ;
: trivial-branch? ( nodes -- value ? ) : trivial-branch? ( nodes -- value ? )
dup length 1 = [ dup length 1 = [
@ -136,11 +132,12 @@ M: #dispatch emit-node
! though. ! though.
ds-pop ^^offset>slot next-vreg ##dispatch, emit-if ; ds-pop ^^offset>slot next-vreg ##dispatch, emit-if ;
M: #call emit-node M: #call emit-node ( node -- )
dup word>> dup "intrinsic" word-prop dup word>> dup "intrinsic" word-prop
[ emit-intrinsic ] [ swap call-height emit-call ] if ; [ emit-intrinsic ] [ swap call-height emit-call ] if ;
M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ; M: #call-recursive emit-node ( node -- )
[ label>> id>> ] [ call-height ] bi emit-call ;
M: #push emit-node M: #push emit-node
literal>> ^^load-literal ds-push ; literal>> ^^load-literal ds-push ;
@ -173,18 +170,18 @@ M: #shuffle emit-node ( node -- )
[ out-vregs/stack ] keep store-height-changes [ first2 store-vregs ] each ; [ out-vregs/stack ] keep store-height-changes [ first2 store-vregs ] each ;
! #return ! #return
: end-word ( -- ) : end-word ( block -- )
##branch, ##branch, begin-basic-block
basic-block get begin-basic-block
basic-block get make-kill-block basic-block get make-kill-block
##safepoint, ##safepoint,
##epilogue, ##epilogue,
##return, ; ##return, ;
M: #return emit-node drop end-word ; M: #return emit-node ( node -- )
drop basic-block get end-word ;
M: #return-recursive emit-node M: #return-recursive emit-node ( node -- )
label>> id>> loops get key? [ end-word ] unless ; label>> id>> loops get key? [ basic-block get end-word ] unless ;
! #terminate ! #terminate
M: #terminate emit-node ( node -- ) M: #terminate emit-node ( node -- )

17
basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman. ! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators compiler.cfg.builder.blocks USING: accessors arrays combinators compiler.cfg
compiler.cfg.comparisons compiler.cfg.hats compiler.cfg.builder.blocks compiler.cfg.comparisons compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.stacks.local compiler.cfg.registers compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks
compiler.cfg.stacks compiler.tree.propagation.info cpu.architecture fry kernel compiler.cfg.stacks.local compiler.tree.propagation.info
layouts math math.intervals namespaces sequences ; cpu.architecture fry kernel layouts math math.intervals namespaces
sequences ;
IN: compiler.cfg.intrinsics.fixnum IN: compiler.cfg.intrinsics.fixnum
: emit-both-fixnums? ( -- ) : emit-both-fixnums? ( -- )
@ -28,7 +29,7 @@ IN: compiler.cfg.intrinsics.fixnum
ds-peek 0 cc> ##compare-integer-imm-branch, ds-peek 0 cc> ##compare-integer-imm-branch,
[ emit-fixnum-left-shift ] with-branch [ emit-fixnum-left-shift ] with-branch
[ emit-fixnum-right-shift ] with-branch [ emit-fixnum-right-shift ] with-branch
2array emit-conditional ; 2array basic-block get emit-conditional ;
: emit-fixnum-shift-fast ( node -- ) : emit-fixnum-shift-fast ( node -- )
node-input-infos second interval>> { node-input-infos second interval>> {
@ -45,7 +46,7 @@ IN: compiler.cfg.intrinsics.fixnum
: emit-overflow-case ( word -- final-bb ) : emit-overflow-case ( word -- final-bb )
[ [
-1 emit-call-block -1 basic-block get emit-call-block
] with-branch ; ] with-branch ;
: emit-fixnum-overflow-op ( quot word -- ) : emit-fixnum-overflow-op ( quot word -- )
@ -53,7 +54,7 @@ IN: compiler.cfg.intrinsics.fixnum
! of loc>vreg sync ! of loc>vreg sync
[ [ (2inputs) [ any-rep ^^copy ] bi@ cc/o ] dip call ] dip [ [ (2inputs) [ any-rep ^^copy ] bi@ cc/o ] dip call ] dip
[ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
emit-conditional ; inline basic-block get emit-conditional ; inline
: fixnum+overflow ( x y -- z ) [ >bignum ] bi@ + ; : fixnum+overflow ( x y -- z ) [ >bignum ] bi@ + ;

2
basis/compiler/cfg/intrinsics/misc/misc.factor
View File

@ -51,4 +51,4 @@ IN: compiler.cfg.intrinsics.misc
if ; if ;
: emit-cleanup-allot ( -- ) : emit-cleanup-allot ( -- )
[ ##no-tco, ] emit-trivial-block ; [ drop ##no-tco, ] emit-trivial-block ;