steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Propagation now does method inlining; working on cleanup pass

db4
Slava Pestov 2008-07-30 03:38:10 -05:00
parent 75af228f5a
commit 45c1da32eb
24 changed files with 1064 additions and 218 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
unfinished/compiler/tree/builder/builder-docs.factor
View File

@ -23,14 +23,14 @@ $nl
{ $subsection specialized-def } ;
HELP: build-tree
{ $values { "quot" quotation } { "dataflow" node } }
{ $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 { "quot" quotation } { "stack" sequence } { "dataflow" node } }
{ $description "Attempts to construct tree SSA IR from a quotaiton, starting with an initial data stack of values." }
{ $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 quotaiton, 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." } ;
HELP: specialized-def

14
unfinished/compiler/tree/builder/builder.factor
View File

@ -11,16 +11,16 @@ IN: compiler.tree.builder
[ V{ } clone stack-visitor set ] prepose
with-infer ; inline
GENERIC# build-tree-with 1 ( quot stack -- nodes )
: build-tree ( quot -- nodes )
#! Not safe to call from inference transforms.
[ f infer-quot ] with-tree-builder nip ;
M: callable build-tree-with
: build-tree-with ( in-stack quot -- nodes out-stack )
#! Not safe to call from inference transforms.
[
>vector meta-d set
f infer-quot
] with-tree-builder nip ;
: build-tree ( quot -- nodes ) f build-tree-with ;
[ >vector meta-d set ] [ f infer-quot ] bi*
] with-tree-builder nip
unclip-last in-d>> ;
: (make-specializer) ( class picker -- quot )
swap "predicate" word-prop append ;

578
unfinished/compiler/tree/cleanup/cleanup-tests.factor Normal file
View File

@ -0,0 +1,578 @@
IN: compiler.tree.cleanup.tests
USING: tools.test kernel.private kernel arrays sequences
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
compiler.tree
compiler.tree.combinators
compiler.tree.cleanup
compiler.tree.builder
compiler.tree.copy-equiv
compiler.tree.normalization
compiler.tree.propagation ;
: cleaned-up-tree ( quot -- nodes )
build-tree normalize compute-copy-equiv propagate cleanup ;
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
[ f ] [ [ f [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
[ f ] [ [ { array } declare [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
[ t ] [ [ { sequence } declare [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
: recursive-test ( a -- b ) dup [ not recursive-test ] when ; inline recursive
[ t ] [ [ recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
[ f ] [ [ f recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
[ t ] [ [ t recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
: inlined? ( quot seq/word -- ? )
[ cleaned-up-tree ] dip
dup word? [ 1array ] when
'[ dup #call? [ word>> , member? ] [ drop f ] if ]
contains-node? not ;
[ f ] [
[ { integer } declare >fixnum ]
\ >fixnum inlined?
] unit-test
GENERIC: mynot ( x -- y )
M: f mynot drop t ;
M: object mynot drop f ;
GENERIC: detect-f ( x -- y )
M: f detect-f ;
[ t ] [
[ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined?
] unit-test
GENERIC: xyz ( n -- n )
M: integer xyz ;
M: object xyz ;
[ t ] [
[ { integer } declare xyz ] \ xyz inlined?
] unit-test
[ t ] [
[ dup fixnum? [ xyz ] [ drop "hi" ] if ]
\ xyz inlined?
] unit-test
: (fx-repeat) ( i n quot: ( i -- i ) -- )
2over fixnum>= [
3drop
] [
[ swap >r call 1 fixnum+fast r> ] keep (fx-repeat)
] if ; inline recursive
: fx-repeat ( n quot -- )
0 -rot (fx-repeat) ; inline
! The + should be optimized into fixnum+, if it was not, then
! the type of the loop index was not inferred correctly
[ t ] [
[ [ dup 2 + drop ] fx-repeat ] \ + inlined?
] unit-test
: (i-repeat) ( i n quot: ( i -- i ) -- )
2over dup xyz drop >= [
3drop
] [
[ swap >r call 1+ r> ] keep (i-repeat)
] if ; inline recursive
: i-repeat >r { integer } declare r> 0 -rot (i-repeat) ; inline
[ t ] [
[ [ dup xyz drop ] i-repeat ] \ xyz inlined?
] unit-test
[ t ] [
[ { fixnum } declare dup 100 >= [ 1 + ] unless ] \ fixnum+ inlined?
] unit-test
[ t ] [
[ { fixnum fixnum } declare dupd < [ 1 + 1 + ] when ]
\ + inlined?
] unit-test
[ t ] [
[ { fixnum fixnum } declare dupd < [ 1 + 1 + ] when ]
\ + inlined?
] unit-test
[ t ] [
[ { fixnum } declare [ ] times ] \ >= inlined?
] unit-test
[ t ] [
[ { fixnum } declare [ ] times ] \ 1+ inlined?
] unit-test
[ t ] [
[ { fixnum } declare [ ] times ] \ + inlined?
] unit-test
[ t ] [
[ { fixnum } declare [ ] times ] \ fixnum+ inlined?
] unit-test
[ t ] [
[ { integer fixnum } declare dupd < [ 1 + ] when ]
\ + inlined?
] unit-test
[ f ] [
[ { integer fixnum } declare dupd < [ 1 + ] when ]
\ +-integer-fixnum inlined?
] unit-test
[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
[ f ] [
[
[ no-cond ] 1
[ 1array dup quotation? [ >quotation ] unless ] times
] \ quotation? inlined?
] unit-test
[ t ] [
[
1000000000000000000000000000000000 [ ] times
] \ + inlined?
] unit-test
[ f ] [
[
1000000000000000000000000000000000 [ ] times
] \ +-integer-fixnum inlined?
] unit-test
[ f ] [
[ { bignum } declare [ ] times ]
\ +-integer-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 ] [
[ { array-capacity } declare 0 < ] \ < inlined?
] unit-test
[ t ] [
[ { array-capacity } declare 0 < ] \ fixnum< inlined?
] unit-test
[ t ] [
[ { array-capacity } declare 1 fixnum- ] \ fixnum- inlined?
] unit-test
[ t ] [
[ 5000 [ 5000 [ ] times ] times ] \ 1+ inlined?
] unit-test
[ t ] [
[ 5000 [ [ ] times ] each ] \ 1+ inlined?
] unit-test
[ t ] [
[ 5000 0 [ dup 2 - swap [ 2drop ] curry each ] reduce ]
\ 1+ inlined?
] unit-test
GENERIC: annotate-entry-test-1 ( x -- )
M: fixnum annotate-entry-test-1 drop ;
: (annotate-entry-test-2) ( from to quot: ( -- ) -- )
2over >= [
3drop
] [
[ swap >r call dup annotate-entry-test-1 1+ r> ] keep (annotate-entry-test-2)
] if ; inline recursive
: annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline
[ f ] [
[ { bignum } declare [ ] annotate-entry-test-2 ]
\ annotate-entry-test-1 inlined?
] unit-test
[ t ] [
[ { float } declare 10 [ 2.3 * ] times >float ]
\ >float inlined?
] unit-test
GENERIC: detect-float ( a -- b )
M: float detect-float ;
[ t ] [
[ { real float } declare + detect-float ]
\ detect-float inlined?
] unit-test
[ t ] [
[ { float real } declare + detect-float ]
\ detect-float inlined?
] unit-test
[ t ] [
[ 3 + = ] \ equal? inlined?
] unit-test
[ f ] [
[ { fixnum fixnum } declare 7 bitand neg shift ]
\ fixnum-shift-fast inlined?
] unit-test
[ t ] [
[ { fixnum fixnum } declare 7 bitand neg shift ]
{ shift fixnum-shift } inlined?
] unit-test
[ t ] [
[ { fixnum fixnum } declare 1 swap 7 bitand shift ]
{ shift fixnum-shift } inlined?
] unit-test
[ f ] [
[ { fixnum fixnum } declare 1 swap 7 bitand shift ]
{ fixnum-shift-fast } inlined?
] unit-test
cell-bits 32 = [
[ t ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ shift inlined?
] unit-test
[ f ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ fixnum-shift inlined?
] unit-test
] when
[ f ] [
[ { integer } declare -63 shift 4095 bitand ]
\ shift inlined?
] unit-test
[ t ] [
[ B{ 1 0 } *short 0 number= ]
\ number= inlined?
] unit-test
[ t ] [
[ B{ 1 0 } *short 0 { number number } declare number= ]
\ number= inlined?
] unit-test
[ t ] [
[ B{ 1 0 } *short 0 = ]
\ number= inlined?
] unit-test
[ t ] [
[ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ]
\ number= inlined?
] unit-test
[ t ] [
[ HEX: ff bitand 0 HEX: ff between? ]
\ >= inlined?
] unit-test
[ t ] [
[ HEX: ff swap HEX: ff bitand >= ]
\ >= inlined?
] unit-test
[ t ] [
[ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
] unit-test
[ t ] [
[
dup integer? [
dup fixnum? [
1 +
] [
2 +
] if
] when
] \ + 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
[ t ] [
[ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
] unit-test
: rec ( a -- b )
dup 0 > [ 1 - rec ] when ; inline recursive
[ t ] [
[ { fixnum } declare rec 1 + ]
{ > - + } inlined?
] unit-test
: fib ( m -- n )
dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline recursive
[ t ] [
[ 27.0 fib ] { < - + } inlined?
] unit-test
[ f ] [
[ 27.0 fib ] { +-integer-integer } inlined?
] unit-test
[ t ] [
[ 27 fib ] { < - + } inlined?
] unit-test
[ t ] [
[ 27 >bignum fib ] { < - + } inlined?
] unit-test
[ f ] [
[ 27/2 fib ] { < - } inlined?
] unit-test
: hang-regression ( m n -- x )
over 0 number= [
nip
] [
dup [
drop 1 hang-regression
] [
dupd hang-regression hang-regression
] if
] if ; inline recursive
[ t ] [
[ dup fixnum? [ 3 over hang-regression ] [ 3 over hang-regression ] if
] { } inlined? ] unit-test
[ t ] [
[ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined?
] unit-test
[ f ] [
[ { integer } declare 10 [ -1 shift ] times ] \ shift inlined?
] unit-test
[ f ] [
[ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ]
\ fixnum-bitand 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 ] [
[ { fixnum } declare [ drop ] each-integer ]
{ < <-integer-fixnum +-integer-fixnum + } inlined?
] unit-test
[ t ] [
[ { fixnum } declare length [ drop ] each-integer ]
{ < <-integer-fixnum +-integer-fixnum + } inlined?
] unit-test
[ t ] [
[ { fixnum } declare [ drop ] each ]
{ < <-integer-fixnum +-integer-fixnum + } inlined?
] unit-test
[ t ] [
[ { fixnum } declare 0 [ + ] reduce ]
{ < <-integer-fixnum } inlined?
] unit-test
[ f ] [
[ { fixnum } declare 0 [ + ] reduce ]
\ +-integer-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
[ f ] [
[
{ integer } declare [ ] map
] \ >fixnum inlined?
] unit-test
[ f ] [
[
{ integer } declare { } set-nth-unsafe
] \ >fixnum inlined?
] unit-test
[ f ] [
[
{ integer } declare 1 + { } set-nth-unsafe
] \ >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 ] [
[ hashtable new ] \ new inlined?
] unit-test
[ t ] [
[ dup hashtable eq? [ new ] when ] \ new inlined?
] unit-test
[ t ] [
[ { hashtable } declare hashtable instance? ] \ instance? inlined?
] unit-test
[ t ] [
[ { vector } declare hashtable instance? ] \ instance? inlined?
] unit-test
[ f ] [
[ { assoc } declare hashtable instance? ] \ instance? inlined?
] unit-test
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 ] [
[
{ array } declare length
1 + dup 100 fixnum> [ 1 fixnum+ ] when
] \ fixnum+ inlined?
] unit-test
[ t ] [
[ [ resize-array ] keep length ] \ length inlined?
] unit-test
[ t ] [
[ dup 0 > [ sqrt ] when ] \ sqrt inlined?
] unit-test
[ t ] [
[ { utf8 } declare decode-char ] \ decode-char inlined?
] unit-test
[ t ] [
[ { ascii } declare decode-char ] \ decode-char inlined?
] unit-test
[ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test
[ t ] [
[
{ integer } declare [ 256 mod ] map
] { mod fixnum-mod } inlined?
] unit-test
[ t ] [
[
{ integer } declare [ 0 >= ] map
] { >= fixnum>= } inlined?
] unit-test

103
unfinished/compiler/tree/cleanup/cleanup.factor
View File

@ -1,5 +1,106 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sequences.deep combinators fry
namespaces
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info
compiler.tree.propagation.branches ;
IN: compiler.tree.cleanup
: cleanup ( nodes -- nodes' ) ;
! A phase run after propagation to finish the job, so to speak.
! Codifies speculative inlining decisions, deletes branches
! marked as never taken, and flattens local recursive blocks
! that do not call themselves.
GENERIC: cleanup* ( node -- node/nodes )
: cleanup ( nodes -- nodes' )
#! We don't recurse into children here, instead the methods
#! do it since the logic is a bit more involved
[ cleanup* ] map flatten ;
: cleanup-constant-folding ( #call -- nodes )
[
[ node-output-infos ] [ out-d>> ] bi
[ [ literal>> ] dip #push ] 2map
]
[ in-d>> #drop ] bi prefix ;
: cleanup-inlining ( #call -- nodes )
body>> cleanup ;
M: #call cleanup*
{
{ [ dup node-output-infos [ literal?>> ] all? ] [ cleanup-constant-folding ] }
{ [ dup body>> ] [ cleanup-inlining ] }
[ ]
} 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 ;
: delete-unreachable-branches ( #branch -- )
dup live-branches>> '[
,
[ [ [ drop ] [ delete-nodes ] if ] 2each ]
[ select-children ]
2bi
] change-children drop ;
: fold-only-branch ( #branch -- node/nodes )
#! If only one branch is live we don't need to branch at
#! all; just drop the condition value.
dup live-children sift dup length 1 =
[ first swap in-d>> #drop prefix ] [ drop ] if ;
SYMBOL: live-branches
: cleanup-children ( #branch -- )
[ [ cleanup ] map ] change-children drop ;
M: #branch cleanup*
{
[ live-branches>> live-branches set ]
[ delete-unreachable-branches ]
[ cleanup-children ]
[ fold-only-branch ]
} cleave ;
: cleanup-phi-in ( phi-in live-branches -- phi-in' )
swap dup empty?
[ nip ] [ flip swap select-children sift flip ] if ;
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 ;
: >copy ( node -- #copy ) [ in-d>> ] [ out-d>> ] bi #copy ;
: flatten-recursive ( #recursive -- nodes )
#! convert #enter-recursive and #return-recursive into
#! #copy nodes.
child>>
unclip >copy prefix
unclip-last >copy suffix ;
M: #recursive cleanup*
#! Inline bodies of #recursive blocks with no calls left.
[ cleanup ] change-child
dup label>> calls>> empty? [ flatten-recursive ] when ;
M: node cleanup* ;

1
unfinished/compiler/tree/combinators/combinators-tests.factor
View File

@ -3,3 +3,4 @@ USING: compiler.tree.combinators tools.test kernel ;
{ 1 0 } [ [ drop ] each-node ] must-infer-as
{ 1 1 } [ [ ] map-nodes ] must-infer-as
{ 1 1 } [ [ ] contains-node? ] must-infer-as

20
unfinished/compiler/tree/combinators/combinators.factor
View File

@ -4,7 +4,7 @@ USING: fry kernel accessors sequences sequences.deep
compiler.tree ;
IN: compiler.tree.combinators
: each-node ( nodes quot -- )
: each-node ( nodes quot: ( node -- ) -- )
dup dup '[
, [
dup #branch? [
@ -15,7 +15,7 @@ IN: compiler.tree.combinators
] [ drop ] if
] if
] bi
] each ; inline
] each ; inline recursive
: map-nodes ( nodes quot: ( node -- node' ) -- nodes )
dup dup '[
@ -28,3 +28,19 @@ IN: compiler.tree.combinators
] when
] if
] map flatten ; inline recursive
: contains-node? ( nodes quot: ( node -- ? ) -- ? )
dup dup '[
, keep swap [ drop t ] [
dup #branch? [
children>> [ , contains-node? ] contains?
] [
dup #recursive? [
child>> , contains-node?
] [ drop f ] if
] if
] if
] contains? ; inline recursive
: select-children ( seq flags -- seq' )
[ [ drop f ] unless ] 2map ;

12
unfinished/compiler/tree/copy-equiv/copy-equiv.factor
View File

@ -5,6 +5,9 @@ kernel accessors fry
compiler.tree compiler.tree.def-use compiler.tree.combinators ;
IN: compiler.tree.copy-equiv
! Two values are copy-equivalent if they are always identical
! at run-time ("DS" relation).
! Disjoint set of copy equivalence
SYMBOL: copies
@ -49,10 +52,13 @@ M: #phi compute-copy-equiv*
M: node compute-copy-equiv* drop ;
: compute-copy-equiv ( node -- node )
<disjoint-set> copies set
dup [
: amend-copy-equiv ( node -- )
[
[ node-defs-values [ introduce-value ] each ]
[ compute-copy-equiv* ]
bi
] each-node ;
: compute-copy-equiv ( node -- node )
<disjoint-set> copies set
dup amend-copy-equiv ;

5
unfinished/compiler/tree/loop/detection/detection.factor Normal file
View File

@ -0,0 +1,5 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.loop-detection
: detect-loops ( nodes -- nodes' ) ;

11
unfinished/compiler/tree/normalization/normalization.factor
View File

@ -51,13 +51,16 @@ M: node count-introductions* drop ;
! Collect label info
GENERIC: collect-label-info ( node -- )
M: #return-recursive collect-label-info dup label>> (>>return) ;
M: #return-recursive collect-label-info
dup label>> (>>return) ;
M: #call-recursive collect-label-info dup label>> calls>> push ;
M: #call-recursive collect-label-info
dup label>> calls>> push ;
M: #recursive collect-label-info
[ label>> ] [ child>> count-introductions ] bi
>>introductions drop ;
[ label>> V{ } clone >>calls ]
[ child>> count-introductions ]
bi >>introductions drop ;
M: node collect-label-info drop ;

42
unfinished/compiler/tree/propagation/branches/branches.factor
View File

@ -4,6 +4,7 @@ USING: fry kernel sequences assocs accessors namespaces
math.intervals arrays classes.algebra combinators
compiler.tree
compiler.tree.def-use
compiler.tree.combinators
compiler.tree.propagation.info
compiler.tree.propagation.nodes
compiler.tree.propagation.simple
@ -19,17 +20,22 @@ M: #if child-constraints
M: #dispatch child-constraints
children>> length f <repetition> ;
GENERIC: live-children ( #branch -- children )
GENERIC: live-branches ( #branch -- indices )
M: #if live-children
[ children>> ] [ in-d>> first value-info possible-boolean-values ] bi
[ t swap memq? [ first ] [ drop f ] if ]
[ f swap memq? [ second ] [ drop f ] if ]
2bi 2array ;
M: #if live-branches
in-d>> first value-info class>> {
{ [ dup null class<= ] [ { f f } ] }
{ [ dup true-class? ] [ { t f } ] }
{ [ dup false-class? ] [ { f t } ] }
[ { t t } ]
} cond nip ;
M: #dispatch live-children
[ children>> ] [ in-d>> first value-info interval>> ] bi
'[ , interval-contains? [ drop f ] unless ] map-index ;
M: #dispatch live-branches
[ children>> length ] [ in-d>> first value-info interval>> ] bi
'[ , interval-contains? ] map ;
: live-children ( #branch -- children )
[ children>> ] [ live-branches>> ] bi select-children ;
SYMBOL: infer-children-data
@ -56,22 +62,27 @@ SYMBOL: infer-children-data
infer-children-data get
'[ , [ [ value-info ] bind ] 2map ] map ;
: annotate-phi-node ( #phi -- )
: 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
dup [ out-d>> ] [ out-r>> ] bi append extract-value-info >>info
drop ;
: annotate-phi-outputs ( #phi -- )
dup [ out-d>> ] [ out-r>> ] bi append extract-value-info
>>info drop ;
: merge-value-infos ( infos outputs -- )
[ [ value-infos-union ] map ] dip set-value-infos ;
SYMBOL: condition-value
M: #phi propagate-before ( #phi -- )
[ annotate-phi-node ]
[ [ phi-info-d>> ] [ out-d>> ] bi merge-value-infos ]
[ [ phi-info-r>> ] [ out-r>> ] bi merge-value-infos ]
tri ;
{
[ 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 ;
: branch-phi-constraints ( output values booleans -- )
{
@ -115,6 +126,7 @@ M: #phi propagate-around ( #phi -- )
[ propagate-before ] [ propagate-after ] bi ;
M: #branch propagate-around
dup live-branches >>live-branches
[ infer-children ] [ annotate-node ] bi ;
M: #if propagate-around

3
unfinished/compiler/tree/propagation/constraints/constraints.factor
View File

@ -107,6 +107,3 @@ M: sequence assume* [ assume ] each ;
: t--> ( constraint boolean-value -- constraint' ) =t swap --> ;
: f--> ( constraint boolean-value -- constraint' ) =f swap --> ;
: save-constraints ( quot -- )
constraints get clone slip constraints set ; inline

10
unfinished/compiler/tree/propagation/info/info-tests.factor
View File

@ -1,5 +1,5 @@
USING: accessors math math.intervals sequences classes.algebra
math kernel tools.test compiler.tree.propagation.info ;
math kernel tools.test compiler.tree.propagation.info arrays ;
IN: compiler.tree.propagation.info.tests
[ f ] [ 0.0 -0.0 eql? ] unit-test
@ -63,3 +63,11 @@ IN: compiler.tree.propagation.info.tests
] unit-test
[ ] [ { } value-infos-union drop ] unit-test
TUPLE: test-tuple { x read-only } ;
[ t ] [
f f 3 <literal-info> 3array test-tuple <tuple-info> dup
object <class-info>
value-info-intersect =
] unit-test

11
unfinished/compiler/tree/propagation/info/info.factor
View File

@ -132,9 +132,14 @@ DEFER: (value-info-intersect)
} cond ;
: intersect-slots ( info1 info2 -- slots )
[ slots>> ] bi@
2dup [ length ] bi@ =
[ [ intersect-slot ] 2map ] [ 2drop f ] if ;
[ slots>> ] bi@ {
{ [ dup not ] [ drop ] }
{ [ over not ] [ nip ] }
[
2dup [ length ] bi@ =
[ [ intersect-slot ] 2map ] [ 2drop f ] if
]
} cond ;
: (value-info-intersect) ( info1 info2 -- info )
[ <value-info> ] 2dip

141
unfinished/compiler/tree/propagation/inlining/inlining.factor
View File

@ -1,3 +1,144 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel arrays sequences math math.order
math.partial-dispatch generic generic.standard classes.algebra
classes.union sets quotations assocs combinators words
namespaces
compiler.tree
compiler.tree.builder
compiler.tree.copy-equiv
compiler.tree.normalization
compiler.tree.propagation.info
compiler.tree.propagation.nodes ;
IN: compiler.tree.propagation.inlining
! Splicing nodes
GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
M: word splicing-nodes
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
M: quotation splicing-nodes
[ [ out-d>> ] [ in-d>> ] bi ] dip
build-tree-with
rot #copy suffix
normalize ;
: propagate-body ( #call -- )
body>> [ amend-copy-equiv ] [ (propagate) ] bi ;
! Dispatch elimination
: eliminate-dispatch ( #call word/quot/f -- ? )
[
over method>> over = [ drop ] [
2dup splicing-nodes
[ >>method ] [ >>body ] bi*
] if
propagate-body t
] [ f >>method f >>body drop f ] if* ;
: inlining-standard-method ( #call word -- method/f )
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
[ swap nth value-info class>> ] dip
specific-method ;
: inline-standard-method ( #call word -- ? )
dupd inlining-standard-method eliminate-dispatch ;
: normalize-math-class ( class -- class' )
{
null
fixnum bignum integer
ratio rational
float real
complex number
object
} [ class<= ] with find nip ;
: inlining-math-method ( #call word -- quot/f )
swap in-d>>
first2 [ value-info class>> normalize-math-class ] bi@
3dup math-both-known? [ math-method* ] [ 3drop f ] if ;
: inline-math-method ( #call word -- ? )
dupd inlining-math-method eliminate-dispatch ;
: inlining-math-partial ( #call word -- quot/f )
[ "derived-from" word-prop first inlining-math-method ]
[ nip 1quotation ] 2bi
[ = not ] [ drop ] 2bi and ;
: inline-math-partial ( #call word -- ? )
dupd inlining-math-partial eliminate-dispatch ;
! Method body inlining
SYMBOL: recursive-calls
DEFER: (flat-length)
: word-flat-length ( word -- n )
{
! not inline
{ [ dup inline? not ] [ drop 1 ] }
! recursive and inline
{ [ dup recursive-calls get key? ] [ drop 10 ] }
! inline
[ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ]
} cond ;
: (flat-length) ( seq -- n )
[
{
{ [ dup quotation? ] [ (flat-length) 2 + ] }
{ [ dup array? ] [ (flat-length) ] }
{ [ dup word? ] [ word-flat-length ] }
[ drop 0 ]
} cond
] sigma ;
: flat-length ( word -- n )
H{ } clone recursive-calls [
[ recursive-calls get conjoin ]
[ def>> (flat-length) 5 /i ]
bi
] with-variable ;
: classes-known? ( #call -- ? )
in-d>> [
value-info class>>
[ class-types length 1 = ]
[ union-class? not ]
bi and
] contains? ;
: inlining-rank ( #call word -- n )
[ classes-known? 2 0 ? ]
[
{
[ flat-length 24 swap [-] 4 /i ]
[ "default" word-prop -4 0 ? ]
[ "specializer" word-prop 1 0 ? ]
[ method-body? 1 0 ? ]
} cleave
] bi* + + + + ;
: should-inline? ( #call word -- ? )
inlining-rank 5 >= ;
SYMBOL: history
: remember-inlining ( word -- )
history get [ swap suffix ] change ;
: inline-word ( #call word -- )
dup history get memq? [
2drop
] [
[
dup remember-inlining
dupd def>> splicing-nodes >>body
propagate-body
] with-scope
] if ;
: inline-method-body ( #call word -- ? )
2dup should-inline? [ inline-word t ] [ 2drop f ] if ;

4
unfinished/compiler/tree/propagation/known-words/known-words.factor
View File

@ -173,8 +173,8 @@ generic-comparison-ops [
} case ;
comparison-ops [
[
dup '[ , fold-comparison ] +outputs+ set-word-prop
dup '[
[ , fold-comparison ] +outputs+ set-word-prop
] each-derived-op
] each

21
unfinished/compiler/tree/propagation/nodes/nodes.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences accessors kernel
USING: sequences accessors kernel assocs sequences
compiler.tree
compiler.tree.def-use
compiler.tree.propagation.info ;
IN: compiler.tree.propagation.nodes
@ -14,4 +15,20 @@ GENERIC: propagate-after ( node -- )
GENERIC: propagate-around ( node -- )
: (propagate) ( node -- ) [ [ propagate-around ] each ] when* ;
: (propagate) ( node -- ) [ propagate-around ] each ;
: 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 ;
M: node propagate-before drop ;
M: node propagate-after drop ;
M: node propagate-around
[ propagate-before ] [ annotate-node ] [ propagate-after ] tri ;

44
unfinished/compiler/tree/propagation/propagation-tests.factor
View File

@ -5,11 +5,10 @@ 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 ;
compiler.tree.propagation.info slots.private ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
\ propagate/node must-infer
: final-info ( quot -- seq )
build-tree
@ -52,6 +51,10 @@ IN: compiler.tree.propagation.tests
[ V{ integer } ] [ [ /i ] final-classes ] unit-test
[ V{ integer } ] [
[ { integer } declare bitnot ] final-classes
] unit-test
[ V{ integer } ] [ [ 255 bitand ] final-classes ] unit-test
[ V{ integer } ] [
@ -316,7 +319,7 @@ cell-bits 32 = [
! Array length propagation
[ V{ t } ] [ [ 10 f <array> length 10 = ] final-literals ] unit-test
[ V{ t } ] [ [ [ 10 f <array> ] [ 10 <byte-array> ] if length 10 = ] final-literals ] unit-test
[ V{ t } ] [ [ [ 10 f <array> length ] [ 10 <byte-array> length ] if 10 = ] final-literals ] unit-test
[ V{ t } ] [ [ [ 1 f <array> ] [ 2 f <array> ] if length 3 < ] final-literals ] unit-test
@ -325,15 +328,6 @@ TUPLE: prop-test-tuple { x integer } ;
[ V{ integer } ] [ [ { prop-test-tuple } declare x>> ] final-classes ] unit-test
TUPLE: another-prop-test-tuple { x ratio initial: 1/2 } ;
UNION: prop-test-union prop-test-tuple another-prop-test-tuple ;
[ t ] [
[ { prop-test-union } declare x>> ] final-classes first
rational class=
] unit-test
TUPLE: fold-boa-test-tuple { x read-only } { y read-only } { z read-only } ;
[ V{ T{ fold-boa-test-tuple f 1 2 3 } } ]
@ -377,6 +371,8 @@ TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
] final-classes
] unit-test
[ ] [ [ dup 3 slot swap 4 slot dup 3 slot swap 4 slot ] final-info drop ] unit-test
[ V{ number } ] [ [ [ "Oops" throw ] [ 2 + ] if ] final-classes ] unit-test
[ V{ number } ] [ [ [ 2 + ] [ "Oops" throw ] if ] final-classes ] unit-test
@ -404,8 +400,13 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
[ V{ integer array } ] [
[
3 { 2 1 } mixed-mutable-immutable boa
[ x>> ] [ y>> ] bi
3 { 2 1 } mixed-mutable-immutable boa [ x>> ] [ y>> ] bi
] final-classes
] unit-test
[ V{ array integer } ] [
[
3 { 2 1 } mixed-mutable-immutable boa [ y>> ] [ x>> ] bi
] final-classes
] unit-test
@ -459,3 +460,18 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
[ V{ fixnum } ] [ [ 1 10 [ dup 10 < [ 2 * ] when ] times ] final-classes ] unit-test
[ V{ integer } ] [ [ 0 2 100 ^ [ nip ] each-integer ] final-classes ] unit-test
[ ] [ [ [ ] [ ] compose curry call ] final-info drop ] unit-test
[ V{ } ] [
[ [ drop ] [ drop ] compose curry (each-integer) ] final-classes
] unit-test
GENERIC: iterate ( obj -- next-obj ? )
M: fixnum iterate f ;
M: array iterate first t ;
: dead-loop ( obj -- final-obj )
iterate [ dead-loop ] when ; inline recursive
[ V{ fixnum } ] [ [ { fixnum } declare dead-loop ] final-classes ] unit-test

12
unfinished/compiler/tree/propagation/propagation.factor
View File

@ -12,15 +12,9 @@ compiler.tree.propagation.constraints
compiler.tree.propagation.known-words ;
IN: compiler.tree.propagation
: propagate-with ( node infos -- )
: propagate ( node -- node )
[
H{ } clone constraints set
>hashtable value-infos set
(propagate)
H{ } clone value-infos set
dup (propagate)
] with-scope ;
: propagate ( node -- node )
dup f propagate-with ;
: propagate/node ( node existing -- )
info>> propagate-with ;

6
unfinished/compiler/tree/propagation/recursive/recursive.factor
View File

@ -4,6 +4,7 @@ USING: kernel sequences accessors arrays fry math.intervals
combinators
stack-checker.inlining
compiler.tree
compiler.tree.copy-equiv
compiler.tree.propagation.info
compiler.tree.propagation.nodes
compiler.tree.propagation.simple
@ -53,11 +54,14 @@ M: #recursive propagate-around ( #recursive -- )
iter-counter get 10 > [ "Oops" throw ] when
dup label>> t >>fixed-point drop [
[
copies [ clone ] change
constraints [ clone ] change
child>>
[ first propagate-recursive-phi ]
[ (propagate) ]
bi
] save-constraints
] with-scope
] [ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ] bi ;
: generalize-return-interval ( info -- info' )

120
unfinished/compiler/tree/propagation/simple/simple.factor
View File

@ -1,17 +1,21 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors kernel sequences sequences.private assocs
words namespaces classes.algebra combinators classes
classes.tuple classes.tuple.private continuations arrays
byte-arrays strings math math.private slots
USING: fry accessors kernel sequences sequences.private assocs words
namespaces classes.algebra combinators classes classes.tuple
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
compiler.tree.propagation.inlining
compiler.tree.propagation.constraints ;
IN: compiler.tree.propagation.simple
! Propagation for straight-line code.
M: #introduce propagate-before
value>> object <class-info> swap set-value-info ;
@ -40,91 +44,61 @@ M: #declare propagate-before
[ [ in-d>> ] [ out-d>> ] bi append ] dip
with-datastack first assume ;
: compute-constraints ( #call -- )
dup word>> +constraints+ word-prop [ custom-constraints ] [
dup word>> predicate? [
[ in-d>> first ]
[ word>> "predicating" word-prop ]
[ out-d>> first ]
tri predicate-constraints assume
] [ drop ] if
: compute-constraints ( #call word -- )
dup +constraints+ word-prop [ nip custom-constraints ] [
dup predicate? [
[ [ in-d>> first ] [ out-d>> first ] bi ]
[ "predicating" word-prop ] bi*
swap predicate-constraints assume
] [ 2drop ] if
] if* ;
: call-outputs-quot ( node -- infos )
[ in-d>> [ value-info ] map ]
[ word>> +outputs+ word-prop ]
bi with-datastack ;
: call-outputs-quot ( #call word -- infos )
[ in-d>> [ value-info ] map ] [ +outputs+ word-prop ] bi*
with-datastack ;
: foldable-word? ( #call -- ? )
dup word>> "foldable" word-prop [
drop t
] [
dup word>> \ <tuple-boa> eq? [
in-d>> peek value-info literal>> immutable-tuple-class?
] [
drop f
] if
] if ;
: foldable-call? ( #call word -- ? )
"foldable" word-prop
[ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ;
: foldable-call? ( #call -- ? )
dup word>> "foldable" word-prop [
in-d>> [ value-info literal?>> ] all?
] [
drop f
] if ;
: fold-call ( #call -- infos )
: fold-call ( #call word -- infos )
[ in-d>> [ value-info literal>> ] map ]
[ word>> [ execute ] curry ]
bi with-datastack
[ [ execute ] curry ]
bi* with-datastack
[ <literal-info> ] map ;
: default-output-value-infos ( node -- infos )
dup word>> "default-output-classes" word-prop [
class-infos
] [
out-d>> length object <class-info> <repetition>
] ?if ;
: default-output-value-infos ( #call word -- infos )
"default-output-classes" word-prop
[ class-infos ] [ out-d>> length object <class-info> <repetition> ] ?if ;
: output-value-infos ( node -- infos )
: output-value-infos ( #call word -- infos )
{
{ [ dup foldable-call? ] [ fold-call ] }
{ [ 2dup foldable-call? ] [ fold-call ] }
{ [ dup tuple-constructor? ] [ propagate-tuple-constructor ] }
{ [ dup word>> reader? ] [ reader-word-outputs ] }
{ [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
{ [ dup length-accessor? ] [ propagate-length ] }
{ [ dup word>> +outputs+ word-prop ] [ call-outputs-quot ] }
{ [ dup +outputs+ word-prop ] [ call-outputs-quot ] }
[ default-output-value-infos ]
} cond ;
M: #call propagate-before
[ [ output-value-infos ] [ out-d>> ] bi set-value-infos ]
[ compute-constraints ]
bi ;
M: node propagate-before drop ;
: propagate-input-classes ( node -- )
[ word>> "input-classes" word-prop class-infos ] [ in-d>> ] bi
refine-value-infos ;
M: #call propagate-after
: do-inlining ( #call word -- ? )
{
{ [ dup reader? ] [ reader-word-inputs ] }
{ [ dup word>> "input-classes" word-prop ] [ propagate-input-classes ] }
[ drop ]
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
{ [ dup math-partial? ] [ inline-math-partial ] }
{ [ dup method-body? ] [ inline-method-body ] }
[ 2drop f ]
} cond ;
M: node propagate-after drop ;
M: #call propagate-before
dup word>> 2dup do-inlining [ 2drop ] [
[ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ]
[ compute-constraints ]
2bi
] if ;
: extract-value-info ( values -- assoc )
[ dup value-info ] H{ } map>assoc ;
: propagate-input-classes ( node input-classes -- )
class-infos swap in-d>> refine-value-infos ;
: annotate-node ( node -- )
dup
[ node-defs-values ] [ node-uses-values ] bi append
extract-value-info
>>info drop ;
M: node propagate-around
[ propagate-before ] [ annotate-node ] [ propagate-after ] tri ;
M: #call propagate-after
dup word>> "input-classes" word-prop dup
[ propagate-input-classes ] [ 2drop ] if ;

103
unfinished/compiler/tree/propagation/slots/slots.factor
View File

@ -3,7 +3,7 @@
USING: fry assocs arrays byte-arrays strings accessors sequences
kernel slots classes.algebra classes.tuple classes.tuple.private
words math math.private combinators sequences.private namespaces
compiler.tree.propagation.info ;
classes compiler.tree.propagation.info ;
IN: compiler.tree.propagation.slots
! Propagation of immutable slots and array lengths
@ -13,8 +13,8 @@ IN: compiler.tree.propagation.slots
UNION: fixed-length-sequence array byte-array string ;
: sequence-constructor? ( node -- ? )
word>> { <array> <byte-array> <string> } memq? ;
: sequence-constructor? ( word -- ? )
{ <array> <byte-array> <string> } memq? ;
: constructor-output-class ( word -- class )
{
@ -23,21 +23,13 @@ UNION: fixed-length-sequence array byte-array string ;
{ <string> string }
} at ;
: propagate-sequence-constructor ( node -- infos )
[ word>> constructor-output-class <class-info> ]
: propagate-sequence-constructor ( #call word -- infos )
[ in-d>> first <sequence-info> ]
bi value-info-intersect 1array ;
[ constructor-output-class <class-info> ]
bi* value-info-intersect 1array ;
: length-accessor? ( node -- ? )
dup in-d>> first value-info class>> fixed-length-sequence class<=
[ word>> \ length eq? ] [ drop f ] if ;
: propagate-length ( node -- infos )
in-d>> first value-info length>>
[ array-capacity <class-info> ] unless* 1array ;
: tuple-constructor? ( node -- ? )
word>> { <tuple-boa> <complex> } memq? ;
: tuple-constructor? ( word -- ? )
{ <tuple-boa> <complex> } memq? ;
: read-only-slots ( values class -- slots )
#! Delegation.
@ -49,7 +41,7 @@ UNION: fixed-length-sequence array byte-array string ;
[ , f , [ literal>> ] map % ] { } make >tuple
<literal-info> ;
: propagate-<tuple-boa> ( node -- info )
: propagate-<tuple-boa> ( #call -- info )
#! Delegation
in-d>> [ value-info ] map unclip-last
literal>> class>> [ read-only-slots ] keep
@ -59,72 +51,45 @@ UNION: fixed-length-sequence array byte-array string ;
<tuple-info>
] if ;
: propagate-<complex> ( node -- info )
: propagate-<complex> ( #call -- info )
in-d>> [ value-info ] map complex <tuple-info> ;
: propagate-tuple-constructor ( node -- infos )
dup word>> {
: propagate-tuple-constructor ( #call word -- infos )
{
{ \ <tuple-boa> [ propagate-<tuple-boa> ] }
{ \ <complex> [ propagate-<complex> ] }
} case 1array ;
: relevant-methods ( node -- methods )
[ word>> "methods" word-prop ]
[ in-d>> first value-info class>> ] bi
'[ drop , classes-intersect? ] assoc-filter ;
: relevant-slots ( node -- slots )
relevant-methods [ nip "reading" word-prop ] { } assoc>map ;
: no-reader-methods ( input slots -- info )
2drop null-info ;
: same-offset ( slots -- slot/f )
dup [ dup [ read-only>> ] when ] all? [
[ offset>> ] map dup all-equal? [ first ] [ drop f ] if
] [ drop f ] if ;
: (reader-word-outputs) ( reader -- info )
null
[ [ class>> ] [ object ] if* class-or ] reduce
<class-info> ;
: tuple>array* ( tuple -- array )
prepare-tuple>array
>r copy-tuple-slots r>
prefix ;
: literal-info-slot ( slot info -- info' )
{
{ [ dup tuple? ] [
tuple>array* nth <literal-info>
] }
{ [ dup complex? ] [
[ real-part ] [ imaginary-part ] bi
2array nth <literal-info>
] }
} cond ;
: read-only-slot? ( n class -- ? )
all-slots [ offset>> = ] with find nip
dup [ read-only>> ] when ;
: literal-info-slot ( slot object -- info/f )
2dup class read-only-slot? [
{
{ [ dup tuple? ] [
[ 1- ] [ tuple>array* ] bi* nth <literal-info>
] }
{ [ dup complex? ] [
[ 1- ] [ [ real-part ] [ imaginary-part ] bi ] bi*
2array nth <literal-info>
] }
} cond
] [ 2drop f ] if ;
: length-accessor? ( slot info -- ? )
[ 1 = ] [ length>> ] bi* and ;
: value-info-slot ( slot info -- info' )
#! Delegation.
{
{ [ over 0 = ] [ 2drop fixnum <class-info> ] }
{ [ dup literal?>> ] [ [ 1- ] [ literal>> ] bi* literal-info-slot ] }
{ [ 2dup length-accessor? ] [ nip length>> ] }
{ [ dup literal?>> ] [ literal>> literal-info-slot ] }
[ [ 1- ] [ slots>> ] bi* ?nth ]
} cond ;
: reader-word-outputs ( node -- infos )
[ relevant-slots ] [ in-d>> first ] bi
over empty? [ no-reader-methods ] [
over same-offset dup
[ swap value-info value-info-slot ] [ 2drop f ] if
[ ] [ (reader-word-outputs) ] ?if
] if 1array ;
: reader-word-inputs ( node -- )
[ in-d>> first ] [
relevant-slots keys
object [ class>> [ class-and ] when* ] reduce
<class-info>
] bi
refine-value-info ;
} cond [ object <class-info> ] unless* ;

6
unfinished/compiler/tree/tree.factor
View File

@ -16,7 +16,7 @@ TUPLE: #introduce < node value ;
: #introduce ( value -- node )
\ #introduce new swap >>value ;
TUPLE: #call < node word history in-d out-d ;
TUPLE: #call < node word in-d out-d body method ;
: #call ( inputs outputs word -- node )
\ #call new
@ -70,7 +70,7 @@ TUPLE: #terminate < node in-d ;
\ #terminate new
swap >>in-d ;
TUPLE: #branch < node in-d children ;
TUPLE: #branch < node in-d children live-branches ;
: new-branch ( value children class -- node )
new
@ -140,6 +140,8 @@ TUPLE: #copy < node in-d out-d ;
swap >>out-d
swap >>in-d ;
: in/out ( node -- in-d out-d ) [ in-d>> ] [ out-d>> ] bi ; inline
: node, ( node -- ) stack-visitor get push ;
M: vector child-visitor V{ } clone ;

5
unfinished/stack-checker/branches/branches.factor
View File

@ -12,10 +12,13 @@ IN: stack-checker.branches
: unify-inputs ( max-d-in d-in meta-d -- new-meta-d )
dup [ [ - f <repetition> ] dip append ] [ 3drop f ] if ;
: pad-with-f ( seq -- newseq )
dup [ length ] map supremum '[ , f pad-left ] map ;
: phi-inputs ( max-d-in pairs -- newseq )
dup empty? [ nip ] [
swap '[ , _ first2 unify-inputs ] map
dup [ length ] map supremum '[ , f pad-left ] map
pad-with-f
flip
] if ;

4
unfinished/stack-checker/inlining/inlining.factor
View File

@ -20,9 +20,7 @@ IN: stack-checker.inlining
TUPLE: inline-recursive word enter-out return calls fixed-point introductions ;
: <inline-recursive> ( word -- label )
inline-recursive new
swap >>word
V{ } clone >>calls ;
inline-recursive new swap >>word ;
: quotation-param? ( obj -- ? )
dup pair? [ second effect? ] [ drop f ] if ;