Updating codegen for new optimizer

db4
Slava Pestov 2008-08-11 23:30:18 -05:00
parent ed848621a3
commit d42edecffb
16 changed files with 1247 additions and 9 deletions

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -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."
} ;

View File

@ -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 ;

View File

@ -0,0 +1 @@
Support for generation of relocatable code

View File

@ -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." } ;

View File

@ -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 ;

View File

@ -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? ;

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -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 ;

View File

@ -0,0 +1 @@
Register allocation and intrinsic selection

View File

@ -0,0 +1 @@
Final stage of compilation generates machine code from dataflow IR

View File

@ -0,0 +1 @@
compiler

View File

@ -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 ;

View File

@ -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, ;

View File

@ -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 -- ? )