Merge branch 'master' of git://factorcode.org/git/factor
Eduardo Cavazos
commit
6e442f5226
|
|
@ -1,417 +0,0 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generator generator.registers generator.fixup
|
||||
hashtables kernel math namespaces sequences words
|
||||
inference.state inference.backend inference.dataflow system
|
||||
math.parser classes alien.arrays alien.c-types alien.strings
|
||||
alien.structs alien.syntax cpu.architecture alien summary
|
||||
quotations assocs kernel.private threads continuations.private
|
||||
libc combinators compiler.errors continuations layouts accessors
|
||||
init sets ;
|
||||
IN: alien.compiler
|
||||
|
||||
TUPLE: #alien-node < node return parameters abi ;
|
||||
|
||||
TUPLE: #alien-callback < #alien-node quot xt ;
|
||||
|
||||
TUPLE: #alien-indirect < #alien-node ;
|
||||
|
||||
TUPLE: #alien-invoke < #alien-node library function ;
|
||||
|
||||
: large-struct? ( ctype -- ? )
|
||||
dup c-struct? [
|
||||
heap-size struct-small-enough? not
|
||||
] [ drop f ] if ;
|
||||
|
||||
: alien-node-parameters* ( node -- seq )
|
||||
dup parameters>>
|
||||
swap return>> large-struct? [ "void*" prefix ] when ;
|
||||
|
||||
: alien-node-return* ( node -- 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 ( node -- n )
|
||||
alien-node-parameters* parameter-sizes drop ;
|
||||
|
||||
: alien-invoke-frame ( node -- 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-node-parameters*
|
||||
flatten-value-types
|
||||
r> [ >r alloc-parameter r> execute ] curry each-parameter ;
|
||||
inline
|
||||
|
||||
: if-void ( type true false -- )
|
||||
pick "void" = [ drop nip call ] [ nip call ] if ; inline
|
||||
|
||||
: alien-invoke-stack ( node extra -- )
|
||||
over parameters>> length + dup reify-curries
|
||||
over consume-values
|
||||
dup return>> "void" = 0 1 ?
|
||||
swap produce-values ;
|
||||
|
||||
: param-prep-quot ( node -- quot )
|
||||
parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
|
||||
|
||||
: 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 ( node -- )
|
||||
#! 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 ;
|
||||
|
||||
: callback-prep-quot ( node -- quot )
|
||||
parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
|
||||
|
||||
: return-prep-quot ( node -- quot )
|
||||
return>> [ [ ] ] [ c-type c-type-boxer-quot ] if-void ;
|
||||
|
||||
M: alien-invoke-error summary
|
||||
drop
|
||||
"Words calling ``alien-invoke'' must be compiled with the optimizing compiler." ;
|
||||
|
||||
: pop-parameters ( -- seq )
|
||||
pop-literal nip [ expand-constants ] map ;
|
||||
|
||||
: stdcall-mangle ( symbol node -- symbol )
|
||||
"@"
|
||||
swap parameters>> parameter-sizes drop
|
||||
number>string 3append ;
|
||||
|
||||
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 ;
|
||||
|
||||
: alien-invoke-dlsym ( node -- symbols dll )
|
||||
dup function>> dup pick stdcall-mangle 2array
|
||||
swap library>> library dup [ dll>> ] when
|
||||
2dup check-dlsym ;
|
||||
|
||||
\ alien-invoke [
|
||||
! Four literals
|
||||
4 ensure-values
|
||||
#alien-invoke 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
|
||||
! Add node to IR
|
||||
dup node,
|
||||
! Magic #: consume exactly the number of inputs
|
||||
dup 0 alien-invoke-stack
|
||||
! Quotation which coerces return value to required type
|
||||
return-prep-quot recursive-state get infer-quot
|
||||
] "infer" set-word-prop
|
||||
|
||||
M: #alien-invoke generate-node
|
||||
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 ;
|
||||
|
||||
M: alien-indirect-error summary
|
||||
drop "Words calling ``alien-indirect'' must be compiled with the optimizing compiler." ;
|
||||
|
||||
\ alien-indirect [
|
||||
! Three literals and function pointer
|
||||
4 ensure-values
|
||||
4 reify-curries
|
||||
#alien-indirect 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
|
||||
! Add node to IR
|
||||
dup node,
|
||||
! Magic #: consume the function pointer, too
|
||||
dup 1 alien-invoke-stack
|
||||
! Quotation which coerces return value to required type
|
||||
return-prep-quot recursive-state get infer-quot
|
||||
] "infer" set-word-prop
|
||||
|
||||
M: #alien-indirect generate-node
|
||||
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 ;
|
||||
|
||||
! 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 ;
|
||||
|
||||
M: alien-callback-error summary
|
||||
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
|
||||
|
||||
: callback-bottom ( node -- )
|
||||
xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
|
||||
recursive-state get infer-quot ;
|
||||
|
||||
\ alien-callback [
|
||||
4 ensure-values
|
||||
#alien-callback new dup node,
|
||||
pop-literal nip >>quot
|
||||
pop-literal nip >>abi
|
||||
pop-parameters >>parameters
|
||||
pop-literal nip >>return
|
||||
gensym >>xt
|
||||
callback-bottom
|
||||
] "infer" set-word-prop
|
||||
|
||||
: box-parameters ( node -- )
|
||||
alien-node-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 ;
|
||||
|
||||
: wrap-callback-quot ( node -- 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 ( node -- n )
|
||||
{
|
||||
{ [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
|
||||
{ [ dup return>> large-struct? ] [ drop 4 ] }
|
||||
[ drop 0 ]
|
||||
} cond ;
|
||||
|
||||
: %callback-return ( node -- )
|
||||
#! All the extra book-keeping for %unwind is only for x86.
|
||||
#! On other platforms its an alias for %return.
|
||||
dup alien-node-return*
|
||||
[ %unnest-stacks ] [ %callback-value ] if-void
|
||||
callback-unwind %unwind ;
|
||||
|
||||
: generate-callback ( node -- )
|
||||
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 generate-callback iterate-next ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
C library interface implementation
|
||||
|
|
@ -24,20 +24,20 @@ $nl
|
|||
{ find find-from find-last find-last find-last-from search } related-words
|
||||
|
||||
HELP: sorted-index
|
||||
{ $values { "elt" object } { "seq" "a sorted sequence" } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } }
|
||||
{ $values { "obj" object } { "seq" "a sorted sequence" } { "i" "an index, or " { $link f } } }
|
||||
{ $description "Outputs the index and value of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." }
|
||||
{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link index } "." } ;
|
||||
|
||||
{ index index-from last-index last-index-from sorted-index } related-words
|
||||
|
||||
HELP: sorted-member?
|
||||
{ $values { "elt" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
|
||||
{ $values { "obj" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
|
||||
{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link = } "." } ;
|
||||
|
||||
{ member? sorted-member? } related-words
|
||||
|
||||
HELP: sorted-memq?
|
||||
{ $values { "elt" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
|
||||
{ $values { "obj" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
|
||||
{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link eq? } "." } ;
|
||||
|
||||
{ memq? sorted-memq? } related-words
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences sequences.private accessors math
|
||||
math.order combinators ;
|
||||
math.order combinators hints arrays ;
|
||||
IN: binary-search
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -36,6 +36,8 @@ PRIVATE>
|
|||
: natural-search ( obj seq -- i elt )
|
||||
[ <=> ] with search ;
|
||||
|
||||
HINTS: natural-search array ;
|
||||
|
||||
: sorted-index ( obj seq -- i )
|
||||
natural-search drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -60,11 +60,11 @@ HELP: set-bits
|
|||
{ $side-effects "bit-array" } ;
|
||||
|
||||
HELP: integer>bit-array
|
||||
{ $values { "integer" integer } { "bit-array" bit-array } }
|
||||
{ $values { "n" integer } { "bit-array" bit-array } }
|
||||
{ $description "Outputs a freshly-allocated bit array whose elements correspond to the bits in the binary representation of the given unsigned integer value." }
|
||||
{ $notes "The bits of the integer are stored in the resulting bit array in order of ascending significance, least significant bit first. This word will fail if passed a negative integer. If you want the two's-complement binary representation of a negative number, use " { $link bitnot } " to get the complement of the number first. This word works with fixnums or bignums of any size; it is not limited by fixnum size or machine word size." } ;
|
||||
|
||||
HELP: bit-array>integer
|
||||
{ $values { "bit-array" bit-array } { "integer" integer } }
|
||||
{ $values { "bit-array" bit-array } { "n" integer } }
|
||||
{ $description "Outputs the unsigned integer whose binary representation corresponds to the contents of the given bit array." }
|
||||
{ $notes "The bits of the integer are taken from the bit array in order of ascending significance, least significant bit first. This word is able to return fixnums or bignums of any size; it is not limited by fixnum size or machine word size." } ;
|
||||
|
|
|
|||
|
|
@ -69,8 +69,7 @@ M: bit-array resize
|
|||
|
||||
M: bit-array byte-length length 7 + -3 shift ;
|
||||
|
||||
: ?{ ( parsed -- parsed )
|
||||
\ } [ >bit-array ] parse-literal ; parsing
|
||||
: ?{ \ } [ >bit-array ] parse-literal ; parsing
|
||||
|
||||
:: integer>bit-array ( n -- bit-array )
|
||||
n zero? [ 0 <bit-array> ] [
|
||||
|
|
@ -84,7 +83,7 @@ M: bit-array byte-length length 7 + -3 shift ;
|
|||
]
|
||||
] if ;
|
||||
|
||||
: bit-array>integer ( bit-array -- int )
|
||||
: bit-array>integer ( bit-array -- n )
|
||||
0 swap underlying>> [ length ] keep [
|
||||
uchar-nth swap 8 shift bitor
|
||||
] curry each ;
|
||||
|
|
|
|||
|
|
@ -3,10 +3,11 @@
|
|||
USING: accessors compiler cpu.architecture vocabs.loader system
|
||||
sequences namespaces parser kernel kernel.private classes
|
||||
classes.private arrays hashtables vectors classes.tuple sbufs
|
||||
inference.dataflow hashtables.private sequences.private math
|
||||
classes.tuple.private growable namespaces.private assocs words
|
||||
generator command-line vocabs io io.encodings.string
|
||||
prettyprint libc compiler.units math.order ;
|
||||
hashtables.private sequences.private math classes.tuple.private
|
||||
growable namespaces.private assocs words command-line vocabs io
|
||||
io.encodings.string prettyprint libc splitting math.parser
|
||||
compiler.units math.order compiler.tree.builder
|
||||
compiler.tree.optimizer ;
|
||||
IN: bootstrap.compiler
|
||||
|
||||
! Don't bring this in when deploying, since it will store a
|
||||
|
|
@ -35,7 +36,7 @@ nl
|
|||
roll -roll declare not
|
||||
|
||||
array? hashtable? vector?
|
||||
tuple? sbuf? node? tombstone?
|
||||
tuple? sbuf? tombstone?
|
||||
|
||||
array-nth set-array-nth
|
||||
|
||||
|
|
@ -71,15 +72,27 @@ nl
|
|||
"." write flush
|
||||
|
||||
{
|
||||
. lines
|
||||
memq? split harvest sift cut cut-slice start index clone
|
||||
set-at reverse push-all class number>string string>number
|
||||
} compile-uncompiled
|
||||
|
||||
"." write flush
|
||||
|
||||
{
|
||||
malloc calloc free memcpy
|
||||
lines prefix suffix unclip new-assoc update
|
||||
word-prop set-word-prop 1array 2array 3array ?nth
|
||||
} compile-uncompiled
|
||||
|
||||
"." write flush
|
||||
|
||||
{
|
||||
. malloc calloc free memcpy
|
||||
} compile-uncompiled
|
||||
|
||||
{ build-tree } compile-uncompiled
|
||||
|
||||
{ optimize-tree } compile-uncompiled
|
||||
|
||||
vocabs [ words compile-uncompiled "." write flush ] each
|
||||
|
||||
" done" print flush
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.strings alien.compiler
|
||||
arrays assocs combinators compiler inference.transforms kernel
|
||||
USING: alien alien.c-types alien.strings
|
||||
arrays assocs combinators compiler kernel
|
||||
math namespaces parser prettyprint prettyprint.sections
|
||||
quotations sequences strings words cocoa.runtime io macros
|
||||
memoize debugger io.encodings.ascii effects ;
|
||||
memoize debugger io.encodings.ascii effects compiler.generator ;
|
||||
IN: cocoa.messages
|
||||
|
||||
: make-sender ( method function -- quot )
|
||||
|
|
|
|||
|
|
@ -4,7 +4,9 @@ IN: columns
|
|||
ARTICLE: "columns" "Column sequences"
|
||||
"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:"
|
||||
{ $subsection column }
|
||||
{ $subsection <column> } ;
|
||||
{ $subsection <column> }
|
||||
"A utility word:"
|
||||
{ $subsection <flipped> } ;
|
||||
|
||||
HELP: column
|
||||
{ $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link <column> } "." } ;
|
||||
|
|
@ -23,4 +25,9 @@ HELP: <column> ( seq n -- column )
|
|||
"In the same sense that " { $link <reversed> } " is a virtual variant of " { $link reverse } ", " { $link <column> } " is a virtual variant of " { $snippet "swap [ nth ] curry map" } "."
|
||||
} ;
|
||||
|
||||
HELP: <flipped>
|
||||
{ $values { "seq" sequence } { "seq'" sequence } }
|
||||
{ $description "Outputs a new virtual sequence which presents the transpose of " { $snippet "seq" } "." }
|
||||
{ $notes "This is the virtual sequence equivalent of " { $link flip } "." } ;
|
||||
|
||||
ABOUT: "columns"
|
||||
|
|
|
|||
|
|
@ -13,3 +13,6 @@ M: column virtual@ dup col>> -rot seq>> nth bounds-check ;
|
|||
M: column length seq>> length ;
|
||||
|
||||
INSTANCE: column virtual-sequence
|
||||
|
||||
: <flipped> ( seq -- seq' )
|
||||
dup empty? [ dup first length [ <column> ] with map ] unless ;
|
||||
|
|
|
|||
|
|
@ -1,11 +1,18 @@
|
|||
|
||||
USING: kernel sequences math inference accessors macros
|
||||
USING: kernel sequences math stack-checker effects accessors macros
|
||||
combinators.short-circuit ;
|
||||
|
||||
IN: combinators.short-circuit.smart
|
||||
|
||||
MACRO: && ( quots -- quot )
|
||||
dup first infer [ in>> ] [ out>> ] bi - 1+ n&&-rewrite ;
|
||||
<PRIVATE
|
||||
|
||||
MACRO: || ( quots -- quot )
|
||||
dup first infer [ in>> ] [ out>> ] bi - 1+ n||-rewrite ;
|
||||
: arity ( quots -- n )
|
||||
first infer
|
||||
dup terminated?>> [ "Cannot determine arity" throw ] when
|
||||
effect-height neg 1+ ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
MACRO: && ( quots -- quot ) dup arity n&&-rewrite ;
|
||||
|
||||
MACRO: || ( quots -- quot ) dup arity n||-rewrite ;
|
||||
|
|
|
|||
|
|
@ -52,9 +52,14 @@ ARTICLE: "standard-cli-args" "Command line switches for general usage"
|
|||
{ { $snippet "-script" } { "Equivalent to " { $snippet "-quiet -run=none" } "." $nl "On Unix systems, Factor can be used for scripting - just create an executable text file whose first line is:" { $code "#! /usr/local/bin/factor -script" } "The space after " { $snippet "#!" } " is necessary because of Factor syntax." } }
|
||||
} ;
|
||||
|
||||
ARTICLE: "cli" "Command line usage"
|
||||
ARTICLE: "rc-files" "Running code on startup"
|
||||
"Unless the " { $snippet "-no-user-init" } " command line switch is specified, The startup routine runs the " { $snippet ".factor-rc" } " file in the user's home directory, if it exists. This file can contain initialization and customization for your development environment."
|
||||
$nl
|
||||
"The " { $snippet ".factor-rc" } " and " { $snippet ".factor-boot-rc" } " files can be run explicitly:"
|
||||
{ $subsection run-user-init }
|
||||
{ $subsection run-bootstrap-init } ;
|
||||
|
||||
ARTICLE: "cli" "Command line usage"
|
||||
"Zero or more command line arguments may be passed to the Factor runtime. Command line arguments starting with a dash (" { $snippet "-" } ") is interpreted as switches. All other arguments are taken to be file names to be run by " { $link run-file } "."
|
||||
$nl
|
||||
"Switches can take one of the following three forms:"
|
||||
|
|
@ -68,9 +73,6 @@ $nl
|
|||
{ $subsection "standard-cli-args" }
|
||||
"The list of command line arguments can be obtained and inspected directly:"
|
||||
{ $subsection cli-args }
|
||||
"The " { $snippet ".factor-rc" } " and " { $snippet ".factor-boot-rc" } " files can be run explicitly:"
|
||||
{ $subsection run-user-init }
|
||||
{ $subsection run-bootstrap-init }
|
||||
"There is a way to override the default vocabulary to run on startup:"
|
||||
{ $subsection main-vocab-hook } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: generator help.markup help.syntax words io parser
|
||||
USING: compiler.generator help.markup help.syntax words io parser
|
||||
assocs words.private sequences compiler.units ;
|
||||
IN: compiler
|
||||
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces arrays sequences io inference.backend
|
||||
inference.state generator debugger words compiler.units
|
||||
continuations vocabs assocs alien.compiler dlists optimizer
|
||||
definitions math compiler.errors threads graphs generic
|
||||
inference combinators dequeues search-dequeues ;
|
||||
USING: kernel namespaces arrays sequences io debugger words fry
|
||||
compiler.units continuations vocabs assocs dlists definitions
|
||||
math threads graphs generic combinators deques search-deques
|
||||
stack-checker stack-checker.state compiler.generator
|
||||
compiler.errors compiler.tree.builder compiler.tree.optimizer ;
|
||||
IN: compiler
|
||||
|
||||
SYMBOL: +failed+
|
||||
|
|
@ -46,22 +46,22 @@ SYMBOL: +failed+
|
|||
] tri ;
|
||||
|
||||
: (compile) ( word -- )
|
||||
[
|
||||
'[
|
||||
H{ } clone dependencies set
|
||||
|
||||
{
|
||||
, {
|
||||
[ compile-begins ]
|
||||
[
|
||||
[ word-dataflow ] [ compile-failed return ] recover
|
||||
optimize
|
||||
[ build-tree-from-word ] [ compile-failed return ] recover
|
||||
optimize-tree
|
||||
]
|
||||
[ dup generate ]
|
||||
[ compile-succeeded ]
|
||||
} cleave
|
||||
] curry with-return ;
|
||||
] with-return ;
|
||||
|
||||
: compile-loop ( dequeue -- )
|
||||
[ (compile) yield ] slurp-dequeue ;
|
||||
: compile-loop ( deque -- )
|
||||
[ (compile) yield ] slurp-deque ;
|
||||
|
||||
: decompile ( word -- )
|
||||
f 2array 1array t modify-code-heap ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: help.syntax help.markup math kernel
|
||||
words strings alien ;
|
||||
words strings alien compiler.generator ;
|
||||
IN: compiler.generator.fixup
|
||||
|
||||
HELP: frame-required
|
||||
|
|
@ -14,3 +14,6 @@ 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."
|
||||
} ;
|
||||
|
||||
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." } ;
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
USING: help.markup help.syntax words debugger generator.fixup
|
||||
generator.registers quotations kernel vectors arrays effects
|
||||
sequences ;
|
||||
USING: help.markup help.syntax words debugger
|
||||
compiler.generator.fixup compiler.generator.registers quotations
|
||||
kernel vectors arrays effects sequences ;
|
||||
IN: compiler.generator
|
||||
|
||||
ARTICLE: "generator" "Compiled code generator"
|
||||
|
|
@ -31,16 +31,13 @@ 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." } ;
|
||||
{ $values { "nodes" "a sequence of nodes" } { "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 sequence of nodes." } ;
|
||||
|
||||
HELP: generate-node
|
||||
{ $values { "node" "a dataflow node" } { "next" "a dataflow node" } }
|
||||
|
|
@ -48,13 +45,13 @@ HELP: generate-node
|
|||
{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
|
||||
|
||||
HELP: generate-nodes
|
||||
{ $values { "node" "a dataflow node" } }
|
||||
{ $values { "nodes" "a sequence of nodes" } }
|
||||
{ $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." } ;
|
||||
{ $values { "word" word } { "label" word } { "nodes" "a sequence of nodes" } }
|
||||
{ $description "Generates machine code for " { $snippet "label" } " from " { $snippet "nodes" } ". 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" } }
|
||||
|
|
@ -3,8 +3,8 @@
|
|||
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
|
||||
quotations sequences system threads words vectors sets deques
|
||||
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
|
||||
|
|
@ -60,7 +60,8 @@ SYMBOL: current-label-start
|
|||
GENERIC: generate-node ( node -- next )
|
||||
|
||||
: generate-nodes ( nodes -- )
|
||||
[ current-node generate-node ] iterate-nodes end-basic-block ;
|
||||
[ current-node generate-node ] iterate-nodes
|
||||
end-basic-block ;
|
||||
|
||||
: init-generate-nodes ( -- )
|
||||
init-templates
|
||||
|
|
@ -105,7 +106,7 @@ M: node generate-node drop iterate-next ;
|
|||
] ?if ;
|
||||
|
||||
! #recursive
|
||||
: compile-recursive ( node -- )
|
||||
: compile-recursive ( node -- next )
|
||||
dup label>> id>> generate-call >r
|
||||
[ child>> ] [ label>> word>> ] [ label>> id>> ] tri generate
|
||||
r> ;
|
||||
|
|
@ -113,7 +114,7 @@ M: node generate-node drop iterate-next ;
|
|||
: compiling-loop ( word -- )
|
||||
<label> dup resolve-label swap compiling-loops get set-at ;
|
||||
|
||||
: compile-loop ( node -- )
|
||||
: compile-loop ( node -- next )
|
||||
end-basic-block
|
||||
[ label>> id>> compiling-loop ] [ child>> generate-nodes ] bi
|
||||
iterate-next ;
|
||||
|
|
@ -150,6 +151,7 @@ M: #if generate-node
|
|||
%save-dispatch-xt
|
||||
%prologue-later
|
||||
[ generate-nodes ] with-node-iterator
|
||||
%return
|
||||
] with-generator
|
||||
] keep ;
|
||||
|
||||
|
|
@ -213,20 +215,17 @@ M: #dispatch generate-node
|
|||
2array 1array define-if-intrinsics ;
|
||||
|
||||
: do-if-intrinsic ( pair -- next )
|
||||
<label> [
|
||||
swap do-template
|
||||
node> next dup >node
|
||||
] keep generate-if ;
|
||||
<label> [ swap do-template skip-next ] 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 ;
|
||||
node@ {
|
||||
{ [ dup length 2 < ] [ 2drop f ] }
|
||||
{ [ dup second #if? ] [ drop if-intrinsics find-template ] }
|
||||
[ 2drop f ]
|
||||
} cond ;
|
||||
|
||||
M: #call generate-node
|
||||
dup node-input-infos [ class>> ] map set-operand-classes
|
||||
|
|
@ -252,13 +251,13 @@ M: #shuffle generate-node
|
|||
shuffle-effect phantom-shuffle iterate-next ;
|
||||
|
||||
M: #>r generate-node
|
||||
in-d>> length
|
||||
phantom->r
|
||||
[ in-d>> length ] [ out-r>> empty? ] bi
|
||||
[ phantom-drop ] [ phantom->r ] if
|
||||
iterate-next ;
|
||||
|
||||
M: #r> generate-node
|
||||
out-d>> length
|
||||
phantom-r>
|
||||
[ in-r>> length ] [ out-d>> empty? ] bi
|
||||
[ phantom-rdrop ] [ phantom-r> ] if
|
||||
iterate-next ;
|
||||
|
||||
! #return
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces sequences cursors kernel compiler.tree ;
|
||||
USING: namespaces sequences kernel compiler.tree ;
|
||||
IN: compiler.generator.iterator
|
||||
|
||||
SYMBOL: node-stack
|
||||
|
|
@ -8,15 +8,15 @@ 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 ;
|
||||
: current-node ( -- node ) node@ first ;
|
||||
: iterate-next ( -- cursor ) node@ rest-slice ;
|
||||
: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ;
|
||||
|
||||
: iterate-nodes ( cursor quot: ( -- ) -- )
|
||||
over [
|
||||
[ swap >node call node> drop ] keep iterate-nodes
|
||||
] [
|
||||
over empty? [
|
||||
2drop
|
||||
] [
|
||||
[ swap >node call node> drop ] keep iterate-nodes
|
||||
] if ; inline recursive
|
||||
|
||||
: with-node-iterator ( quot -- )
|
||||
|
|
@ -25,17 +25,21 @@ SYMBOL: node-stack
|
|||
DEFER: (tail-call?)
|
||||
|
||||
: tail-phi? ( cursor -- ? )
|
||||
[ value #phi? ] [ next (tail-call?) ] bi and ;
|
||||
[ first #phi? ] [ rest-slice (tail-call?) ] bi and ;
|
||||
|
||||
: (tail-call?) ( cursor -- ? )
|
||||
[ value [ #return? ] [ #terminate? ] bi or ]
|
||||
[ tail-phi? ]
|
||||
bi or ;
|
||||
dup empty? [ drop t ] [
|
||||
[ first [ #return? ] [ #terminate? ] bi or ]
|
||||
[ tail-phi? ]
|
||||
bi or
|
||||
] if ;
|
||||
|
||||
: tail-call? ( -- ? )
|
||||
node-stack get [
|
||||
next
|
||||
[ (tail-call?) ]
|
||||
[ value #terminate? not ]
|
||||
bi and
|
||||
rest-slice
|
||||
dup [
|
||||
[ (tail-call?) ]
|
||||
[ first #terminate? not ]
|
||||
bi and
|
||||
] [ drop t ] if
|
||||
] all? ;
|
||||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! Copyright (C) 2006, 2008 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 ;
|
||||
combinators hashtables kernel layouts math namespaces quotations
|
||||
sequences system vectors words effects alien byte-arrays
|
||||
accessors sets math.order cpu.architecture
|
||||
compiler.generator.fixup ;
|
||||
IN: compiler.generator.registers
|
||||
|
||||
SYMBOL: +input+
|
||||
|
|
@ -658,3 +658,9 @@ UNION: immediate fixnum POSTPONE: f ;
|
|||
: phantom-r> ( n -- )
|
||||
phantom-retainstack get phantom-input
|
||||
phantom-datastack get phantom-append ;
|
||||
|
||||
: phantom-drop ( n -- )
|
||||
phantom-datastack get phantom-input drop ;
|
||||
|
||||
: phantom-rdrop ( n -- )
|
||||
phantom-retainstack get phantom-input drop ;
|
||||
10
basis/alien/compiler/compiler-tests.factor → basis/compiler/tests/alien.factor
Executable file → Normal file
10
basis/alien/compiler/compiler-tests.factor → basis/compiler/tests/alien.factor
Executable file → Normal file
|
|
@ -1,9 +1,9 @@
|
|||
IN: alien.compiler.tests
|
||||
IN: compiler.tests
|
||||
USING: alien alien.c-types alien.syntax compiler kernel
|
||||
namespaces namespaces tools.test sequences inference words
|
||||
arrays parser quotations continuations inference.backend effects
|
||||
namespaces.private io io.streams.string memory system threads
|
||||
tools.test math ;
|
||||
namespaces namespaces tools.test sequences stack-checker
|
||||
stack-checker.errors words arrays parser quotations
|
||||
continuations effects namespaces.private io io.streams.string
|
||||
memory system threads tools.test math ;
|
||||
|
||||
FUNCTION: void ffi_test_0 ;
|
||||
[ ] [ ffi_test_0 ] unit-test
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
IN: compiler.tests
|
||||
USING: words kernel inference alien.strings tools.test ;
|
||||
USING: words kernel stack-checker alien.strings tools.test ;
|
||||
|
||||
[ ] [ \ if redefined [ string>alien ] infer. ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,19 +1,11 @@
|
|||
USING: accessors arrays compiler.units generic hashtables
|
||||
inference kernel kernel.private math optimizer generator
|
||||
prettyprint sequences sbufs strings tools.test vectors words
|
||||
sequences.private quotations optimizer.backend classes
|
||||
classes.algebra inference.dataflow classes.tuple.private
|
||||
continuations growable optimizer.inlining namespaces hints ;
|
||||
stack-checker kernel kernel.private math prettyprint sequences
|
||||
sbufs strings tools.test vectors words sequences.private
|
||||
quotations classes classes.algebra classes.tuple.private
|
||||
continuations growable namespaces hints alien.accessors
|
||||
compiler.tree.builder compiler.tree.optimizer ;
|
||||
IN: optimizer.tests
|
||||
|
||||
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
|
||||
H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union*
|
||||
] unit-test
|
||||
|
||||
[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [
|
||||
H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
|
||||
] unit-test
|
||||
|
||||
GENERIC: xyz ( obj -- obj )
|
||||
M: array xyz xyz ;
|
||||
|
||||
|
|
@ -86,7 +78,7 @@ TUPLE: pred-test ;
|
|||
3 2 (double-recursion)
|
||||
] when ; inline
|
||||
|
||||
: double-recursion 0 2 (double-recursion) ;
|
||||
: double-recursion ( -- ) 0 2 (double-recursion) ;
|
||||
|
||||
[ ] [ double-recursion ] unit-test
|
||||
|
||||
|
|
@ -124,12 +116,6 @@ GENERIC: void-generic ( obj -- * )
|
|||
: bar ( -- ? ) foo 4 4 = and ;
|
||||
[ f ] [ bar ] unit-test
|
||||
|
||||
! ensure identities are working in some form
|
||||
[ t ] [
|
||||
[ { number } declare 0 + ] dataflow optimize
|
||||
[ #push? ] node-exists? not
|
||||
] unit-test
|
||||
|
||||
! compiling <tuple> with a non-literal class failed
|
||||
: <tuple>-regression ( class -- tuple ) <tuple> ;
|
||||
|
||||
|
|
@ -219,6 +205,7 @@ M: number detect-number ;
|
|||
|
||||
! Regression
|
||||
USE: sorting
|
||||
USE: binary-search
|
||||
USE: binary-search.private
|
||||
|
||||
: old-binsearch ( elt quot seq -- elt quot i )
|
||||
|
|
@ -235,16 +222,6 @@ USE: binary-search.private
|
|||
[ [ - ] swap old-binsearch ] compile-call 2nip
|
||||
] unit-test
|
||||
|
||||
! Regression
|
||||
TUPLE: silly-tuple a b ;
|
||||
|
||||
[ 1 2 { silly-tuple-a silly-tuple-b } ] [
|
||||
T{ silly-tuple f 1 2 }
|
||||
[
|
||||
{ silly-tuple-a silly-tuple-b } [ get-slots ] keep
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
||||
! Regression
|
||||
: empty-compound ;
|
||||
|
||||
|
|
@ -253,9 +230,9 @@ TUPLE: silly-tuple a b ;
|
|||
|
||||
[ t ] [ \ node-successor-f-bug compiled>> ] unit-test
|
||||
|
||||
[ ] [ [ new ] dataflow optimize drop ] unit-test
|
||||
[ ] [ [ new ] build-tree optimize-tree drop ] unit-test
|
||||
|
||||
[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
|
||||
[ ] [ [ <tuple> ] build-tree optimize-tree drop ] unit-test
|
||||
|
||||
! Regression
|
||||
: lift-throw-tail-regression ( obj -- obj str )
|
||||
|
|
@ -285,28 +262,6 @@ TUPLE: silly-tuple a b ;
|
|||
|
||||
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
|
||||
|
||||
GENERIC: generic-inline-test ( x -- y )
|
||||
M: integer generic-inline-test ;
|
||||
|
||||
: generic-inline-test-1 ( -- x )
|
||||
1
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test ;
|
||||
|
||||
! Inlining all of the above should only take two passes
|
||||
[ { t f } ] [
|
||||
\ generic-inline-test-1 def>> dataflow
|
||||
[ optimize-1 , optimize-1 , drop ] { } make
|
||||
] unit-test
|
||||
|
||||
! Forgot a recursive inline check
|
||||
: recursive-inline-hang ( a -- a )
|
||||
dup array? [ recursive-inline-hang ] when ;
|
||||
|
|
@ -347,7 +302,7 @@ USE: sequences.private
|
|||
: member-test ( obj -- ? ) { + - * / /i } member? ;
|
||||
|
||||
\ member-test must-infer
|
||||
[ ] [ \ member-test word-dataflow optimize 2drop ] unit-test
|
||||
[ ] [ \ member-test build-tree-from-word optimize-tree 2drop ] unit-test
|
||||
[ t ] [ \ + member-test ] unit-test
|
||||
[ f ] [ \ append member-test ] unit-test
|
||||
|
||||
|
|
@ -391,3 +346,10 @@ TUPLE: some-tuple x ;
|
|||
[ ] curry some-tuple boa ;
|
||||
|
||||
[ T{ some-tuple f [ 3 ] } ] [ 3 allot-regression ] unit-test
|
||||
|
||||
[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-signed-4 1+ ] compile-call ] unit-test
|
||||
[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-unsigned-4 1+ ] compile-call ] unit-test
|
||||
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-8 1+ ] compile-call ] unit-test
|
||||
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1+ ] compile-call ] unit-test
|
||||
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1+ ] compile-call ] unit-test
|
||||
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1+ ] compile-call ] unit-test
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
IN: compiler.tests
|
||||
USING: accessors compiler compiler.units tools.test math parser
|
||||
kernel sequences sequences.private classes.mixin generic
|
||||
definitions arrays words assocs eval ;
|
||||
IN: compiler.tests
|
||||
|
||||
GENERIC: method-redefine-test ( a -- b )
|
||||
|
||||
|
|
@ -31,15 +31,6 @@ M: integer method-redefine-test 3 + ;
|
|||
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
|
||||
[ t ] [ \ there compiled>> ] unit-test
|
||||
|
||||
! Just changing the stack effect didn't mark a word for recompilation
|
||||
DEFER: change-effect
|
||||
|
||||
[ ] [ "IN: compiler.tests GENERIC: change-effect ( a -- b )" eval ] unit-test
|
||||
{ 1 1 } [ change-effect ] must-infer-as
|
||||
|
||||
[ ] [ "IN: compiler.tests GENERIC: change-effect ( a -- )" eval ] unit-test
|
||||
{ 1 0 } [ change-effect ] must-infer-as
|
||||
|
||||
: good ( -- ) ;
|
||||
: bad ( -- ) good ;
|
||||
: ugly ( -- ) bad ;
|
||||
|
|
|
|||
|
|
@ -235,6 +235,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
|
|||
10 [
|
||||
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
|
||||
[ t ] [
|
||||
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval
|
||||
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval
|
||||
] unit-test
|
||||
] times
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Testing templates machinery without compiling anything
|
||||
IN: compiler.tests
|
||||
USING: compiler generator generator.registers
|
||||
generator.registers.private tools.test namespaces sequences
|
||||
words kernel math effects definitions compiler.units accessors
|
||||
cpu.architecture ;
|
||||
USING: compiler compiler.generator compiler.generator.registers
|
||||
compiler.generator.registers.private tools.test namespaces
|
||||
sequences words kernel math effects definitions compiler.units
|
||||
accessors cpu.architecture ;
|
||||
|
||||
: <int-vreg> ( n -- vreg ) int-regs <vreg> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,14 @@
|
|||
USING: help.markup help.syntax sequences quotations words
|
||||
compiler.tree stack-checker.errors ;
|
||||
IN: compiler.tree.builder
|
||||
|
||||
HELP: build-tree
|
||||
{ $values { "quot" quotation } { "nodes" "a sequence of nodes" } }
|
||||
{ $description "Attempts to construct tree SSA IR from a quotation." }
|
||||
{ $notes "This is the first stage of the compiler." }
|
||||
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
|
||||
|
||||
HELP: build-tree-with
|
||||
{ $values { "in-stack" "a sequence of values" } { "quot" quotation } { "nodes" "a sequence of nodes" } { "out-stack" "a sequence of values" } }
|
||||
{ $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values, and outputting stack resulting at the end." }
|
||||
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
IN: compiler.tree.builder.tests
|
||||
USING: compiler.tree.builder tools.test sequences kernel
|
||||
compiler.tree ;
|
||||
|
||||
\ build-tree must-infer
|
||||
\ build-tree-with must-infer
|
||||
\ build-tree-from-word must-infer
|
||||
|
||||
: inline-recursive ( -- ) inline-recursive ; inline recursive
|
||||
|
||||
[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] contains? nip ] unit-test
|
||||
|
|
@ -0,0 +1,57 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry accessors quotations kernel sequences namespaces
|
||||
assocs words arrays vectors hints combinators stack-checker
|
||||
stack-checker.state stack-checker.visitor stack-checker.errors
|
||||
stack-checker.backend compiler.tree ;
|
||||
IN: compiler.tree.builder
|
||||
|
||||
: with-tree-builder ( quot -- nodes )
|
||||
[ V{ } clone stack-visitor set ] prepose
|
||||
with-infer ; inline
|
||||
|
||||
: build-tree ( quot -- nodes )
|
||||
#! Not safe to call from inference transforms.
|
||||
[ f infer-quot ] with-tree-builder nip ;
|
||||
|
||||
: build-tree-with ( in-stack quot -- nodes out-stack )
|
||||
#! Not safe to call from inference transforms.
|
||||
[
|
||||
[ >vector meta-d set ] [ f infer-quot ] bi*
|
||||
] with-tree-builder nip
|
||||
unclip-last in-d>> ;
|
||||
|
||||
: build-sub-tree ( #call quot -- nodes )
|
||||
[ [ out-d>> ] [ in-d>> ] bi ] dip build-tree-with
|
||||
over ends-with-terminate?
|
||||
[ drop swap [ f swap #push ] map append ]
|
||||
[ rot #copy suffix ]
|
||||
if ;
|
||||
|
||||
: (build-tree-from-word) ( word -- )
|
||||
dup
|
||||
[ "inline" word-prop ]
|
||||
[ "recursive" word-prop ] bi and [
|
||||
1quotation f infer-quot
|
||||
] [
|
||||
[ specialized-def ]
|
||||
[ dup 2array 1array ] bi infer-quot
|
||||
] if ;
|
||||
|
||||
: check-cannot-infer ( word -- )
|
||||
dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;
|
||||
|
||||
: check-no-compile ( word -- )
|
||||
dup "no-compile" word-prop [ cannot-infer-effect ] [ drop ] if ;
|
||||
|
||||
: build-tree-from-word ( word -- effect nodes )
|
||||
[
|
||||
[
|
||||
{
|
||||
[ check-cannot-infer ]
|
||||
[ check-no-compile ]
|
||||
[ (build-tree-from-word) ]
|
||||
[ finish-word ]
|
||||
} cleave
|
||||
] maybe-cannot-infer
|
||||
] with-tree-builder ;
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
IN: compiler.tree.checker.tests
|
||||
USING: compiler.tree.checker tools.test ;
|
||||
|
||||
\ check-nodes must-infer
|
||||
|
|
@ -0,0 +1,210 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences kernel sets namespaces accessors assocs
|
||||
arrays combinators continuations columns math vectors
|
||||
stack-checker.branches
|
||||
compiler.tree
|
||||
compiler.tree.def-use
|
||||
compiler.tree.combinators ;
|
||||
IN: compiler.tree.checker
|
||||
|
||||
! Check some invariants; this can help catch compiler bugs.
|
||||
|
||||
ERROR: check-use-error value message ;
|
||||
|
||||
: check-use ( value uses -- )
|
||||
[ empty? [ "No use" check-use-error ] [ drop ] if ]
|
||||
[ all-unique? [ drop ] [ "Uses not all unique" check-use-error ] if ] 2bi ;
|
||||
|
||||
: check-def-use ( -- )
|
||||
def-use get [ uses>> check-use ] assoc-each ;
|
||||
|
||||
GENERIC: check-node* ( node -- )
|
||||
|
||||
M: #shuffle check-node*
|
||||
[ [ mapping>> values ] [ in-d>> ] bi subset? [ "Bad mapping inputs" throw ] unless ]
|
||||
[ [ mapping>> keys ] [ out-d>> ] bi set= [ "Bad mapping outputs" throw ] unless ]
|
||||
bi ;
|
||||
|
||||
: check-lengths ( seq -- )
|
||||
[ length ] map all-equal? [ "Bad lengths" throw ] unless ;
|
||||
|
||||
M: #copy check-node* inputs/outputs 2array check-lengths ;
|
||||
|
||||
: check->r/r> ( node -- )
|
||||
inputs/outputs dup empty? [ 2drop ] [ 2array check-lengths ] if ;
|
||||
|
||||
M: #>r check-node* check->r/r> ;
|
||||
|
||||
M: #r> check-node* check->r/r> ;
|
||||
|
||||
M: #return-recursive check-node* inputs/outputs 2array check-lengths ;
|
||||
|
||||
M: #phi check-node*
|
||||
[ [ phi-in-d>> <flipped> ] [ out-d>> ] bi 2array check-lengths ]
|
||||
[ phi-in-d>> check-lengths ]
|
||||
bi ;
|
||||
|
||||
M: #enter-recursive check-node*
|
||||
[ [ label>> enter-out>> ] [ out-d>> ] bi assert= ]
|
||||
[ [ in-d>> ] [ out-d>> ] bi 2array check-lengths ]
|
||||
[ recursive-phi-in check-lengths ]
|
||||
tri ;
|
||||
|
||||
M: #push check-node*
|
||||
out-d>> length 1 = [ "Bad #push" throw ] unless ;
|
||||
|
||||
M: node check-node* drop ;
|
||||
|
||||
: check-values ( seq -- )
|
||||
[ integer? ] all? [ "Bad values" throw ] unless ;
|
||||
|
||||
ERROR: check-node-error node error ;
|
||||
|
||||
: check-node ( node -- )
|
||||
[
|
||||
[ node-uses-values check-values ]
|
||||
[ node-defs-values check-values ]
|
||||
[ check-node* ]
|
||||
tri
|
||||
] [ check-node-error ] recover ;
|
||||
|
||||
SYMBOL: datastack
|
||||
SYMBOL: retainstack
|
||||
SYMBOL: terminated?
|
||||
|
||||
GENERIC: check-stack-flow* ( node -- )
|
||||
|
||||
: (check-stack-flow) ( nodes -- )
|
||||
[ check-stack-flow* terminated? get not ] all? drop ;
|
||||
|
||||
: init-stack-flow ( -- )
|
||||
V{ } clone datastack set
|
||||
V{ } clone retainstack set ;
|
||||
|
||||
: check-stack-flow ( nodes -- )
|
||||
[
|
||||
init-stack-flow
|
||||
(check-stack-flow)
|
||||
] with-scope ;
|
||||
|
||||
: check-inputs ( seq var -- )
|
||||
[ dup length ] dip [ swap cut* swap ] change
|
||||
sequence= [ "Bad stack flow" throw ] unless ;
|
||||
|
||||
: check-in-d ( node -- )
|
||||
in-d>> datastack check-inputs ;
|
||||
|
||||
: check-in-r ( node -- )
|
||||
in-r>> retainstack check-inputs ;
|
||||
|
||||
: check-outputs ( node var -- )
|
||||
get push-all ;
|
||||
|
||||
: check-out-d ( node -- )
|
||||
out-d>> datastack check-outputs ;
|
||||
|
||||
: check-out-r ( node -- )
|
||||
out-r>> retainstack check-outputs ;
|
||||
|
||||
M: #introduce check-stack-flow* check-out-d ;
|
||||
|
||||
M: #push check-stack-flow* check-out-d ;
|
||||
|
||||
M: #call check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
|
||||
|
||||
M: #shuffle check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
|
||||
|
||||
M: #>r check-stack-flow* [ check-in-d ] [ check-out-r ] bi ;
|
||||
|
||||
M: #r> check-stack-flow* [ check-in-r ] [ check-out-d ] bi ;
|
||||
|
||||
: assert-datastack-empty ( -- )
|
||||
datastack get empty? [ "Data stack not empty" throw ] unless ;
|
||||
|
||||
: assert-retainstack-empty ( -- )
|
||||
retainstack get empty? [ "Retain stack not empty" throw ] unless ;
|
||||
|
||||
M: #return check-stack-flow*
|
||||
check-in-d
|
||||
assert-datastack-empty
|
||||
terminated? get [ assert-retainstack-empty ] unless ;
|
||||
|
||||
M: #enter-recursive check-stack-flow*
|
||||
check-out-d ;
|
||||
|
||||
M: #return-recursive check-stack-flow*
|
||||
[ check-in-d ] [ check-out-d ] bi ;
|
||||
|
||||
M: #call-recursive check-stack-flow*
|
||||
[ check-in-d ] [ check-out-d ] bi ;
|
||||
|
||||
: check-terminate-in-d ( #terminate -- )
|
||||
in-d>> datastack get over length tail* sequence=
|
||||
[ "Bad terminate data stack" throw ] unless ;
|
||||
|
||||
: check-terminate-in-r ( #terminate -- )
|
||||
in-r>> retainstack get over length tail* sequence=
|
||||
[ "Bad terminate retain stack" throw ] unless ;
|
||||
|
||||
M: #terminate check-stack-flow*
|
||||
terminated? on
|
||||
[ check-terminate-in-d ]
|
||||
[ check-terminate-in-r ] bi ;
|
||||
|
||||
SYMBOL: branch-out
|
||||
|
||||
: check-branch ( nodes -- stack )
|
||||
[
|
||||
datastack [ clone ] change
|
||||
V{ } clone retainstack set
|
||||
(check-stack-flow)
|
||||
terminated? get [ assert-retainstack-empty ] unless
|
||||
terminated? get f datastack get ?
|
||||
] with-scope ;
|
||||
|
||||
M: #branch check-stack-flow*
|
||||
[ check-in-d ]
|
||||
[ children>> [ check-branch ] map branch-out set ]
|
||||
bi ;
|
||||
|
||||
: check-phi-in ( #phi -- )
|
||||
phi-in-d>> branch-out get [
|
||||
dup [
|
||||
over length tail* sequence= [
|
||||
"Branch outputs don't match phi inputs"
|
||||
throw
|
||||
] unless
|
||||
] [
|
||||
2drop
|
||||
] if
|
||||
] 2each ;
|
||||
|
||||
: set-phi-datastack ( #phi -- )
|
||||
phi-in-d>> first length
|
||||
branch-out get [ ] find nip swap head* >vector datastack set ;
|
||||
|
||||
M: #phi check-stack-flow*
|
||||
branch-out get [ ] contains? [
|
||||
[ check-phi-in ] [ set-phi-datastack ] [ check-out-d ] tri
|
||||
] [ drop terminated? on ] if ;
|
||||
|
||||
M: #recursive check-stack-flow*
|
||||
[ check-in-d ] [ child>> (check-stack-flow) ] bi ;
|
||||
|
||||
M: #copy check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
|
||||
|
||||
M: #alien-invoke check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
|
||||
|
||||
M: #alien-indirect check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
|
||||
|
||||
M: #alien-callback check-stack-flow* drop ;
|
||||
|
||||
M: #declare check-stack-flow* drop ;
|
||||
|
||||
: check-nodes ( nodes -- )
|
||||
compute-def-use
|
||||
check-def-use
|
||||
[ [ check-node ] each-node ]
|
||||
[ check-stack-flow ]
|
||||
bi ;
|
||||
|
|
@ -4,16 +4,18 @@ math.private math generic words quotations alien alien.c-types
|
|||
strings sbufs sequences.private slots.private combinators
|
||||
definitions system layouts vectors math.partial-dispatch
|
||||
math.order math.functions accessors hashtables classes assocs
|
||||
io.encodings.utf8 io.encodings.ascii io.encodings fry
|
||||
io.encodings.utf8 io.encodings.ascii io.encodings fry slots
|
||||
sorting.private
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.cleanup
|
||||
compiler.tree.builder
|
||||
compiler.tree.normalization
|
||||
compiler.tree.propagation ;
|
||||
compiler.tree.propagation
|
||||
compiler.tree.checker ;
|
||||
|
||||
: cleaned-up-tree ( quot -- nodes )
|
||||
build-tree normalize propagate cleanup ;
|
||||
build-tree normalize propagate cleanup dup check-nodes ;
|
||||
|
||||
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
|
||||
|
||||
|
|
@ -142,7 +144,7 @@ M: object xyz ;
|
|||
|
||||
[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ t ] [
|
||||
[
|
||||
[ no-cond ] 1
|
||||
[ 1array dup quotation? [ >quotation ] unless ] times
|
||||
|
|
@ -430,3 +432,32 @@ cell-bits 32 = [
|
|||
{ integer } declare [ 0 >= ] map
|
||||
] { >= fixnum>= } inlined?
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
4 pick array-capacity?
|
||||
[ set-slot ] [ \ array-capacity 2nip bad-slot-value ] if
|
||||
] cleaned-up-tree drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[ { merge } declare accum>> 0 >>length ] cleaned-up-tree drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
[ "X" throw ]
|
||||
[ dupd dup -1 < [ 0 >= [ ] [ "X" throw ] if ] [ drop ] if ]
|
||||
if
|
||||
] cleaned-up-tree drop
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ [ 2array ] [ 0 3array ] if first ]
|
||||
{ nth-unsafe < <= > >= } inlined?
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[ [ >r "A" throw r> ] [ "B" throw ] if ]
|
||||
cleaned-up-tree drop
|
||||
] unit-test
|
||||
|
|
@ -3,6 +3,7 @@
|
|||
USING: kernel accessors sequences sequences.deep combinators fry
|
||||
classes.algebra namespaces assocs math math.private
|
||||
math.partial-dispatch classes.tuple classes.tuple.private
|
||||
definitions stack-checker.state stack-checker.branches
|
||||
compiler.tree
|
||||
compiler.tree.intrinsics
|
||||
compiler.tree.combinators
|
||||
|
|
@ -15,6 +16,18 @@ IN: compiler.tree.cleanup
|
|||
! marked as never taken, and flattens local recursive blocks
|
||||
! that do not call themselves.
|
||||
|
||||
GENERIC: delete-node ( node -- )
|
||||
|
||||
M: #call-recursive delete-node
|
||||
dup label>> [ [ eq? not ] with filter ] change-calls drop ;
|
||||
|
||||
M: #return-recursive delete-node
|
||||
label>> f >>return drop ;
|
||||
|
||||
M: node delete-node drop ;
|
||||
|
||||
: delete-nodes ( nodes -- ) [ delete-node ] each-node ;
|
||||
|
||||
GENERIC: cleanup* ( node -- node/nodes )
|
||||
|
||||
: cleanup ( nodes -- nodes' )
|
||||
|
|
@ -29,14 +42,18 @@ GENERIC: cleanup* ( node -- node/nodes )
|
|||
: cleanup-folding ( #call -- nodes )
|
||||
#! Replace a #call having a known result with a #drop of its
|
||||
#! inputs followed by #push nodes for the outputs.
|
||||
[ word>> +inlined+ depends-on ]
|
||||
[
|
||||
[ node-output-infos ] [ out-d>> ] bi
|
||||
[ [ literal>> ] dip #push ] 2map
|
||||
]
|
||||
[ in-d>> #drop ] bi prefix ;
|
||||
[ in-d>> #drop ]
|
||||
tri prefix ;
|
||||
|
||||
: cleanup-inlining ( #call -- nodes )
|
||||
body>> cleanup ;
|
||||
[ dup method>> [ drop ] [ word>> +inlined+ depends-on ] if ]
|
||||
[ body>> cleanup ]
|
||||
bi ;
|
||||
|
||||
! Removing overflow checks
|
||||
: no-overflow-variant ( op -- fast-op )
|
||||
|
|
@ -54,35 +71,15 @@ GENERIC: cleanup* ( node -- node/nodes )
|
|||
: remove-overflow-check ( #call -- #call )
|
||||
[ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ;
|
||||
|
||||
: immutable-tuple-boa? ( #call -- ? )
|
||||
dup word>> \ <tuple-boa> eq? [
|
||||
dup in-d>> peek node-value-info
|
||||
literal>> class>> immutable-tuple-class?
|
||||
] [ drop f ] if ;
|
||||
|
||||
: immutable-tuple-boa ( #call -- #call )
|
||||
\ <immutable-tuple-boa> >>word ;
|
||||
|
||||
M: #call cleanup*
|
||||
{
|
||||
{ [ dup body>> ] [ cleanup-inlining ] }
|
||||
{ [ dup cleanup-folding? ] [ cleanup-folding ] }
|
||||
{ [ dup remove-overflow-check? ] [ remove-overflow-check ] }
|
||||
{ [ dup immutable-tuple-boa? ] [ immutable-tuple-boa ] }
|
||||
[ ]
|
||||
} cond ;
|
||||
|
||||
GENERIC: delete-node ( node -- )
|
||||
|
||||
M: #call-recursive delete-node
|
||||
dup label>> [ [ eq? not ] with filter ] change-calls drop ;
|
||||
|
||||
M: #return-recursive delete-node
|
||||
label>> f >>return drop ;
|
||||
|
||||
M: node delete-node drop ;
|
||||
|
||||
: delete-nodes ( nodes -- ) [ delete-node ] each-node ;
|
||||
M: #declare cleanup* drop f ;
|
||||
|
||||
: delete-unreachable-branches ( #branch -- )
|
||||
dup live-branches>> '[
|
||||
|
|
@ -111,18 +108,26 @@ M: #branch cleanup*
|
|||
[ live-branches>> live-branches set ]
|
||||
} cleave ;
|
||||
|
||||
: cleanup-phi-in ( phi-in live-branches -- phi-in' )
|
||||
swap dup empty?
|
||||
[ nip ] [ flip swap select-children sift flip ] if ;
|
||||
: eliminate-single-phi ( #phi -- node )
|
||||
[ phi-in-d>> first ] [ out-d>> ] bi over [ +bottom+ eq? ] all?
|
||||
[ [ drop ] [ [ f swap #push ] map ] bi* ]
|
||||
[ #copy ]
|
||||
if ;
|
||||
|
||||
: eliminate-phi ( #phi -- node )
|
||||
live-branches get sift length {
|
||||
{ 0 [ drop f ] }
|
||||
{ 1 [ eliminate-single-phi ] }
|
||||
[ drop ]
|
||||
} case ;
|
||||
|
||||
M: #phi cleanup*
|
||||
#! Remove #phi function inputs which no longer exist.
|
||||
live-branches get {
|
||||
[ '[ , cleanup-phi-in ] change-phi-in-d ]
|
||||
[ '[ , cleanup-phi-in ] change-phi-in-r ]
|
||||
[ '[ , cleanup-phi-in ] change-phi-info-d ]
|
||||
[ '[ , cleanup-phi-in ] change-phi-info-r ]
|
||||
} cleave
|
||||
live-branches get
|
||||
[ '[ , sift-children ] change-phi-in-d ]
|
||||
[ '[ , sift-children ] change-phi-info-d ]
|
||||
[ '[ , sift-children ] change-terminated ] tri
|
||||
eliminate-phi
|
||||
live-branches off ;
|
||||
|
||||
: >copy ( node -- #copy ) [ in-d>> ] [ out-d>> ] bi #copy ;
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry kernel accessors sequences sequences.deep arrays
|
||||
USING: assocs fry kernel accessors sequences sequences.deep arrays
|
||||
stack-checker.inlining namespaces compiler.tree ;
|
||||
IN: compiler.tree.combinators
|
||||
|
||||
|
|
@ -45,13 +45,17 @@ IN: compiler.tree.combinators
|
|||
: select-children ( seq flags -- seq' )
|
||||
[ [ drop f ] unless ] 2map ;
|
||||
|
||||
: sift-children ( seq flags -- seq' )
|
||||
zip [ nip ] assoc-filter keys ;
|
||||
|
||||
: (3each) [ 3array flip ] dip [ first3 ] prepose ; inline
|
||||
|
||||
: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
|
||||
|
||||
: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline
|
||||
|
||||
: until-fixed-point ( #recursive quot -- )
|
||||
: until-fixed-point ( #recursive quot: ( node -- ) -- )
|
||||
over label>> t >>fixed-point drop
|
||||
[ with-scope ] 2keep
|
||||
over label>> fixed-point>> [ 2drop ] [ until-fixed-point ] if ; inline
|
||||
over label>> fixed-point>> [ 2drop ] [ until-fixed-point ] if ;
|
||||
inline recursive
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences namespaces kernel accessors assocs sets fry
|
||||
arrays combinators columns stack-checker.backend
|
||||
stack-checker.branches compiler.tree compiler.tree.combinators
|
||||
compiler.tree.dead-code.liveness compiler.tree.dead-code.simple
|
||||
;
|
||||
IN: compiler.tree.dead-code.branches
|
||||
|
||||
M: #if mark-live-values* look-at-inputs ;
|
||||
|
||||
M: #dispatch mark-live-values* look-at-inputs ;
|
||||
|
||||
: look-at-phi ( value outputs inputs -- )
|
||||
[ index ] dip swap dup [ <column> look-at-values ] [ 2drop ] if ;
|
||||
|
||||
M: #phi compute-live-values*
|
||||
#! If any of the outputs of a #phi are live, then the
|
||||
#! corresponding inputs are live too.
|
||||
[ out-d>> ] [ phi-in-d>> ] bi look-at-phi ;
|
||||
|
||||
SYMBOL: if-node
|
||||
|
||||
M: #branch remove-dead-code*
|
||||
[ [ [ (remove-dead-code) ] map ] change-children ]
|
||||
[ if-node set ]
|
||||
bi ;
|
||||
|
||||
: remove-phi-inputs ( #phi -- )
|
||||
if-node get children>>
|
||||
[ dup ends-with-terminate? [ drop f ] [ peek out-d>> ] if ] map
|
||||
pad-with-bottom >>phi-in-d drop ;
|
||||
|
||||
: live-value-indices ( values -- indices )
|
||||
[ length ] keep live-values get
|
||||
'[ , nth , key? ] filter ; inline
|
||||
|
||||
: drop-indexed-values ( values indices -- node )
|
||||
[ drop filter-live ] [ nths ] 2bi
|
||||
[ make-values ] keep
|
||||
[ drop ] [ zip ] 2bi
|
||||
#shuffle ;
|
||||
|
||||
: insert-drops ( nodes values indices -- nodes' )
|
||||
'[
|
||||
over ends-with-terminate?
|
||||
[ drop ] [ , drop-indexed-values suffix ] if
|
||||
] 2map ;
|
||||
|
||||
: hoist-drops ( #phi -- )
|
||||
if-node get swap
|
||||
[ phi-in-d>> ] [ out-d>> live-value-indices ] bi
|
||||
'[ , , insert-drops ] change-children drop ;
|
||||
|
||||
: remove-phi-outputs ( #phi -- )
|
||||
[ filter-live ] change-out-d drop ;
|
||||
|
||||
M: #phi remove-dead-code*
|
||||
{
|
||||
[ hoist-drops ]
|
||||
[ remove-phi-inputs ]
|
||||
[ remove-phi-outputs ]
|
||||
[ ]
|
||||
} cleave ;
|
||||
|
|
@ -0,0 +1,184 @@
|
|||
USING: namespaces assocs sequences compiler.tree.builder
|
||||
compiler.tree.dead-code compiler.tree.def-use compiler.tree
|
||||
compiler.tree.combinators compiler.tree.propagation
|
||||
compiler.tree.cleanup compiler.tree.escape-analysis
|
||||
compiler.tree.tuple-unboxing compiler.tree.debugger
|
||||
compiler.tree.normalization compiler.tree.checker tools.test
|
||||
kernel math stack-checker.state accessors combinators io
|
||||
prettyprint words sequences.deep sequences.private arrays
|
||||
classes kernel.private ;
|
||||
IN: compiler.tree.dead-code.tests
|
||||
|
||||
\ remove-dead-code must-infer
|
||||
|
||||
: count-live-values ( quot -- n )
|
||||
build-tree
|
||||
normalize
|
||||
propagate
|
||||
cleanup
|
||||
escape-analysis
|
||||
unbox-tuples
|
||||
compute-def-use
|
||||
remove-dead-code
|
||||
0 swap [
|
||||
dup
|
||||
[ #push? ] [ #introduce? ] bi or
|
||||
[ out-d>> length + ] [ drop ] if
|
||||
] each-node ;
|
||||
|
||||
[ 3 ] [ [ 1 2 3 ] count-live-values ] unit-test
|
||||
|
||||
[ 1 ] [ [ drop ] count-live-values ] unit-test
|
||||
|
||||
[ 0 ] [ [ 1 drop ] count-live-values ] unit-test
|
||||
|
||||
[ 1 ] [ [ 1 2 drop ] count-live-values ] unit-test
|
||||
|
||||
[ 3 ] [ [ [ 1 ] [ 2 ] if ] count-live-values ] unit-test
|
||||
|
||||
[ 1 ] [ [ [ 1 ] [ 2 ] if drop ] count-live-values ] unit-test
|
||||
|
||||
[ 2 ] [ [ [ 1 ] [ dup ] if drop ] count-live-values ] unit-test
|
||||
|
||||
[ 2 ] [ [ 1 + ] count-live-values ] unit-test
|
||||
|
||||
[ 0 ] [ [ 1 2 + drop ] count-live-values ] unit-test
|
||||
|
||||
[ 3 ] [ [ 1 + 3 + ] count-live-values ] unit-test
|
||||
|
||||
[ 0 ] [ [ 1 2 + 3 + drop ] count-live-values ] unit-test
|
||||
|
||||
[ 4 ] [ [ [ 1 ] [ 2 ] if 3 + ] count-live-values ] unit-test
|
||||
|
||||
[ 1 ] [ [ [ 1 ] [ 2 ] if 3 + drop ] count-live-values ] unit-test
|
||||
|
||||
[ 0 ] [ [ [ ] call ] count-live-values ] unit-test
|
||||
|
||||
[ 1 ] [ [ [ 1 ] call ] count-live-values ] unit-test
|
||||
|
||||
[ 2 ] [ [ [ 1 ] [ 2 ] compose call ] count-live-values ] unit-test
|
||||
|
||||
[ 0 ] [ [ [ 1 ] [ 2 ] compose call + drop ] count-live-values ] unit-test
|
||||
|
||||
[ 3 ] [ [ 10 [ ] times ] count-live-values ] unit-test
|
||||
|
||||
: optimize-quot ( quot -- quot' )
|
||||
build-tree
|
||||
normalize
|
||||
propagate
|
||||
cleanup
|
||||
escape-analysis
|
||||
unbox-tuples
|
||||
compute-def-use
|
||||
remove-dead-code
|
||||
"no-check" get [ dup check-nodes ] unless nodes>quot ;
|
||||
|
||||
[ [ drop 1 ] ] [ [ >r 1 r> drop ] optimize-quot ] unit-test
|
||||
|
||||
[ [ read drop 1 2 ] ] [ [ read >r 1 2 r> drop ] optimize-quot ] unit-test
|
||||
|
||||
[ [ over >r + r> ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test
|
||||
|
||||
[ [ [ ] [ ] if ] ] [ [ [ 1 ] [ 2 ] if drop ] optimize-quot ] unit-test
|
||||
|
||||
: flushable-1 ( a b -- c ) 2drop f ; flushable
|
||||
: flushable-2 ( a b -- c ) 2drop f ; flushable
|
||||
|
||||
[ [ 2nip [ ] [ ] if ] ] [
|
||||
[ [ flushable-1 ] [ flushable-2 ] if drop ] optimize-quot
|
||||
] unit-test
|
||||
|
||||
: non-flushable-3 ( a b -- c ) 2drop f ;
|
||||
|
||||
[ [ [ 2drop ] [ non-flushable-3 drop ] if ] ] [
|
||||
[ [ flushable-1 ] [ non-flushable-3 ] if drop ] optimize-quot
|
||||
] unit-test
|
||||
|
||||
[ [ [ f ] [ f ] if ] ] [ [ [ f ] [ f ] if ] optimize-quot ] unit-test
|
||||
|
||||
[ ] [ [ dup [ 3 throw ] [ ] if ] optimize-quot drop ] unit-test
|
||||
|
||||
[ [ [ . ] [ drop ] if ] ] [ [ [ dup . ] [ ] if drop ] optimize-quot ] unit-test
|
||||
|
||||
[ [ f ] ] [ [ f dup [ ] [ ] if ] optimize-quot ] unit-test
|
||||
|
||||
[ ] [ [ over [ ] [ dup [ "X" throw ] [ "X" throw ] if ] if ] optimize-quot drop ] unit-test
|
||||
|
||||
: boo ( a b -- c ) 2drop f ;
|
||||
|
||||
[ [ dup 4 eq? [ nip ] [ boo ] if ] ] [ [ dup dup 4 eq? [ drop nip ] [ drop boo ] if ] optimize-quot ] unit-test
|
||||
|
||||
: squish ( quot -- quot' )
|
||||
[
|
||||
{
|
||||
{ [ dup word? ] [ dup vocabulary>> [ drop "REC" ] unless ] }
|
||||
{ [ dup wrapper? ] [ dup wrapped>> vocabulary>> [ drop "WRAP" ] unless ] }
|
||||
[ ]
|
||||
} cond
|
||||
] deep-map ;
|
||||
|
||||
: call-recursive-dce-1 ( a -- b )
|
||||
[ call-recursive-dce-1 drop ] [ call-recursive-dce-1 ] bi ; inline recursive
|
||||
|
||||
[ [ "WRAP" [ dup >r "REC" drop r> "REC" ] label ] ] [
|
||||
[ call-recursive-dce-1 ] optimize-quot squish
|
||||
] unit-test
|
||||
|
||||
: produce-a-value ( -- a ) f ;
|
||||
|
||||
: call-recursive-dce-2 ( a -- b )
|
||||
drop
|
||||
produce-a-value dup . call-recursive-dce-2 ; inline recursive
|
||||
|
||||
[ [ "WRAP" [ produce-a-value . "REC" ] label ] ] [
|
||||
[ f call-recursive-dce-2 drop ] optimize-quot squish
|
||||
] unit-test
|
||||
|
||||
[ [ "WRAP" [ produce-a-value dup . drop "REC" ] label ] ] [
|
||||
[ f call-recursive-dce-2 ] optimize-quot squish
|
||||
] unit-test
|
||||
|
||||
: call-recursive-dce-3 ( a -- )
|
||||
call-recursive-dce-3 ; inline recursive
|
||||
|
||||
[ [ [ drop "WRAP" [ "REC" ] label ] [ . ] if ] ] [
|
||||
[ [ call-recursive-dce-3 ] [ . ] if ] optimize-quot squish
|
||||
] unit-test
|
||||
|
||||
[ [ drop "WRAP" [ "REC" ] label ] ] [
|
||||
[ call-recursive-dce-3 ] optimize-quot squish
|
||||
] unit-test
|
||||
|
||||
: call-recursive-dce-4 ( a -- b )
|
||||
call-recursive-dce-4 ; inline recursive
|
||||
|
||||
[ [ "WRAP" [ "REC" ] label ] ] [
|
||||
[ call-recursive-dce-4 ] optimize-quot squish
|
||||
] unit-test
|
||||
|
||||
[ [ drop "WRAP" [ "REC" ] label ] ] [
|
||||
[ call-recursive-dce-4 drop ] optimize-quot squish
|
||||
] unit-test
|
||||
|
||||
[ ] [ [ f call-recursive-dce-3 swap ] optimize-quot drop ] unit-test
|
||||
|
||||
: call-recursive-dce-5 ( -- ) call-recursive-dce-5 ; inline recursive
|
||||
|
||||
[ ] [ [ call-recursive-dce-5 swap ] optimize-quot drop ] unit-test
|
||||
|
||||
[ ] [ [ [ 0 -rot set-nth-unsafe ] curry (each-integer) ] optimize-quot drop ] unit-test
|
||||
|
||||
: call-recursive-dce-6 ( i quot: ( i -- ? ) -- i )
|
||||
dup call [ drop ] [ call-recursive-dce-6 ] if ; inline recursive
|
||||
|
||||
[ ] [ [ [ ] curry [ ] swap compose call-recursive-dce-6 ] optimize-quot drop ] unit-test
|
||||
|
||||
[ ] [ [ [ ] rot [ . ] curry pick [ roll 2drop call ] [ 2nip call ] if ] optimize-quot drop ] unit-test
|
||||
|
||||
[ [ drop ] ] [ [ array? drop ] optimize-quot ] unit-test
|
||||
|
||||
[ [ drop ] ] [ [ array instance? drop ] optimize-quot ] unit-test
|
||||
|
||||
[ [ drop ] ] [ [ { integer } declare f <array> drop ] optimize-quot ] unit-test
|
||||
|
||||
[ [ f <array> drop ] ] [ [ f <array> drop ] optimize-quot ] unit-test
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: compiler.tree.dead-code.branches
|
||||
compiler.tree.dead-code.liveness
|
||||
compiler.tree.dead-code.recursive
|
||||
compiler.tree.dead-code.simple ;
|
||||
IN: compiler.tree.dead-code
|
||||
|
||||
: remove-dead-code ( nodes -- nodes )
|
||||
init-dead-code
|
||||
mark-live-values
|
||||
compute-live-values
|
||||
(remove-dead-code) ;
|
||||
|
||||
|
|
@ -0,0 +1,51 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry accessors namespaces assocs deques search-deques
|
||||
kernel sequences sequences.deep words sets stack-checker.branches
|
||||
compiler.tree compiler.tree.def-use compiler.tree.combinators ;
|
||||
IN: compiler.tree.dead-code.liveness
|
||||
|
||||
SYMBOL: work-list
|
||||
|
||||
SYMBOL: live-values
|
||||
|
||||
: live-value? ( value -- ? ) live-values get at ;
|
||||
|
||||
: look-at-value ( values -- ) work-list get push-front ;
|
||||
|
||||
: look-at-values ( values -- ) work-list get push-all-front ;
|
||||
|
||||
: look-at-inputs ( node -- ) in-d>> look-at-values ;
|
||||
|
||||
: init-dead-code ( -- )
|
||||
<hashed-dlist> work-list set
|
||||
H{ { +bottom+ f } } clone live-values set ;
|
||||
|
||||
GENERIC: mark-live-values* ( node -- )
|
||||
|
||||
: mark-live-values ( nodes -- nodes )
|
||||
dup [ mark-live-values* ] each-node ; inline
|
||||
|
||||
M: node mark-live-values* drop ;
|
||||
|
||||
GENERIC: compute-live-values* ( value node -- )
|
||||
|
||||
M: node compute-live-values* 2drop ;
|
||||
|
||||
: iterate-live-values ( value -- )
|
||||
dup live-values get key? [
|
||||
drop
|
||||
] [
|
||||
dup live-values get conjoin
|
||||
dup defined-by compute-live-values*
|
||||
] if ;
|
||||
|
||||
: compute-live-values ( -- )
|
||||
work-list get [ iterate-live-values ] slurp-deque ;
|
||||
|
||||
GENERIC: remove-dead-code* ( node -- node' )
|
||||
|
||||
M: node remove-dead-code* ;
|
||||
|
||||
: (remove-dead-code) ( nodes -- nodes' )
|
||||
[ remove-dead-code* ] map flatten ;
|
||||
|
|
@ -0,0 +1,81 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs sequences kernel locals fry
|
||||
combinators stack-checker.backend
|
||||
compiler.tree
|
||||
compiler.tree.dead-code.branches
|
||||
compiler.tree.dead-code.liveness
|
||||
compiler.tree.dead-code.simple ;
|
||||
IN: compiler.tree.dead-code.recursive
|
||||
|
||||
M: #enter-recursive compute-live-values*
|
||||
#! If the output of an #enter-recursive is live, then the
|
||||
#! corresponding inputs to the #call-recursive are live also.
|
||||
[ out-d>> ] [ recursive-phi-in ] bi look-at-phi ;
|
||||
|
||||
: return-recursive-phi-in ( #return-recursive -- phi-in )
|
||||
[ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
|
||||
|
||||
M: #return-recursive compute-live-values*
|
||||
[ out-d>> ] [ return-recursive-phi-in ] bi look-at-phi ;
|
||||
|
||||
M: #call-recursive compute-live-values*
|
||||
#! If the output of a #call-recursive is live, then the
|
||||
#! corresponding inputs to #return nodes are live also.
|
||||
[ out-d>> ] [ label>> return>> in-d>> ] bi look-at-mapping ;
|
||||
|
||||
:: drop-dead-inputs ( inputs outputs -- #shuffle )
|
||||
[let* | live-inputs [ inputs filter-live ]
|
||||
new-live-inputs [ outputs inputs filter-corresponding make-values ] |
|
||||
live-inputs
|
||||
new-live-inputs
|
||||
outputs
|
||||
inputs
|
||||
drop-values
|
||||
] ;
|
||||
|
||||
M: #recursive remove-dead-code* ( node -- nodes )
|
||||
dup [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs
|
||||
{
|
||||
[ [ dup label>> enter-recursive>> ] [ out-d>> ] bi* '[ , >>in-d drop ] bi@ ]
|
||||
[ drop [ (remove-dead-code) ] change-child drop ]
|
||||
[ drop label>> [ filter-live ] change-enter-out drop ]
|
||||
[ swap 2array ]
|
||||
} 2cleave ;
|
||||
|
||||
M: #enter-recursive remove-dead-code*
|
||||
[ filter-live ] change-out-d ;
|
||||
|
||||
: drop-call-recursive-inputs ( node -- #shuffle )
|
||||
dup [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs
|
||||
[ out-d>> >>in-d drop ]
|
||||
[ nip ]
|
||||
2bi ;
|
||||
|
||||
:: (drop-call-recursive-outputs) ( inputs outputs -- #shuffle )
|
||||
[let* | new-live-outputs [ inputs outputs filter-corresponding make-values ]
|
||||
live-outputs [ outputs filter-live ] |
|
||||
new-live-outputs
|
||||
live-outputs
|
||||
live-outputs
|
||||
new-live-outputs
|
||||
drop-values
|
||||
] ;
|
||||
|
||||
: drop-call-recursive-outputs ( node -- #shuffle )
|
||||
dup [ label>> return>> in-d>> ] [ out-d>> ] bi
|
||||
(drop-call-recursive-outputs)
|
||||
[ in-d>> >>out-d drop ] keep ;
|
||||
|
||||
M: #call-recursive remove-dead-code*
|
||||
[ drop-call-recursive-inputs ]
|
||||
[ ]
|
||||
[ drop-call-recursive-outputs ]
|
||||
tri 3array ;
|
||||
|
||||
M: #return-recursive remove-dead-code* ( node -- nodes )
|
||||
dup [ in-d>> ] [ out-d>> ] bi drop-dead-inputs
|
||||
[ drop [ filter-live ] change-out-d drop ]
|
||||
[ out-d>> >>in-d drop ]
|
||||
[ swap 2array ]
|
||||
2tri ;
|
||||
|
|
@ -0,0 +1,135 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors words assocs sequences arrays namespaces
|
||||
fry locals classes.algebra stack-checker.backend
|
||||
compiler.tree
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.dead-code.liveness ;
|
||||
IN: compiler.tree.dead-code.simple
|
||||
|
||||
: flushable? ( word -- ? )
|
||||
[ "flushable" word-prop ] [ "predicating" word-prop ] bi or ;
|
||||
|
||||
: flushable-call? ( #call -- ? )
|
||||
dup word>> dup flushable? [
|
||||
"input-classes" word-prop dup [
|
||||
[ node-input-infos ] dip
|
||||
[ [ class>> ] dip class<= ] 2all?
|
||||
] [ 2drop t ] if
|
||||
] [ 2drop f ] if ;
|
||||
|
||||
M: #call mark-live-values*
|
||||
dup flushable-call? [ drop ] [ look-at-inputs ] if ;
|
||||
|
||||
M: #alien-invoke mark-live-values* look-at-inputs ;
|
||||
|
||||
M: #alien-indirect mark-live-values* look-at-inputs ;
|
||||
|
||||
M: #return mark-live-values* look-at-inputs ;
|
||||
|
||||
: look-at-mapping ( value inputs outputs -- )
|
||||
[ index ] dip over [ nth look-at-value ] [ 2drop ] if ;
|
||||
|
||||
M: #copy compute-live-values*
|
||||
#! If the output of a copy is live, then the corresponding
|
||||
#! input is live also.
|
||||
[ out-d>> ] [ in-d>> ] bi look-at-mapping ;
|
||||
|
||||
M: #call compute-live-values* nip look-at-inputs ;
|
||||
|
||||
M: #>r compute-live-values*
|
||||
[ out-r>> ] [ in-d>> ] bi look-at-mapping ;
|
||||
|
||||
M: #r> compute-live-values*
|
||||
[ out-d>> ] [ in-r>> ] bi look-at-mapping ;
|
||||
|
||||
M: #shuffle compute-live-values*
|
||||
mapping>> at look-at-value ;
|
||||
|
||||
M: #alien-invoke compute-live-values* nip look-at-inputs ;
|
||||
|
||||
M: #alien-indirect compute-live-values* nip look-at-inputs ;
|
||||
|
||||
: filter-mapping ( assoc -- assoc' )
|
||||
live-values get '[ drop , key? ] assoc-filter ;
|
||||
|
||||
: filter-corresponding ( new old -- old' )
|
||||
#! Remove elements from 'old' if the element with the same
|
||||
#! index in 'new' is dead.
|
||||
zip filter-mapping values ;
|
||||
|
||||
: filter-live ( values -- values' )
|
||||
[ live-value? ] filter ;
|
||||
|
||||
:: drop-values ( inputs outputs mapping-keys mapping-values -- #shuffle )
|
||||
inputs
|
||||
outputs
|
||||
outputs
|
||||
mapping-keys
|
||||
mapping-values
|
||||
filter-corresponding zip #shuffle ; inline
|
||||
|
||||
:: drop-dead-values ( outputs -- #shuffle )
|
||||
[let* | new-outputs [ outputs make-values ]
|
||||
live-outputs [ outputs filter-live ] |
|
||||
new-outputs
|
||||
live-outputs
|
||||
outputs
|
||||
new-outputs
|
||||
drop-values
|
||||
] ;
|
||||
|
||||
: drop-dead-outputs ( node -- nodes )
|
||||
dup out-d>> drop-dead-values
|
||||
[ in-d>> >>out-d drop ] [ 2array ] 2bi ;
|
||||
|
||||
M: #introduce remove-dead-code* ( #introduce -- nodes )
|
||||
drop-dead-outputs ;
|
||||
|
||||
M: #>r remove-dead-code*
|
||||
[ filter-live ] change-out-r
|
||||
[ filter-live ] change-in-d
|
||||
dup in-d>> empty? [ drop f ] when ;
|
||||
|
||||
M: #r> remove-dead-code*
|
||||
[ filter-live ] change-out-d
|
||||
[ filter-live ] change-in-r
|
||||
dup in-r>> empty? [ drop f ] when ;
|
||||
|
||||
M: #push remove-dead-code*
|
||||
dup out-d>> first live-value? [ drop f ] unless ;
|
||||
|
||||
: dead-flushable-call? ( #call -- ? )
|
||||
dup flushable-call? [
|
||||
out-d>> [ live-value? not ] all?
|
||||
] [ drop f ] if ;
|
||||
|
||||
: remove-flushable-call ( #call -- node )
|
||||
in-d>> #drop remove-dead-code* ;
|
||||
|
||||
: some-outputs-dead? ( #call -- ? )
|
||||
out-d>> [ live-value? not ] contains? ;
|
||||
|
||||
M: #call remove-dead-code*
|
||||
dup dead-flushable-call? [
|
||||
remove-flushable-call
|
||||
] [
|
||||
dup some-outputs-dead? [
|
||||
drop-dead-outputs
|
||||
] when
|
||||
] if ;
|
||||
|
||||
M: #shuffle remove-dead-code*
|
||||
[ filter-live ] change-in-d
|
||||
[ filter-live ] change-out-d
|
||||
[ filter-mapping ] change-mapping
|
||||
dup in-d>> empty? [ drop f ] when ;
|
||||
|
||||
M: #copy remove-dead-code*
|
||||
[ in-d>> ] [ out-d>> ] bi
|
||||
2dup swap zip #shuffle
|
||||
remove-dead-code* ;
|
||||
|
||||
M: #terminate remove-dead-code*
|
||||
[ filter-live ] change-in-d
|
||||
[ filter-live ] change-in-r ;
|
||||
|
|
@ -3,12 +3,11 @@
|
|||
USING: kernel assocs fry match accessors namespaces effects
|
||||
sequences sequences.private quotations generic macros arrays
|
||||
prettyprint prettyprint.backend prettyprint.sections math words
|
||||
combinators io sorting
|
||||
combinators io sorting hints
|
||||
compiler.tree
|
||||
compiler.tree.builder
|
||||
compiler.tree.optimizer
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info ;
|
||||
compiler.tree.combinators ;
|
||||
IN: compiler.tree.debugger
|
||||
|
||||
! A simple tool for turning tree IR into quotations and
|
||||
|
|
@ -46,18 +45,15 @@ MATCH-VARS: ?a ?b ?c ;
|
|||
{ _ f }
|
||||
} match-choose ;
|
||||
|
||||
TUPLE: shuffle effect ;
|
||||
|
||||
M: shuffle pprint* effect>> effect>string text ;
|
||||
TUPLE: shuffle-node { effect effect } ;
|
||||
|
||||
M: shuffle-node pprint* effect>> effect>string text ;
|
||||
|
||||
M: #shuffle node>quot
|
||||
shuffle-effect dup pretty-shuffle
|
||||
[ % ] [ shuffle boa , ] ?if ;
|
||||
[ % ] [ shuffle-node boa , ] ?if ;
|
||||
|
||||
: pushed-literals ( node -- seq )
|
||||
dup out-d>> [ node-value-info literal>> literalize ] with map ;
|
||||
|
||||
M: #push node>quot pushed-literals % ;
|
||||
M: #push node>quot literal>> , ;
|
||||
|
||||
M: #call node>quot word>> , ;
|
||||
|
||||
|
|
@ -78,9 +74,21 @@ M: #if node>quot
|
|||
M: #dispatch node>quot
|
||||
children>> [ nodes>quot ] map , \ dispatch , ;
|
||||
|
||||
M: #>r node>quot in-d>> length \ >r <repetition> % ;
|
||||
M: #>r node>quot
|
||||
[ in-d>> length ] [ out-r>> empty? \ drop \ >r ? ] bi
|
||||
<repetition> % ;
|
||||
|
||||
M: #r> node>quot out-d>> length \ r> <repetition> % ;
|
||||
DEFER: rdrop
|
||||
|
||||
M: #r> node>quot
|
||||
[ in-r>> length ] [ out-d>> empty? \ rdrop \ r> ? ] bi
|
||||
<repetition> % ;
|
||||
|
||||
M: #alien-invoke node>quot params>> , \ #alien-invoke , ;
|
||||
|
||||
M: #alien-indirect node>quot params>> , \ #alien-indirect , ;
|
||||
|
||||
M: #alien-callback node>quot params>> , \ #alien-callback , ;
|
||||
|
||||
M: node node>quot drop ;
|
||||
|
||||
|
|
@ -24,6 +24,11 @@ IN: compiler.tree.def-use.tests
|
|||
compute-def-use
|
||||
check-nodes ;
|
||||
|
||||
: too-deep ( a b -- c )
|
||||
dup [ drop ] [ 2dup too-deep too-deep drop ] if ; inline recursive
|
||||
|
||||
[ ] [ [ too-deep ] build-tree normalize compute-def-use check-nodes ] unit-test
|
||||
|
||||
! compute-def-use checks for SSA violations, so we use that to
|
||||
! ensure we generate some common patterns correctly.
|
||||
{
|
||||
|
|
@ -39,22 +39,21 @@ GENERIC: node-uses-values ( node -- values )
|
|||
M: #introduce node-uses-values drop f ;
|
||||
M: #push node-uses-values drop f ;
|
||||
M: #r> node-uses-values in-r>> ;
|
||||
M: #phi node-uses-values
|
||||
[ phi-in-d>> ] [ phi-in-r>> ] bi
|
||||
append concat remove-bottom prune ;
|
||||
M: #phi node-uses-values phi-in-d>> concat remove-bottom prune ;
|
||||
M: #declare node-uses-values declaration>> keys ;
|
||||
M: #terminate node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
|
||||
M: #alien-callback node-uses-values drop f ;
|
||||
M: node node-uses-values in-d>> ;
|
||||
|
||||
GENERIC: node-defs-values ( node -- values )
|
||||
|
||||
M: #introduce node-defs-values value>> 1array ;
|
||||
M: #>r node-defs-values out-r>> ;
|
||||
M: #branch node-defs-values drop f ;
|
||||
M: #phi node-defs-values [ out-d>> ] [ out-r>> ] bi append ;
|
||||
M: #declare node-defs-values drop f ;
|
||||
M: #return node-defs-values drop f ;
|
||||
M: #recursive node-defs-values drop f ;
|
||||
M: #terminate node-defs-values drop f ;
|
||||
M: #alien-callback node-defs-values drop f ;
|
||||
M: node node-defs-values out-d>> ;
|
||||
|
||||
: node-def-use ( node -- )
|
||||
|
|
@ -57,7 +57,7 @@ SYMBOL: +escaping+
|
|||
<value> dup introduce-value ;
|
||||
|
||||
: merge-values ( in-values out-value -- )
|
||||
escaping-values get '[ , , equate ] each ;
|
||||
escaping-values get equate-all-with ;
|
||||
|
||||
: merge-slots ( values -- value )
|
||||
<slot-value> [ merge-values ] keep ;
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces sequences sets fry
|
||||
USING: accessors kernel namespaces sequences sets fry columns
|
||||
stack-checker.branches
|
||||
compiler.tree
|
||||
compiler.tree.propagation.branches
|
||||
|
|
@ -33,6 +33,4 @@ M: #branch escape-analysis*
|
|||
2bi ;
|
||||
|
||||
M: #phi escape-analysis*
|
||||
[ [ phi-in-d>> ] [ out-d>> ] bi merge-allocations ]
|
||||
[ [ phi-in-r>> ] [ out-r>> ] bi merge-allocations ]
|
||||
bi ;
|
||||
[ phi-in-d>> <flipped> ] [ out-d>> ] bi merge-allocations ;
|
||||
|
|
@ -6,7 +6,8 @@ compiler.tree.propagation compiler.tree.cleanup
|
|||
compiler.tree.combinators compiler.tree sequences math math.private
|
||||
kernel tools.test accessors slots.private quotations.private
|
||||
prettyprint classes.tuple.private classes classes.tuple
|
||||
compiler.tree.intrinsics ;
|
||||
compiler.tree.intrinsics namespaces compiler.tree.propagation.info
|
||||
stack-checker.errors ;
|
||||
|
||||
\ escape-analysis must-infer
|
||||
|
||||
|
|
@ -16,7 +17,7 @@ GENERIC: count-unboxed-allocations* ( m node -- n )
|
|||
out-d>> first escaping-allocation? [ 1+ ] unless ;
|
||||
|
||||
M: #call count-unboxed-allocations*
|
||||
dup word>> { <immutable-tuple-boa> <complex> } memq?
|
||||
dup [ immutable-tuple-boa? ] [ word>> \ <complex> eq? ] bi or
|
||||
[ (count-unboxed-allocations) ] [ drop ] if ;
|
||||
|
||||
M: #push count-unboxed-allocations*
|
||||
|
|
@ -295,3 +296,23 @@ C: <ro-box> ro-box
|
|||
[ 1 ] [ [ 1 cons boa 2 cons boa car>> ] count-unboxed-allocations ] unit-test
|
||||
|
||||
[ 0 ] [ [ 1 cons boa 2 cons boa dup . car>> ] count-unboxed-allocations ] unit-test
|
||||
|
||||
[ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test
|
||||
|
||||
: impeach-node ( quot: ( node -- ) -- )
|
||||
dup slip impeach-node ; inline recursive
|
||||
|
||||
: bleach-node ( quot: ( node -- ) -- )
|
||||
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
|
||||
|
||||
[ 2 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
|
||||
|
||||
[ 0 ] [
|
||||
[ dup -1 over >= [ 0 >= [ "A" throw ] unless ] [ drop ] if ]
|
||||
count-unboxed-allocations
|
||||
] unit-test
|
||||
|
||||
[ 0 ] [
|
||||
[ \ too-many->r boa f f \ inference-error boa ]
|
||||
count-unboxed-allocations
|
||||
] unit-test
|
||||
|
|
@ -1,9 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces search-dequeues assocs fry sequences
|
||||
disjoint-sets
|
||||
USING: kernel namespaces assocs fry sequences
|
||||
compiler.tree
|
||||
compiler.tree.def-use
|
||||
compiler.tree.escape-analysis.allocations
|
||||
compiler.tree.escape-analysis.recursive
|
||||
compiler.tree.escape-analysis.branches
|
||||
|
|
@ -27,7 +27,7 @@ IN: compiler.tree.escape-analysis.recursive
|
|||
out-d>> [ allocation ] map ;
|
||||
|
||||
: recursive-stacks ( #enter-recursive -- stacks )
|
||||
[ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix
|
||||
recursive-phi-in
|
||||
escaping-values get '[ [ , disjoint-set-member? ] all? ] filter
|
||||
flip ;
|
||||
|
||||
|
|
@ -42,14 +42,13 @@ IN: compiler.tree.escape-analysis.recursive
|
|||
] 2bi ;
|
||||
|
||||
M: #recursive escape-analysis* ( #recursive -- )
|
||||
{ 0 } clone [ USE: math
|
||||
dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
|
||||
[
|
||||
child>>
|
||||
[ first out-d>> introduce-values ]
|
||||
[ first analyze-recursive-phi ]
|
||||
[ (escape-analysis) ]
|
||||
tri
|
||||
] curry until-fixed-point ;
|
||||
] until-fixed-point ;
|
||||
|
||||
M: #enter-recursive escape-analysis* ( #enter-recursive -- )
|
||||
#! Handled by #recursive
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences classes.tuple
|
||||
classes.tuple.private arrays math math.private slots.private
|
||||
combinators dequeues search-dequeues namespaces fry classes
|
||||
combinators deques search-deques namespaces fry classes
|
||||
classes.algebra stack-checker.state
|
||||
compiler.tree
|
||||
compiler.tree.intrinsics
|
||||
|
|
@ -11,13 +11,11 @@ compiler.tree.escape-analysis.nodes
|
|||
compiler.tree.escape-analysis.allocations ;
|
||||
IN: compiler.tree.escape-analysis.simple
|
||||
|
||||
M: #declare escape-analysis* drop ;
|
||||
|
||||
M: #terminate escape-analysis* drop ;
|
||||
|
||||
M: #renaming escape-analysis* inputs/outputs [ copy-value ] 2each ;
|
||||
|
||||
M: #introduce escape-analysis* value>> unknown-allocation ;
|
||||
M: #introduce escape-analysis* out-d>> unknown-allocations ;
|
||||
|
||||
DEFER: record-literal-allocation
|
||||
|
||||
|
|
@ -42,8 +40,15 @@ M: #push escape-analysis*
|
|||
#! Delegation.
|
||||
[ out-d>> first ] [ literal>> ] bi record-literal-allocation ;
|
||||
|
||||
: record-unknown-allocation ( #call -- )
|
||||
[ in-d>> add-escaping-values ]
|
||||
[ out-d>> unknown-allocations ] bi ;
|
||||
|
||||
: record-tuple-allocation ( #call -- )
|
||||
[ in-d>> but-last ] [ out-d>> first ] bi record-allocation ;
|
||||
dup immutable-tuple-boa?
|
||||
[ [ in-d>> but-last ] [ out-d>> first ] bi record-allocation ]
|
||||
[ record-unknown-allocation ]
|
||||
if ;
|
||||
|
||||
: record-complex-allocation ( #call -- )
|
||||
[ in-d>> ] [ out-d>> first ] bi record-allocation ;
|
||||
|
|
@ -61,21 +66,17 @@ M: #push escape-analysis*
|
|||
] [ 2drop f ] if ;
|
||||
|
||||
: record-slot-call ( #call -- )
|
||||
[ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri
|
||||
over [
|
||||
[ record-slot-access ] [ copy-slot-value ] 3bi
|
||||
] [ 2drop unknown-allocation ] if ;
|
||||
[ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri over
|
||||
[ [ record-slot-access ] [ copy-slot-value ] 3bi ]
|
||||
[ [ unknown-allocation ] [ drop ] [ add-escaping-value ] tri* ]
|
||||
if ;
|
||||
|
||||
M: #call escape-analysis*
|
||||
dup word>> {
|
||||
{ \ <immutable-tuple-boa> [ record-tuple-allocation ] }
|
||||
{ \ <tuple-boa> [ record-tuple-allocation ] }
|
||||
{ \ <complex> [ record-complex-allocation ] }
|
||||
{ \ slot [ record-slot-call ] }
|
||||
[
|
||||
drop
|
||||
[ in-d>> add-escaping-values ]
|
||||
[ out-d>> unknown-allocations ] bi
|
||||
]
|
||||
[ drop record-unknown-allocation ]
|
||||
} case ;
|
||||
|
||||
M: #return escape-analysis*
|
||||
|
|
@ -83,10 +84,12 @@ M: #return escape-analysis*
|
|||
|
||||
M: #alien-invoke escape-analysis*
|
||||
[ in-d>> add-escaping-values ]
|
||||
[ out-d>> unknown-allocation ]
|
||||
[ out-d>> unknown-allocations ]
|
||||
bi ;
|
||||
|
||||
M: #alien-indirect escape-analysis*
|
||||
[ in-d>> add-escaping-values ]
|
||||
[ out-d>> unknown-allocation ]
|
||||
[ out-d>> unknown-allocations ]
|
||||
bi ;
|
||||
|
||||
M: #alien-callback escape-analysis* drop ;
|
||||
|
|
@ -4,9 +4,6 @@ USING: kernel classes.tuple classes.tuple.private math arrays
|
|||
byte-arrays words stack-checker.known-words ;
|
||||
IN: compiler.tree.intrinsics
|
||||
|
||||
: <immutable-tuple-boa> ( ... class -- tuple )
|
||||
"BUG: missing <immutable-tuple-boa> intrinsic" throw ;
|
||||
|
||||
: (tuple) ( layout -- tuple )
|
||||
"BUG: missing (tuple) intrinsic" throw ;
|
||||
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences namespaces assocs accessors fry
|
||||
compiler.tree dequeues search-dequeues ;
|
||||
compiler.tree deques search-deques ;
|
||||
IN: compiler.tree.loop.detection
|
||||
|
||||
! A loop is a #recursive which only tail calls itself, and those
|
||||
|
|
@ -82,7 +82,7 @@ M: node collect-loop-info* 2drop ;
|
|||
[ loop-calls get at [ disqualify-loop ] each ]
|
||||
bi
|
||||
] [ drop ] if
|
||||
] slurp-dequeue ;
|
||||
] slurp-deque ;
|
||||
|
||||
: detect-loops ( nodes -- nodes )
|
||||
dup collect-loop-info disqualify-loops ;
|
||||
|
|
@ -0,0 +1,48 @@
|
|||
IN: compiler.tree.normalization.tests
|
||||
USING: compiler.tree.builder compiler.tree.normalization
|
||||
compiler.tree compiler.tree.checker
|
||||
sequences accessors tools.test kernel math ;
|
||||
|
||||
\ count-introductions must-infer
|
||||
\ normalize must-infer
|
||||
|
||||
[ 3 ] [ [ 3drop 1 2 3 ] build-tree count-introductions ] unit-test
|
||||
|
||||
[ 4 ] [ [ 3drop 1 2 3 3drop drop ] build-tree count-introductions ] unit-test
|
||||
|
||||
[ 3 ] [ [ [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test
|
||||
|
||||
[ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test
|
||||
|
||||
: foo ( -- ) swap ; inline recursive
|
||||
|
||||
: recursive-inputs ( nodes -- n )
|
||||
[ #recursive? ] find nip child>> first in-d>> length ;
|
||||
|
||||
[ 0 2 ] [
|
||||
[ foo ] build-tree
|
||||
[ recursive-inputs ]
|
||||
[ normalize recursive-inputs ] bi
|
||||
] unit-test
|
||||
|
||||
[ ] [ [ [ 1 ] [ 2 ] if + * ] build-tree normalize check-nodes ] unit-test
|
||||
|
||||
DEFER: bbb
|
||||
: aaa ( x -- ) dup [ dup >r bbb r> aaa ] [ drop ] if ; inline recursive
|
||||
: bbb ( x -- ) >r drop 0 r> aaa ; inline recursive
|
||||
|
||||
[ ] [ [ bbb ] build-tree normalize check-nodes ] unit-test
|
||||
|
||||
: ccc ( -- ) ccc drop 1 ; inline recursive
|
||||
|
||||
[ ] [ [ ccc ] build-tree normalize check-nodes ] unit-test
|
||||
|
||||
DEFER: eee
|
||||
: ddd ( -- ) eee ; inline recursive
|
||||
: eee ( -- ) swap ddd ; inline recursive
|
||||
|
||||
[ ] [ [ eee ] build-tree normalize check-nodes ] unit-test
|
||||
|
||||
: call-recursive-5 ( -- ) call-recursive-5 ; inline recursive
|
||||
|
||||
[ ] [ [ call-recursive-5 swap ] build-tree normalize check-nodes ] unit-test
|
||||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry namespaces sequences math accessors kernel arrays
|
||||
combinators sequences.deep assocs
|
||||
stack-checker.backend
|
||||
stack-checker.branches
|
||||
stack-checker.inlining
|
||||
|
|
@ -11,10 +12,9 @@ IN: compiler.tree.normalization
|
|||
! A transform pass done before optimization can begin to
|
||||
! fix up some oddities in the tree output by the stack checker:
|
||||
!
|
||||
! - We rewrite the code is that #introduce nodes only appear
|
||||
! at the beginning of a program, never having #introduce follow
|
||||
! any other type of node or appear inside a #branch or
|
||||
! #recursive. This simplifies some types of analysis.
|
||||
! - We rewrite the code so that all #introduce nodes are
|
||||
! replaced with a single one, at the beginning of a program.
|
||||
! This simplifies subsequent analysis.
|
||||
!
|
||||
! - We collect #return-recursive and #call-recursive nodes and
|
||||
! store them in the #recursive's label slot.
|
||||
|
|
@ -43,16 +43,20 @@ GENERIC: count-introductions* ( node -- )
|
|||
introductions get
|
||||
] with-scope ;
|
||||
|
||||
M: #introduce count-introductions* drop introductions inc ;
|
||||
: introductions+ ( n -- ) introductions [ + ] change ;
|
||||
|
||||
M: #introduce count-introductions*
|
||||
out-d>> length introductions+ ;
|
||||
|
||||
M: #branch count-introductions*
|
||||
children>>
|
||||
[ count-introductions ] map supremum
|
||||
introductions [ + ] change ;
|
||||
introductions+ ;
|
||||
|
||||
M: #recursive count-introductions*
|
||||
[ label>> ] [ child>> count-introductions ] bi
|
||||
>>introductions drop ;
|
||||
>>introductions
|
||||
drop ;
|
||||
|
||||
M: node count-introductions* drop ;
|
||||
|
||||
|
|
@ -70,88 +74,135 @@ M: #recursive collect-label-info
|
|||
|
||||
M: node collect-label-info drop ;
|
||||
|
||||
! Eliminate introductions
|
||||
! Rename
|
||||
SYMBOL: rename-map
|
||||
|
||||
: rename-value ( value -- value' )
|
||||
[ rename-map get at ] keep or ;
|
||||
|
||||
: rename-values ( values -- values' )
|
||||
rename-map get '[ [ , at ] keep or ] map ;
|
||||
|
||||
GENERIC: rename-node-values* ( node -- node )
|
||||
|
||||
M: #introduce rename-node-values* ;
|
||||
|
||||
M: #shuffle rename-node-values*
|
||||
[ rename-values ] change-in-d
|
||||
[ [ rename-value ] assoc-map ] change-mapping ;
|
||||
|
||||
M: #push rename-node-values* ;
|
||||
|
||||
M: #r> rename-node-values*
|
||||
[ rename-values ] change-in-r ;
|
||||
|
||||
M: #terminate rename-node-values*
|
||||
[ rename-values ] change-in-d
|
||||
[ rename-values ] change-in-r ;
|
||||
|
||||
M: #phi rename-node-values*
|
||||
[ [ rename-values ] map ] change-phi-in-d ;
|
||||
|
||||
M: #declare rename-node-values*
|
||||
[ [ [ rename-value ] dip ] assoc-map ] change-declaration ;
|
||||
|
||||
M: #alien-callback rename-node-values* ;
|
||||
|
||||
M: node rename-node-values*
|
||||
[ rename-values ] change-in-d ;
|
||||
|
||||
: rename-node-values ( nodes -- nodes' )
|
||||
dup [ rename-node-values* drop ] each-node ;
|
||||
|
||||
! Normalize
|
||||
GENERIC: normalize* ( node -- node' )
|
||||
|
||||
SYMBOL: introduction-stack
|
||||
|
||||
: fixup-enter-recursive ( introductions recursive -- )
|
||||
[ child>> first ] [ in-d>> ] bi >>in-d
|
||||
[ append ] change-out-d
|
||||
drop ;
|
||||
|
||||
GENERIC: eliminate-introductions* ( node -- node' )
|
||||
|
||||
: pop-introduction ( -- value )
|
||||
introduction-stack [ unclip-last swap ] change ;
|
||||
|
||||
M: #introduce eliminate-introductions*
|
||||
pop-introduction swap value>> [ 1array ] bi@ #copy ;
|
||||
: pop-introductions ( n -- values )
|
||||
introduction-stack [ swap cut* swap ] change ;
|
||||
|
||||
: add-renamings ( old new -- )
|
||||
[ rename-values ] dip
|
||||
rename-map get '[ , set-at ] 2each ;
|
||||
|
||||
M: #introduce normalize*
|
||||
out-d>> [ length pop-introductions ] keep add-renamings f ;
|
||||
|
||||
SYMBOL: remaining-introductions
|
||||
|
||||
M: #branch eliminate-introductions*
|
||||
dup children>> [
|
||||
M: #branch normalize*
|
||||
[
|
||||
[
|
||||
[ eliminate-introductions* ] change-each
|
||||
introduction-stack get
|
||||
] with-scope
|
||||
] map
|
||||
[
|
||||
[ normalize* ] map flatten
|
||||
introduction-stack get
|
||||
2array
|
||||
] with-scope
|
||||
] map unzip swap
|
||||
] change-children swap
|
||||
[ remaining-introductions set ]
|
||||
[ [ length ] map infimum introduction-stack [ swap head ] change ]
|
||||
bi ;
|
||||
|
||||
: eliminate-phi-introductions ( introductions seq terminated -- seq' )
|
||||
[ flip ] dip [
|
||||
[
|
||||
[ nip ] [
|
||||
dup [ +bottom+ eq? ] left-trim
|
||||
[ [ length ] bi@ - tail* ] keep append
|
||||
] if
|
||||
] 3map flip ;
|
||||
] 3map ;
|
||||
|
||||
M: #phi eliminate-introductions*
|
||||
M: #phi normalize*
|
||||
remaining-introductions get swap dup terminated>>
|
||||
'[ , eliminate-phi-introductions ] change-phi-in-d ;
|
||||
|
||||
M: node eliminate-introductions* ;
|
||||
|
||||
: eliminate-introductions ( nodes introductions -- nodes )
|
||||
: (normalize) ( nodes introductions -- nodes )
|
||||
introduction-stack [
|
||||
[ eliminate-introductions* ] map
|
||||
[ normalize* ] map flatten
|
||||
] with-variable ;
|
||||
|
||||
: eliminate-toplevel-introductions ( nodes -- nodes' )
|
||||
dup count-introductions make-values
|
||||
[ nip [ #introduce ] map ] [ eliminate-introductions ] 2bi
|
||||
append ;
|
||||
|
||||
: eliminate-recursive-introductions ( recursive n -- )
|
||||
make-values
|
||||
[ swap fixup-enter-recursive ]
|
||||
[ '[ , eliminate-introductions ] change-child drop ]
|
||||
M: #recursive normalize*
|
||||
dup label>> introductions>>
|
||||
[ drop [ child>> first ] [ in-d>> ] bi >>in-d drop ]
|
||||
[ make-values '[ , (normalize) ] change-child ]
|
||||
2bi ;
|
||||
|
||||
! Normalize
|
||||
GENERIC: normalize* ( node -- node' )
|
||||
|
||||
M: #recursive normalize*
|
||||
dup dup label>> introductions>>
|
||||
eliminate-recursive-introductions ;
|
||||
|
||||
M: #enter-recursive normalize*
|
||||
[ introduction-stack get prepend ] change-out-d
|
||||
dup [ label>> ] keep >>enter-recursive drop
|
||||
dup [ label>> ] [ out-d>> ] bi >>enter-out drop ;
|
||||
|
||||
: unchanged-underneath ( #call-recursive -- n )
|
||||
[ out-d>> length ] [ label>> return>> in-d>> length ] bi - ;
|
||||
|
||||
M: #call-recursive normalize*
|
||||
dup unchanged-underneath
|
||||
[ [ [ in-d>> ] [ out-d>> ] bi ] [ '[ , head ] ] bi* bi@ #copy ]
|
||||
: call<return ( #call-recursive n -- nodes )
|
||||
neg dup make-values [
|
||||
[ pop-introductions '[ , prepend ] change-in-d ]
|
||||
[ '[ , prepend ] change-out-d ]
|
||||
bi*
|
||||
] [ introduction-stack [ prepend ] change ] bi ;
|
||||
|
||||
: call>return ( #call-recursive n -- #call-recursive )
|
||||
[ [ [ in-d>> ] [ out-d>> ] bi ] [ '[ , head ] ] bi* bi@ add-renamings ]
|
||||
[ '[ , tail ] [ change-in-d ] [ change-out-d ] bi ]
|
||||
2bi 2array ;
|
||||
2bi ;
|
||||
|
||||
M: #call-recursive normalize*
|
||||
dup unchanged-underneath {
|
||||
{ [ dup 0 < ] [ call<return ] }
|
||||
{ [ dup 0 = ] [ drop ] }
|
||||
{ [ dup 0 > ] [ call>return ] }
|
||||
} cond ;
|
||||
|
||||
M: node normalize* ;
|
||||
|
||||
: normalize ( nodes -- nodes' )
|
||||
H{ } clone rename-map set
|
||||
dup [ collect-label-info ] each-node
|
||||
eliminate-toplevel-introductions
|
||||
[ normalize* ] map-nodes ;
|
||||
dup count-introductions make-values
|
||||
[ (normalize) ] [ nip #introduce ] 2bi prefix
|
||||
rename-node-values ;
|
||||
|
|
@ -10,7 +10,8 @@ compiler.tree.dead-code
|
|||
compiler.tree.strength-reduction
|
||||
compiler.tree.loop.detection
|
||||
compiler.tree.loop.inversion
|
||||
compiler.tree.branch-fusion ;
|
||||
compiler.tree.branch-fusion
|
||||
compiler.tree.checker ;
|
||||
IN: compiler.tree.optimizer
|
||||
|
||||
: optimize-tree ( nodes -- nodes' )
|
||||
|
|
@ -18,10 +19,14 @@ IN: compiler.tree.optimizer
|
|||
propagate
|
||||
cleanup
|
||||
detect-loops
|
||||
invert-loops
|
||||
fuse-branches
|
||||
! invert-loops
|
||||
! fuse-branches
|
||||
escape-analysis
|
||||
unbox-tuples
|
||||
compute-def-use
|
||||
remove-dead-code
|
||||
strength-reduce ;
|
||||
! strength-reduce
|
||||
! USE: kernel
|
||||
! compute-def-use
|
||||
! dup check-nodes
|
||||
;
|
||||
|
|
@ -1,10 +1,9 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry kernel sequences assocs accessors namespaces
|
||||
math.intervals arrays classes.algebra combinators
|
||||
math.intervals arrays classes.algebra combinators columns
|
||||
stack-checker.branches
|
||||
compiler.tree
|
||||
compiler.tree.def-use
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.nodes
|
||||
|
|
@ -60,23 +59,17 @@ SYMBOL: infer-children-data
|
|||
|
||||
: compute-phi-input-infos ( phi-in -- phi-info )
|
||||
infer-children-data get
|
||||
'[
|
||||
, [
|
||||
[
|
||||
[
|
||||
'[
|
||||
, [
|
||||
dup +bottom+ eq?
|
||||
[ drop null-info ] [ value-info ] if
|
||||
] bind
|
||||
] 2map
|
||||
] map ;
|
||||
] map
|
||||
] 2map ;
|
||||
|
||||
: annotate-phi-inputs ( #phi -- )
|
||||
dup phi-in-d>> compute-phi-input-infos >>phi-info-d
|
||||
dup phi-in-r>> compute-phi-input-infos >>phi-info-r
|
||||
drop ;
|
||||
|
||||
: annotate-phi-outputs ( #phi -- )
|
||||
dup [ out-d>> ] [ out-r>> ] bi append extract-value-info
|
||||
>>info drop ;
|
||||
dup phi-in-d>> compute-phi-input-infos >>phi-info-d drop ;
|
||||
|
||||
: merge-value-infos ( infos outputs -- )
|
||||
[ [ value-infos-union ] map ] dip set-value-infos ;
|
||||
|
|
@ -84,12 +77,9 @@ SYMBOL: infer-children-data
|
|||
SYMBOL: condition-value
|
||||
|
||||
M: #phi propagate-before ( #phi -- )
|
||||
{
|
||||
[ annotate-phi-inputs ]
|
||||
[ [ phi-info-d>> ] [ out-d>> ] bi merge-value-infos ]
|
||||
[ [ phi-info-r>> ] [ out-r>> ] bi merge-value-infos ]
|
||||
[ annotate-phi-outputs ]
|
||||
} cleave ;
|
||||
[ annotate-phi-inputs ]
|
||||
[ [ phi-info-d>> <flipped> ] [ out-d>> ] bi merge-value-infos ]
|
||||
bi ;
|
||||
|
||||
: branch-phi-constraints ( output values booleans -- )
|
||||
{
|
||||
|
|
@ -146,7 +136,9 @@ M: #phi propagate-before ( #phi -- )
|
|||
|
||||
M: #phi propagate-after ( #phi -- )
|
||||
condition-value get [
|
||||
[ out-d>> ] [ phi-in-d>> ] [ phi-info-d>> ] tri
|
||||
[ out-d>> ]
|
||||
[ phi-in-d>> <flipped> ]
|
||||
[ phi-info-d>> <flipped> ] tri
|
||||
[
|
||||
[ possible-boolean-values ] map
|
||||
branch-phi-constraints
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces sequences assocs math kernel accessors fry
|
||||
combinators sets locals
|
||||
combinators sets locals columns
|
||||
stack-checker.branches
|
||||
compiler.tree
|
||||
compiler.tree.def-use
|
||||
|
|
@ -49,8 +49,7 @@ M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ;
|
|||
] 2each ;
|
||||
|
||||
M: #phi compute-copy-equiv*
|
||||
[ [ phi-in-d>> ] [ out-d>> ] bi compute-phi-equiv ]
|
||||
[ [ phi-in-r>> ] [ out-r>> ] bi compute-phi-equiv ] bi ;
|
||||
[ phi-in-d>> <flipped> ] [ out-d>> ] bi compute-phi-equiv ;
|
||||
|
||||
M: node compute-copy-equiv* drop ;
|
||||
|
||||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs classes classes.algebra kernel
|
||||
accessors math math.intervals namespaces sequences words
|
||||
combinators combinators.short-circuit arrays
|
||||
compiler.tree.propagation.copy ;
|
||||
USING: assocs classes classes.algebra classes.tuple
|
||||
classes.tuple.private kernel accessors math math.intervals
|
||||
namespaces sequences words combinators combinators.short-circuit
|
||||
arrays compiler.tree.propagation.copy ;
|
||||
IN: compiler.tree.propagation.info
|
||||
|
||||
: false-class? ( class -- ? ) \ f class<= ;
|
||||
|
|
@ -276,3 +276,9 @@ SYMBOL: value-infos
|
|||
|
||||
: node-output-infos ( node -- seq )
|
||||
dup out-d>> [ node-value-info ] with map ;
|
||||
|
||||
: immutable-tuple-boa? ( #call -- ? )
|
||||
dup word>> \ <tuple-boa> eq? [
|
||||
dup in-d>> peek node-value-info
|
||||
literal>> class>> immutable-tuple-class?
|
||||
] [ drop f ] if ;
|
||||
|
|
@ -123,7 +123,7 @@ DEFER: (flat-length)
|
|||
SYMBOL: history
|
||||
|
||||
: remember-inlining ( word -- )
|
||||
history get [ swap suffix ] change ;
|
||||
history [ swap suffix ] change ;
|
||||
|
||||
: inline-word ( #call word -- )
|
||||
dup history get memq? [
|
||||
|
|
@ -247,13 +247,13 @@ generic-comparison-ops [
|
|||
[ string>number 8 * 2^ 1- 0 swap [a,b] ]
|
||||
}
|
||||
} cond
|
||||
[ fixnum fits? fixnum bignum ? ] keep <class/interval-info>
|
||||
[ fixnum fits? fixnum integer ? ] keep <class/interval-info>
|
||||
[ 2nip ] curry +outputs+ set-word-prop
|
||||
] each
|
||||
|
||||
{ <tuple> <tuple-boa> } [
|
||||
[
|
||||
literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if
|
||||
literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if <class-info>
|
||||
[ clear ] dip
|
||||
] +outputs+ set-word-prop
|
||||
] each
|
||||
|
|
@ -263,7 +263,10 @@ generic-comparison-ops [
|
|||
] +outputs+ set-word-prop
|
||||
|
||||
! the output of clone has the same type as the input
|
||||
{ clone (clone) } [ [ ] +outputs+ set-word-prop ] each
|
||||
{ clone (clone) } [
|
||||
[ clone f >>literal f >>literal? ]
|
||||
+outputs+ set-word-prop
|
||||
] each
|
||||
|
||||
\ slot [
|
||||
dup literal?>>
|
||||
|
|
@ -273,10 +276,10 @@ generic-comparison-ops [
|
|||
\ instance? [
|
||||
[ value-info ] dip over literal>> class? [
|
||||
[ literal>> ] dip predicate-constraints
|
||||
] [ 2drop f ] if
|
||||
] [ 3drop f ] if
|
||||
] +constraints+ set-word-prop
|
||||
|
||||
\ instance? [
|
||||
dup literal>> class?
|
||||
[ literal>> predicate-output-infos ] [ 2drop f ] if
|
||||
[ literal>> predicate-output-infos ] [ 2drop object-info ] if
|
||||
] +outputs+ set-word-prop
|
||||
|
|
@ -2,7 +2,6 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences accessors kernel assocs sequences
|
||||
compiler.tree
|
||||
compiler.tree.def-use
|
||||
compiler.tree.propagation.copy
|
||||
compiler.tree.propagation.info ;
|
||||
IN: compiler.tree.propagation.nodes
|
||||
|
|
@ -14,6 +13,8 @@ GENERIC: propagate-before ( node -- )
|
|||
|
||||
GENERIC: propagate-after ( node -- )
|
||||
|
||||
GENERIC: annotate-node ( node -- )
|
||||
|
||||
GENERIC: propagate-around ( node -- )
|
||||
|
||||
: (propagate) ( node -- )
|
||||
|
|
@ -22,15 +23,14 @@ GENERIC: propagate-around ( node -- )
|
|||
: extract-value-info ( values -- assoc )
|
||||
[ dup value-info ] H{ } map>assoc ;
|
||||
|
||||
: annotate-node ( node -- )
|
||||
dup
|
||||
[ node-defs-values ] [ node-uses-values ] bi append
|
||||
extract-value-info
|
||||
>>info drop ;
|
||||
: (annotate-node) ( node values -- )
|
||||
extract-value-info >>info drop ; inline
|
||||
|
||||
M: node propagate-before drop ;
|
||||
|
||||
M: node propagate-after drop ;
|
||||
|
||||
M: node annotate-node drop ;
|
||||
|
||||
M: node propagate-around
|
||||
[ propagate-before ] [ annotate-node ] [ propagate-after ] tri ;
|
||||
|
|
@ -5,7 +5,8 @@ accessors sequences arrays kernel.private vectors
|
|||
alien.accessors alien.c-types sequences.private
|
||||
byte-arrays classes.algebra classes.tuple.private
|
||||
math.functions math.private strings layouts
|
||||
compiler.tree.propagation.info slots.private words hashtables
|
||||
compiler.tree.propagation.info compiler.tree.def-use
|
||||
compiler.tree.checker slots.private words hashtables
|
||||
classes assocs ;
|
||||
IN: compiler.tree.propagation.tests
|
||||
|
||||
|
|
@ -15,6 +16,8 @@ IN: compiler.tree.propagation.tests
|
|||
build-tree
|
||||
normalize
|
||||
propagate
|
||||
compute-def-use
|
||||
dup check-nodes
|
||||
peek node-input-infos ;
|
||||
|
||||
: final-classes ( quot -- seq )
|
||||
|
|
@ -140,10 +143,6 @@ IN: compiler.tree.propagation.tests
|
|||
[ dup string? not not >boolean [ ] [ "Oops" throw ] if ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ string } ] [
|
||||
[ dup string? t xor [ "A" throw ] [ ] if ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ f ] [ [ t xor ] final-classes first null-class? ] unit-test
|
||||
|
||||
[ t ] [ [ t or ] final-classes first true-class? ] unit-test
|
||||
|
|
@ -156,20 +155,12 @@ IN: compiler.tree.propagation.tests
|
|||
|
||||
[ t ] [ [ dup not or ] final-classes first true-class? ] unit-test
|
||||
|
||||
[ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
|
||||
|
||||
[ t ] [ [ dup not swap or ] final-classes first true-class? ] unit-test
|
||||
|
||||
[ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
|
||||
|
||||
[ t ] [ [ dup not and ] final-classes first false-class? ] unit-test
|
||||
|
||||
[ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
|
||||
|
||||
[ t ] [ [ dup not swap and ] final-classes first false-class? ] unit-test
|
||||
|
||||
[ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
|
||||
|
||||
[ t ] [ [ over [ drop f ] when [ "A" throw ] unless ] final-classes first false-class? ] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
|
|
@ -271,10 +262,6 @@ IN: compiler.tree.propagation.tests
|
|||
[ 0 dup 100 < not [ 1+ ] [ 1- ] if ] final-literals
|
||||
] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[ [ 1 >r ] [ 2 >r ] if r> 3 + ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ 2 } ] [
|
||||
[ [ 1 ] [ 1 ] if 1 + ] final-literals
|
||||
] unit-test
|
||||
|
|
@ -548,7 +535,7 @@ M: array iterate first t ;
|
|||
|
||||
GENERIC: bad-generic ( a -- b )
|
||||
M: fixnum bad-generic 1 fixnum+fast ;
|
||||
: bad-behavior 4 bad-generic ; inline recursive
|
||||
: bad-behavior ( -- b ) 4 bad-generic ; inline recursive
|
||||
|
||||
[ V{ fixnum } ] [ [ bad-behavior ] final-classes ] unit-test
|
||||
|
||||
|
|
@ -557,3 +544,35 @@ M: fixnum bad-generic 1 fixnum+fast ;
|
|||
0 10 [ bad-generic dup 123 bitand drop bad-generic 1 + ] times
|
||||
] final-classes
|
||||
] unit-test
|
||||
|
||||
GENERIC: infinite-loop ( a -- b )
|
||||
M: integer infinite-loop infinite-loop ;
|
||||
|
||||
[ ] [ [ { integer } declare infinite-loop ] final-classes drop ] unit-test
|
||||
|
||||
[ V{ tuple } ] [ [ tuple-layout <tuple> ] final-classes ] unit-test
|
||||
|
||||
[ ] [ [ instance? ] final-classes drop ] unit-test
|
||||
|
||||
[ f ] [ [ V{ } clone ] final-info first literal?>> ] unit-test
|
||||
|
||||
: fold-throw-test ( a -- b ) "A" throw ; foldable
|
||||
|
||||
[ ] [ [ 0 fold-throw-test ] final-info drop ] unit-test
|
||||
|
||||
: too-deep ( a b -- c )
|
||||
dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline recursive
|
||||
|
||||
[ ] [ [ too-deep ] final-info drop ] unit-test
|
||||
|
||||
! [ V{ string } ] [
|
||||
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
|
||||
! ] unit-test
|
||||
|
||||
! [ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
|
||||
|
||||
! [ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
|
||||
|
||||
! [ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
|
||||
|
||||
! [ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
|
||||
|
|
@ -2,7 +2,6 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences namespaces hashtables
|
||||
compiler.tree
|
||||
compiler.tree.def-use
|
||||
compiler.tree.propagation.copy
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.nodes
|
||||
|
|
@ -52,8 +52,7 @@ IN: compiler.tree.propagation.recursive
|
|||
3bi ;
|
||||
|
||||
M: #recursive propagate-around ( #recursive -- )
|
||||
{ 0 } clone [ USE: math
|
||||
dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
|
||||
[
|
||||
constraints [ clone ] change
|
||||
|
||||
child>>
|
||||
|
|
@ -61,7 +60,7 @@ M: #recursive propagate-around ( #recursive -- )
|
|||
[ first propagate-recursive-phi ]
|
||||
[ (propagate) ]
|
||||
tri
|
||||
] curry until-fixed-point ;
|
||||
] until-fixed-point ;
|
||||
|
||||
: generalize-return-interval ( info -- info' )
|
||||
dup [ literal?>> ] [ class>> null-class? ] bi or
|
||||
|
|
@ -73,6 +72,15 @@ M: #recursive propagate-around ( #recursive -- )
|
|||
: return-infos ( node -- infos )
|
||||
label>> return>> node-input-infos generalize-return ;
|
||||
|
||||
M: #call-recursive propagate-before ( #call-label -- )
|
||||
M: #call-recursive propagate-before ( #call-recursive -- )
|
||||
[ ] [ return-infos ] [ node-output-infos ] tri
|
||||
[ check-fixed-point ] [ drop swap out-d>> set-value-infos ] 3bi ;
|
||||
|
||||
M: #call-recursive annotate-node
|
||||
dup [ in-d>> ] [ out-d>> ] bi append (annotate-node) ;
|
||||
|
||||
M: #enter-recursive annotate-node
|
||||
dup out-d>> (annotate-node) ;
|
||||
|
||||
M: #return-recursive annotate-node
|
||||
dup in-d>> (annotate-node) ;
|
||||
|
|
@ -6,7 +6,6 @@ classes.tuple.private continuations arrays byte-arrays strings
|
|||
math math.partial-dispatch math.private slots generic
|
||||
generic.standard generic.math
|
||||
compiler.tree
|
||||
compiler.tree.def-use
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.nodes
|
||||
compiler.tree.propagation.slots
|
||||
|
|
@ -17,7 +16,7 @@ IN: compiler.tree.propagation.simple
|
|||
! Propagation for straight-line code.
|
||||
|
||||
M: #introduce propagate-before
|
||||
value>> object-info swap set-value-info ;
|
||||
out-d>> [ object-info swap set-value-info ] each ;
|
||||
|
||||
M: #push propagate-before
|
||||
[ literal>> <literal-info> ] [ out-d>> first ] bi
|
||||
|
|
@ -62,10 +61,10 @@ M: #declare propagate-before
|
|||
[ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ;
|
||||
|
||||
: fold-call ( #call word -- infos )
|
||||
[ in-d>> [ value-info literal>> ] map ]
|
||||
[ [ execute ] curry ]
|
||||
bi* with-datastack
|
||||
[ <literal-info> ] map ;
|
||||
[ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ , execute ] ] bi*
|
||||
'[ , , with-datastack [ <literal-info> ] map nip ]
|
||||
[ drop [ object-info ] replicate ]
|
||||
recover ;
|
||||
|
||||
: predicate-output-infos ( info class -- info )
|
||||
[ class>> ] dip {
|
||||
|
|
@ -109,6 +108,9 @@ M: #call propagate-before
|
|||
2bi
|
||||
] if ;
|
||||
|
||||
M: #call annotate-node
|
||||
dup [ in-d>> ] [ out-d>> ] bi append (annotate-node) ;
|
||||
|
||||
: propagate-input-classes ( node input-classes -- )
|
||||
class-infos swap in-d>> refine-value-infos ;
|
||||
|
||||
|
|
@ -121,3 +123,6 @@ M: #alien-invoke propagate-before
|
|||
|
||||
M: #alien-indirect propagate-before
|
||||
out-d>> [ object-info swap set-value-info ] each ;
|
||||
|
||||
M: #return annotate-node
|
||||
dup in-d>> (annotate-node) ;
|
||||
|
|
@ -0,0 +1,119 @@
|
|||
! TUPLE: declared-fixnum { x fixnum } ;
|
||||
!
|
||||
! [ t ] [
|
||||
! [ { declared-fixnum } declare [ 1 + ] change-x ]
|
||||
! { + fixnum+ >fixnum } inlined?
|
||||
! ] unit-test
|
||||
!
|
||||
! [ t ] [
|
||||
! [ { declared-fixnum } declare x>> drop ]
|
||||
! { slot } inlined?
|
||||
! ] unit-test
|
||||
!
|
||||
! [ t ] [
|
||||
! [ hashtable new ] \ new inlined?
|
||||
! ] unit-test
|
||||
!
|
||||
! [ t ] [
|
||||
! [ dup hashtable eq? [ new ] when ] \ new inlined?
|
||||
! ] unit-test
|
||||
!
|
||||
! [ f ] [
|
||||
! [ { integer } declare -63 shift 4095 bitand ]
|
||||
! \ shift inlined?
|
||||
! ] unit-test
|
||||
!
|
||||
! [ t ] [
|
||||
! [ { integer } declare 127 bitand 3 + ]
|
||||
! { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined?
|
||||
! ] unit-test
|
||||
!
|
||||
! [ f ] [
|
||||
! [ { integer } declare 127 bitand 3 + ]
|
||||
! { >fixnum } inlined?
|
||||
! ] unit-test
|
||||
!
|
||||
! [ t ] [
|
||||
! [
|
||||
! { integer } declare
|
||||
! dup 0 >= [
|
||||
! 615949 * 797807 + 20 2^ mod dup 19 2^ -
|
||||
! ] [ dup ] if
|
||||
! ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
|
||||
! ] unit-test
|
||||
!
|
||||
! [ t ] [
|
||||
! [
|
||||
! { fixnum } declare
|
||||
! 615949 * 797807 + 20 2^ mod dup 19 2^ -
|
||||
! ] { >fixnum } inlined?
|
||||
! ] unit-test
|
||||
!
|
||||
! [ t ] [
|
||||
! [
|
||||
! { integer } declare 0 swap
|
||||
! [
|
||||
! drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
|
||||
! ] map
|
||||
! ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
|
||||
! ] unit-test
|
||||
!
|
||||
! [ t ] [
|
||||
! [
|
||||
! { fixnum } declare 0 swap
|
||||
! [
|
||||
! drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
|
||||
! ] map
|
||||
! ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
|
||||
! ] unit-test
|
||||
!
|
||||
! [ t ] [
|
||||
! [ { string sbuf } declare ] \ push-all def>> append \ + inlined?
|
||||
! ] unit-test
|
||||
!
|
||||
! [ t ] [
|
||||
! [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
|
||||
! ] unit-test
|
||||
!
|
||||
! [ t ] [
|
||||
! [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
|
||||
! ] unit-test
|
||||
!
|
||||
!
|
||||
!
|
||||
! [ t ] [
|
||||
! [
|
||||
! { integer } declare [ 256 mod ] map
|
||||
! ] { mod fixnum-mod } inlined?
|
||||
! ] unit-test
|
||||
!
|
||||
!
|
||||
! [ f ] [
|
||||
! [
|
||||
! 256 mod
|
||||
! ] { mod fixnum-mod } inlined?
|
||||
! ] unit-test
|
||||
!
|
||||
! [ f ] [
|
||||
! [
|
||||
! dup 0 >= [ 256 mod ] when
|
||||
! ] { mod fixnum-mod } inlined?
|
||||
! ] unit-test
|
||||
!
|
||||
! [ t ] [
|
||||
! [
|
||||
! { integer } declare dup 0 >= [ 256 mod ] when
|
||||
! ] { mod fixnum-mod } inlined?
|
||||
! ] unit-test
|
||||
!
|
||||
! [ t ] [
|
||||
! [
|
||||
! { integer } declare 256 rem
|
||||
! ] { mod fixnum-mod } inlined?
|
||||
! ] unit-test
|
||||
!
|
||||
! [ t ] [
|
||||
! [
|
||||
! { integer } declare [ 256 rem ] map
|
||||
! ] { mod fixnum-mod rem } inlined?
|
||||
! ] unit-test
|
||||
|
|
@ -1,22 +1,23 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic assocs kernel math namespaces parser
|
||||
USING: fry arrays generic assocs kernel math namespaces parser
|
||||
sequences words vectors math.intervals effects classes
|
||||
accessors combinators stack-checker.state stack-checker.visitor ;
|
||||
accessors combinators stack-checker.state stack-checker.visitor
|
||||
stack-checker.inlining ;
|
||||
IN: compiler.tree
|
||||
|
||||
! High-level tree SSA form.
|
||||
|
||||
TUPLE: node < identity-tuple info ;
|
||||
TUPLE: node < identity-tuple ;
|
||||
|
||||
M: node hashcode* drop node hashcode* ;
|
||||
|
||||
TUPLE: #introduce < node value ;
|
||||
TUPLE: #introduce < node out-d ;
|
||||
|
||||
: #introduce ( value -- node )
|
||||
\ #introduce new swap >>value ;
|
||||
: #introduce ( out-d -- node )
|
||||
\ #introduce new swap >>out-d ;
|
||||
|
||||
TUPLE: #call < node word in-d out-d body method ;
|
||||
TUPLE: #call < node word in-d out-d body method info ;
|
||||
|
||||
: #call ( inputs outputs word -- node )
|
||||
\ #call new
|
||||
|
|
@ -24,7 +25,7 @@ TUPLE: #call < node word in-d out-d body method ;
|
|||
swap >>out-d
|
||||
swap >>in-d ;
|
||||
|
||||
TUPLE: #call-recursive < node label in-d out-d ;
|
||||
TUPLE: #call-recursive < node label in-d out-d info ;
|
||||
|
||||
: #call-recursive ( inputs outputs label -- node )
|
||||
\ #call-recursive new
|
||||
|
|
@ -66,10 +67,11 @@ TUPLE: #r> < #renaming in-r out-d ;
|
|||
swap >>out-d
|
||||
swap >>in-r ;
|
||||
|
||||
TUPLE: #terminate < node in-d ;
|
||||
TUPLE: #terminate < node in-d in-r ;
|
||||
|
||||
: #terminate ( stack -- node )
|
||||
: #terminate ( in-d in-r -- node )
|
||||
\ #terminate new
|
||||
swap >>in-r
|
||||
swap >>in-d ;
|
||||
|
||||
TUPLE: #branch < node in-d children live-branches ;
|
||||
|
|
@ -89,13 +91,11 @@ TUPLE: #dispatch < #branch ;
|
|||
: #dispatch ( n branches -- node )
|
||||
\ #dispatch new-branch ;
|
||||
|
||||
TUPLE: #phi < node phi-in-d phi-info-d phi-in-r phi-info-r out-d out-r terminated ;
|
||||
TUPLE: #phi < node phi-in-d phi-info-d out-d terminated ;
|
||||
|
||||
: #phi ( d-phi-in d-phi-out r-phi-in r-phi-out terminated -- node )
|
||||
: #phi ( d-phi-in d-phi-out terminated -- node )
|
||||
\ #phi new
|
||||
swap >>terminated
|
||||
swap >>out-r
|
||||
swap >>phi-in-r
|
||||
swap >>out-d
|
||||
swap >>phi-in-d ;
|
||||
|
||||
|
|
@ -105,22 +105,21 @@ TUPLE: #declare < node declaration ;
|
|||
\ #declare new
|
||||
swap >>declaration ;
|
||||
|
||||
TUPLE: #return < node in-d ;
|
||||
TUPLE: #return < node in-d info ;
|
||||
|
||||
: #return ( stack -- node )
|
||||
\ #return new
|
||||
swap >>in-d ;
|
||||
|
||||
TUPLE: #recursive < node in-d word label loop? returns calls child ;
|
||||
TUPLE: #recursive < node in-d word label loop? child ;
|
||||
|
||||
: #recursive ( word label inputs child -- node )
|
||||
: #recursive ( label inputs child -- node )
|
||||
\ #recursive new
|
||||
swap >>child
|
||||
swap >>in-d
|
||||
swap >>label
|
||||
swap >>word ;
|
||||
swap >>label ;
|
||||
|
||||
TUPLE: #enter-recursive < node in-d out-d label ;
|
||||
TUPLE: #enter-recursive < node in-d out-d label info ;
|
||||
|
||||
: #enter-recursive ( label inputs outputs -- node )
|
||||
\ #enter-recursive new
|
||||
|
|
@ -128,7 +127,7 @@ TUPLE: #enter-recursive < node in-d out-d label ;
|
|||
swap >>in-d
|
||||
swap >>label ;
|
||||
|
||||
TUPLE: #return-recursive < #renaming in-d out-d label ;
|
||||
TUPLE: #return-recursive < #renaming in-d out-d label info ;
|
||||
|
||||
: #return-recursive ( label inputs outputs -- node )
|
||||
\ #return-recursive new
|
||||
|
|
@ -179,9 +178,15 @@ M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
|
|||
|
||||
: shuffle-effect ( #shuffle -- effect )
|
||||
[ in-d>> ] [ out-d>> ] [ mapping>> ] tri
|
||||
[ at ] curry map
|
||||
'[ , at ] map
|
||||
<effect> ;
|
||||
|
||||
: recursive-phi-in ( #enter-recursive -- seq )
|
||||
[ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
|
||||
|
||||
: ends-with-terminate? ( nodes -- ? )
|
||||
dup empty? [ drop f ] [ peek #terminate? ] if ;
|
||||
|
||||
M: vector child-visitor V{ } clone ;
|
||||
M: vector #introduce, #introduce node, ;
|
||||
M: vector #call, #call node, ;
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue