compiler.cfg.*: changes to remove basic-block variable
The emit-node generics signature is changed to ( block node -- block' ) so that it always returns the next block to operate on. Signature for a lot of related words are changed similarily. Now there is only a few basic-block usages left.db4
Björn Lindqvist
parent
07adc2ecae
commit
f9c6d7cc43
|
|
@ -1,6 +1,6 @@
|
|||
USING: alien alien.libraries compiler.cfg.builder help.markup
|
||||
help.syntax literals make multiline sequences stack-checker.alien
|
||||
strings ;
|
||||
USING: alien alien.libraries compiler.cfg compiler.cfg.builder
|
||||
compiler.cfg.instructions compiler.tree help.markup help.syntax
|
||||
literals make multiline sequences stack-checker.alien strings ;
|
||||
IN: compiler.cfg.builder.alien
|
||||
|
||||
<<
|
||||
|
|
@ -34,12 +34,26 @@ HELP: check-dlsym
|
|||
{ $values { "symbol" string } { "library" library } }
|
||||
{ $description "Checks that a symbol with the given name exists in the given library. Throws an error if not." } ;
|
||||
|
||||
HELP: emit-callback-body
|
||||
{ $values { "params" alien-node-params } }
|
||||
{ $description "Emits the nodes that forms the body of the alien callback." } ;
|
||||
|
||||
HELP: emit-callback-return
|
||||
{ $values { "params" alien-node-params } { "block" basic-block } }
|
||||
{ $description "Emits a " { $link ##callback-outputs } " instruction for the " { $link #alien-callback } " if needed." } ;
|
||||
|
||||
HELP: unbox-parameters
|
||||
{ $values { "parameters" sequence } { "vregs" sequence } { "reps" sequence } }
|
||||
{ $description "Unboxes a sequence of parameters to send to an ffi function." } ;
|
||||
|
||||
ARTICLE: "compiler.cfg.builder.alien"
|
||||
"CFG node emitter for alien nodes"
|
||||
"The " { $vocab-link "compiler.cfg.builder.alien" } " vocab implements " { $link emit-node } " methods for alien nodes." ;
|
||||
"The " { $vocab-link "compiler.cfg.builder.alien" } " vocab implements " { $link emit-node } " methods for alien nodes."
|
||||
$nl
|
||||
"Words for alien callbacks:"
|
||||
{ $subsections
|
||||
emit-callback-body
|
||||
emit-callback-return
|
||||
} ;
|
||||
|
||||
ABOUT: "compiler.cfg.builder.alien"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,9 @@
|
|||
USING: alien.c-types compiler.cfg.builder.alien compiler.cfg.instructions
|
||||
compiler.cfg.registers compiler.cfg.stacks.local compiler.test
|
||||
cpu.architecture kernel make namespaces system tools.test ;
|
||||
USING: accessors alien alien.c-types compiler.cfg compiler.cfg.builder
|
||||
compiler.cfg.builder.alien compiler.cfg.instructions
|
||||
compiler.cfg.registers compiler.test compiler.tree.builder
|
||||
compiler.tree.optimizer cpu.architecture cpu.x86.assembler
|
||||
cpu.x86.assembler.operands kernel make namespaces sequences system
|
||||
tools.test words ;
|
||||
IN: compiler.cfg.builder.alien.tests
|
||||
|
||||
! unboxing ints is only needed on 32bit archs
|
||||
|
|
@ -25,3 +28,37 @@ cpu x86.32?
|
|||
} ? [
|
||||
[ { c-string int } unbox-parameters ] V{ } make
|
||||
] cfg-unit-test
|
||||
|
||||
: dummy-assembly ( -- ass )
|
||||
int { } cdecl [
|
||||
EAX 33 MOV
|
||||
] alien-assembly ;
|
||||
|
||||
{ t } [
|
||||
<basic-block> dup basic-block set dup
|
||||
\ dummy-assembly build-tree optimize-tree first
|
||||
[ emit-node ] V{ } make drop eq?
|
||||
] unit-test
|
||||
|
||||
: dummy-callback ( -- cb )
|
||||
void { } cdecl [ ] alien-callback ;
|
||||
|
||||
{ 2 t } [
|
||||
\ dummy-callback build-tree optimize-tree gensym build-cfg
|
||||
[ length ] [ second frame-pointer?>> ] bi
|
||||
] unit-test
|
||||
|
||||
{
|
||||
V{
|
||||
T{ ##load-reference { dst 1 } { obj t } }
|
||||
T{ ##load-integer { dst 2 } { val 3 } }
|
||||
T{ ##copy { dst 4 } { src 1 } { rep any-rep } }
|
||||
T{ ##copy { dst 3 } { src 2 } { rep any-rep } }
|
||||
T{ ##inc { loc D: 2 } }
|
||||
T{ ##branch }
|
||||
}
|
||||
} [
|
||||
basic-block get
|
||||
\ dummy-callback build-tree optimize-tree 3 swap nth child>>
|
||||
[ emit-callback-body drop ] V{ } make
|
||||
] cfg-unit-test
|
||||
|
|
|
|||
|
|
@ -1,15 +1,12 @@
|
|||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.c-types alien.libraries
|
||||
alien.strings arrays assocs classes.struct combinators
|
||||
compiler.cfg compiler.cfg.builder
|
||||
compiler.cfg.builder.alien.boxing
|
||||
compiler.cfg.builder.alien.params compiler.cfg.hats
|
||||
compiler.cfg.instructions compiler.cfg.registers
|
||||
USING: accessors alien.c-types alien.libraries alien.strings arrays
|
||||
assocs classes.struct combinators compiler.cfg compiler.cfg.builder
|
||||
compiler.cfg.builder.alien.boxing compiler.cfg.builder.alien.params
|
||||
compiler.cfg.hats compiler.cfg.instructions compiler.cfg.registers
|
||||
compiler.cfg.stacks compiler.cfg.stacks.local compiler.errors
|
||||
compiler.tree cpu.architecture fry kernel layouts make math
|
||||
math.parser namespaces sequences sequences.generalizations
|
||||
strings words ;
|
||||
compiler.tree cpu.architecture fry kernel layouts make math namespaces
|
||||
sequences sequences.generalizations words ;
|
||||
IN: compiler.cfg.builder.alien
|
||||
|
||||
: with-param-regs* ( quot -- reg-values stack-values )
|
||||
|
|
@ -84,8 +81,8 @@ IN: compiler.cfg.builder.alien
|
|||
base-type box-return ds-push
|
||||
] if-void ;
|
||||
|
||||
M: #alien-invoke emit-node ( block node -- )
|
||||
nip params>>
|
||||
M: #alien-invoke emit-node ( block node -- block' )
|
||||
params>>
|
||||
[
|
||||
{
|
||||
[ caller-parameters ]
|
||||
|
|
@ -95,11 +92,10 @@ M: #alien-invoke emit-node ( block node -- )
|
|||
} cleave
|
||||
<gc-map> ##alien-invoke,
|
||||
]
|
||||
[ caller-return ]
|
||||
bi ;
|
||||
[ caller-return ] bi ;
|
||||
|
||||
M: #alien-indirect emit-node ( block node -- )
|
||||
nip params>>
|
||||
M: #alien-indirect emit-node ( block node -- block' )
|
||||
params>>
|
||||
[
|
||||
[ ds-pop ^^unbox-any-c-ptr ] dip
|
||||
[ caller-parameters ]
|
||||
|
|
@ -107,11 +103,10 @@ M: #alien-indirect emit-node ( block node -- )
|
|||
[ caller-stack-frame ] tri
|
||||
<gc-map> ##alien-indirect,
|
||||
]
|
||||
[ caller-return ]
|
||||
bi ;
|
||||
[ caller-return ] bi ;
|
||||
|
||||
M: #alien-assembly emit-node ( block node -- )
|
||||
nip params>>
|
||||
M: #alien-assembly emit-node ( block node -- block' )
|
||||
params>>
|
||||
[
|
||||
{
|
||||
[ caller-parameters ]
|
||||
|
|
@ -120,8 +115,7 @@ M: #alien-assembly emit-node ( block node -- )
|
|||
[ quot>> ]
|
||||
} cleave ##alien-assembly,
|
||||
]
|
||||
[ caller-return ]
|
||||
bi ;
|
||||
[ caller-return ] bi ;
|
||||
|
||||
: callee-parameter ( rep on-stack? odd-register? -- dst )
|
||||
[ next-vreg dup ] 3dip next-parameter ;
|
||||
|
|
@ -133,8 +127,7 @@ M: #alien-assembly emit-node ( block node -- )
|
|||
: (callee-parameters) ( params -- vregs reps )
|
||||
[ flatten-parameter-type ] map
|
||||
[ [ [ first3 callee-parameter ] map ] map ]
|
||||
[ [ keys ] map ]
|
||||
bi ;
|
||||
[ [ keys ] map ] bi ;
|
||||
|
||||
: box-parameters ( vregs reps params -- )
|
||||
parameters>> [ base-type box-parameter ds-push ] 3each ;
|
||||
|
|
@ -152,30 +145,30 @@ M: #alien-assembly emit-node ( block node -- )
|
|||
base-type unbox-return store-return
|
||||
] if-void ;
|
||||
|
||||
: emit-callback-body ( block nodes -- block' )
|
||||
dup last #return? t assert= but-last emit-nodes ;
|
||||
|
||||
: emit-callback-inputs ( params -- )
|
||||
[ callee-parameters ##callback-inputs, ] keep box-parameters ;
|
||||
|
||||
: callback-stack-cleanup ( params -- )
|
||||
[ xt>> ]
|
||||
[ [ stack-params get ] dip [ return>> ] [ abi>> ] bi stack-cleanup ] bi
|
||||
"stack-cleanup" set-word-prop ;
|
||||
|
||||
: needs-frame-pointer ( -- )
|
||||
cfg get t >>frame-pointer? drop ;
|
||||
: emit-callback-return ( block params -- )
|
||||
swap [ callee-return ##callback-outputs, ] [ drop ] if ;
|
||||
|
||||
: emit-callback-body ( nodes -- )
|
||||
[ last #return? t assert= ] [ but-last emit-nodes ] bi ;
|
||||
: emit-callback-outputs ( block params -- )
|
||||
[ emit-callback-return ] keep callback-stack-cleanup ;
|
||||
|
||||
: emit-callback-return ( params -- )
|
||||
basic-block get [ callee-return ##callback-outputs, ] [ drop ] if ;
|
||||
|
||||
M: #alien-callback emit-node ( block node -- )
|
||||
nip dup params>> xt>> dup
|
||||
M: #alien-callback emit-node ( block node -- block' )
|
||||
dup params>> xt>> dup
|
||||
[
|
||||
needs-frame-pointer begin-word
|
||||
{
|
||||
[ params>> callee-parameters ##callback-inputs, ]
|
||||
[ params>> box-parameters ]
|
||||
[ child>> emit-callback-body ]
|
||||
[ params>> emit-callback-return ]
|
||||
[ params>> callback-stack-cleanup ]
|
||||
} cleave
|
||||
basic-block get [ end-word ] when*
|
||||
t cfg get frame-pointer?<<
|
||||
begin-word
|
||||
over params>> emit-callback-inputs
|
||||
over child>> emit-callback-body
|
||||
[ swap params>> emit-callback-outputs ] keep
|
||||
[ end-word drop ] when*
|
||||
] with-cfg-builder ;
|
||||
|
|
|
|||
|
|
@ -29,9 +29,16 @@ T{ basic-block
|
|||
>>
|
||||
|
||||
HELP: begin-basic-block
|
||||
{ $values { "block" basic-block } }
|
||||
{ $values { "block" basic-block } { "block'" basic-block } }
|
||||
{ $description "Terminates the given block and initializes a new " { $link basic-block } " to begin outputting instructions to. The new block is included in the old blocks " { $slot "successors" } "." } ;
|
||||
|
||||
HELP: begin-branch
|
||||
{ $values
|
||||
{ "block" "current " { $link basic-block } }
|
||||
{ "block" basic-block }
|
||||
}
|
||||
{ $description "Used to begin emitting a branch." } ;
|
||||
|
||||
HELP: call-height
|
||||
{ $values { "#call" #call } { "n" number } }
|
||||
{ $description "Calculates how many items a " { $link #call } " will add or remove from the data stack." }
|
||||
|
|
@ -43,6 +50,14 @@ HELP: call-height
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: emit-conditional
|
||||
{ $values
|
||||
{ "block" basic-block }
|
||||
{ "branches" "sequence of pairs" }
|
||||
{ "block'" basic-block }
|
||||
}
|
||||
{ $description "Emits a sequence of conditional branches to the current " { $link cfg } ". Each branch is a pair where the first item is the entry basic block and the second the branches " { $link height-state } ". 'block' is the block in which the control flow is branched and \"block'\" the block in which it converges again." } ;
|
||||
|
||||
HELP: emit-trivial-block
|
||||
{ $values { "quot" 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." }
|
||||
|
|
@ -63,3 +78,22 @@ HELP: set-basic-block
|
|||
HELP: with-branch
|
||||
{ $values { "quot" quotation } { "pair/f" { $maybe "pair" } } }
|
||||
{ $description "The pair is either " { $link f } " or a two-tuple containing a " { $link basic-block } " and a " { $link height-state } " two-tuple." } ;
|
||||
|
||||
ARTICLE: "compiler.cfg.builder.blocks"
|
||||
"CFG construction utilities"
|
||||
$nl
|
||||
"This vocab contains utilities for that helps " { $vocab-link "compiler.cfg.builder" } " to construct CFG:s."
|
||||
$nl
|
||||
"Combinators:"
|
||||
{ $subsections
|
||||
with-branch
|
||||
}
|
||||
"Creating blocks:"
|
||||
{ $subsections
|
||||
begin-basic-block
|
||||
begin-branch
|
||||
emit-call-block
|
||||
emit-conditional
|
||||
} ;
|
||||
|
||||
ABOUT: "compiler.cfg.builder.blocks"
|
||||
|
|
|
|||
|
|
@ -7,12 +7,16 @@ IN: compiler.cfg.builder.blocks.tests
|
|||
! (begin-basic-block)
|
||||
{ 20 } [
|
||||
{ } 20 insns>block (begin-basic-block)
|
||||
basic-block get predecessors>> first number>>
|
||||
predecessors>> first number>>
|
||||
] cfg-unit-test
|
||||
|
||||
! begin-branch
|
||||
{ f } [
|
||||
height-state get <basic-block> begin-branch height-state get eq?
|
||||
height-state get <basic-block> begin-branch drop height-state get eq?
|
||||
] cfg-unit-test
|
||||
|
||||
{ f } [
|
||||
<basic-block> dup begin-branch eq?
|
||||
] cfg-unit-test
|
||||
|
||||
! emit-trivial-block
|
||||
|
|
@ -23,6 +27,11 @@ IN: compiler.cfg.builder.blocks.tests
|
|||
basic-block get successors>> first instructions>>
|
||||
] cfg-unit-test
|
||||
|
||||
! end-basic-block
|
||||
{ f } [
|
||||
f end-basic-block basic-block get
|
||||
] unit-test
|
||||
|
||||
! make-kill-block
|
||||
{ t } [
|
||||
<basic-block> [ make-kill-block ] keep kill-block?>>
|
||||
|
|
|
|||
|
|
@ -15,16 +15,16 @@ IN: compiler.cfg.builder.blocks
|
|||
: end-basic-block ( block -- )
|
||||
[ end-local-analysis ] when* building off basic-block off ;
|
||||
|
||||
: (begin-basic-block) ( block -- )
|
||||
<basic-block> swap [ over connect-bbs ] when* set-basic-block ;
|
||||
: (begin-basic-block) ( block -- block' )
|
||||
<basic-block> swap [ over connect-bbs ] when* dup set-basic-block ;
|
||||
|
||||
: begin-basic-block ( block -- )
|
||||
: begin-basic-block ( block -- block' )
|
||||
dup [ end-local-analysis ] when* (begin-basic-block) ;
|
||||
|
||||
: emit-trivial-block ( quot: ( ..a block -- ..b ) -- )
|
||||
##branch, basic-block get begin-basic-block
|
||||
basic-block get [ swap call ] keep
|
||||
##branch, begin-basic-block ; inline
|
||||
[ swap call ] keep
|
||||
##branch, begin-basic-block drop ; inline
|
||||
|
||||
: make-kill-block ( block -- )
|
||||
t swap kill-block?<< ;
|
||||
|
|
@ -39,7 +39,7 @@ IN: compiler.cfg.builder.blocks
|
|||
[ word>> ] [ call-height ] bi
|
||||
[ emit-call-block ] emit-trivial-block ;
|
||||
|
||||
: begin-branch ( block -- )
|
||||
: begin-branch ( block -- block' )
|
||||
height-state [ clone-height-state ] change (begin-basic-block) ;
|
||||
|
||||
: end-branch ( block -- pair/f )
|
||||
|
|
@ -51,16 +51,16 @@ IN: compiler.cfg.builder.blocks
|
|||
|
||||
: with-branch ( quot -- pair/f )
|
||||
[
|
||||
basic-block get begin-branch
|
||||
basic-block get begin-branch drop
|
||||
call
|
||||
basic-block get end-branch
|
||||
] with-scope ; inline
|
||||
|
||||
: emit-conditional ( branches block -- )
|
||||
! branches is a sequence of pairs as above
|
||||
end-basic-block
|
||||
sift [
|
||||
: emit-conditional ( block branches -- block' )
|
||||
swap end-basic-block
|
||||
sift [ f ] [
|
||||
dup first second height-state set
|
||||
basic-block get begin-basic-block
|
||||
[ first ] map basic-block get connect-Nto1-bbs
|
||||
] unless-empty ;
|
||||
[ first ] map
|
||||
f begin-basic-block
|
||||
[ connect-Nto1-bbs ] keep
|
||||
] if-empty ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
USING: assocs compiler.cfg compiler.cfg.builder.blocks
|
||||
compiler.cfg.stacks.local compiler.tree help.markup help.syntax kernel
|
||||
literals math multiline quotations sequences vectors words ;
|
||||
compiler.cfg.instructions compiler.cfg.stacks.local compiler.tree
|
||||
help.markup help.syntax kernel literals math multiline quotations
|
||||
sequences vectors words ;
|
||||
IN: compiler.cfg.builder
|
||||
|
||||
<<
|
||||
|
|
@ -49,7 +50,8 @@ HELP: build-cfg
|
|||
{ $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." } ;
|
||||
{ $var-description "A " { $link vector } " used as temporary storage during cfg construction for all procedures being built." }
|
||||
{ $see-also build-cfg } ;
|
||||
|
||||
HELP: make-input-map
|
||||
{ $values { "#shuffle" #shuffle } { "assoc" assoc } }
|
||||
|
|
@ -57,8 +59,17 @@ HELP: make-input-map
|
|||
{ $examples { $unchecked-example $[ ex-make-input-map ] } } ;
|
||||
|
||||
HELP: emit-call
|
||||
{ $values { "block" basic-block } { "word" word } { "height" number } }
|
||||
{ $description "Emits a call to the given word to the " { $link cfg } " being constructed. \"height\" is the number of items being added to or removed from the data stack. Side effects of the word is that it modifies the \"basic-block\" and " { $link height-state } " variables." }
|
||||
{ $values
|
||||
{ "block" basic-block }
|
||||
{ "word" word }
|
||||
{ "height" number }
|
||||
{ "block'" basic-block }
|
||||
}
|
||||
{ $description
|
||||
"Emits a call to the given word to the " { $link cfg } " being constructed. \"height\" is the number of items being added to or removed from the data stack."
|
||||
$nl
|
||||
"Side effects of the word is that it modifies the \"basic-block\" and " { $link height-state } " variables."
|
||||
}
|
||||
{ $examples
|
||||
"In this example, a call to a dummy word is emitted which pushes three items onto the stack."
|
||||
{ $unchecked-example $[ ex-emit-call ] }
|
||||
|
|
@ -70,8 +81,31 @@ HELP: emit-loop-call
|
|||
{ $description "Sets the given block as the successor of the current block. Then ends the block." } ;
|
||||
|
||||
HELP: emit-node
|
||||
{ $values { "block" basic-block } { "node" node } }
|
||||
{ $description "Emits CFG instructions for the given SSA node." } ;
|
||||
{ $values { "block" basic-block } { "node" node } { "block'" basic-block } }
|
||||
{ $description "Emits CFG instructions for the given SSA node. The word can add one or more basic blocks to the " { $link cfg } ". The next block to operate on is pushed onto the stack. "
|
||||
$nl
|
||||
"The following classes emit-node methods does not change the current block:"
|
||||
{ $list
|
||||
{ $link #alien-assembly }
|
||||
{ $link #alien-callback }
|
||||
{ $link #alien-indirect }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: emit-nodes
|
||||
{ $values
|
||||
{ "block" "current " { $link basic-block } }
|
||||
{ "nodes" sequence }
|
||||
{ "block'" basic-block }
|
||||
}
|
||||
{ $description "Emits all tree nodes to the cfg. The next block to operate on is pushed onto the stack." } ;
|
||||
|
||||
HELP: end-word
|
||||
{ $values
|
||||
{ "block" "current " { $link basic-block } }
|
||||
{ "block'" basic-block }
|
||||
}
|
||||
{ $description "Ends the word by adding a basic block containing a " { $link ##return } " instructions to the " { $link cfg } "." } ;
|
||||
|
||||
HELP: trivial-branch?
|
||||
{ $values
|
||||
|
|
@ -94,6 +128,41 @@ HELP: with-cfg-builder
|
|||
|
||||
ARTICLE: "compiler.cfg.builder"
|
||||
"Final stage of compilation generates machine code from dataflow IR"
|
||||
"Convert tree SSA IR to CFG IR. The result is not in SSA form; this is constructed later by calling compiler.cfg.ssa.construction:construct-ssa." ;
|
||||
$nl
|
||||
"The compiler first builds an SSA IR tree of the word to be compiled (see " { $vocab-link "compiler.tree.builder" } ") then this vocab converts it to a CFG IR tree. The result is not in SSA form; this is constructed later by calling compiler.cfg.ssa.construction:construct-ssa."
|
||||
$nl
|
||||
"Main word:"
|
||||
{ $subsections
|
||||
build-cfg
|
||||
}
|
||||
"Block adders:"
|
||||
{ $subsections
|
||||
begin-word
|
||||
end-word
|
||||
}
|
||||
"Combinators:"
|
||||
{ $subsections
|
||||
with-cfg-builder
|
||||
}
|
||||
"Emitters for " { $link #call } ":"
|
||||
{ $subsections
|
||||
emit-call
|
||||
emit-loop-call
|
||||
emit-trivial-call
|
||||
}
|
||||
"Emitters for " { $link #dispatch } " and " { $link #if } ":"
|
||||
{ $subsections
|
||||
emit-actual-if
|
||||
emit-branch
|
||||
emit-if
|
||||
emit-trivial-if
|
||||
}
|
||||
"Emitters for " { $link #recursive } ":"
|
||||
{
|
||||
$subsections
|
||||
emit-loop
|
||||
emit-recursive
|
||||
end-branch
|
||||
} ;
|
||||
|
||||
ABOUT: "compiler.cfg.builder"
|
||||
|
|
|
|||
|
|
@ -1,10 +1,11 @@
|
|||
USING: accessors alien alien.accessors arrays assocs byte-arrays
|
||||
combinators.short-circuit compiler.cfg compiler.cfg.builder
|
||||
compiler.cfg.checker compiler.cfg.debugger compiler.cfg.instructions
|
||||
compiler.cfg.optimizer compiler.cfg.registers
|
||||
compiler.cfg.stacks.local compiler.cfg.utilities compiler.test
|
||||
compiler.tree compiler.tree.propagation.info cpu.architecture fry
|
||||
hashtables io kernel kernel.private locals make math math.intervals
|
||||
compiler.cfg.builder.blocks compiler.cfg.checker compiler.cfg.debugger
|
||||
compiler.cfg.instructions compiler.cfg.optimizer
|
||||
compiler.cfg.registers compiler.cfg.stacks.local
|
||||
compiler.cfg.utilities compiler.test compiler.tree
|
||||
compiler.tree.propagation.info cpu.architecture fry hashtables io
|
||||
kernel kernel.private locals make math math.intervals
|
||||
math.partial-dispatch math.private namespaces prettyprint sbufs
|
||||
sequences sequences.private slots.private strings strings.private
|
||||
tools.test vectors words ;
|
||||
|
|
@ -236,6 +237,13 @@ IN: compiler.cfg.builder.tests
|
|||
[ ##compare-integer-imm-branch? ] contains-insn?
|
||||
] unit-test
|
||||
|
||||
! begin-cfg
|
||||
SYMBOL: foo
|
||||
|
||||
{ foo } [
|
||||
\ foo f begin-cfg word>>
|
||||
] cfg-unit-test
|
||||
|
||||
! make-input-map
|
||||
{
|
||||
{ { 37 D: 2 } { 81 D: 1 } { 92 D: 0 } }
|
||||
|
|
@ -243,36 +251,42 @@ IN: compiler.cfg.builder.tests
|
|||
T{ #shuffle { in-d { 37 81 92 } } } make-input-map
|
||||
] unit-test
|
||||
|
||||
! emit-branch
|
||||
{ 77 } [
|
||||
{ T{ #call { word + } } }
|
||||
V{ } 77 insns>block dup basic-block set
|
||||
emit-branch
|
||||
first predecessors>>
|
||||
first predecessors>>
|
||||
first predecessors>>
|
||||
first number>>
|
||||
] cfg-unit-test
|
||||
|
||||
! emit-call
|
||||
{
|
||||
V{ T{ ##call { word print } } T{ ##branch } }
|
||||
} [
|
||||
[ f \ print 4 emit-call ] V{ } make drop
|
||||
basic-block get successors>> first instructions>>
|
||||
<basic-block> dup set-basic-block \ print 4 emit-call
|
||||
predecessors>> first instructions>>
|
||||
] cfg-unit-test
|
||||
|
||||
! emit-loop-call
|
||||
{ 1 } [
|
||||
V{ } 0 insns>block basic-block set init-cfg-test
|
||||
V{ } 1 insns>block [ basic-block get emit-loop-call ] V{ } make drop
|
||||
basic-block get successors>> length
|
||||
] unit-test
|
||||
|
||||
{ "bar" } [
|
||||
V{ } "foo" insns>block basic-block set
|
||||
init-cfg-test
|
||||
[ V{ } "bar" insns>block basic-block get emit-loop-call ] V{ } make drop
|
||||
basic-block get successors>> first number>>
|
||||
] unit-test
|
||||
|
||||
! emit-node
|
||||
{
|
||||
{ T{ ##load-integer { dst 78 } { val 0 } } }
|
||||
} [
|
||||
77 vreg-counter set-global
|
||||
[ f T{ #push { literal 0 } { out-d { 8537399 } } } emit-node ] { } make
|
||||
] cfg-unit-test
|
||||
|
||||
{
|
||||
{ { 1 1 } { 0 0 } }
|
||||
H{ { D: -1 4 } { D: 0 4 } }
|
||||
} [
|
||||
4 D: 0 replace-loc
|
||||
f T{ #shuffle
|
||||
{ mapping { { 2 4 } { 3 4 } } }
|
||||
{ in-d V{ 4 } }
|
||||
{ out-d V{ 2 3 } }
|
||||
} emit-node
|
||||
height-state get
|
||||
replaces get
|
||||
] cfg-unit-test
|
||||
|
||||
! ! #call
|
||||
{
|
||||
V{
|
||||
T{ ##load-integer { dst 3 } { val 0 } }
|
||||
|
|
@ -290,15 +304,9 @@ IN: compiler.cfg.builder.tests
|
|||
{ word alien-cell }
|
||||
{ in-d V{ 10 20 } }
|
||||
{ out-d { 30 } }
|
||||
} [ emit-node ] V{ } make
|
||||
} [ emit-node drop ] V{ } make
|
||||
] cfg-unit-test
|
||||
|
||||
{ 1 } [
|
||||
V{ } 0 insns>block basic-block set init-cfg-test
|
||||
V{ } 1 insns>block [ basic-block get emit-loop-call ] V{ } make drop
|
||||
basic-block get successors>> length
|
||||
] unit-test
|
||||
|
||||
: call-node-1 ( -- node )
|
||||
T{ #call
|
||||
{ word set-slot }
|
||||
|
|
@ -334,38 +342,60 @@ IN: compiler.cfg.builder.tests
|
|||
{
|
||||
V{ T{ ##call { word set-slot } } T{ ##branch } }
|
||||
} [
|
||||
[ f call-node-1 emit-node ] V{ } make drop
|
||||
[ f call-node-1 emit-node drop ] V{ } make drop
|
||||
basic-block get successors>> first instructions>>
|
||||
] cfg-unit-test
|
||||
|
||||
! emit-loop-call
|
||||
{ "bar" } [
|
||||
V{ } "foo" insns>block basic-block set
|
||||
init-cfg-test
|
||||
[ V{ } "bar" insns>block basic-block get emit-loop-call ] V{ } make drop
|
||||
basic-block get successors>> first number>>
|
||||
! ! #push
|
||||
{
|
||||
{ T{ ##load-integer { dst 78 } { val 0 } } }
|
||||
} [
|
||||
77 vreg-counter set-global
|
||||
[ f T{ #push { literal 0 } { out-d { 8537399 } } } emit-node drop ] { } make
|
||||
] cfg-unit-test
|
||||
|
||||
! ! #shuffle
|
||||
{
|
||||
{ { 1 1 } { 0 0 } }
|
||||
H{ { D: -1 4 } { D: 0 4 } }
|
||||
} [
|
||||
4 D: 0 replace-loc
|
||||
f T{ #shuffle
|
||||
{ mapping { { 2 4 } { 3 4 } } }
|
||||
{ in-d V{ 4 } }
|
||||
{ out-d V{ 2 3 } }
|
||||
} emit-node drop
|
||||
height-state get
|
||||
replaces get
|
||||
] cfg-unit-test
|
||||
|
||||
! ! #terminate
|
||||
|
||||
{ f } [
|
||||
basic-block get dup set-basic-block
|
||||
T{ #terminate { in-d { } } { in-r { } } } emit-node
|
||||
] cfg-unit-test
|
||||
|
||||
! end-word
|
||||
{
|
||||
V{
|
||||
T{ ##safepoint }
|
||||
T{ ##epilogue }
|
||||
T{ ##return }
|
||||
}
|
||||
} [
|
||||
[
|
||||
<basic-block> dup set-basic-block end-word
|
||||
] V{ } make drop instructions>>
|
||||
] unit-test
|
||||
|
||||
! begin-cfg
|
||||
SYMBOL: foo
|
||||
|
||||
{ foo } [
|
||||
\ foo f begin-cfg word>>
|
||||
] cfg-unit-test
|
||||
|
||||
! remember-loop
|
||||
{ 20 } [
|
||||
H{ } clone loops set
|
||||
"hello" { } 20 insns>block remember-loop
|
||||
loops get "hello" of number>>
|
||||
] cfg-unit-test
|
||||
|
||||
! store-shuffle
|
||||
{
|
||||
H{ { D: 2 1 } }
|
||||
} [
|
||||
f T{ #shuffle { in-d { 7 3 0 } } { out-d { 55 } } { mapping { { 55 3 } } } }
|
||||
emit-node replaces get
|
||||
emit-node drop replaces get
|
||||
] cfg-unit-test
|
||||
|
||||
{
|
||||
|
|
@ -375,5 +405,5 @@ SYMBOL: foo
|
|||
{ in-d { 7 } }
|
||||
{ out-d { 55 77 } }
|
||||
{ mapping { { 55 7 } { 77 7 } } }
|
||||
} emit-node replaces get
|
||||
} emit-node drop replaces get
|
||||
] cfg-unit-test
|
||||
|
|
|
|||
|
|
@ -5,8 +5,8 @@ compiler.cfg.builder.blocks compiler.cfg.comparisons
|
|||
compiler.cfg.hats compiler.cfg.instructions
|
||||
compiler.cfg.intrinsics compiler.cfg.registers
|
||||
compiler.cfg.stacks compiler.cfg.stacks.local compiler.tree
|
||||
compiler.cfg.utilities cpu.architecture fry kernel make math namespaces
|
||||
sequences words ;
|
||||
compiler.cfg.utilities cpu.architecture fry kernel locals make math
|
||||
namespaces sequences words ;
|
||||
IN: compiler.cfg.builder
|
||||
|
||||
SYMBOL: procedures
|
||||
|
|
@ -16,14 +16,11 @@ SYMBOL: loops
|
|||
H{ } clone loops set
|
||||
<basic-block> dup set-basic-block <cfg> dup cfg set ;
|
||||
|
||||
: begin-procedure ( word label -- )
|
||||
begin-cfg procedures get push ;
|
||||
|
||||
: with-cfg-builder ( nodes word label quot: ( ..a block -- ..b ) -- )
|
||||
'[
|
||||
begin-stack-analysis
|
||||
begin-procedure
|
||||
basic-block get @
|
||||
begin-cfg dup procedures get push
|
||||
entry>> @
|
||||
end-stack-analysis
|
||||
] with-scope ; inline
|
||||
|
||||
|
|
@ -33,18 +30,18 @@ SYMBOL: loops
|
|||
'[ _ t t [ drop _ call( node -- ) ] with-cfg-builder ] with-variable
|
||||
] { } make drop ;
|
||||
|
||||
GENERIC: emit-node ( block node -- )
|
||||
GENERIC: emit-node ( block node -- block' )
|
||||
|
||||
: emit-nodes ( nodes -- )
|
||||
[ basic-block get [ swap emit-node ] [ drop ] if* ] each ;
|
||||
: emit-nodes ( block nodes -- block' )
|
||||
[ over [ emit-node ] [ drop ] if ] each ;
|
||||
|
||||
: begin-word ( block -- )
|
||||
: begin-word ( block -- block' )
|
||||
dup make-kill-block
|
||||
##safepoint, ##prologue, ##branch,
|
||||
begin-basic-block ;
|
||||
|
||||
: (build-cfg) ( nodes word label -- )
|
||||
[ begin-word emit-nodes ] with-cfg-builder ;
|
||||
[ begin-word swap emit-nodes drop ] with-cfg-builder ;
|
||||
|
||||
: build-cfg ( nodes word -- procedures )
|
||||
V{ } clone [
|
||||
|
|
@ -54,41 +51,40 @@ GENERIC: emit-node ( block node -- )
|
|||
] keep ;
|
||||
|
||||
: emit-loop-call ( successor-block current-block -- )
|
||||
##safepoint,
|
||||
##branch,
|
||||
##safepoint, ##branch,
|
||||
[ swap connect-bbs ] [ end-basic-block ] bi ;
|
||||
|
||||
: emit-call ( block word height -- )
|
||||
over loops get at [ 2nip swap emit-loop-call ]
|
||||
[
|
||||
[ emit-call-block ] emit-trivial-block drop
|
||||
] if* ;
|
||||
: emit-trivial-call ( block word height -- block' )
|
||||
##branch, rot begin-basic-block
|
||||
[ emit-call-block ] keep
|
||||
##branch, begin-basic-block ;
|
||||
|
||||
: emit-call ( block word height -- block' )
|
||||
over loops get at [
|
||||
2nip swap emit-loop-call f
|
||||
] [ emit-trivial-call ] if* ;
|
||||
|
||||
! #recursive
|
||||
: recursive-height ( #recursive -- n )
|
||||
[ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
|
||||
|
||||
: emit-recursive ( block #recursive -- )
|
||||
: emit-recursive ( block #recursive -- block' )
|
||||
[ [ label>> id>> ] [ recursive-height ] bi emit-call ] keep
|
||||
[ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ;
|
||||
|
||||
: remember-loop ( label block -- )
|
||||
swap loops get set-at ;
|
||||
: emit-loop ( block #recursive -- block' )
|
||||
##branch, [ begin-basic-block ] dip
|
||||
[ label>> id>> loops get set-at ] [ child>> emit-nodes ] 2bi ;
|
||||
|
||||
: emit-loop ( node block -- )
|
||||
##branch, begin-basic-block
|
||||
[ label>> id>> basic-block get remember-loop ]
|
||||
[ child>> emit-nodes ] bi ;
|
||||
|
||||
M: #recursive emit-node ( block node -- )
|
||||
dup label>> loop?>> [ swap emit-loop ] [ emit-recursive ] if ;
|
||||
M: #recursive emit-node ( block node -- block' )
|
||||
dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
|
||||
|
||||
! #if
|
||||
: emit-branch ( obj -- pair/f )
|
||||
[ emit-nodes ] with-branch ;
|
||||
: emit-branch ( nodes block -- pair/f )
|
||||
[ begin-branch swap emit-nodes end-branch ] with-scope ;
|
||||
|
||||
: emit-if ( block node -- )
|
||||
children>> [ emit-branch ] map swap emit-conditional ;
|
||||
: emit-if ( block node -- block' )
|
||||
children>> over '[ _ emit-branch ] map emit-conditional ;
|
||||
|
||||
: trivial-branch? ( nodes -- value ? )
|
||||
dup length 1 = [
|
||||
|
|
@ -113,33 +109,34 @@ M: #recursive emit-node ( block node -- )
|
|||
: emit-trivial-not-if ( -- )
|
||||
[ f cc= ^^compare-imm ] unary-op ;
|
||||
|
||||
: emit-actual-if ( block #if -- )
|
||||
: emit-actual-if ( block #if -- block' )
|
||||
! Inputs to the final instruction need to be copied because of
|
||||
! loc>vreg sync
|
||||
ds-pop any-rep ^^copy f cc/= ##compare-imm-branch, emit-if ;
|
||||
|
||||
M: #if emit-node ( block node -- )
|
||||
M: #if emit-node ( block node -- block' )
|
||||
{
|
||||
{ [ dup trivial-if? ] [ 2drop emit-trivial-if ] }
|
||||
{ [ dup trivial-not-if? ] [ 2drop emit-trivial-not-if ] }
|
||||
{ [ dup trivial-if? ] [ drop emit-trivial-if ] }
|
||||
{ [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
|
||||
[ emit-actual-if ]
|
||||
} cond ;
|
||||
|
||||
M: #dispatch emit-node ( block node -- )
|
||||
M: #dispatch emit-node ( block node -- block' )
|
||||
! Inputs to the final instruction need to be copied because of
|
||||
! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
|
||||
! though.
|
||||
ds-pop ^^offset>slot next-vreg ##dispatch, emit-if ;
|
||||
|
||||
M: #call emit-node ( block node -- )
|
||||
dup word>> dup "intrinsic" word-prop
|
||||
[ nip call( node -- ) drop ] [ swap call-height emit-call ] if* ;
|
||||
M: #call emit-node ( block node -- block' )
|
||||
dup word>> dup "intrinsic" word-prop [
|
||||
nip call( node -- ) drop basic-block get
|
||||
] [ swap call-height emit-call ] if* ;
|
||||
|
||||
M: #call-recursive emit-node ( block node -- )
|
||||
M: #call-recursive emit-node ( block node -- block' )
|
||||
[ label>> id>> ] [ call-height ] bi emit-call ;
|
||||
|
||||
M: #push emit-node ( block node -- )
|
||||
nip literal>> ^^load-literal ds-push ;
|
||||
M: #push emit-node ( block node -- block' )
|
||||
literal>> ^^load-literal ds-push ;
|
||||
|
||||
! #shuffle
|
||||
|
||||
|
|
@ -165,35 +162,35 @@ M: #push emit-node ( block node -- )
|
|||
[ make-input-map ] [ mapping>> ] [ extract-outputs ] tri
|
||||
[ first2 [ [ of of peek-loc ] 2with map ] dip 2array ] 2with map ;
|
||||
|
||||
M: #shuffle emit-node ( block node -- )
|
||||
nip [ out-vregs/stack ] keep store-height-changes
|
||||
M: #shuffle emit-node ( block node -- block' )
|
||||
[ out-vregs/stack ] keep store-height-changes
|
||||
[ first2 store-vregs ] each ;
|
||||
|
||||
! #return
|
||||
: end-word ( block -- )
|
||||
: end-word ( block -- block' )
|
||||
##branch, begin-basic-block
|
||||
basic-block get make-kill-block
|
||||
dup make-kill-block
|
||||
##safepoint,
|
||||
##epilogue,
|
||||
##return, ;
|
||||
|
||||
M: #return emit-node ( block node -- )
|
||||
M: #return emit-node ( block node -- block' )
|
||||
drop end-word ;
|
||||
|
||||
M: #return-recursive emit-node ( block node -- )
|
||||
label>> id>> loops get key? [ drop ] [ end-word ] if ;
|
||||
M: #return-recursive emit-node ( block node -- block' )
|
||||
label>> id>> loops get key? [ ] [ end-word ] if ;
|
||||
|
||||
! #terminate
|
||||
M: #terminate emit-node ( block node -- )
|
||||
drop ##no-tco, end-basic-block ;
|
||||
M: #terminate emit-node ( block node -- block' )
|
||||
drop ##no-tco, end-basic-block f ;
|
||||
|
||||
! No-op nodes
|
||||
M: #introduce emit-node 2drop ;
|
||||
M: #introduce emit-node drop ;
|
||||
|
||||
M: #copy emit-node 2drop ;
|
||||
M: #copy emit-node drop ;
|
||||
|
||||
M: #enter-recursive emit-node 2drop ;
|
||||
M: #enter-recursive emit-node drop ;
|
||||
|
||||
M: #phi emit-node 2drop ;
|
||||
M: #phi emit-node drop ;
|
||||
|
||||
M: #declare emit-node 2drop ;
|
||||
M: #declare emit-node drop ;
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
ds-peek 0 cc> ##compare-integer-imm-branch,
|
||||
[ emit-fixnum-left-shift ] with-branch
|
||||
[ emit-fixnum-right-shift ] with-branch
|
||||
2array basic-block get emit-conditional ;
|
||||
2array basic-block get swap emit-conditional drop ;
|
||||
|
||||
: emit-fixnum-shift-fast ( node -- )
|
||||
node-input-infos second interval>> {
|
||||
|
|
@ -54,7 +54,7 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
! of loc>vreg sync
|
||||
[ [ (2inputs) [ any-rep ^^copy ] bi@ cc/o ] dip call ] dip
|
||||
[ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
|
||||
basic-block get emit-conditional ; inline
|
||||
basic-block get swap emit-conditional drop ; inline
|
||||
|
||||
: fixnum+overflow ( x y -- z ) [ >bignum ] bi@ + ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue