M: #alien-callback emit-node
dup params>> xt>> dup
[
- needs-frame-pointer basic-block get begin-word
+ needs-frame-pointer begin-word
{
[ params>> callee-parameters ##callback-inputs, ]
[ params>> box-parameters ]
[ params>> emit-callback-return ]
[ params>> callback-stack-cleanup ]
} cleave
- basic-block get [ end-word ] when
+ basic-block get [ end-word ] when*
] with-cfg-builder ;
HELP: emit-trivial-block
{ $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 ] } } ;
HELP: end-branch
USING: accessors compiler.cfg compiler.cfg.builder.blocks
-compiler.cfg.stacks.local compiler.cfg.utilities compiler.test kernel
-namespaces sequences tools.test ;
+compiler.cfg.instructions compiler.cfg.stacks.local
+compiler.cfg.utilities compiler.test kernel make namespaces sequences
+tools.test ;
IN: compiler.cfg.builder.blocks.tests
! (begin-basic-block)
height-state get <basic-block> begin-branch height-state get eq?
] 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
{ t } [
<basic-block> [ make-kill-block ] keep kill-block?>>
: emit-trivial-block ( quot -- )
##branch, basic-block get begin-basic-block
- call
- ##branch, basic-block get begin-basic-block ; inline
+ basic-block get [ swap call ] keep
+ ##branch, begin-basic-block ; inline
: make-kill-block ( block -- )
t swap kill-block?<< ;
: call-height ( #call -- n )
[ out-d>> length ] [ in-d>> length ] bi - ;
-: emit-call-block ( word height -- )
- adjust-d ##call, basic-block get make-kill-block ;
+: emit-call-block ( word height block -- )
+ make-kill-block adjust-d ##call, ;
: emit-primitive ( node -- )
- [
- [ word>> ] [ call-height ] bi emit-call-block
- ] emit-trivial-block ;
+ [ word>> ] [ call-height ] bi
+ [ emit-call-block ] emit-trivial-block ;
: begin-branch ( block -- )
height-state [ clone-height-state ] change (begin-basic-block) ;
basic-block get end-branch
] with-scope ; inline
-: emit-conditional ( branches -- )
+: emit-conditional ( branches block -- )
! branches is a sequence of pairs as above
- basic-block get end-basic-block
+ end-basic-block
sift [
dup first second height-state set
basic-block get begin-basic-block
USING: assocs compiler.cfg compiler.cfg.builder.blocks
-compiler.cfg.stacks.local compiler.tree help.markup help.syntax
-kernel literals math multiline sequences vectors words ;
+compiler.cfg.stacks.local compiler.tree help.markup help.syntax kernel
+literals math multiline quotations sequences vectors words ;
IN: compiler.cfg.builder
<<
;
>>
+HELP: build-cfg
+{ $values { "nodes" sequence } { "word" word } { "procedures" sequence } }
+{ $description "Builds one or more cfgs from the given word." } ;
+
HELP: procedures
{ $var-description "A " { $link vector } " used as temporary storage during cfg construction for all procedures being built." } ;
}
} ;
-HELP: build-cfg
-{ $values { "nodes" sequence } { "word" word } { "procedures" sequence } }
-{ $description "Builds one or more cfgs from the given word." } ;
+HELP: with-cfg-builder
+{ $values { "nodes" sequence } { "word" word } { "label" word } { "quot" quotation } }
+{ $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"
"Final stage of compilation generates machine code from dataflow IR"
'[
begin-stack-analysis
begin-procedure
- @
+ basic-block get @
end-stack-analysis
] with-scope ; inline
: with-dummy-cfg-builder ( node quot -- )
[
[ 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 ;
GENERIC: emit-node ( node -- )
begin-basic-block ;
: (build-cfg) ( nodes word label -- )
- [
-
- basic-block get begin-word
- emit-nodes
- ] with-cfg-builder ;
+ [ begin-word emit-nodes ] with-cfg-builder ;
: build-cfg ( nodes word -- procedures )
V{ } clone [
[ emit-nodes ] with-branch ;
: emit-if ( node -- )
- children>> [ emit-branch ] map emit-conditional ;
+ children>> [ emit-branch ] map basic-block get emit-conditional ;
: trivial-branch? ( nodes -- value ? )
dup length 1 = [
! though.
ds-pop ^^offset>slot next-vreg ##dispatch, emit-if ;
-M: #call emit-node
+M: #call emit-node ( node -- )
dup word>> dup "intrinsic" word-prop
[ 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
literal>> ^^load-literal ds-push ;
[ out-vregs/stack ] keep store-height-changes [ first2 store-vregs ] each ;
! #return
-: end-word ( -- )
- ##branch,
- basic-block get begin-basic-block
+: end-word ( block -- )
+ ##branch, begin-basic-block
basic-block get make-kill-block
##safepoint,
##epilogue,
##return, ;
-M: #return emit-node drop end-word ;
+M: #return emit-node ( node -- )
+ drop basic-block get end-word ;
-M: #return-recursive emit-node
- label>> id>> loops get key? [ end-word ] unless ;
+M: #return-recursive emit-node ( node -- )
+ label>> id>> loops get key? [ basic-block get end-word ] unless ;
! #terminate
M: #terminate emit-node ( node -- )
! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators compiler.cfg.builder.blocks
-compiler.cfg.comparisons compiler.cfg.hats
-compiler.cfg.instructions compiler.cfg.stacks.local compiler.cfg.registers
-compiler.cfg.stacks compiler.tree.propagation.info cpu.architecture fry kernel
-layouts math math.intervals namespaces sequences ;
+USING: accessors arrays combinators compiler.cfg
+compiler.cfg.builder.blocks compiler.cfg.comparisons compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks
+compiler.cfg.stacks.local compiler.tree.propagation.info
+cpu.architecture fry kernel layouts math math.intervals namespaces
+sequences ;
IN: compiler.cfg.intrinsics.fixnum
: emit-both-fixnums? ( -- )
ds-peek 0 cc> ##compare-integer-imm-branch,
[ emit-fixnum-left-shift ] with-branch
[ emit-fixnum-right-shift ] with-branch
- 2array emit-conditional ;
+ 2array basic-block get emit-conditional ;
: emit-fixnum-shift-fast ( node -- )
node-input-infos second interval>> {
: emit-overflow-case ( word -- final-bb )
[
- -1 emit-call-block
+ -1 basic-block get emit-call-block
] with-branch ;
: emit-fixnum-overflow-op ( quot word -- )
! of loc>vreg sync
[ [ (2inputs) [ any-rep ^^copy ] bi@ cc/o ] dip call ] dip
[ 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@ + ;
if ;
: emit-cleanup-allot ( -- )
- [ ##no-tco, ] emit-trivial-block ;
+ [ drop ##no-tco, ] emit-trivial-block ;