Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
d776206f9c
|
|
@ -2,6 +2,12 @@ IN: alien.c-types.tests
|
||||||
USING: alien alien.syntax alien.c-types kernel tools.test
|
USING: alien alien.syntax alien.c-types kernel tools.test
|
||||||
sequences system libc alien.strings io.encodings.utf8 ;
|
sequences system libc alien.strings io.encodings.utf8 ;
|
||||||
|
|
||||||
|
\ expand-constants must-infer
|
||||||
|
|
||||||
|
: xyz 123 ;
|
||||||
|
|
||||||
|
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
|
||||||
|
|
||||||
: foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
|
: foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
|
||||||
|
|
||||||
[ 123 ] [ foo ] unit-test
|
[ 123 ] [ foo ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
|
||||||
namespaces parser sequences strings words assocs splitting
|
namespaces parser sequences strings words assocs splitting
|
||||||
math.parser cpu.architecture alien alien.accessors quotations
|
math.parser cpu.architecture alien alien.accessors quotations
|
||||||
layouts system compiler.units io.files io.encodings.binary
|
layouts system compiler.units io.files io.encodings.binary
|
||||||
accessors combinators effects ;
|
accessors combinators effects continuations ;
|
||||||
IN: alien.c-types
|
IN: alien.c-types
|
||||||
|
|
||||||
DEFER: <int>
|
DEFER: <int>
|
||||||
|
|
@ -239,15 +239,20 @@ M: long-long-type box-return ( type -- )
|
||||||
} 2cleave ;
|
} 2cleave ;
|
||||||
|
|
||||||
: expand-constants ( c-type -- c-type' )
|
: expand-constants ( c-type -- c-type' )
|
||||||
#! We use def>> call instead of execute to get around
|
|
||||||
#! staging violations
|
|
||||||
dup array? [
|
dup array? [
|
||||||
unclip >r [ dup word? [ def>> call ] when ] map r> prefix
|
unclip >r [
|
||||||
|
dup word? [
|
||||||
|
def>> { } swap with-datastack first
|
||||||
|
] when
|
||||||
|
] map r> prefix
|
||||||
] when ;
|
] when ;
|
||||||
|
|
||||||
: malloc-file-contents ( path -- alien len )
|
: malloc-file-contents ( path -- alien len )
|
||||||
binary file-contents dup malloc-byte-array swap length ;
|
binary file-contents dup malloc-byte-array swap length ;
|
||||||
|
|
||||||
|
: if-void ( type true false -- )
|
||||||
|
pick "void" = [ drop nip call ] [ nip call ] if ; inline
|
||||||
|
|
||||||
[
|
[
|
||||||
<c-type>
|
<c-type>
|
||||||
[ alien-cell ] >>getter
|
[ alien-cell ] >>getter
|
||||||
|
|
|
||||||
|
|
@ -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,584 @@
|
||||||
|
! 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 math.parser namespaces prettyprint
|
||||||
|
quotations sequences system threads words vectors sets dequeues
|
||||||
|
cursors continuations.private summary alien alien.c-types
|
||||||
|
alien.structs alien.strings alien.arrays libc compiler.errors
|
||||||
|
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 ( nodes 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 ;
|
||||||
|
|
||||||
|
! #alien-invoke
|
||||||
|
: large-struct? ( ctype -- ? )
|
||||||
|
dup c-struct? [
|
||||||
|
heap-size struct-small-enough? not
|
||||||
|
] [ drop f ] if ;
|
||||||
|
|
||||||
|
: alien-parameters ( params -- seq )
|
||||||
|
dup parameters>>
|
||||||
|
swap return>> large-struct? [ "void*" prefix ] when ;
|
||||||
|
|
||||||
|
: alien-return ( params -- ctype )
|
||||||
|
return>> dup large-struct? [ drop "void" ] when ;
|
||||||
|
|
||||||
|
: c-type-stack-align ( type -- align )
|
||||||
|
dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
|
||||||
|
|
||||||
|
: parameter-align ( n type -- n delta )
|
||||||
|
over >r c-type-stack-align align dup r> - ;
|
||||||
|
|
||||||
|
: parameter-sizes ( types -- total offsets )
|
||||||
|
#! Compute stack frame locations.
|
||||||
|
[
|
||||||
|
0 [
|
||||||
|
[ parameter-align drop dup , ] keep stack-size +
|
||||||
|
] reduce cell align
|
||||||
|
] { } make ;
|
||||||
|
|
||||||
|
: return-size ( ctype -- n )
|
||||||
|
#! Amount of space we reserve for a return value.
|
||||||
|
dup large-struct? [ heap-size ] [ drop 0 ] if ;
|
||||||
|
|
||||||
|
: alien-stack-frame ( params -- n )
|
||||||
|
alien-parameters parameter-sizes drop ;
|
||||||
|
|
||||||
|
: alien-invoke-frame ( params -- n )
|
||||||
|
#! One cell is temporary storage, temp@
|
||||||
|
dup return>> return-size
|
||||||
|
swap alien-stack-frame +
|
||||||
|
cell + ;
|
||||||
|
|
||||||
|
: set-stack-frame ( n -- )
|
||||||
|
dup [ frame-required ] when* \ stack-frame set ;
|
||||||
|
|
||||||
|
: with-stack-frame ( n quot -- )
|
||||||
|
swap set-stack-frame
|
||||||
|
call
|
||||||
|
f set-stack-frame ; inline
|
||||||
|
|
||||||
|
GENERIC: reg-size ( register-class -- n )
|
||||||
|
|
||||||
|
M: int-regs reg-size drop cell ;
|
||||||
|
|
||||||
|
M: single-float-regs reg-size drop 4 ;
|
||||||
|
|
||||||
|
M: double-float-regs reg-size drop 8 ;
|
||||||
|
|
||||||
|
GENERIC: reg-class-variable ( register-class -- symbol )
|
||||||
|
|
||||||
|
M: reg-class reg-class-variable ;
|
||||||
|
|
||||||
|
M: float-regs reg-class-variable drop float-regs ;
|
||||||
|
|
||||||
|
GENERIC: inc-reg-class ( register-class -- )
|
||||||
|
|
||||||
|
M: reg-class inc-reg-class
|
||||||
|
dup reg-class-variable inc
|
||||||
|
fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
|
||||||
|
|
||||||
|
M: float-regs inc-reg-class
|
||||||
|
dup call-next-method
|
||||||
|
fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
|
||||||
|
|
||||||
|
: reg-class-full? ( class -- ? )
|
||||||
|
[ reg-class-variable get ] [ param-regs length ] bi >= ;
|
||||||
|
|
||||||
|
: spill-param ( reg-class -- n reg-class )
|
||||||
|
stack-params get
|
||||||
|
>r reg-size stack-params +@ r>
|
||||||
|
stack-params ;
|
||||||
|
|
||||||
|
: fastcall-param ( reg-class -- n reg-class )
|
||||||
|
[ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
|
||||||
|
|
||||||
|
: alloc-parameter ( parameter -- reg reg-class )
|
||||||
|
c-type-reg-class dup reg-class-full?
|
||||||
|
[ spill-param ] [ fastcall-param ] if
|
||||||
|
[ param-reg ] keep ;
|
||||||
|
|
||||||
|
: (flatten-int-type) ( size -- )
|
||||||
|
cell /i "void*" c-type <repetition> % ;
|
||||||
|
|
||||||
|
GENERIC: flatten-value-type ( type -- )
|
||||||
|
|
||||||
|
M: object flatten-value-type , ;
|
||||||
|
|
||||||
|
M: struct-type flatten-value-type ( type -- )
|
||||||
|
stack-size cell align (flatten-int-type) ;
|
||||||
|
|
||||||
|
M: long-long-type flatten-value-type ( type -- )
|
||||||
|
stack-size cell align (flatten-int-type) ;
|
||||||
|
|
||||||
|
: flatten-value-types ( params -- params )
|
||||||
|
#! Convert value type structs to consecutive void*s.
|
||||||
|
[
|
||||||
|
0 [
|
||||||
|
c-type
|
||||||
|
[ parameter-align (flatten-int-type) ] keep
|
||||||
|
[ stack-size cell align + ] keep
|
||||||
|
flatten-value-type
|
||||||
|
] reduce drop
|
||||||
|
] { } make ;
|
||||||
|
|
||||||
|
: each-parameter ( parameters quot -- )
|
||||||
|
>r [ parameter-sizes nip ] keep r> 2each ; inline
|
||||||
|
|
||||||
|
: reverse-each-parameter ( parameters quot -- )
|
||||||
|
>r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
|
||||||
|
|
||||||
|
: reset-freg-counts ( -- )
|
||||||
|
{ int-regs float-regs stack-params } [ 0 swap set ] each ;
|
||||||
|
|
||||||
|
: with-param-regs ( quot -- )
|
||||||
|
#! In quot you can call alloc-parameter
|
||||||
|
[ reset-freg-counts call ] with-scope ; inline
|
||||||
|
|
||||||
|
: move-parameters ( node word -- )
|
||||||
|
#! Moves values from C stack to registers (if word is
|
||||||
|
#! %load-param-reg) and registers to C stack (if word is
|
||||||
|
#! %save-param-reg).
|
||||||
|
>r
|
||||||
|
alien-parameters
|
||||||
|
flatten-value-types
|
||||||
|
r> [ >r alloc-parameter r> execute ] curry each-parameter ;
|
||||||
|
inline
|
||||||
|
|
||||||
|
: unbox-parameters ( offset node -- )
|
||||||
|
parameters>> [
|
||||||
|
%prepare-unbox >r over + r> unbox-parameter
|
||||||
|
] reverse-each-parameter drop ;
|
||||||
|
|
||||||
|
: prepare-box-struct ( node -- offset )
|
||||||
|
#! Return offset on C stack where to store unboxed
|
||||||
|
#! parameters. If the C function is returning a structure,
|
||||||
|
#! the first parameter is an implicit target area pointer,
|
||||||
|
#! so we need to use a different offset.
|
||||||
|
return>> dup large-struct?
|
||||||
|
[ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
|
||||||
|
|
||||||
|
: objects>registers ( params -- )
|
||||||
|
#! Generate code for unboxing a list of C types, then
|
||||||
|
#! generate code for moving these parameters to register on
|
||||||
|
#! architectures where parameters are passed in registers.
|
||||||
|
[
|
||||||
|
[ prepare-box-struct ] keep
|
||||||
|
[ unbox-parameters ] keep
|
||||||
|
\ %load-param-reg move-parameters
|
||||||
|
] with-param-regs ;
|
||||||
|
|
||||||
|
: box-return* ( node -- )
|
||||||
|
return>> [ ] [ box-return ] if-void ;
|
||||||
|
|
||||||
|
TUPLE: no-such-library name ;
|
||||||
|
|
||||||
|
M: no-such-library summary
|
||||||
|
drop "Library not found" ;
|
||||||
|
|
||||||
|
M: no-such-library compiler-error-type
|
||||||
|
drop +linkage+ ;
|
||||||
|
|
||||||
|
: no-such-library ( name -- )
|
||||||
|
\ no-such-library boa
|
||||||
|
compiling-word get compiler-error ;
|
||||||
|
|
||||||
|
TUPLE: no-such-symbol name ;
|
||||||
|
|
||||||
|
M: no-such-symbol summary
|
||||||
|
drop "Symbol not found" ;
|
||||||
|
|
||||||
|
M: no-such-symbol compiler-error-type
|
||||||
|
drop +linkage+ ;
|
||||||
|
|
||||||
|
: no-such-symbol ( name -- )
|
||||||
|
\ no-such-symbol boa
|
||||||
|
compiling-word get compiler-error ;
|
||||||
|
|
||||||
|
: check-dlsym ( symbols dll -- )
|
||||||
|
dup dll-valid? [
|
||||||
|
dupd [ dlsym ] curry contains?
|
||||||
|
[ drop ] [ no-such-symbol ] if
|
||||||
|
] [
|
||||||
|
dll-path no-such-library drop
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: stdcall-mangle ( symbol node -- symbol )
|
||||||
|
"@"
|
||||||
|
swap parameters>> parameter-sizes drop
|
||||||
|
number>string 3append ;
|
||||||
|
|
||||||
|
: alien-invoke-dlsym ( params -- symbols dll )
|
||||||
|
dup function>> dup pick stdcall-mangle 2array
|
||||||
|
swap library>> library dup [ dll>> ] when
|
||||||
|
2dup check-dlsym ;
|
||||||
|
|
||||||
|
M: #alien-invoke generate-node
|
||||||
|
params>>
|
||||||
|
dup alien-invoke-frame [
|
||||||
|
end-basic-block
|
||||||
|
%prepare-alien-invoke
|
||||||
|
dup objects>registers
|
||||||
|
%prepare-var-args
|
||||||
|
dup alien-invoke-dlsym %alien-invoke
|
||||||
|
dup %cleanup
|
||||||
|
box-return*
|
||||||
|
iterate-next
|
||||||
|
] with-stack-frame ;
|
||||||
|
|
||||||
|
! #alien-indirect
|
||||||
|
M: #alien-indirect generate-node
|
||||||
|
params>>
|
||||||
|
dup alien-invoke-frame [
|
||||||
|
! Flush registers
|
||||||
|
end-basic-block
|
||||||
|
! Save registers for GC
|
||||||
|
%prepare-alien-invoke
|
||||||
|
! Save alien at top of stack to temporary storage
|
||||||
|
%prepare-alien-indirect
|
||||||
|
dup objects>registers
|
||||||
|
%prepare-var-args
|
||||||
|
! Call alien in temporary storage
|
||||||
|
%alien-indirect
|
||||||
|
dup %cleanup
|
||||||
|
box-return*
|
||||||
|
iterate-next
|
||||||
|
] with-stack-frame ;
|
||||||
|
|
||||||
|
! #alien-callback
|
||||||
|
: box-parameters ( params -- )
|
||||||
|
alien-parameters [ box-parameter ] each-parameter ;
|
||||||
|
|
||||||
|
: registers>objects ( node -- )
|
||||||
|
[
|
||||||
|
dup \ %save-param-reg move-parameters
|
||||||
|
"nest_stacks" f %alien-invoke
|
||||||
|
box-parameters
|
||||||
|
] with-param-regs ;
|
||||||
|
|
||||||
|
TUPLE: callback-context ;
|
||||||
|
|
||||||
|
: current-callback 2 getenv ;
|
||||||
|
|
||||||
|
: wait-to-return ( token -- )
|
||||||
|
dup current-callback eq? [
|
||||||
|
drop
|
||||||
|
] [
|
||||||
|
yield wait-to-return
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: do-callback ( quot token -- )
|
||||||
|
init-catchstack
|
||||||
|
dup 2 setenv
|
||||||
|
slip
|
||||||
|
wait-to-return ; inline
|
||||||
|
|
||||||
|
: callback-return-quot ( ctype -- quot )
|
||||||
|
return>> {
|
||||||
|
{ [ dup "void" = ] [ drop [ ] ] }
|
||||||
|
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
|
||||||
|
[ c-type c-type-unboxer-quot ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: callback-prep-quot ( params -- quot )
|
||||||
|
parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
|
||||||
|
|
||||||
|
: wrap-callback-quot ( params -- quot )
|
||||||
|
[
|
||||||
|
[ callback-prep-quot ]
|
||||||
|
[ quot>> ]
|
||||||
|
[ callback-return-quot ] tri 3append ,
|
||||||
|
[ callback-context new do-callback ] %
|
||||||
|
] [ ] make ;
|
||||||
|
|
||||||
|
: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
|
||||||
|
|
||||||
|
: callback-unwind ( params -- n )
|
||||||
|
{
|
||||||
|
{ [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
|
||||||
|
{ [ dup return>> large-struct? ] [ drop 4 ] }
|
||||||
|
[ drop 0 ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: %callback-return ( params -- )
|
||||||
|
#! All the extra book-keeping for %unwind is only for x86.
|
||||||
|
#! On other platforms its an alias for %return.
|
||||||
|
dup alien-return
|
||||||
|
[ %unnest-stacks ] [ %callback-value ] if-void
|
||||||
|
callback-unwind %unwind ;
|
||||||
|
|
||||||
|
: generate-callback ( params -- )
|
||||||
|
dup xt>> dup [
|
||||||
|
init-templates
|
||||||
|
%prologue-later
|
||||||
|
dup alien-stack-frame [
|
||||||
|
[ registers>objects ]
|
||||||
|
[ wrap-callback-quot %alien-callback ]
|
||||||
|
[ %callback-return ]
|
||||||
|
tri
|
||||||
|
] with-stack-frame
|
||||||
|
] with-generator ;
|
||||||
|
|
||||||
|
M: #alien-callback generate-node
|
||||||
|
end-basic-block
|
||||||
|
params>> generate-callback iterate-next ;
|
||||||
|
|
@ -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
|
||||||
|
|
@ -35,6 +35,12 @@ M: #phi backward
|
||||||
[ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ]
|
[ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ]
|
||||||
2bi ;
|
2bi ;
|
||||||
|
|
||||||
|
M: #alien-invoke backward
|
||||||
|
nip [ look-at-inputs ] [ look-at-outputs ] bi ;
|
||||||
|
|
||||||
|
M: #alien-indirect backward
|
||||||
|
nip [ look-at-inputs ] [ look-at-outputs ] bi ;
|
||||||
|
|
||||||
M: node backward 2drop ;
|
M: node backward 2drop ;
|
||||||
|
|
||||||
: backward-dfa ( node quot -- assoc ) [ backward ] dfa ; inline
|
: backward-dfa ( node quot -- assoc ) [ backward ] dfa ; inline
|
||||||
|
|
|
||||||
|
|
@ -23,6 +23,12 @@ M: #call mark-live-values
|
||||||
dup word>> "flushable" word-prop
|
dup word>> "flushable" word-prop
|
||||||
[ drop ] [ [ look-at-inputs ] [ look-at-outputs ] bi ] if ;
|
[ drop ] [ [ look-at-inputs ] [ look-at-outputs ] bi ] if ;
|
||||||
|
|
||||||
|
M: #alien-invoke mark-live-values
|
||||||
|
[ look-at-inputs ] [ look-at-outputs ] bi ;
|
||||||
|
|
||||||
|
M: #alien-indirect mark-live-values
|
||||||
|
[ look-at-inputs ] [ look-at-outputs ] bi ;
|
||||||
|
|
||||||
M: #return mark-live-values
|
M: #return mark-live-values
|
||||||
look-at-inputs ;
|
look-at-inputs ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,5 @@
|
||||||
IN: compiler.tree.debugger.tests
|
IN: compiler.tree.debugger.tests
|
||||||
USING: compiler.tree.debugger tools.test ;
|
USING: compiler.tree.debugger tools.test ;
|
||||||
|
|
||||||
\ optimized-quot. must-infer
|
\ optimized. must-infer
|
||||||
\ optimized-word. must-infer
|
|
||||||
\ optimizer-report. must-infer
|
\ optimizer-report. must-infer
|
||||||
|
|
|
||||||
|
|
@ -21,8 +21,8 @@ MACRO: match-choose ( alist -- )
|
||||||
|
|
||||||
MATCH-VARS: ?a ?b ?c ;
|
MATCH-VARS: ?a ?b ?c ;
|
||||||
|
|
||||||
: pretty-shuffle ( in out -- word/f )
|
: pretty-shuffle ( effect -- word/f )
|
||||||
2array {
|
[ in>> ] [ out>> ] bi 2array {
|
||||||
{ { { } { } } [ ] }
|
{ { { } { } } [ ] }
|
||||||
{ { { ?a } { ?a } } [ ] }
|
{ { { ?a } { ?a } } [ ] }
|
||||||
{ { { ?a ?b } { ?a ?b } } [ ] }
|
{ { { ?a ?b } { ?a ?b } } [ ] }
|
||||||
|
|
@ -50,13 +50,9 @@ TUPLE: shuffle effect ;
|
||||||
|
|
||||||
M: shuffle pprint* effect>> effect>string text ;
|
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
|
M: #shuffle node>quot
|
||||||
shuffle-inputs/outputs 2dup pretty-shuffle dup
|
shuffle-effect dup pretty-shuffle
|
||||||
[ 2nip % ] [ drop <effect> shuffle boa , ] if ;
|
[ % ] [ shuffle boa , ] ?if ;
|
||||||
|
|
||||||
: pushed-literals ( node -- seq )
|
: pushed-literals ( node -- seq )
|
||||||
dup out-d>> [ node-value-info literal>> literalize ] with map ;
|
dup out-d>> [ node-value-info literal>> literalize ] with map ;
|
||||||
|
|
|
||||||
|
|
@ -80,3 +80,13 @@ M: #call escape-analysis*
|
||||||
|
|
||||||
M: #return escape-analysis*
|
M: #return escape-analysis*
|
||||||
in-d>> add-escaping-values ;
|
in-d>> add-escaping-values ;
|
||||||
|
|
||||||
|
M: #alien-invoke escape-analysis*
|
||||||
|
[ in-d>> add-escaping-values ]
|
||||||
|
[ out-d>> unknown-allocation ]
|
||||||
|
bi ;
|
||||||
|
|
||||||
|
M: #alien-indirect escape-analysis*
|
||||||
|
[ in-d>> add-escaping-values ]
|
||||||
|
[ out-d>> unknown-allocation ]
|
||||||
|
bi ;
|
||||||
|
|
|
||||||
|
|
@ -115,3 +115,9 @@ M: #call propagate-before
|
||||||
M: #call propagate-after
|
M: #call propagate-after
|
||||||
dup word>> "input-classes" word-prop dup
|
dup word>> "input-classes" word-prop dup
|
||||||
[ propagate-input-classes ] [ 2drop ] if ;
|
[ propagate-input-classes ] [ 2drop ] if ;
|
||||||
|
|
||||||
|
M: #alien-invoke propagate-before
|
||||||
|
out-d>> [ object-info swap set-value-info ] each ;
|
||||||
|
|
||||||
|
M: #alien-indirect propagate-before
|
||||||
|
out-d>> [ object-info swap set-value-info ] each ;
|
||||||
|
|
|
||||||
|
|
@ -143,6 +143,30 @@ TUPLE: #copy < #renaming in-d out-d ;
|
||||||
swap >>out-d
|
swap >>out-d
|
||||||
swap >>in-d ;
|
swap >>in-d ;
|
||||||
|
|
||||||
|
TUPLE: #alien-node < node params ;
|
||||||
|
|
||||||
|
: new-alien-node ( params class -- node )
|
||||||
|
new
|
||||||
|
over in-d>> >>in-d
|
||||||
|
over out-d>> >>out-d
|
||||||
|
swap >>params ; inline
|
||||||
|
|
||||||
|
TUPLE: #alien-invoke < #alien-node in-d out-d ;
|
||||||
|
|
||||||
|
: #alien-invoke ( params -- node )
|
||||||
|
\ #alien-invoke new-alien-node ;
|
||||||
|
|
||||||
|
TUPLE: #alien-indirect < #alien-node in-d out-d ;
|
||||||
|
|
||||||
|
: #alien-indirect ( params -- node )
|
||||||
|
\ #alien-indirect new-alien-node ;
|
||||||
|
|
||||||
|
TUPLE: #alien-callback < #alien-node ;
|
||||||
|
|
||||||
|
: #alien-callback ( params -- node )
|
||||||
|
\ #alien-callback new
|
||||||
|
swap >>params ;
|
||||||
|
|
||||||
: node, ( node -- ) stack-visitor get push ;
|
: node, ( node -- ) stack-visitor get push ;
|
||||||
|
|
||||||
GENERIC: inputs/outputs ( #renaming -- inputs outputs )
|
GENERIC: inputs/outputs ( #renaming -- inputs outputs )
|
||||||
|
|
@ -153,6 +177,11 @@ M: #r> inputs/outputs [ in-r>> ] [ out-d>> ] bi ;
|
||||||
M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
|
M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
|
||||||
M: #return-recursive 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 child-visitor V{ } clone ;
|
||||||
M: vector #introduce, #introduce node, ;
|
M: vector #introduce, #introduce node, ;
|
||||||
M: vector #call, #call node, ;
|
M: vector #call, #call node, ;
|
||||||
|
|
@ -172,3 +201,6 @@ M: vector #phi, #phi node, ;
|
||||||
M: vector #declare, #declare node, ;
|
M: vector #declare, #declare node, ;
|
||||||
M: vector #recursive, #recursive node, ;
|
M: vector #recursive, #recursive node, ;
|
||||||
M: vector #copy, #copy node, ;
|
M: vector #copy, #copy node, ;
|
||||||
|
M: vector #alien-invoke, #alien-invoke node, ;
|
||||||
|
M: vector #alien-indirect, #alien-indirect node, ;
|
||||||
|
M: vector #alien-callback, #alien-callback node, ;
|
||||||
|
|
|
||||||
|
|
@ -128,4 +128,8 @@ M: #return unbox-tuples* dup in-d>> assert-not-unboxed ;
|
||||||
|
|
||||||
M: #introduce unbox-tuples* dup value>> assert-not-unboxed ;
|
M: #introduce unbox-tuples* dup value>> assert-not-unboxed ;
|
||||||
|
|
||||||
|
M: #alien-invoke unbox-tuples* dup in-d>> assert-not-unboxed ;
|
||||||
|
|
||||||
|
M: #alien-indirect unbox-tuples* dup in-d>> assert-not-unboxed ;
|
||||||
|
|
||||||
: unbox-tuples ( nodes -- nodes ) [ unbox-tuples* ] map-nodes ;
|
: unbox-tuples ( nodes -- nodes ) [ unbox-tuples* ] map-nodes ;
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,84 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: kernel sequences accessors combinators math namespaces
|
||||||
|
init sets words
|
||||||
|
alien alien.c-types
|
||||||
|
stack-checker.backend stack-checker.errors stack-checker.visitor ;
|
||||||
|
IN: stack-checker.alien
|
||||||
|
|
||||||
|
TUPLE: alien-node-params return parameters abi in-d out-d ;
|
||||||
|
|
||||||
|
TUPLE: alien-invoke-params < alien-node-params library function ;
|
||||||
|
|
||||||
|
TUPLE: alien-indirect-params < alien-node-params ;
|
||||||
|
|
||||||
|
TUPLE: alien-callback-params < alien-node-params quot xt ;
|
||||||
|
|
||||||
|
: pop-parameters ( -- seq )
|
||||||
|
pop-literal nip [ expand-constants ] map ;
|
||||||
|
|
||||||
|
: param-prep-quot ( node -- quot )
|
||||||
|
parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
|
||||||
|
|
||||||
|
: alien-stack ( params extra -- )
|
||||||
|
over parameters>> length + consume-d >>in-d
|
||||||
|
dup return>> "void" = 0 1 ? produce-d >>out-d
|
||||||
|
drop ;
|
||||||
|
|
||||||
|
: return-prep-quot ( node -- quot )
|
||||||
|
return>> [ [ ] ] [ c-type c-type-boxer-quot ] if-void ;
|
||||||
|
|
||||||
|
: infer-alien-invoke ( -- )
|
||||||
|
alien-invoke-params new
|
||||||
|
! Compile-time parameters
|
||||||
|
pop-parameters >>parameters
|
||||||
|
pop-literal nip >>function
|
||||||
|
pop-literal nip >>library
|
||||||
|
pop-literal nip >>return
|
||||||
|
! Quotation which coerces parameters to required types
|
||||||
|
dup param-prep-quot recursive-state get infer-quot
|
||||||
|
! Set ABI
|
||||||
|
dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
|
||||||
|
! Magic #: consume exactly the number of inputs
|
||||||
|
dup 0 alien-stack
|
||||||
|
! Add node to IR
|
||||||
|
dup #alien-invoke,
|
||||||
|
! Quotation which coerces return value to required type
|
||||||
|
return-prep-quot recursive-state get infer-quot ;
|
||||||
|
|
||||||
|
: infer-alien-indirect ( -- )
|
||||||
|
alien-indirect-params new
|
||||||
|
! Compile-time parameters
|
||||||
|
pop-literal nip >>abi
|
||||||
|
pop-parameters >>parameters
|
||||||
|
pop-literal nip >>return
|
||||||
|
! Quotation which coerces parameters to required types
|
||||||
|
dup param-prep-quot [ dip ] curry recursive-state get infer-quot
|
||||||
|
! Magic #: consume the function pointer, too
|
||||||
|
dup 1 alien-stack
|
||||||
|
! Add node to IR
|
||||||
|
dup #alien-indirect,
|
||||||
|
! Quotation which coerces return value to required type
|
||||||
|
return-prep-quot recursive-state get infer-quot ;
|
||||||
|
|
||||||
|
! Callbacks are registered in a global hashtable. If you clear
|
||||||
|
! this hashtable, they will all be blown away by code GC, beware
|
||||||
|
SYMBOL: callbacks
|
||||||
|
|
||||||
|
[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
|
||||||
|
|
||||||
|
: register-callback ( word -- ) callbacks get conjoin ;
|
||||||
|
|
||||||
|
: callback-bottom ( params -- )
|
||||||
|
xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
|
||||||
|
recursive-state get infer-quot ;
|
||||||
|
|
||||||
|
: infer-alien-callback ( -- )
|
||||||
|
alien-callback-params new
|
||||||
|
pop-literal nip >>quot
|
||||||
|
pop-literal nip >>abi
|
||||||
|
pop-parameters >>parameters
|
||||||
|
pop-literal nip >>return
|
||||||
|
gensym >>xt
|
||||||
|
dup callback-bottom
|
||||||
|
#alien-callback, ;
|
||||||
|
|
@ -28,9 +28,11 @@ loop? ;
|
||||||
|
|
||||||
M: inline-recursive hashcode* id>> hashcode* ;
|
M: inline-recursive hashcode* id>> hashcode* ;
|
||||||
|
|
||||||
|
: inlined-block? ( word -- ? ) "inlined-block" word-prop ;
|
||||||
|
|
||||||
: <inline-recursive> ( word -- label )
|
: <inline-recursive> ( word -- label )
|
||||||
inline-recursive new
|
inline-recursive new
|
||||||
gensym >>id
|
gensym dup t "inlined-block" set-word-prop >>id
|
||||||
swap >>word ;
|
swap >>word ;
|
||||||
|
|
||||||
: quotation-param? ( obj -- ? )
|
: quotation-param? ( obj -- ? )
|
||||||
|
|
|
||||||
|
|
@ -10,10 +10,14 @@ sequences sequences.private slots.private strings
|
||||||
strings.private system threads.private classes.tuple
|
strings.private system threads.private classes.tuple
|
||||||
classes.tuple.private vectors vectors.private words definitions
|
classes.tuple.private vectors vectors.private words definitions
|
||||||
words.private assocs summary compiler.units system.private
|
words.private assocs summary compiler.units system.private
|
||||||
combinators locals.backend stack-checker.state
|
combinators locals.backend
|
||||||
stack-checker.backend stack-checker.branches
|
stack-checker.state
|
||||||
stack-checker.errors stack-checker.transforms
|
stack-checker.backend
|
||||||
stack-checker.visitor ;
|
stack-checker.branches
|
||||||
|
stack-checker.errors
|
||||||
|
stack-checker.transforms
|
||||||
|
stack-checker.visitor
|
||||||
|
stack-checker.alien ;
|
||||||
IN: stack-checker.known-words
|
IN: stack-checker.known-words
|
||||||
|
|
||||||
: infer-primitive ( word -- )
|
: infer-primitive ( word -- )
|
||||||
|
|
@ -153,13 +157,15 @@ M: object infer-call*
|
||||||
{ \ get-local [ infer-get-local ] }
|
{ \ get-local [ infer-get-local ] }
|
||||||
{ \ drop-locals [ infer-drop-locals ] }
|
{ \ drop-locals [ infer-drop-locals ] }
|
||||||
{ \ do-primitive [ \ do-primitive cannot-infer-effect ] }
|
{ \ do-primitive [ \ do-primitive cannot-infer-effect ] }
|
||||||
|
{ \ alien-invoke [ infer-alien-invoke ] }
|
||||||
|
{ \ alien-indirect [ infer-alien-indirect ] }
|
||||||
|
{ \ alien-callback [ infer-alien-callback ] }
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
{
|
{
|
||||||
>r r> declare call curry compose
|
>r r> declare call curry compose execute if dispatch
|
||||||
execute if dispatch <tuple-boa>
|
<tuple-boa> (throw) load-locals get-local drop-locals
|
||||||
(throw) load-locals get-local drop-locals
|
do-primitive alien-invoke alien-indirect alien-callback
|
||||||
do-primitive
|
|
||||||
} [ t +special+ set-word-prop ] each
|
} [ t +special+ set-word-prop ] each
|
||||||
|
|
||||||
{ call execute dispatch load-locals get-local drop-locals }
|
{ call execute dispatch load-locals get-local drop-locals }
|
||||||
|
|
@ -173,10 +179,10 @@ SYMBOL: +primitive+
|
||||||
{ [ dup +shuffle+ word-prop ] [ infer-shuffle-word ] }
|
{ [ dup +shuffle+ word-prop ] [ infer-shuffle-word ] }
|
||||||
{ [ dup +special+ word-prop ] [ infer-special ] }
|
{ [ dup +special+ word-prop ] [ infer-special ] }
|
||||||
{ [ dup +primitive+ word-prop ] [ infer-primitive ] }
|
{ [ dup +primitive+ word-prop ] [ infer-primitive ] }
|
||||||
{ [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
|
|
||||||
{ [ dup +transform-quot+ word-prop ] [ apply-transform ] }
|
{ [ dup +transform-quot+ word-prop ] [ apply-transform ] }
|
||||||
{ [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
|
|
||||||
{ [ dup "macro" word-prop ] [ apply-macro ] }
|
{ [ dup "macro" word-prop ] [ apply-macro ] }
|
||||||
|
{ [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
|
||||||
|
{ [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
|
||||||
{ [ dup recursive-label ] [ call-recursive-word ] }
|
{ [ dup recursive-label ] [ call-recursive-word ] }
|
||||||
[ dup infer-word apply-word/effect ]
|
[ dup infer-word apply-word/effect ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
|
||||||
|
|
@ -23,10 +23,11 @@ SYMBOL: +transform-n+
|
||||||
inline
|
inline
|
||||||
|
|
||||||
: (apply-transform) ( word quot n -- )
|
: (apply-transform) ( word quot n -- )
|
||||||
consume-d dup [ known literal? ] all? [
|
dup ensure-d [ known literal? ] all? [
|
||||||
dup empty? [
|
dup empty? [
|
||||||
drop recursive-state get 1array
|
drop recursive-state get 1array
|
||||||
] [
|
] [
|
||||||
|
consume-d
|
||||||
[ #drop, ]
|
[ #drop, ]
|
||||||
[ [ literal value>> ] map ]
|
[ [ literal value>> ] map ]
|
||||||
[ first literal recursion>> ] tri prefix
|
[ first literal recursion>> ] tri prefix
|
||||||
|
|
@ -123,7 +124,6 @@ SYMBOL: +transform-n+
|
||||||
|
|
||||||
: bit-member-quot ( seq -- newquot )
|
: bit-member-quot ( seq -- newquot )
|
||||||
[
|
[
|
||||||
[ drop ] % ! drop the sequence itself; we don't use it at run time
|
|
||||||
bit-member-seq ,
|
bit-member-seq ,
|
||||||
[
|
[
|
||||||
{
|
{
|
||||||
|
|
@ -140,7 +140,7 @@ SYMBOL: +transform-n+
|
||||||
bit-member-quot
|
bit-member-quot
|
||||||
] [
|
] [
|
||||||
[ literalize [ t ] ] { } map>assoc
|
[ literalize [ t ] ] { } map>assoc
|
||||||
[ drop f ] suffix [ nip case ] curry
|
[ drop f ] suffix [ case ] curry
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
\ member? [
|
\ member? [
|
||||||
|
|
|
||||||
|
|
@ -22,3 +22,6 @@ M: f #declare, drop ;
|
||||||
M: f #recursive, 2drop 2drop ;
|
M: f #recursive, 2drop 2drop ;
|
||||||
M: f #copy, 2drop ;
|
M: f #copy, 2drop ;
|
||||||
M: f #drop, drop ;
|
M: f #drop, drop ;
|
||||||
|
M: f #alien-invoke, drop ;
|
||||||
|
M: f #alien-indirect, drop ;
|
||||||
|
M: f #alien-callback, drop ;
|
||||||
|
|
|
||||||
|
|
@ -27,3 +27,6 @@ HOOK: #enter-recursive, stack-visitor ( label inputs outputs -- )
|
||||||
HOOK: #return-recursive, stack-visitor ( label inputs outputs -- )
|
HOOK: #return-recursive, stack-visitor ( label inputs outputs -- )
|
||||||
HOOK: #recursive, stack-visitor ( word label inputs visitor -- )
|
HOOK: #recursive, stack-visitor ( word label inputs visitor -- )
|
||||||
HOOK: #copy, stack-visitor ( inputs outputs -- )
|
HOOK: #copy, stack-visitor ( inputs outputs -- )
|
||||||
|
HOOK: #alien-invoke, stack-visitor ( params -- )
|
||||||
|
HOOK: #alien-indirect, stack-visitor ( params -- )
|
||||||
|
HOOK: #alien-callback, stack-visitor ( params -- )
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue