Updating codegen for new optimizer
parent
ed848621a3
commit
d42edecffb
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1,16 @@
|
|||
USING: help.syntax help.markup math kernel
|
||||
words strings alien ;
|
||||
IN: compiler.generator.fixup
|
||||
|
||||
HELP: frame-required
|
||||
{ $values { "n" "a non-negative integer" } }
|
||||
{ $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ;
|
||||
|
||||
HELP: add-literal
|
||||
{ $values { "obj" object } { "n" integer } }
|
||||
{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
|
||||
|
||||
HELP: rel-dlsym
|
||||
{ $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } }
|
||||
{ $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats."
|
||||
} ;
|
|
@ -0,0 +1,154 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays byte-arrays generic assocs hashtables io.binary
|
||||
kernel kernel.private math namespaces sequences words
|
||||
quotations strings alien.accessors alien.strings layouts system
|
||||
combinators math.bitfields words.private cpu.architecture
|
||||
math.order accessors growable ;
|
||||
IN: compiler.generator.fixup
|
||||
|
||||
: no-stack-frame -1 ; inline
|
||||
|
||||
TUPLE: frame-required n ;
|
||||
|
||||
: frame-required ( n -- ) \ frame-required boa , ;
|
||||
|
||||
: stack-frame-size ( code -- n )
|
||||
no-stack-frame [
|
||||
dup frame-required? [ frame-required-n max ] [ drop ] if
|
||||
] reduce ;
|
||||
|
||||
GENERIC: fixup* ( frame-size obj -- frame-size )
|
||||
|
||||
: code-format 22 getenv ;
|
||||
|
||||
: compiled-offset ( -- n ) building get length code-format * ;
|
||||
|
||||
TUPLE: label offset ;
|
||||
|
||||
: <label> ( -- label ) label new ;
|
||||
|
||||
M: label fixup*
|
||||
compiled-offset swap set-label-offset ;
|
||||
|
||||
: define-label ( name -- ) <label> swap set ;
|
||||
|
||||
: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
|
||||
|
||||
: if-stack-frame ( frame-size quot -- )
|
||||
swap dup no-stack-frame =
|
||||
[ 2drop ] [ stack-frame swap call ] if ; inline
|
||||
|
||||
M: word fixup*
|
||||
{
|
||||
{ \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
|
||||
{ \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
|
||||
} case ;
|
||||
|
||||
SYMBOL: relocation-table
|
||||
SYMBOL: label-table
|
||||
|
||||
! Relocation classes
|
||||
: rc-absolute-cell 0 ;
|
||||
: rc-absolute 1 ;
|
||||
: rc-relative 2 ;
|
||||
: rc-absolute-ppc-2/2 3 ;
|
||||
: rc-relative-ppc-2 4 ;
|
||||
: rc-relative-ppc-3 5 ;
|
||||
: rc-relative-arm-3 6 ;
|
||||
: rc-indirect-arm 7 ;
|
||||
: rc-indirect-arm-pc 8 ;
|
||||
|
||||
: rc-absolute? ( n -- ? )
|
||||
dup rc-absolute-cell =
|
||||
over rc-absolute =
|
||||
rot rc-absolute-ppc-2/2 = or or ;
|
||||
|
||||
! Relocation types
|
||||
: rt-primitive 0 ;
|
||||
: rt-dlsym 1 ;
|
||||
: rt-literal 2 ;
|
||||
: rt-dispatch 3 ;
|
||||
: rt-xt 4 ;
|
||||
: rt-here 5 ;
|
||||
: rt-label 6 ;
|
||||
: rt-immediate 7 ;
|
||||
|
||||
TUPLE: label-fixup label class ;
|
||||
|
||||
: label-fixup ( label class -- ) \ label-fixup boa , ;
|
||||
|
||||
M: label-fixup fixup*
|
||||
dup class>> rc-absolute?
|
||||
[ "Absolute labels not supported" throw ] when
|
||||
dup label>> swap class>> compiled-offset 4 - rot
|
||||
3array label-table get push ;
|
||||
|
||||
TUPLE: rel-fixup arg class type ;
|
||||
|
||||
: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
|
||||
|
||||
: push-4 ( value vector -- )
|
||||
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
|
||||
swap set-alien-unsigned-4 ;
|
||||
|
||||
M: rel-fixup fixup*
|
||||
[ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
|
||||
[ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
|
||||
[ relocation-table get push-4 ] bi@ ;
|
||||
|
||||
M: frame-required fixup* drop ;
|
||||
|
||||
M: integer fixup* , ;
|
||||
|
||||
: adjoin* ( obj table -- n )
|
||||
2dup swap [ eq? ] curry find drop
|
||||
[ 2nip ] [ dup length >r push r> ] if* ;
|
||||
|
||||
SYMBOL: literal-table
|
||||
|
||||
: add-literal ( obj -- n ) literal-table get adjoin* ;
|
||||
|
||||
: add-dlsym-literals ( symbol dll -- )
|
||||
>r string>symbol r> 2array literal-table get push-all ;
|
||||
|
||||
: rel-dlsym ( name dll class -- )
|
||||
>r literal-table get length >r
|
||||
add-dlsym-literals
|
||||
r> r> rt-dlsym rel-fixup ;
|
||||
|
||||
: rel-word ( word class -- )
|
||||
>r add-literal r> rt-xt rel-fixup ;
|
||||
|
||||
: rel-primitive ( word class -- )
|
||||
>r def>> first r> rt-primitive rel-fixup ;
|
||||
|
||||
: rel-literal ( literal class -- )
|
||||
>r add-literal r> rt-literal rel-fixup ;
|
||||
|
||||
: rel-this ( class -- )
|
||||
0 swap rt-label rel-fixup ;
|
||||
|
||||
: rel-here ( class -- )
|
||||
0 swap rt-here rel-fixup ;
|
||||
|
||||
: init-fixup ( -- )
|
||||
BV{ } clone relocation-table set
|
||||
V{ } clone label-table set ;
|
||||
|
||||
: resolve-labels ( labels -- labels' )
|
||||
[
|
||||
first3 label-offset
|
||||
[ "Unresolved label" throw ] unless*
|
||||
3array
|
||||
] map concat ;
|
||||
|
||||
: fixup ( code -- literals relocation labels code )
|
||||
[
|
||||
init-fixup
|
||||
dup stack-frame-size swap [ fixup* ] each drop
|
||||
|
||||
literal-table get >array
|
||||
relocation-table get >byte-array
|
||||
label-table get resolve-labels
|
||||
] { } make ;
|
|
@ -0,0 +1 @@
|
|||
Support for generation of relocatable code
|
|
@ -0,0 +1,88 @@
|
|||
USING: help.markup help.syntax words debugger generator.fixup
|
||||
generator.registers quotations kernel vectors arrays effects
|
||||
sequences ;
|
||||
IN: compiler.generator
|
||||
|
||||
ARTICLE: "generator" "Compiled code generator"
|
||||
"Most of the words in the " { $vocab-link "generator" } " vocabulary are internal to the compiler and user code has no reason to call them."
|
||||
$nl
|
||||
"Debugging information can be enabled or disabled; this hook is used by " { $link "tools.deploy" } ":"
|
||||
{ $subsection compiled-stack-traces? }
|
||||
"Assembler intrinsics can be defined for low-level optimization:"
|
||||
{ $subsection define-intrinsic }
|
||||
{ $subsection define-intrinsics }
|
||||
{ $subsection define-if-intrinsic }
|
||||
{ $subsection define-if-intrinsics }
|
||||
"The main entry point into the code generator:"
|
||||
{ $subsection generate } ;
|
||||
|
||||
ABOUT: "generator"
|
||||
|
||||
HELP: compiled
|
||||
{ $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
|
||||
|
||||
HELP: compiling-word
|
||||
{ $var-description "The word currently being compiled, set by " { $link with-generator } "." } ;
|
||||
|
||||
HELP: compiling-label
|
||||
{ $var-description "The label currently being compiled, set by " { $link with-generator } "." } ;
|
||||
|
||||
HELP: compiled-stack-traces?
|
||||
{ $values { "?" "a boolean" } }
|
||||
{ $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
|
||||
|
||||
HELP: literal-table
|
||||
{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ;
|
||||
|
||||
HELP: begin-compiling
|
||||
{ $values { "word" word } { "label" word } }
|
||||
{ $description "Prepares to generate machine code for a word." } ;
|
||||
|
||||
HELP: with-generator
|
||||
{ $values { "node" "a dataflow node" } { "word" word } { "label" word } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
|
||||
{ $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the dataflow node." } ;
|
||||
|
||||
HELP: generate-node
|
||||
{ $values { "node" "a dataflow node" } { "next" "a dataflow node" } }
|
||||
{ $contract "Generates machine code for a dataflow node, and outputs the next node to generate machine code for." }
|
||||
{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
|
||||
|
||||
HELP: generate-nodes
|
||||
{ $values { "node" "a dataflow node" } }
|
||||
{ $description "Recursively generate machine code for a dataflow graph." }
|
||||
{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
|
||||
|
||||
HELP: generate
|
||||
{ $values { "word" word } { "label" word } { "node" "a dataflow node" } }
|
||||
{ $description "Generates machine code for " { $snippet "label" } " from " { $snippet "node" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ;
|
||||
|
||||
HELP: define-intrinsics
|
||||
{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot assoc }" } " pairs" } }
|
||||
{ $description "Defines a set of assembly intrinsics for the word. When a call to the word is being compiled, each intrinsic is tested in turn; the first applicable one will be called to generate machine code. If no suitable intrinsic is found, a simple call to the word is compiled instead."
|
||||
$nl
|
||||
"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
|
||||
|
||||
HELP: define-intrinsic
|
||||
{ $values { "word" word } { "quot" quotation } { "assoc" "an assoc" } }
|
||||
{ $description "Defines an assembly intrinsic for the word. When a call to the word is being compiled, this intrinsic will be used if it is found to be applicable. If it is not applicable, a simple call to the word is compiled instead."
|
||||
$nl
|
||||
"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
|
||||
|
||||
HELP: if>boolean-intrinsic
|
||||
{ $values { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } }
|
||||
{ $description "Generates code which pushes " { $link t } " or " { $link f } " on the data stack, depending on whether the quotation jumps to the label or not." } ;
|
||||
|
||||
HELP: define-if-intrinsics
|
||||
{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot inputs }" } " pairs" } }
|
||||
{ $description "Defines a set of conditional assembly intrinsics for the word, which must have a boolean value as its single output."
|
||||
$nl
|
||||
"The quotations must have stack effect " { $snippet "( label -- )" } "; they are required to branch to the label if the word evaluates to true."
|
||||
$nl
|
||||
"The " { $snippet "inputs" } " are in the same format as the " { $link +input+ } " key to " { $link with-template } "; a description can be found in the documentation for thatt word." }
|
||||
{ $notes "Conditional intrinsics are used when the word is followed by a call to " { $link if } ". They allow for tighter code to be generated in certain situations; for example, if two integers are being compared and the result is immediately used to branch, the intermediate boolean does not need to be pushed at all." } ;
|
||||
|
||||
HELP: define-if-intrinsic
|
||||
{ $values { "word" word } { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } { "inputs" "a sequence of input register specifiers" } }
|
||||
{ $description "Defines a conditional assembly intrinsic for the word, which must have a boolean value as its single output."
|
||||
$nl
|
||||
"See " { $link define-if-intrinsics } " for a description of the parameters." } ;
|
|
@ -0,0 +1,269 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs classes combinators
|
||||
cpu.architecture effects generic hashtables io kernel
|
||||
kernel.private layouts math namespaces prettyprint quotations
|
||||
sequences system threads words vectors sets dequeues cursors
|
||||
stack-checker.inlining
|
||||
compiler.tree compiler.tree.builder compiler.tree.combinators
|
||||
compiler.tree.propagation.info compiler.generator.fixup
|
||||
compiler.generator.registers compiler.generator.iterator ;
|
||||
IN: compiler.generator
|
||||
|
||||
SYMBOL: compile-queue
|
||||
SYMBOL: compiled
|
||||
|
||||
: queue-compile ( word -- )
|
||||
{
|
||||
{ [ dup "forgotten" word-prop ] [ ] }
|
||||
{ [ dup compiled get key? ] [ ] }
|
||||
{ [ dup inlined-block? ] [ ] }
|
||||
{ [ dup primitive? ] [ ] }
|
||||
[ dup compile-queue get push-front ]
|
||||
} cond drop ;
|
||||
|
||||
: maybe-compile ( word -- )
|
||||
dup compiled>> [ drop ] [ queue-compile ] if ;
|
||||
|
||||
SYMBOL: compiling-word
|
||||
|
||||
SYMBOL: compiling-label
|
||||
|
||||
SYMBOL: compiling-loops
|
||||
|
||||
! Label of current word, after prologue, makes recursion faster
|
||||
SYMBOL: current-label-start
|
||||
|
||||
: compiled-stack-traces? ( -- ? ) 59 getenv ;
|
||||
|
||||
: begin-compiling ( word label -- )
|
||||
H{ } clone compiling-loops set
|
||||
compiling-label set
|
||||
compiling-word set
|
||||
compiled-stack-traces?
|
||||
compiling-word get f ?
|
||||
1vector literal-table set
|
||||
f compiling-label get compiled get set-at ;
|
||||
|
||||
: save-machine-code ( literals relocation labels code -- )
|
||||
4array compiling-label get compiled get set-at ;
|
||||
|
||||
: with-generator ( node word label quot -- )
|
||||
[
|
||||
>r begin-compiling r>
|
||||
{ } make fixup
|
||||
save-machine-code
|
||||
] with-scope ; inline
|
||||
|
||||
GENERIC: generate-node ( node -- next )
|
||||
|
||||
: generate-nodes ( nodes -- )
|
||||
[ current-node generate-node ] iterate-nodes end-basic-block ;
|
||||
|
||||
: init-generate-nodes ( -- )
|
||||
init-templates
|
||||
%save-word-xt
|
||||
%prologue-later
|
||||
current-label-start define-label
|
||||
current-label-start resolve-label ;
|
||||
|
||||
: generate ( nodes word label -- )
|
||||
[
|
||||
init-generate-nodes
|
||||
[ generate-nodes ] with-node-iterator
|
||||
] with-generator ;
|
||||
|
||||
: intrinsics ( #call -- quot )
|
||||
word>> "intrinsics" word-prop ;
|
||||
|
||||
: if-intrinsics ( #call -- quot )
|
||||
word>> "if-intrinsics" word-prop ;
|
||||
|
||||
! node
|
||||
M: node generate-node drop iterate-next ;
|
||||
|
||||
: %jump ( word -- )
|
||||
dup compiling-label get eq?
|
||||
[ drop current-label-start get ] [ %epilogue-later ] if
|
||||
%jump-label ;
|
||||
|
||||
: generate-call ( label -- next )
|
||||
dup maybe-compile
|
||||
end-basic-block
|
||||
dup compiling-loops get at [
|
||||
%jump-label f
|
||||
] [
|
||||
tail-call? [
|
||||
%jump f
|
||||
] [
|
||||
0 frame-required
|
||||
%call
|
||||
iterate-next
|
||||
] if
|
||||
] ?if ;
|
||||
|
||||
! #recursive
|
||||
: compile-recursive ( node -- )
|
||||
dup label>> id>> generate-call >r
|
||||
[ child>> ] [ label>> word>> ] [ label>> id>> ] tri generate
|
||||
r> ;
|
||||
|
||||
: compiling-loop ( word -- )
|
||||
<label> dup resolve-label swap compiling-loops get set-at ;
|
||||
|
||||
: compile-loop ( node -- )
|
||||
end-basic-block
|
||||
[ label>> id>> compiling-loop ] [ child>> generate-nodes ] bi
|
||||
iterate-next ;
|
||||
|
||||
M: #recursive generate-node
|
||||
dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
|
||||
|
||||
! #if
|
||||
: end-false-branch ( label -- )
|
||||
tail-call? [ %return drop ] [ %jump-label ] if ;
|
||||
|
||||
: generate-branch ( nodes -- )
|
||||
[ copy-templates generate-nodes ] with-scope ;
|
||||
|
||||
: generate-if ( node label -- next )
|
||||
<label> [
|
||||
>r >r children>> first2 swap generate-branch
|
||||
r> r> end-false-branch resolve-label
|
||||
generate-branch
|
||||
init-templates
|
||||
] keep resolve-label iterate-next ;
|
||||
|
||||
M: #if generate-node
|
||||
[ <label> dup %jump-f ]
|
||||
H{ { +input+ { { f "flag" } } } }
|
||||
with-template
|
||||
generate-if ;
|
||||
|
||||
! #dispatch
|
||||
: dispatch-branch ( nodes word -- label )
|
||||
gensym [
|
||||
[
|
||||
copy-templates
|
||||
%save-dispatch-xt
|
||||
%prologue-later
|
||||
[ generate-nodes ] with-node-iterator
|
||||
] with-generator
|
||||
] keep ;
|
||||
|
||||
: dispatch-branches ( node -- )
|
||||
children>> [
|
||||
compiling-word get dispatch-branch
|
||||
%dispatch-label
|
||||
] each ;
|
||||
|
||||
: generate-dispatch ( node -- )
|
||||
%dispatch dispatch-branches init-templates ;
|
||||
|
||||
M: #dispatch generate-node
|
||||
#! The order here is important, dispatch-branches must
|
||||
#! run after %dispatch, so that each branch gets the
|
||||
#! correct register state
|
||||
tail-call? [
|
||||
generate-dispatch iterate-next
|
||||
] [
|
||||
compiling-word get gensym [
|
||||
[
|
||||
init-generate-nodes
|
||||
generate-dispatch
|
||||
] with-generator
|
||||
] keep generate-call
|
||||
] if ;
|
||||
|
||||
! #call
|
||||
: define-intrinsics ( word intrinsics -- )
|
||||
"intrinsics" set-word-prop ;
|
||||
|
||||
: define-intrinsic ( word quot assoc -- )
|
||||
2array 1array define-intrinsics ;
|
||||
|
||||
: define-if>branch-intrinsics ( word intrinsics -- )
|
||||
"if-intrinsics" set-word-prop ;
|
||||
|
||||
: if>boolean-intrinsic ( quot -- )
|
||||
"false" define-label
|
||||
"end" define-label
|
||||
"false" get swap call
|
||||
t "if-scratch" get load-literal
|
||||
"end" get %jump-label
|
||||
"false" resolve-label
|
||||
f "if-scratch" get load-literal
|
||||
"end" resolve-label
|
||||
"if-scratch" get phantom-push ; inline
|
||||
|
||||
: define-if>boolean-intrinsics ( word intrinsics -- )
|
||||
[
|
||||
>r [ if>boolean-intrinsic ] curry r>
|
||||
{ { f "if-scratch" } } +scratch+ associate assoc-union
|
||||
] assoc-map "intrinsics" set-word-prop ;
|
||||
|
||||
: define-if-intrinsics ( word intrinsics -- )
|
||||
[ +input+ associate ] assoc-map
|
||||
2dup define-if>branch-intrinsics
|
||||
define-if>boolean-intrinsics ;
|
||||
|
||||
: define-if-intrinsic ( word quot inputs -- )
|
||||
2array 1array define-if-intrinsics ;
|
||||
|
||||
: do-if-intrinsic ( pair -- next )
|
||||
<label> [
|
||||
swap do-template
|
||||
node> next dup >node
|
||||
] keep generate-if ;
|
||||
|
||||
: find-intrinsic ( #call -- pair/f )
|
||||
intrinsics find-template ;
|
||||
|
||||
: find-if-intrinsic ( #call -- pair/f )
|
||||
node@ next #if? [
|
||||
if-intrinsics find-template
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
M: #call generate-node
|
||||
dup node-input-infos [ class>> ] map set-operand-classes
|
||||
dup find-if-intrinsic [
|
||||
do-if-intrinsic
|
||||
] [
|
||||
dup find-intrinsic [
|
||||
do-template iterate-next
|
||||
] [
|
||||
word>> generate-call
|
||||
] ?if
|
||||
] ?if ;
|
||||
|
||||
! #call-recursive
|
||||
M: #call-recursive generate-node label>> id>> generate-call ;
|
||||
|
||||
! #push
|
||||
M: #push generate-node
|
||||
literal>> <constant> phantom-push iterate-next ;
|
||||
|
||||
! #shuffle
|
||||
M: #shuffle generate-node
|
||||
shuffle-effect phantom-shuffle iterate-next ;
|
||||
|
||||
M: #>r generate-node
|
||||
in-d>> length
|
||||
phantom->r
|
||||
iterate-next ;
|
||||
|
||||
M: #r> generate-node
|
||||
out-d>> length
|
||||
phantom-r>
|
||||
iterate-next ;
|
||||
|
||||
! #return
|
||||
M: #return generate-node
|
||||
drop end-basic-block %return f ;
|
||||
|
||||
M: #return-recursive generate-node
|
||||
end-basic-block
|
||||
label>> id>> compiling-loops get key?
|
||||
[ %return ] unless f ;
|
|
@ -0,0 +1,41 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces sequences cursors kernel compiler.tree ;
|
||||
IN: compiler.generator.iterator
|
||||
|
||||
SYMBOL: node-stack
|
||||
|
||||
: >node ( cursor -- ) node-stack get push ;
|
||||
: node> ( -- cursor ) node-stack get pop ;
|
||||
: node@ ( -- cursor ) node-stack get peek ;
|
||||
: current-node ( -- node ) node@ value ;
|
||||
|
||||
: iterate-next ( -- cursor ) node@ next ;
|
||||
|
||||
: iterate-nodes ( cursor quot: ( -- ) -- )
|
||||
over [
|
||||
[ swap >node call node> drop ] keep iterate-nodes
|
||||
] [
|
||||
2drop
|
||||
] if ; inline recursive
|
||||
|
||||
: with-node-iterator ( quot -- )
|
||||
>r V{ } clone node-stack r> with-variable ; inline
|
||||
|
||||
DEFER: (tail-call?)
|
||||
|
||||
: tail-phi? ( cursor -- ? )
|
||||
[ value #phi? ] [ next (tail-call?) ] bi and ;
|
||||
|
||||
: (tail-call?) ( cursor -- ? )
|
||||
[ value [ #return? ] [ #terminate? ] bi or ]
|
||||
[ tail-phi? ]
|
||||
bi or ;
|
||||
|
||||
: tail-call? ( -- ? )
|
||||
node-stack get [
|
||||
next
|
||||
[ (tail-call?) ]
|
||||
[ value #terminate? not ]
|
||||
bi and
|
||||
] all? ;
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1,660 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs classes classes.private classes.algebra
|
||||
combinators cpu.architecture generator.fixup hashtables kernel
|
||||
layouts math namespaces quotations sequences system vectors
|
||||
words effects alien byte-arrays
|
||||
accessors sets math.order ;
|
||||
IN: compiler.generator.registers
|
||||
|
||||
SYMBOL: +input+
|
||||
SYMBOL: +output+
|
||||
SYMBOL: +scratch+
|
||||
SYMBOL: +clobber+
|
||||
SYMBOL: known-tag
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! Value protocol
|
||||
GENERIC: set-operand-class ( class obj -- )
|
||||
GENERIC: operand-class* ( operand -- class )
|
||||
GENERIC: move-spec ( obj -- spec )
|
||||
GENERIC: live-vregs* ( obj -- )
|
||||
GENERIC: live-loc? ( actual current -- ? )
|
||||
GENERIC# (lazy-load) 1 ( value spec -- value )
|
||||
GENERIC: lazy-store ( dst src -- )
|
||||
GENERIC: minimal-ds-loc* ( min obj -- min )
|
||||
|
||||
! This will be a multimethod soon
|
||||
DEFER: %move
|
||||
|
||||
MIXIN: value
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: operand-class ( operand -- class )
|
||||
operand-class* object or ;
|
||||
|
||||
! Default implementation
|
||||
M: value set-operand-class 2drop ;
|
||||
M: value operand-class* drop f ;
|
||||
M: value live-vregs* drop ;
|
||||
M: value live-loc? 2drop f ;
|
||||
M: value minimal-ds-loc* drop ;
|
||||
M: value lazy-store 2drop ;
|
||||
|
||||
! A scratch register for computations
|
||||
TUPLE: vreg n reg-class ;
|
||||
|
||||
C: <vreg> vreg ( n reg-class -- vreg )
|
||||
|
||||
M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ;
|
||||
M: vreg live-vregs* , ;
|
||||
M: vreg move-spec reg-class>> move-spec ;
|
||||
|
||||
INSTANCE: vreg value
|
||||
|
||||
M: float-regs move-spec drop float ;
|
||||
M: float-regs operand-class* drop float ;
|
||||
|
||||
! Temporary register for stack shuffling
|
||||
SINGLETON: temp-reg
|
||||
|
||||
M: temp-reg move-spec drop f ;
|
||||
|
||||
INSTANCE: temp-reg value
|
||||
|
||||
! A data stack location.
|
||||
TUPLE: ds-loc n class ;
|
||||
|
||||
: <ds-loc> ( n -- loc ) f ds-loc boa ;
|
||||
|
||||
M: ds-loc minimal-ds-loc* ds-loc-n min ;
|
||||
M: ds-loc operand-class* ds-loc-class ;
|
||||
M: ds-loc set-operand-class set-ds-loc-class ;
|
||||
M: ds-loc live-loc?
|
||||
over ds-loc? [ [ ds-loc-n ] bi@ = not ] [ 2drop t ] if ;
|
||||
|
||||
! A retain stack location.
|
||||
TUPLE: rs-loc n class ;
|
||||
|
||||
: <rs-loc> ( n -- loc ) f rs-loc boa ;
|
||||
M: rs-loc operand-class* rs-loc-class ;
|
||||
M: rs-loc set-operand-class set-rs-loc-class ;
|
||||
M: rs-loc live-loc?
|
||||
over rs-loc? [ [ rs-loc-n ] bi@ = not ] [ 2drop t ] if ;
|
||||
|
||||
UNION: loc ds-loc rs-loc ;
|
||||
|
||||
M: loc move-spec drop loc ;
|
||||
|
||||
INSTANCE: loc value
|
||||
|
||||
M: f move-spec drop loc ;
|
||||
M: f operand-class* ;
|
||||
|
||||
! A stack location which has been loaded into a register. To
|
||||
! read the location, we just read the register, but when time
|
||||
! comes to save it back to the stack, we know the register just
|
||||
! contains a stack value so we don't have to redundantly write
|
||||
! it back.
|
||||
TUPLE: cached loc vreg ;
|
||||
|
||||
C: <cached> cached
|
||||
|
||||
M: cached set-operand-class cached-vreg set-operand-class ;
|
||||
M: cached operand-class* cached-vreg operand-class* ;
|
||||
M: cached move-spec drop cached ;
|
||||
M: cached live-vregs* cached-vreg live-vregs* ;
|
||||
M: cached live-loc? cached-loc live-loc? ;
|
||||
M: cached (lazy-load) >r cached-vreg r> (lazy-load) ;
|
||||
M: cached lazy-store
|
||||
2dup cached-loc live-loc?
|
||||
[ "live-locs" get at %move ] [ 2drop ] if ;
|
||||
M: cached minimal-ds-loc* cached-loc minimal-ds-loc* ;
|
||||
|
||||
INSTANCE: cached value
|
||||
|
||||
! A tagged pointer
|
||||
TUPLE: tagged vreg class ;
|
||||
|
||||
: <tagged> ( vreg -- tagged )
|
||||
f tagged boa ;
|
||||
|
||||
M: tagged v>operand tagged-vreg v>operand ;
|
||||
M: tagged set-operand-class set-tagged-class ;
|
||||
M: tagged operand-class* tagged-class ;
|
||||
M: tagged move-spec drop f ;
|
||||
M: tagged live-vregs* tagged-vreg , ;
|
||||
|
||||
INSTANCE: tagged value
|
||||
|
||||
! Unboxed alien pointers
|
||||
TUPLE: unboxed-alien vreg ;
|
||||
C: <unboxed-alien> unboxed-alien
|
||||
M: unboxed-alien v>operand unboxed-alien-vreg v>operand ;
|
||||
M: unboxed-alien operand-class* drop simple-alien ;
|
||||
M: unboxed-alien move-spec class ;
|
||||
M: unboxed-alien live-vregs* unboxed-alien-vreg , ;
|
||||
|
||||
INSTANCE: unboxed-alien value
|
||||
|
||||
TUPLE: unboxed-byte-array vreg ;
|
||||
C: <unboxed-byte-array> unboxed-byte-array
|
||||
M: unboxed-byte-array v>operand unboxed-byte-array-vreg v>operand ;
|
||||
M: unboxed-byte-array operand-class* drop c-ptr ;
|
||||
M: unboxed-byte-array move-spec class ;
|
||||
M: unboxed-byte-array live-vregs* unboxed-byte-array-vreg , ;
|
||||
|
||||
INSTANCE: unboxed-byte-array value
|
||||
|
||||
TUPLE: unboxed-f vreg ;
|
||||
C: <unboxed-f> unboxed-f
|
||||
M: unboxed-f v>operand unboxed-f-vreg v>operand ;
|
||||
M: unboxed-f operand-class* drop \ f ;
|
||||
M: unboxed-f move-spec class ;
|
||||
M: unboxed-f live-vregs* unboxed-f-vreg , ;
|
||||
|
||||
INSTANCE: unboxed-f value
|
||||
|
||||
TUPLE: unboxed-c-ptr vreg ;
|
||||
C: <unboxed-c-ptr> unboxed-c-ptr
|
||||
M: unboxed-c-ptr v>operand unboxed-c-ptr-vreg v>operand ;
|
||||
M: unboxed-c-ptr operand-class* drop c-ptr ;
|
||||
M: unboxed-c-ptr move-spec class ;
|
||||
M: unboxed-c-ptr live-vregs* unboxed-c-ptr-vreg , ;
|
||||
|
||||
INSTANCE: unboxed-c-ptr value
|
||||
|
||||
! A constant value
|
||||
TUPLE: constant value ;
|
||||
C: <constant> constant
|
||||
M: constant operand-class* constant-value class ;
|
||||
M: constant move-spec class ;
|
||||
|
||||
INSTANCE: constant value
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! Moving values between locations and registers
|
||||
: %move-bug ( -- * ) "Bug in generator.registers" throw ;
|
||||
|
||||
: %unbox-c-ptr ( dst src -- )
|
||||
dup operand-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
|
||||
|
||||
: %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.
|
||||
temp-reg over %move
|
||||
operand-class temp-reg
|
||||
tagged new
|
||||
swap >>vreg
|
||||
swap >>class
|
||||
%move ;
|
||||
|
||||
: %move ( dst src -- )
|
||||
2dup [ move-spec ] bi@ 2array {
|
||||
{ { f f } [ %move-bug ] }
|
||||
{ { f unboxed-c-ptr } [ %move-bug ] }
|
||||
{ { f unboxed-byte-array } [ %move-bug ] }
|
||||
|
||||
{ { f constant } [ constant-value swap load-literal ] }
|
||||
|
||||
{ { f float } [ %box-float ] }
|
||||
{ { f unboxed-alien } [ %box-alien ] }
|
||||
{ { f loc } [ %peek ] }
|
||||
|
||||
{ { float f } [ %unbox-float ] }
|
||||
{ { unboxed-alien f } [ %unbox-alien ] }
|
||||
{ { unboxed-byte-array f } [ %unbox-byte-array ] }
|
||||
{ { unboxed-f f } [ %unbox-f ] }
|
||||
{ { unboxed-c-ptr f } [ %unbox-c-ptr ] }
|
||||
{ { loc f } [ swap %replace ] }
|
||||
|
||||
[ drop %move-via-temp ]
|
||||
} case ;
|
||||
|
||||
! A compile-time stack
|
||||
TUPLE: phantom-stack height stack ;
|
||||
|
||||
M: phantom-stack clone
|
||||
call-next-method [ clone ] change-stack ;
|
||||
|
||||
GENERIC: finalize-height ( stack -- )
|
||||
|
||||
: new-phantom-stack ( class -- stack )
|
||||
>r 0 V{ } clone r> boa ; inline
|
||||
|
||||
: (loc) ( m stack -- n )
|
||||
#! Utility for methods on <loc>
|
||||
height>> - ;
|
||||
|
||||
: (finalize-height) ( stack word -- )
|
||||
#! We consolidate multiple stack height changes until the
|
||||
#! last moment, and we emit the final height changing
|
||||
#! instruction here.
|
||||
[
|
||||
over zero? [ 2drop ] [ execute ] if 0
|
||||
] curry change-height drop ; inline
|
||||
|
||||
GENERIC: <loc> ( n stack -- loc )
|
||||
|
||||
TUPLE: phantom-datastack < phantom-stack ;
|
||||
|
||||
: <phantom-datastack> ( -- stack )
|
||||
phantom-datastack new-phantom-stack ;
|
||||
|
||||
M: phantom-datastack <loc> (loc) <ds-loc> ;
|
||||
|
||||
M: phantom-datastack finalize-height
|
||||
\ %inc-d (finalize-height) ;
|
||||
|
||||
TUPLE: phantom-retainstack < phantom-stack ;
|
||||
|
||||
: <phantom-retainstack> ( -- stack )
|
||||
phantom-retainstack new-phantom-stack ;
|
||||
|
||||
M: phantom-retainstack <loc> (loc) <rs-loc> ;
|
||||
|
||||
M: phantom-retainstack finalize-height
|
||||
\ %inc-r (finalize-height) ;
|
||||
|
||||
: phantom-locs ( n phantom -- locs )
|
||||
#! A sequence of n ds-locs or rs-locs indexing the stack.
|
||||
>r <reversed> r> [ <loc> ] curry map ;
|
||||
|
||||
: phantom-locs* ( phantom -- locs )
|
||||
[ stack>> length ] keep phantom-locs ;
|
||||
|
||||
: phantoms ( -- phantom phantom )
|
||||
phantom-datastack get phantom-retainstack get ;
|
||||
|
||||
: (each-loc) ( phantom quot -- )
|
||||
>r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
|
||||
|
||||
: each-loc ( quot -- )
|
||||
phantoms 2array swap [ (each-loc) ] curry each ; inline
|
||||
|
||||
: adjust-phantom ( n phantom -- )
|
||||
swap [ + ] curry change-height drop ;
|
||||
|
||||
: cut-phantom ( n phantom -- seq )
|
||||
swap [ cut* swap ] curry change-stack drop ;
|
||||
|
||||
: phantom-append ( seq stack -- )
|
||||
over length over adjust-phantom stack>> push-all ;
|
||||
|
||||
: add-locs ( n phantom -- )
|
||||
2dup stack>> length <= [
|
||||
2drop
|
||||
] [
|
||||
[ phantom-locs ] keep
|
||||
[ stack>> length head-slice* ] keep
|
||||
[ append >vector ] change-stack drop
|
||||
] if ;
|
||||
|
||||
: phantom-input ( n phantom -- seq )
|
||||
2dup add-locs
|
||||
2dup cut-phantom
|
||||
>r >r neg r> adjust-phantom r> ;
|
||||
|
||||
: each-phantom ( quot -- ) phantoms rot bi@ ; inline
|
||||
|
||||
: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
|
||||
|
||||
: live-vregs ( -- seq )
|
||||
[ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ;
|
||||
|
||||
: (live-locs) ( phantom -- seq )
|
||||
#! Discard locs which haven't moved
|
||||
[ phantom-locs* ] [ stack>> ] bi zip
|
||||
[ live-loc? ] assoc-filter
|
||||
values ;
|
||||
|
||||
: live-locs ( -- seq )
|
||||
[ (live-locs) ] each-phantom append prune ;
|
||||
|
||||
! Operands holding pointers to freshly-allocated objects which
|
||||
! are guaranteed to be in the nursery
|
||||
SYMBOL: fresh-objects
|
||||
|
||||
! Computing free registers and initializing allocator
|
||||
: reg-spec>class ( spec -- class )
|
||||
float eq? double-float-regs int-regs ? ;
|
||||
|
||||
: free-vregs ( reg-class -- seq )
|
||||
#! Free vregs in a given register class
|
||||
\ free-vregs get at ;
|
||||
|
||||
: alloc-vreg ( spec -- reg )
|
||||
[ reg-spec>class free-vregs pop ] keep {
|
||||
{ f [ <tagged> ] }
|
||||
{ unboxed-alien [ <unboxed-alien> ] }
|
||||
{ unboxed-byte-array [ <unboxed-byte-array> ] }
|
||||
{ unboxed-f [ <unboxed-f> ] }
|
||||
{ unboxed-c-ptr [ <unboxed-c-ptr> ] }
|
||||
[ drop ]
|
||||
} case ;
|
||||
|
||||
: compatible? ( value spec -- ? )
|
||||
>r move-spec r> {
|
||||
{ [ 2dup = ] [ t ] }
|
||||
{ [ dup unboxed-c-ptr eq? ] [
|
||||
over { unboxed-byte-array unboxed-alien } member?
|
||||
] }
|
||||
[ f ]
|
||||
} cond 2nip ;
|
||||
|
||||
: allocation ( value spec -- reg-class )
|
||||
{
|
||||
{ [ dup quotation? ] [ 2drop f ] }
|
||||
{ [ 2dup compatible? ] [ 2drop f ] }
|
||||
[ nip reg-spec>class ]
|
||||
} cond ;
|
||||
|
||||
: alloc-vreg-for ( value spec -- vreg )
|
||||
alloc-vreg swap operand-class
|
||||
over tagged? [ >>class ] [ drop ] if ;
|
||||
|
||||
M: value (lazy-load)
|
||||
2dup allocation [
|
||||
dupd alloc-vreg-for dup rot %move
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: (compute-free-vregs) ( used class -- vector )
|
||||
#! Find all vregs in 'class' which are not in 'used'.
|
||||
[ vregs length reverse ] keep
|
||||
[ <vreg> ] curry map swap diff
|
||||
>vector ;
|
||||
|
||||
: compute-free-vregs ( -- )
|
||||
#! Create a new hashtable for thee free-vregs variable.
|
||||
live-vregs
|
||||
{ int-regs double-float-regs }
|
||||
[ 2dup (compute-free-vregs) ] H{ } map>assoc
|
||||
\ free-vregs set
|
||||
drop ;
|
||||
|
||||
M: loc lazy-store
|
||||
2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
|
||||
|
||||
: do-shuffle ( hash -- )
|
||||
dup assoc-empty? [
|
||||
drop
|
||||
] [
|
||||
"live-locs" set
|
||||
[ lazy-store ] each-loc
|
||||
] if ;
|
||||
|
||||
: fast-shuffle ( locs -- )
|
||||
#! We have enough free registers to load all shuffle inputs
|
||||
#! at once
|
||||
[ dup f (lazy-load) ] H{ } map>assoc do-shuffle ;
|
||||
|
||||
: minimal-ds-loc ( phantom -- n )
|
||||
#! When shuffling more values than can fit in registers, we
|
||||
#! need to find an area on the data stack which isn't in
|
||||
#! use.
|
||||
[ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ;
|
||||
|
||||
: find-tmp-loc ( -- n )
|
||||
#! Find an area of the data stack which is not referenced
|
||||
#! from the phantom stacks. We can clobber there all we want
|
||||
[ minimal-ds-loc ] each-phantom min 1- ;
|
||||
|
||||
: slow-shuffle-mapping ( locs tmp -- pairs )
|
||||
>r dup length r>
|
||||
[ swap - <ds-loc> ] curry map zip ;
|
||||
|
||||
: slow-shuffle ( locs -- )
|
||||
#! We don't have enough free registers to load all shuffle
|
||||
#! inputs, so we use a single temporary register, together
|
||||
#! with the area of the data stack above the stack pointer
|
||||
find-tmp-loc slow-shuffle-mapping [
|
||||
[
|
||||
swap dup cached? [ cached-vreg ] when %move
|
||||
] assoc-each
|
||||
] keep >hashtable do-shuffle ;
|
||||
|
||||
: fast-shuffle? ( live-locs -- ? )
|
||||
#! Test if we have enough free registers to load all
|
||||
#! shuffle inputs at once.
|
||||
int-regs free-vregs [ length ] bi@ <= ;
|
||||
|
||||
: finalize-locs ( -- )
|
||||
#! Perform any deferred stack shuffling.
|
||||
[
|
||||
\ free-vregs [ [ clone ] assoc-map ] change
|
||||
live-locs dup fast-shuffle?
|
||||
[ fast-shuffle ] [ slow-shuffle ] if
|
||||
] with-scope ;
|
||||
|
||||
: finalize-vregs ( -- )
|
||||
#! Store any vregs to their final stack locations.
|
||||
[
|
||||
dup loc? over cached? or [ 2drop ] [ %move ] if
|
||||
] each-loc ;
|
||||
|
||||
: reset-phantom ( phantom -- )
|
||||
#! Kill register assignments but preserve constants and
|
||||
#! class information.
|
||||
dup phantom-locs*
|
||||
over stack>> [
|
||||
dup constant? [ nip ] [
|
||||
operand-class over set-operand-class
|
||||
] if
|
||||
] 2map
|
||||
over stack>> delete-all
|
||||
swap stack>> push-all ;
|
||||
|
||||
: reset-phantoms ( -- )
|
||||
[ reset-phantom ] each-phantom ;
|
||||
|
||||
: finalize-contents ( -- )
|
||||
finalize-locs finalize-vregs reset-phantoms ;
|
||||
|
||||
! Loading stacks to vregs
|
||||
: free-vregs? ( int# float# -- ? )
|
||||
double-float-regs free-vregs length <=
|
||||
>r int-regs free-vregs length <= r> and ;
|
||||
|
||||
: phantom&spec ( phantom spec -- phantom' spec' )
|
||||
>r stack>> r>
|
||||
[ length f pad-left ] keep
|
||||
[ <reversed> ] bi@ ; inline
|
||||
|
||||
: phantom&spec-agree? ( phantom spec quot -- ? )
|
||||
>r phantom&spec r> 2all? ; inline
|
||||
|
||||
: vreg-substitution ( value vreg -- pair )
|
||||
dupd <cached> 2array ;
|
||||
|
||||
: substitute-vreg? ( old new -- ? )
|
||||
#! We don't substitute locs for float or alien vregs,
|
||||
#! since in those cases the boxing overhead might kill us.
|
||||
cached-vreg tagged? >r loc? r> and ;
|
||||
|
||||
: substitute-vregs ( values vregs -- )
|
||||
[ vreg-substitution ] 2map
|
||||
[ substitute-vreg? ] assoc-filter >hashtable
|
||||
[ >r stack>> r> substitute-here ] curry each-phantom ;
|
||||
|
||||
: set-operand ( value var -- )
|
||||
>r dup constant? [ constant-value ] when r> set ;
|
||||
|
||||
: lazy-load ( values template -- )
|
||||
#! Set operand vars here.
|
||||
2dup [ first (lazy-load) ] 2map
|
||||
dup rot [ second set-operand ] 2each
|
||||
substitute-vregs ;
|
||||
|
||||
: load-inputs ( -- )
|
||||
+input+ get
|
||||
[ length phantom-datastack get phantom-input ] keep
|
||||
lazy-load ;
|
||||
|
||||
: output-vregs ( -- seq seq )
|
||||
+output+ +clobber+ [ get [ get ] map ] bi@ ;
|
||||
|
||||
: clash? ( seq -- ? )
|
||||
phantoms [ stack>> ] bi@ append [
|
||||
dup cached? [ cached-vreg ] when swap member?
|
||||
] with contains? ;
|
||||
|
||||
: outputs-clash? ( -- ? )
|
||||
output-vregs append clash? ;
|
||||
|
||||
: count-vregs ( reg-classes -- ) [ [ inc ] when* ] each ;
|
||||
|
||||
: count-input-vregs ( phantom spec -- )
|
||||
phantom&spec [
|
||||
>r dup cached? [ cached-vreg ] when r> first allocation
|
||||
] 2map count-vregs ;
|
||||
|
||||
: count-scratch-regs ( spec -- )
|
||||
[ first reg-spec>class ] map count-vregs ;
|
||||
|
||||
: guess-vregs ( dinput rinput scratch -- int# float# )
|
||||
[
|
||||
0 int-regs set
|
||||
0 double-float-regs set
|
||||
count-scratch-regs
|
||||
phantom-retainstack get swap count-input-vregs
|
||||
phantom-datastack get swap count-input-vregs
|
||||
int-regs get double-float-regs get
|
||||
] with-scope ;
|
||||
|
||||
: alloc-scratch ( -- )
|
||||
+scratch+ get [ >r alloc-vreg r> set ] assoc-each ;
|
||||
|
||||
: guess-template-vregs ( -- int# float# )
|
||||
+input+ get { } +scratch+ get guess-vregs ;
|
||||
|
||||
: template-inputs ( -- )
|
||||
! Load input values into registers
|
||||
load-inputs
|
||||
! Allocate scratch registers
|
||||
alloc-scratch
|
||||
! If outputs clash, we write values back to the stack
|
||||
outputs-clash? [ finalize-contents ] when ;
|
||||
|
||||
: template-outputs ( -- )
|
||||
+output+ get [ get ] map phantom-datastack get phantom-append ;
|
||||
|
||||
: 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 quotation? [
|
||||
over constant?
|
||||
[ >r constant-value r> call ] [ 2drop f ] if
|
||||
] [
|
||||
2drop t
|
||||
] if ;
|
||||
|
||||
: class-matches? ( actual expected -- ? )
|
||||
{
|
||||
{ f [ drop t ] }
|
||||
{ known-tag [ dup [ class-tag >boolean ] when ] }
|
||||
[ class<= ]
|
||||
} case ;
|
||||
|
||||
: spec-matches? ( value spec -- ? )
|
||||
2dup first value-matches?
|
||||
>r >r operand-class 2 r> ?nth class-matches? r> and ;
|
||||
|
||||
: template-matches? ( spec -- ? )
|
||||
phantom-datastack get +input+ rot at
|
||||
[ spec-matches? ] phantom&spec-agree? ;
|
||||
|
||||
: ensure-template-vregs ( -- )
|
||||
guess-template-vregs free-vregs? [
|
||||
finalize-contents compute-free-vregs
|
||||
] unless ;
|
||||
|
||||
: clear-phantoms ( -- )
|
||||
[ stack>> delete-all ] each-phantom ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: set-operand-classes ( classes -- )
|
||||
phantom-datastack get
|
||||
over length over add-locs
|
||||
stack>> [ set-operand-class ] 2reverse-each ;
|
||||
|
||||
: end-basic-block ( -- )
|
||||
#! Commit all deferred stacking shuffling, and ensure the
|
||||
#! in-memory data and retain stacks are up to date with
|
||||
#! respect to the compiler's current picture.
|
||||
finalize-contents
|
||||
clear-phantoms
|
||||
finalize-heights
|
||||
fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
|
||||
|
||||
: with-template ( quot hash -- )
|
||||
clone [
|
||||
ensure-template-vregs
|
||||
template-inputs call template-outputs
|
||||
] bind
|
||||
compute-free-vregs ; inline
|
||||
|
||||
: do-template ( pair -- )
|
||||
#! Use with return value from find-template
|
||||
first2 with-template ;
|
||||
|
||||
: fresh-object ( obj -- ) fresh-objects get push ;
|
||||
|
||||
: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
|
||||
|
||||
: init-templates ( -- )
|
||||
#! Initialize register allocator.
|
||||
V{ } clone fresh-objects set
|
||||
<phantom-datastack> phantom-datastack set
|
||||
<phantom-retainstack> phantom-retainstack set
|
||||
compute-free-vregs ;
|
||||
|
||||
: copy-templates ( -- )
|
||||
#! Copies register allocator state, used when compiling
|
||||
#! branches.
|
||||
fresh-objects [ clone ] change
|
||||
phantom-datastack [ clone ] change
|
||||
phantom-retainstack [ clone ] change
|
||||
compute-free-vregs ;
|
||||
|
||||
: find-template ( templates -- pair/f )
|
||||
#! Pair has shape { quot hash }
|
||||
[ second template-matches? ] find nip ;
|
||||
|
||||
: operand-tag ( operand -- tag/f )
|
||||
operand-class dup [ class-tag ] when ;
|
||||
|
||||
UNION: immediate fixnum POSTPONE: f ;
|
||||
|
||||
: operand-immediate? ( operand -- ? )
|
||||
operand-class immediate class<= ;
|
||||
|
||||
: phantom-push ( obj -- )
|
||||
1 phantom-datastack get adjust-phantom
|
||||
phantom-datastack get stack>> push ;
|
||||
|
||||
: phantom-shuffle ( shuffle -- )
|
||||
[ effect-in length phantom-datastack get phantom-input ] keep
|
||||
shuffle* phantom-datastack get phantom-append ;
|
||||
|
||||
: phantom->r ( n -- )
|
||||
phantom-datastack get phantom-input
|
||||
phantom-retainstack get phantom-append ;
|
||||
|
||||
: phantom-r> ( n -- )
|
||||
phantom-retainstack get phantom-input
|
||||
phantom-datastack get phantom-append ;
|
|
@ -0,0 +1 @@
|
|||
Register allocation and intrinsic selection
|
|
@ -0,0 +1 @@
|
|||
Final stage of compilation generates machine code from dataflow IR
|
|
@ -0,0 +1 @@
|
|||
compiler
|
|
@ -21,8 +21,8 @@ MACRO: match-choose ( alist -- )
|
|||
|
||||
MATCH-VARS: ?a ?b ?c ;
|
||||
|
||||
: pretty-shuffle ( in out -- word/f )
|
||||
2array {
|
||||
: pretty-shuffle ( effect -- word/f )
|
||||
[ in>> ] [ out>> ] bi {
|
||||
{ { { } { } } [ ] }
|
||||
{ { { ?a } { ?a } } [ ] }
|
||||
{ { { ?a ?b } { ?a ?b } } [ ] }
|
||||
|
@ -50,13 +50,9 @@ TUPLE: shuffle effect ;
|
|||
|
||||
M: shuffle pprint* effect>> effect>string text ;
|
||||
|
||||
: shuffle-inputs/outputs ( node -- in out )
|
||||
[ in-d>> ] [ out-d>> ] [ mapping>> ] tri
|
||||
[ at ] curry map ;
|
||||
|
||||
M: #shuffle node>quot
|
||||
shuffle-inputs/outputs 2dup pretty-shuffle dup
|
||||
[ 2nip % ] [ drop <effect> shuffle boa , ] if ;
|
||||
shuffle-effect dup pretty-shuffle
|
||||
[ % ] [ shuffle boa , ] ?if ;
|
||||
|
||||
: pushed-literals ( node -- seq )
|
||||
dup out-d>> [ node-value-info literal>> literalize ] with map ;
|
||||
|
|
|
@ -153,6 +153,11 @@ M: #r> inputs/outputs [ in-r>> ] [ out-d>> ] bi ;
|
|||
M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
|
||||
M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
|
||||
|
||||
: shuffle-effect ( #shuffle -- effect )
|
||||
[ in-d>> ] [ out-d>> ] [ mapping>> ] tri
|
||||
[ at ] curry map
|
||||
<effect> ;
|
||||
|
||||
M: vector child-visitor V{ } clone ;
|
||||
M: vector #introduce, #introduce node, ;
|
||||
M: vector #call, #call node, ;
|
||||
|
|
|
@ -28,9 +28,11 @@ loop? ;
|
|||
|
||||
M: inline-recursive hashcode* id>> hashcode* ;
|
||||
|
||||
: inlined-block? ( word -- ? ) "inlined-block" word-prop ;
|
||||
|
||||
: <inline-recursive> ( word -- label )
|
||||
inline-recursive new
|
||||
gensym >>id
|
||||
gensym t "inlined-block" set-word-prop >>id
|
||||
swap >>word ;
|
||||
|
||||
: quotation-param? ( obj -- ? )
|
||||
|
|
Loading…
Reference in New Issue