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

Merge branch 'master' of factorcode.org:/git/factor

db4
Eduardo Cavazos 2008-07-30 04:34:53 -05:00
parent 553fd49391 d8b6a7f7e6
commit 677865dc75
32 changed files with 1103 additions and 258 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
basis/bootstrap/threads/threads.factor
View File

@ -4,3 +4,4 @@ IN: bootstrap.threads
USE: io.thread
USE: threads
USE: debugger.threads

2
basis/concurrency/mailboxes/mailboxes.factor
View File

@ -4,7 +4,7 @@ IN: concurrency.mailboxes
USING: dlists dequeues threads sequences continuations
destructors namespaces random math quotations words kernel
arrays assocs init system concurrency.conditions accessors
debugger ;
debugger debugger.threads ;
TUPLE: mailbox threads data disposed ;

38
basis/debugger/debugger.factor
View File

@ -5,10 +5,10 @@ kernel math namespaces prettyprint prettyprint.config sequences
assocs sequences.private strings io.styles io.files vectors
words system splitting math.parser classes.tuple continuations
continuations.private combinators generic.math classes.builtin
classes compiler.units generic.standard vocabs threads
threads.private init kernel.private libc io.encodings accessors
math.order destructors source-files parser classes.tuple.parser
effects.parser lexer compiler.errors dlists generic.parser
classes compiler.units generic.standard vocabs init
kernel.private io.encodings accessors math.order
destructors source-files parser classes.tuple.parser
effects.parser lexer compiler.errors generic.parser
strings.parser ;
IN: debugger
@ -245,33 +245,6 @@ M: no-compilation-unit error.
M: no-vocab summary
drop "Vocabulary does not exist" ;
M: bad-ptr summary
drop "Memory allocation failed" ;
M: double-free summary
drop "Free failed since memory is not allocated" ;
M: realloc-error summary
drop "Memory reallocation failed" ;
: error-in-thread. ( thread -- )
"Error in thread " write
[
dup thread-id #
" (" % dup thread-name %
", " % dup thread-quot unparse-short % ")" %
] "" make swap write-object ":" print nl ;
! Hooks
M: thread error-in-thread ( error thread -- )
initial-thread get-global eq? [
die drop
] [
global [
error-thread get-global error-in-thread. print-error flush
] bind
] if ;
M: encode-error summary drop "Character encoding error" ;
M: decode-error summary drop "Character decoding error" ;
@ -348,9 +321,6 @@ M: object compiler-error. ( error word -- )
nl
print-error ;
M: empty-dlist summary ( dlist -- )
drop "Empty dlist" ;
M: bad-effect summary
drop "Bad stack effect declaration" ;

22
basis/debugger/threads/threads.factor Normal file
View File

@ -0,0 +1,22 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors debugger continuations threads threads.private
io io.styles prettyprint kernel math.parser namespaces ;
IN: debugger.threads
: error-in-thread. ( thread -- )
"Error in thread " write
[
dup id>> #
" (" % dup name>> %
", " % dup quot>> unparse-short % ")" %
] "" make swap write-object ":" print nl ;
M: thread error-in-thread ( error thread -- )
initial-thread get-global eq? [
die drop
] [
global [
error-thread get-global error-in-thread. print-error flush
] bind
] if ;

6
basis/dlists/dlists.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel math sequences accessors dequeues ;
USING: combinators kernel math sequences accessors dequeues
summary ;
IN: dlists
TUPLE: dlist front back length ;
@ -80,6 +81,9 @@ M: dlist push-back* ( obj dlist -- dlist-node )
ERROR: empty-dlist ;
M: empty-dlist summary ( dlist -- )
drop "Empty dlist" ;
M: dlist peek-front ( dlist -- obj )
front>> [ obj>> ] [ empty-dlist ] if* ;

11
basis/libc/libc.factor
View File

@ -3,7 +3,7 @@
! Copyright (C) 2007, 2008 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: alien assocs continuations destructors kernel
namespaces accessors sets ;
namespaces accessors sets summary ;
IN: libc
<PRIVATE
@ -34,13 +34,22 @@ PRIVATE>
ERROR: bad-ptr ;
M: bad-ptr summary
drop "Memory allocation failed" ;
: check-ptr ( c-ptr -- c-ptr )
[ bad-ptr ] unless* ;
ERROR: double-free ;
M: double-free summary
drop "Free failed since memory is not allocated" ;
ERROR: realloc-error ptr size ;
M: realloc-error summary
drop "Memory reallocation failed" ;
<PRIVATE
: add-malloc ( alien -- )

4
basis/tools/deploy/deploy-tests.factor
View File

@ -26,7 +26,7 @@ namespaces continuations layouts accessors ;
[ t ] [ 1300000 small-enough? ] unit-test
[ "staging.math-compiler-ui-strip.image" ] [
[ "staging.threads-math-compiler-ui-strip.image" ] [
"hello-ui" deploy-config
[ bootstrap-profile staging-image-name file-name ] bind
] unit-test
@ -79,7 +79,7 @@ M: quit-responder call-responder*
[
<dispatcher>
add-quot-responder
"resource:basis/http/test" <static> >>default
"resource:extra/http/test" <static> >>default
main-responder set
test-httpd

2
core/generic/generic.factor
View File

@ -39,7 +39,7 @@ GENERIC: effective-method ( generic -- method )
order [ class<= ] with filter reverse dup length 1 =
[ drop f ] [ second ] if ;
: next-method ( class generic -- class/f )
: next-method ( class generic -- method/f )
[ next-method-class ] keep method ;
GENERIC: next-method-quot* ( class generic combination -- quot )

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 ;

0
unfinished/compiler/tree/loop-detection/loop-detection.factor → unfinished/compiler/tree/loop/detection/detection.factor
View File

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

4
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

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 ;