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

db4
Doug Coleman 2008-08-11 00:48:37 -05:00
commit 96508d2daf
41 changed files with 990 additions and 254 deletions

View File

@ -66,6 +66,10 @@ M: disjoint-set add-atom
: add-atoms ( seq disjoint-set -- ) '[ , add-atom ] each ; : add-atoms ( seq disjoint-set -- ) '[ , add-atom ] each ;
GENERIC: disjoint-set-member? ( a disjoint-set -- ? )
M: disjoint-set disjoint-set-member? parents>> key? ;
GENERIC: equiv-set-size ( a disjoint-set -- n ) GENERIC: equiv-set-size ( a disjoint-set -- n )
M: disjoint-set equiv-set-size [ representative ] keep count ; M: disjoint-set equiv-set-size [ representative ] keep count ;

View File

@ -1,5 +1,6 @@
! Copyright (C) 2004, 2005 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USE: math
IN: math.constants IN: math.constants
: e ( -- e ) 2.7182818284590452354 ; inline : e ( -- e ) 2.7182818284590452354 ; inline
@ -7,3 +8,5 @@ IN: math.constants
: phi ( -- phi ) 1.61803398874989484820 ; inline : phi ( -- phi ) 1.61803398874989484820 ; inline
: pi ( -- pi ) 3.14159265358979323846 ; inline : pi ( -- pi ) 3.14159265358979323846 ; inline
: epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline
: smallest-float ( -- x ) HEX: 1 bits>double ; foldable
: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable

View File

@ -0,0 +1 @@
Daniel Ehrenberg

View File

@ -0,0 +1,56 @@
USING: help.markup help.syntax kernel sequences ;
IN: persistent.deques
ARTICLE: "persistent.deques" "Persistent deques"
"A deque is a data structure that can be used as both a queue and a stack. That is, there are two ends, the left and the right, and values can be pushed onto and popped off of both ends. These operations take O(1) amortized time and space in a normal usage pattern."
$nl
"This vocabulary provides a deque implementation which is persistent and purely functional: old versions of deques are not modified by operations. Instead, each push and pop operation creates a new deque based off the old one."
$nl
"The class of persistent deques:"
{ $subsection deque }
"To create a deque:"
{ $subsection <deque> }
{ $subsection sequence>deque }
"To test if a deque is empty:"
{ $subsection deque-empty? }
"To manipulate deques:"
{ $subsection push-left }
{ $subsection push-right }
{ $subsection pop-left }
{ $subsection pop-right }
{ $subsection deque>sequence } ;
HELP: deque
{ $class-description "This is the class of persistent (functional) double-ended queues. All deque operations can be done in O(1) amortized time for single-threaded access while maintaining the old version. For more information, see " { $link "persistent.deques" } "." } ;
HELP: <deque>
{ $values { "deque" "an empty deque" } }
{ $description "Creates an empty deque." } ;
HELP: sequence>deque
{ $values { "sequence" sequence } { "deque" deque } }
{ $description "Given a sequence, creates a deque containing those elements in the order such that the beginning of the sequence is on the left and the end is on the right." } ;
HELP: deque>sequence
{ $values { "deque" deque } { "sequence" sequence } }
{ $description "Given a deque, creates a sequence containing those elements, such that the left side of the deque is the beginning of the sequence." } ;
HELP: deque-empty?
{ $values { "deque" deque } { "?" "t/f" } }
{ $description "Returns true if the deque is empty. This takes constant time." } ;
HELP: push-left
{ $values { "deque" deque } { "item" object } { "newdeque" deque } }
{ $description "Creates a new deque with the given object pushed onto the left side. This takes constant time." } ;
HELP: push-right
{ $values { "deque" deque } { "item" object } { "newdeque" deque } }
{ $description "Creates a new deque with the given object pushed onto the right side. This takes constant time." } ;
HELP: pop-left
{ $values { "deque" object } { "item" object } { "newdeque" deque } }
{ $description "Creates a new deque with the leftmost item removed. This takes amortized constant time with single-threaded access." } ;
HELP: pop-right
{ $values { "deque" object } { "item" object } { "newdeque" deque } }
{ $description "Creates a new deque with the rightmost item removed. This takes amortized constant time with single-threaded access." } ;

View File

@ -0,0 +1,35 @@
! Copyright (C) 2008 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test persistent.deques kernel math ;
IN: persistent.deques.tests
[ 3 2 1 t ]
[ { 1 2 3 } sequence>deque 3 [ pop-right ] times deque-empty? ] unit-test
[ 1 2 3 t ]
[ { 1 2 3 } sequence>deque 3 [ pop-left ] times deque-empty? ] unit-test
[ 1 3 2 t ]
[ { 1 2 3 } sequence>deque pop-left 2 [ pop-right ] times deque-empty? ]
unit-test
[ { 2 3 4 5 6 1 } ]
[ { 1 2 3 4 5 6 } sequence>deque pop-left swap push-right deque>sequence ]
unit-test
[ 1 t ] [ <deque> 1 push-left pop-right deque-empty? ] unit-test
[ 1 t ] [ <deque> 1 push-left pop-left deque-empty? ] unit-test
[ 1 t ] [ <deque> 1 push-right pop-left deque-empty? ] unit-test
[ 1 t ] [ <deque> 1 push-right pop-right deque-empty? ] unit-test
[ 1 f ]
[ <deque> 1 push-left 2 push-left pop-right deque-empty? ] unit-test
[ 1 f ]
[ <deque> 1 push-right 2 push-right pop-left deque-empty? ] unit-test
[ 2 f ]
[ <deque> 1 push-right 2 push-right pop-right deque-empty? ] unit-test
[ 2 f ]
[ <deque> 1 push-left 2 push-left pop-left deque-empty? ] unit-test

View File

@ -0,0 +1,76 @@
! Copyright (C) 2008 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors math qualified ;
QUALIFIED: sequences
IN: persistent.deques
! Amortized O(1) push/pop on both ends for single-threaded access
! In a pathological case, if there are m modified versions from the
! same source, it could take O(m) amortized time per update.
<PRIVATE
TUPLE: cons { car read-only } { cdr read-only } ;
C: <cons> cons
: each ( list quot -- )
over
[ [ >r car>> r> call ] [ >r cdr>> r> ] 2bi each ]
[ 2drop ] if ; inline
: reduce ( list start quot -- end )
swapd each ; inline
: reverse ( list -- reversed )
f [ swap <cons> ] reduce ;
: length ( list -- length )
0 [ drop 1+ ] reduce ;
: cut ( list index -- back front-reversed )
f swap [ >r [ cdr>> ] [ car>> ] bi r> <cons> ] times ;
: split-reverse ( list -- back-reversed front )
dup length 2/ cut [ reverse ] bi@ ;
PRIVATE>
TUPLE: deque { lhs read-only } { rhs read-only } ;
: <deque> ( -- deque ) T{ deque } ;
: deque-empty? ( deque -- ? )
[ lhs>> ] [ rhs>> ] bi or not ;
: push-left ( deque item -- newdeque )
swap [ lhs>> <cons> ] [ rhs>> ] bi deque boa ;
: push-right ( deque item -- newdeque )
swap [ rhs>> <cons> ] [ lhs>> ] bi swap deque boa ;
<PRIVATE
: (pop-left) ( deque -- item newdeque )
[ lhs>> car>> ] [ [ lhs>> cdr>> ] [ rhs>> ] bi deque boa ] bi ;
: transfer-left ( deque -- item newdeque )
rhs>> [ split-reverse deque boa (pop-left) ]
[ "Popping from an empty deque" throw ] if* ;
PRIVATE>
: pop-left ( deque -- item newdeque )
dup lhs>> [ (pop-left) ] [ transfer-left ] if ;
<PRIVATE
: (pop-right) ( deque -- item newdeque )
[ rhs>> car>> ] [ [ lhs>> ] [ rhs>> cdr>> ] bi deque boa ] bi ;
: transfer-right ( deque -- newdeque item )
lhs>> [ split-reverse deque boa (pop-left) ]
[ "Popping from an empty deque" throw ] if* ;
PRIVATE>
: pop-right ( deque -- item newdeque )
dup rhs>> [ (pop-right) ] [ transfer-right ] if ;
: sequence>deque ( sequence -- deque )
<deque> [ push-right ] sequences:reduce ;
: deque>sequence ( deque -- sequence )
[ dup deque-empty? not ] [ pop-left swap ] [ ] sequences:produce nip ;

View File

@ -0,0 +1 @@
Persistent amortized O(1) deques

View File

@ -0,0 +1 @@
collections

View File

@ -629,7 +629,7 @@ HELP: 2bi*
"The following two lines are equivalent:" "The following two lines are equivalent:"
{ $code { $code
"[ p ] [ q ] 2bi*" "[ p ] [ q ] 2bi*"
">r >r q r> r> q" ">r >r p r> r> q"
} }
} ; } ;

View File

@ -22,6 +22,11 @@ IN: compiler.tree.builder
] with-tree-builder nip ] with-tree-builder nip
unclip-last in-d>> ; unclip-last in-d>> ;
: build-sub-tree ( #call quot -- nodes )
[ [ out-d>> ] [ in-d>> ] bi ] dip
build-tree-with
rot #copy suffix ;
: (make-specializer) ( class picker -- quot ) : (make-specializer) ( class picker -- quot )
swap "predicate" word-prop append ; swap "predicate" word-prop append ;

View File

@ -0,0 +1,61 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel sets namespaces accessors assocs
arrays combinators continuations
compiler.tree
compiler.tree.def-use
compiler.tree.combinators ;
IN: compiler.tree.checker
! Check some invariants.
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 ;
M: #>r check-node inputs/outputs 2array check-lengths ;
M: #r> check-node inputs/outputs 2array check-lengths ;
M: #return-recursive check-node inputs/outputs 2array check-lengths ;
M: #phi check-node
{
[ [ phi-in-d>> ] [ out-d>> ] bi 2array check-lengths ]
[ [ phi-in-r>> ] [ out-r>> ] bi 2array check-lengths ]
[ phi-in-d>> check-lengths ]
[ phi-in-r>> check-lengths ]
} cleave ;
M: #enter-recursive check-node
[ [ in-d>> ] [ out-d>> ] bi 2array check-lengths ]
[ [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix check-lengths ]
bi ;
M: #push check-node
out-d>> length 1 = [ "Bad #push" throw ] unless ;
M: node check-node drop ;
ERROR: check-node-error node error ;
: check-nodes ( nodes -- )
compute-def-use
check-def-use
[ [ check-node ] [ check-node-error ] recover ] each-node ;

View File

@ -2,8 +2,9 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sequences.deep combinators fry USING: kernel accessors sequences sequences.deep combinators fry
classes.algebra namespaces assocs math math.private classes.algebra namespaces assocs math math.private
math.partial-dispatch math.partial-dispatch classes.tuple classes.tuple.private
compiler.tree compiler.tree
compiler.tree.intrinsics
compiler.tree.combinators compiler.tree.combinators
compiler.tree.propagation.info compiler.tree.propagation.info
compiler.tree.propagation.branches ; compiler.tree.propagation.branches ;
@ -53,11 +54,21 @@ GENERIC: cleanup* ( node -- node/nodes )
: remove-overflow-check ( #call -- #call ) : remove-overflow-check ( #call -- #call )
[ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ; [ 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* M: #call cleanup*
{ {
{ [ dup body>> ] [ cleanup-inlining ] } { [ dup body>> ] [ cleanup-inlining ] }
{ [ dup cleanup-folding? ] [ cleanup-folding ] } { [ dup cleanup-folding? ] [ cleanup-folding ] }
{ [ dup remove-overflow-check? ] [ remove-overflow-check ] } { [ dup remove-overflow-check? ] [ remove-overflow-check ] }
{ [ dup immutable-tuple-boa? ] [ immutable-tuple-boa ] }
[ ] [ ]
} cond ; } cond ;
@ -94,10 +105,10 @@ SYMBOL: live-branches
M: #branch cleanup* M: #branch cleanup*
{ {
[ live-branches>> live-branches set ]
[ delete-unreachable-branches ] [ delete-unreachable-branches ]
[ cleanup-children ] [ cleanup-children ]
[ fold-only-branch ] [ fold-only-branch ]
[ live-branches>> live-branches set ]
} cleave ; } cleave ;
: cleanup-phi-in ( phi-in live-branches -- phi-in' ) : cleanup-phi-in ( phi-in live-branches -- phi-in' )
@ -111,7 +122,8 @@ M: #phi cleanup*
[ '[ , cleanup-phi-in ] change-phi-in-r ] [ '[ , cleanup-phi-in ] change-phi-in-r ]
[ '[ , cleanup-phi-in ] change-phi-info-d ] [ '[ , cleanup-phi-in ] change-phi-info-d ]
[ '[ , cleanup-phi-in ] change-phi-info-r ] [ '[ , cleanup-phi-in ] change-phi-info-r ]
} cleave ; } cleave
live-branches off ;
: >copy ( node -- #copy ) [ in-d>> ] [ out-d>> ] bi #copy ; : >copy ( node -- #copy ) [ in-d>> ] [ out-d>> ] bi #copy ;

View File

@ -1,8 +1,9 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors namespaces assocs dequeues search-dequeues USING: fry accessors namespaces assocs dequeues search-dequeues
kernel sequences words sets stack-checker.inlining compiler.tree kernel sequences words sets
compiler.tree.def-use compiler.tree.combinators ; stack-checker.branches stack-checker.inlining
compiler.tree compiler.tree.def-use compiler.tree.combinators ;
IN: compiler.tree.dataflow-analysis IN: compiler.tree.dataflow-analysis
! Dataflow analysis ! Dataflow analysis
@ -34,5 +35,5 @@ SYMBOL: work-list
: dfa ( node mark-quot iterate-quot -- assoc ) : dfa ( node mark-quot iterate-quot -- assoc )
init-dfa init-dfa
[ each-node ] dip [ each-node ] dip
work-list get H{ { f f } } clone work-list get H{ { +bottom+ f } } clone
[ rot '[ , , iterate-dfa ] slurp-dequeue ] keep ; inline [ rot '[ , , iterate-dfa ] slurp-dequeue ] keep ; inline

View File

@ -1,7 +1,7 @@
USING: namespaces assocs sequences compiler.tree.builder USING: namespaces assocs sequences compiler.tree.builder
compiler.tree.dead-code compiler.tree.def-use compiler.tree compiler.tree.dead-code compiler.tree.def-use compiler.tree
compiler.tree.combinators tools.test kernel math compiler.tree.combinators tools.test kernel math
stack-checker.state accessors ; stack-checker.state accessors combinators ;
IN: compiler.tree.dead-code.tests IN: compiler.tree.dead-code.tests
\ remove-dead-code must-infer \ remove-dead-code must-infer
@ -10,20 +10,27 @@ IN: compiler.tree.dead-code.tests
build-tree build-tree
compute-def-use compute-def-use
remove-dead-code remove-dead-code
compute-def-use 0 swap [
0 swap [ dup #push? [ out-d>> length + ] [ drop ] if ] each-node ; {
{ [ dup #push? ] [ out-d>> length + ] }
{ [ dup #introduce? ] [ drop 1 + ] }
[ drop ]
} cond
] each-node ;
[ 3 ] [ [ 1 2 3 ] count-live-values ] unit-test [ 3 ] [ [ 1 2 3 ] count-live-values ] unit-test
[ 1 ] [ [ drop ] count-live-values ] unit-test
[ 0 ] [ [ 1 drop ] count-live-values ] unit-test [ 0 ] [ [ 1 drop ] count-live-values ] unit-test
[ 1 ] [ [ 1 2 drop ] count-live-values ] unit-test [ 1 ] [ [ 1 2 drop ] count-live-values ] unit-test
[ 2 ] [ [ [ 1 ] [ 2 ] if ] count-live-values ] unit-test [ 3 ] [ [ [ 1 ] [ 2 ] if ] count-live-values ] unit-test
[ 0 ] [ [ [ 1 ] [ 2 ] if drop ] count-live-values ] unit-test [ 1 ] [ [ [ 1 ] [ 2 ] if drop ] count-live-values ] unit-test
[ 0 ] [ [ [ 1 ] [ dup ] if drop ] count-live-values ] unit-test [ 2 ] [ [ [ 1 ] [ dup ] if drop ] count-live-values ] unit-test
[ 2 ] [ [ 1 2 + ] count-live-values ] unit-test [ 2 ] [ [ 1 2 + ] count-live-values ] unit-test
@ -33,9 +40,9 @@ IN: compiler.tree.dead-code.tests
[ 0 ] [ [ 1 2 + 3 + drop ] count-live-values ] unit-test [ 0 ] [ [ 1 2 + 3 + drop ] count-live-values ] unit-test
[ 3 ] [ [ [ 1 ] [ 2 ] if 3 + ] count-live-values ] unit-test [ 4 ] [ [ [ 1 ] [ 2 ] if 3 + ] count-live-values ] unit-test
[ 0 ] [ [ [ 1 ] [ 2 ] if 3 + drop ] count-live-values ] unit-test [ 1 ] [ [ [ 1 ] [ 2 ] if 3 + drop ] count-live-values ] unit-test
[ 0 ] [ [ [ ] call ] count-live-values ] unit-test [ 0 ] [ [ [ ] call ] count-live-values ] unit-test

View File

@ -3,15 +3,18 @@
USING: fry accessors namespaces assocs dequeues search-dequeues USING: fry accessors namespaces assocs dequeues search-dequeues
kernel sequences words sets stack-checker.inlining kernel sequences words sets stack-checker.inlining
compiler.tree compiler.tree
compiler.tree.combinators
compiler.tree.dataflow-analysis compiler.tree.dataflow-analysis
compiler.tree.dataflow-analysis.backward compiler.tree.dataflow-analysis.backward ;
compiler.tree.combinators ;
IN: compiler.tree.dead-code IN: compiler.tree.dead-code
! Dead code elimination: remove #push and flushable #call whose ! Dead code elimination: remove #push and flushable #call whose
! outputs are unused using backward DFA. ! outputs are unused using backward DFA.
GENERIC: mark-live-values ( node -- ) GENERIC: mark-live-values ( node -- )
M: #introduce mark-live-values
value>> look-at-value ;
M: #if mark-live-values look-at-inputs ; M: #if mark-live-values look-at-inputs ;
M: #dispatch mark-live-values look-at-inputs ; M: #dispatch mark-live-values look-at-inputs ;
@ -34,9 +37,6 @@ SYMBOL: live-values
GENERIC: remove-dead-values* ( node -- ) GENERIC: remove-dead-values* ( node -- )
M: #introduce remove-dead-values*
[ [ live-value? ] filter ] change-values drop ;
M: #>r remove-dead-values* M: #>r remove-dead-values*
dup out-r>> first live-value? [ { } >>out-r ] unless dup out-r>> first live-value? [ { } >>out-r ] unless
dup in-d>> first live-value? [ { } >>in-d ] unless dup in-d>> first live-value? [ { } >>in-d ] unless
@ -57,6 +57,30 @@ M: #push remove-dead-values*
: filter-live ( values -- values' ) : filter-live ( values -- values' )
[ live-value? ] filter ; [ live-value? ] filter ;
M: #call remove-dead-values*
[ filter-live ] change-in-d
[ filter-live ] change-out-d
drop ;
M: #recursive remove-dead-values*
[ filter-live ] change-in-d
drop ;
M: #call-recursive remove-dead-values*
[ filter-live ] change-in-d
[ filter-live ] change-out-d
drop ;
M: #enter-recursive remove-dead-values*
[ filter-live ] change-in-d
[ filter-live ] change-out-d
drop ;
M: #return-recursive remove-dead-values*
[ filter-live ] change-in-d
[ filter-live ] change-out-d
drop ;
M: #shuffle remove-dead-values* M: #shuffle remove-dead-values*
[ filter-live ] change-in-d [ filter-live ] change-in-d
[ filter-live ] change-out-d [ filter-live ] change-out-d
@ -92,24 +116,19 @@ M: #phi remove-dead-values*
M: node remove-dead-values* drop ; M: node remove-dead-values* drop ;
M: f remove-dead-values* drop ; : remove-dead-values ( nodes -- )
[ remove-dead-values* ] each-node ;
GENERIC: remove-dead-nodes* ( node -- newnode/t ) GENERIC: remove-dead-nodes* ( node -- node/f )
: prune-if-empty ( node seq -- successor/t ) : prune-if-empty ( node seq -- node/f )
empty? [ successor>> ] [ drop t ] if ; inline empty? [ drop f ] when ; inline
M: #introduce remove-dead-nodes* dup values>> prune-if-empty ; : live-call? ( #call -- ? ) out-d>> [ live-value? ] contains? ;
: live-call? ( #call -- ? )
out-d>> [ live-value? ] contains? ;
M: #declare remove-dead-nodes* dup declaration>> prune-if-empty ; M: #declare remove-dead-nodes* dup declaration>> prune-if-empty ;
M: #call remove-dead-nodes* M: #call remove-dead-nodes* dup live-call? [ in-d>> #drop ] unless ;
dup live-call? [ drop t ] [
[ in-d>> #drop ] [ successor>> ] bi >>successor
] if ;
M: #shuffle remove-dead-nodes* dup in-d>> prune-if-empty ; M: #shuffle remove-dead-nodes* dup in-d>> prune-if-empty ;
@ -121,25 +140,13 @@ M: #r> remove-dead-nodes* dup in-r>> prune-if-empty ;
M: #copy remove-dead-nodes* dup in-d>> prune-if-empty ; M: #copy remove-dead-nodes* dup in-d>> prune-if-empty ;
: (remove-dead-code) ( node -- newnode ) M: node remove-dead-nodes* ;
[
dup remove-dead-values*
dup remove-dead-nodes* dup t eq?
[ drop ] [ nip (remove-dead-code) ] if
] transform-nodes ;
M: #if remove-dead-nodes* : remove-dead-nodes ( nodes -- nodes' )
[ (remove-dead-code) ] map-children t ; [ remove-dead-nodes* ] map-nodes ;
M: #dispatch remove-dead-nodes*
[ (remove-dead-code) ] map-children t ;
M: #recursive remove-dead-nodes*
[ (remove-dead-code) ] change-child drop t ;
M: node remove-dead-nodes* drop t ;
M: f remove-dead-nodes* drop t ;
: remove-dead-code ( node -- newnode ) : remove-dead-code ( node -- newnode )
[ [ compute-live-values ] [ (remove-dead-code) ] bi ] with-scope ; [ compute-live-values ]
[ remove-dead-values ]
[ remove-dead-nodes ]
tri ;

View File

@ -1,7 +1,9 @@
USING: accessors namespaces assocs kernel sequences math USING: accessors namespaces assocs kernel sequences math
tools.test words sets combinators.short-circuit tools.test words sets combinators.short-circuit
stack-checker.state compiler.tree compiler.tree.builder stack-checker.state compiler.tree compiler.tree.builder
compiler.tree.def-use arrays kernel.private ; compiler.tree.normalization compiler.tree.propagation
compiler.tree.cleanup compiler.tree.def-use arrays kernel.private
sorting math.order binary-search compiler.tree.checker ;
IN: compiler.tree.def-use.tests IN: compiler.tree.def-use.tests
\ compute-def-use must-infer \ compute-def-use must-infer
@ -14,8 +16,16 @@ IN: compiler.tree.def-use.tests
} 1&& } 1&&
] unit-test ] unit-test
! compute-def-use checks for SSA violations, so we make sure : test-def-use ( quot -- )
! some common patterns are generated correctly. build-tree
normalize
propagate
cleanup
compute-def-use
check-nodes ;
! compute-def-use checks for SSA violations, so we use that to
! ensure we generate some common patterns correctly.
{ {
[ [ drop ] each-integer ] [ [ drop ] each-integer ]
[ [ 2drop ] curry each-integer ] [ [ 2drop ] curry each-integer ]
@ -28,6 +38,10 @@ IN: compiler.tree.def-use.tests
[ [ 1 ] 2 [ + ] curry compose call + ] [ [ 1 ] 2 [ + ] curry compose call + ]
[ [ 1 ] [ call 2 ] curry call + ] [ [ 1 ] [ call 2 ] curry call + ]
[ [ 1 ] [ 2 ] compose swap [ 1 ] [ 2 ] if + * ] [ [ 1 ] [ 2 ] compose swap [ 1 ] [ 2 ] if + * ]
[ dup slice? [ dup array? [ ] [ ] if ] [ ] if ]
[ dup [ drop f ] [ "A" throw ] if ]
[ [ <=> ] sort ]
[ [ <=> ] with search ]
} [ } [
[ ] swap [ build-tree compute-def-use drop ] curry unit-test [ ] swap [ test-def-use ] curry unit-test
] each ] each

View File

@ -1,8 +1,11 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays namespaces assocs sequences kernel generic assocs USING: arrays namespaces assocs sequences kernel generic assocs
classes vectors accessors combinators sets stack-checker.state classes vectors accessors combinators sets
compiler.tree compiler.tree.combinators ; stack-checker.state
stack-checker.branches
compiler.tree
compiler.tree.combinators ;
IN: compiler.tree.def-use IN: compiler.tree.def-use
SYMBOL: def-use SYMBOL: def-use
@ -37,7 +40,8 @@ M: #introduce node-uses-values drop f ;
M: #push node-uses-values drop f ; M: #push node-uses-values drop f ;
M: #r> node-uses-values in-r>> ; M: #r> node-uses-values in-r>> ;
M: #phi node-uses-values M: #phi node-uses-values
[ phi-in-d>> ] [ phi-in-r>> ] bi append concat sift prune ; [ phi-in-d>> ] [ phi-in-r>> ] bi
append concat remove-bottom prune ;
M: #declare node-uses-values declaration>> keys ; M: #declare node-uses-values declaration>> keys ;
M: node node-uses-values in-d>> ; M: node node-uses-values in-d>> ;
@ -57,14 +61,6 @@ M: node node-defs-values out-d>> ;
[ dup node-uses-values [ use-value ] with each ] [ dup node-uses-values [ use-value ] with each ]
[ dup node-defs-values [ def-value ] with each ] bi ; [ dup node-defs-values [ def-value ] with each ] bi ;
: check-use ( uses -- )
[ empty? [ "No use" throw ] when ]
[ all-unique? [ "Uses not all unique" throw ] unless ] bi ;
: check-def-use ( -- )
def-use get [ nip uses>> check-use ] assoc-each ;
: compute-def-use ( node -- node ) : compute-def-use ( node -- node )
H{ } clone def-use set H{ } clone def-use set
dup [ node-def-use ] each-node dup [ node-def-use ] each-node ;
check-def-use ;

View File

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

View File

@ -9,21 +9,13 @@ IN: compiler.tree.escape-analysis.allocations
! may potentially become an allocation later ! may potentially become an allocation later
! - a sequence of values -- potentially unboxed tuple allocations ! - a sequence of values -- potentially unboxed tuple allocations
! - t -- not allocated in this procedure, can never be unboxed ! - t -- not allocated in this procedure, can never be unboxed
SYMBOL: allocations SYMBOL: allocations
TUPLE: slot-access slot# value ;
C: <slot-access> slot-access
: (allocation) ( value -- value' allocations ) : (allocation) ( value -- value' allocations )
allocations get ; inline allocations get ; inline
: allocation ( value -- allocation ) : allocation ( value -- allocation )
(allocation) at dup slot-access? [ (allocation) at ;
[ slot#>> ] [ value>> allocation ] bi nth
allocation
] when ;
: record-allocation ( allocation value -- ) : record-allocation ( allocation value -- )
(allocation) set-at ; (allocation) set-at ;
@ -31,6 +23,17 @@ C: <slot-access> slot-access
: record-allocations ( allocations values -- ) : record-allocations ( allocations values -- )
[ record-allocation ] 2each ; [ record-allocation ] 2each ;
! We track slot access to connect constructor inputs with
! accessor outputs.
SYMBOL: slot-accesses
TUPLE: slot-access slot# value ;
C: <slot-access> slot-access
: record-slot-access ( out slot# in -- )
<slot-access> swap slot-accesses get set-at ;
! We track escaping values with a disjoint set. ! We track escaping values with a disjoint set.
SYMBOL: escaping-values SYMBOL: escaping-values
@ -43,18 +46,15 @@ SYMBOL: +escaping+
<escaping-values> escaping-values set ; <escaping-values> escaping-values set ;
: introduce-value ( values -- ) : introduce-value ( values -- )
escaping-values get add-atom ; escaping-values get
2dup disjoint-set-member?
[ 2drop ] [ add-atom ] if ;
: introduce-values ( values -- ) : introduce-values ( values -- )
escaping-values get add-atoms ; [ introduce-value ] each ;
: <slot-value> ( -- value ) : <slot-value> ( -- value )
<value> dup escaping-values get add-atom ; <value> dup introduce-value ;
: record-slot-access ( out slot# in -- )
over zero? [ 3drop ] [
<slot-access> swap record-allocation
] if ;
: merge-values ( in-values out-value -- ) : merge-values ( in-values out-value -- )
escaping-values get '[ , , equate ] each ; escaping-values get '[ , , equate ] each ;
@ -66,11 +66,17 @@ SYMBOL: +escaping+
escaping-values get equate ; escaping-values get equate ;
: add-escaping-value ( value -- ) : add-escaping-value ( value -- )
+escaping+ equate-values ; [
allocation {
{ [ dup not ] [ drop ] }
{ [ dup t eq? ] [ drop ] }
[ [ add-escaping-value ] each ]
} cond
]
[ +escaping+ equate-values ] bi ;
: add-escaping-values ( values -- ) : add-escaping-values ( values -- )
escaping-values get [ add-escaping-value ] each ;
'[ +escaping+ , equate ] each ;
: unknown-allocation ( value -- ) : unknown-allocation ( value -- )
[ add-escaping-value ] [ add-escaping-value ]
@ -97,6 +103,14 @@ DEFER: copy-value
[ [ allocation copy-allocation ] dip record-allocation ] [ [ allocation copy-allocation ] dip record-allocation ]
2bi ; 2bi ;
: copy-slot-value ( out slot# in -- )
allocation {
{ [ dup not ] [ 3drop ] }
{ [ dup t eq? ] [ 3drop ] }
[ nth swap copy-value ]
} cond ;
! Compute which tuples escape
SYMBOL: escaping-allocations SYMBOL: escaping-allocations
: compute-escaping-allocations ( -- ) : compute-escaping-allocations ( -- )
@ -111,6 +125,5 @@ SYMBOL: escaping-allocations
dup escaping-allocation? [ drop f ] [ allocation ] if ; dup escaping-allocation? [ drop f ] [ allocation ] if ;
: unboxed-slot-access? ( value -- ? ) : unboxed-slot-access? ( value -- ? )
(allocation) at dup slot-access? slot-accesses get at*
[ value>> unboxed-allocation >boolean ] [ drop f ] if ; [ value>> unboxed-allocation >boolean ] when ;

View File

@ -9,7 +9,9 @@ compiler.tree.escape-analysis.allocations ;
IN: compiler.tree.escape-analysis.branches IN: compiler.tree.escape-analysis.branches
M: #branch escape-analysis* M: #branch escape-analysis*
live-children sift [ (escape-analysis) ] each ; [ in-d>> add-escaping-values ]
[ live-children sift [ (escape-analysis) ] each ]
bi ;
: (merge-allocations) ( values -- allocation ) : (merge-allocations) ( values -- allocation )
[ [
@ -25,7 +27,7 @@ M: #branch escape-analysis*
] map ; ] map ;
: merge-allocations ( in-values out-values -- ) : merge-allocations ( in-values out-values -- )
[ [ sift ] map ] dip [ [ remove-bottom ] map ] dip
[ [ merge-values ] 2each ] [ [ merge-values ] 2each ]
[ [ (merge-allocations) ] dip record-allocations ] [ [ (merge-allocations) ] dip record-allocations ]
2bi ; 2bi ;

View File

@ -5,7 +5,8 @@ compiler.tree.normalization math.functions
compiler.tree.propagation compiler.tree.cleanup compiler.tree.propagation compiler.tree.cleanup
compiler.tree.combinators compiler.tree sequences math math.private compiler.tree.combinators compiler.tree sequences math math.private
kernel tools.test accessors slots.private quotations.private kernel tools.test accessors slots.private quotations.private
prettyprint classes.tuple.private classes classes.tuple ; prettyprint classes.tuple.private classes classes.tuple
compiler.tree.intrinsics ;
\ escape-analysis must-infer \ escape-analysis must-infer
@ -15,7 +16,7 @@ GENERIC: count-unboxed-allocations* ( m node -- n )
out-d>> first escaping-allocation? [ 1+ ] unless ; out-d>> first escaping-allocation? [ 1+ ] unless ;
M: #call count-unboxed-allocations* M: #call count-unboxed-allocations*
dup word>> { <tuple-boa> <complex> } memq? dup word>> { <immutable-tuple-boa> <complex> } memq?
[ (count-unboxed-allocations) ] [ drop ] if ; [ (count-unboxed-allocations) ] [ drop ] if ;
M: #push count-unboxed-allocations* M: #push count-unboxed-allocations*
@ -217,6 +218,11 @@ C: <ro-box> ro-box
[ 3 ] [ [ <ro-box> tuple-fib ] count-unboxed-allocations ] unit-test [ 3 ] [ [ <ro-box> tuple-fib ] count-unboxed-allocations ] unit-test
: tuple-fib' ( m -- n )
dup 1 <= [ 1- tuple-fib' i>> ] when <ro-box> ; inline recursive
[ 0 ] [ [ tuple-fib' ] count-unboxed-allocations ] unit-test
: bad-tuple-fib-1 ( m -- n ) : bad-tuple-fib-1 ( m -- n )
dup i>> 1 <= [ dup i>> 1 <= [
drop 1 <ro-box> drop 1 <ro-box>
@ -283,3 +289,9 @@ C: <ro-box> ro-box
[ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test [ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
[ 1 ] [ [ <complex> >rect ] count-unboxed-allocations ] unit-test [ 1 ] [ [ <complex> >rect ] count-unboxed-allocations ] unit-test
[ 0 ] [ [ 1 cons boa 2 cons boa ] count-unboxed-allocations ] unit-test
[ 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

View File

@ -16,5 +16,6 @@ IN: compiler.tree.escape-analysis
: escape-analysis ( node -- node ) : escape-analysis ( node -- node )
init-escaping-values init-escaping-values
H{ } clone allocations set H{ } clone allocations set
H{ } clone slot-accesses set
dup (escape-analysis) dup (escape-analysis)
compute-escaping-allocations ; compute-escaping-allocations ;

View File

@ -4,7 +4,7 @@ compiler.tree.escape-analysis.recursive
compiler.tree.escape-analysis.allocations ; compiler.tree.escape-analysis.allocations ;
H{ } clone allocations set H{ } clone allocations set
H{ } clone copies set <escaping-values> escaping-values set
[ ] [ 8 [ introduce-value ] each ] unit-test [ ] [ 8 [ introduce-value ] each ] unit-test

View File

@ -18,9 +18,7 @@ IN: compiler.tree.escape-analysis.recursive
} cond ; } cond ;
: check-fixed-point ( node alloc1 alloc2 -- ) : check-fixed-point ( node alloc1 alloc2 -- )
[ congruent? ] 2all? [ drop ] [ [ congruent? ] 2all? [ drop ] [ label>> f >>fixed-point drop ] if ;
label>> f >>fixed-point drop
] if ;
: node-input-allocations ( node -- allocations ) : node-input-allocations ( node -- allocations )
in-d>> [ allocation ] map ; in-d>> [ allocation ] map ;
@ -29,10 +27,12 @@ IN: compiler.tree.escape-analysis.recursive
out-d>> [ allocation ] map ; out-d>> [ allocation ] map ;
: recursive-stacks ( #enter-recursive -- stacks ) : recursive-stacks ( #enter-recursive -- stacks )
[ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ; [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix
escaping-values get '[ [ , disjoint-set-member? ] all? ] filter
flip ;
: analyze-recursive-phi ( #enter-recursive -- ) : analyze-recursive-phi ( #enter-recursive -- )
[ ] [ recursive-stacks flip ] [ out-d>> ] tri [ ] [ recursive-stacks ] [ out-d>> ] tri
[ [ merge-values ] 2each ] [ [ merge-values ] 2each ]
[ [
[ (merge-allocations) ] dip [ (merge-allocations) ] dip
@ -42,12 +42,18 @@ IN: compiler.tree.escape-analysis.recursive
] 2bi ; ] 2bi ;
M: #recursive escape-analysis* ( #recursive -- ) M: #recursive escape-analysis* ( #recursive -- )
[ { 0 } clone [ USE: math
dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
child>> child>>
[ first out-d>> introduce-values ]
[ first analyze-recursive-phi ] [ first analyze-recursive-phi ]
[ (escape-analysis) ] [ (escape-analysis) ]
bi tri
] until-fixed-point ; ] curry until-fixed-point ;
M: #enter-recursive escape-analysis* ( #enter-recursive -- )
#! Handled by #recursive
drop ;
: return-allocations ( node -- allocations ) : return-allocations ( node -- allocations )
label>> return>> node-input-allocations ; label>> return>> node-input-allocations ;
@ -57,5 +63,8 @@ M: #call-recursive escape-analysis* ( #call-label -- )
[ check-fixed-point ] [ drop swap out-d>> record-allocations ] 3bi ; [ check-fixed-point ] [ drop swap out-d>> record-allocations ] 3bi ;
M: #return-recursive escape-analysis* ( #return-recursive -- ) M: #return-recursive escape-analysis* ( #return-recursive -- )
[ in-d>> ] [ label>> calls>> ] bi [ call-next-method ]
[ out-d>> escaping-values get '[ , equate ] 2each ] with each ; [
[ in-d>> ] [ label>> calls>> ] bi
[ out-d>> escaping-values get '[ , equate ] 2each ] with each
] bi ;

View File

@ -5,6 +5,7 @@ classes.tuple.private arrays math math.private slots.private
combinators dequeues search-dequeues namespaces fry classes combinators dequeues search-dequeues namespaces fry classes
classes.algebra stack-checker.state classes.algebra stack-checker.state
compiler.tree compiler.tree
compiler.tree.intrinsics
compiler.tree.propagation.info compiler.tree.propagation.info
compiler.tree.escape-analysis.nodes compiler.tree.escape-analysis.nodes
compiler.tree.escape-analysis.allocations ; compiler.tree.escape-analysis.allocations ;
@ -23,33 +24,26 @@ DEFER: record-literal-allocation
: make-literal-slots ( seq -- values ) : make-literal-slots ( seq -- values )
[ <slot-value> [ swap record-literal-allocation ] keep ] map ; [ <slot-value> [ swap record-literal-allocation ] keep ] map ;
: record-literal-tuple-allocation ( value object -- ) : object-slots ( object -- slots/f )
tuple-slots rest-slice #! Delegation
make-literal-slots {
swap record-allocation ; { [ dup class immutable-tuple-class? ] [ tuple-slots rest-slice ] }
{ [ dup complex? ] [ [ real-part ] [ imaginary-part ] bi 2array ] }
: record-literal-complex-allocation ( value object -- ) [ drop f ]
[ real-part ] [ imaginary-part ] bi 2array make-literal-slots } cond ;
swap record-allocation ;
: record-literal-allocation ( value object -- ) : record-literal-allocation ( value object -- )
{ object-slots
{ [ dup class immutable-tuple-class? ] [ record-literal-tuple-allocation ] } [ make-literal-slots swap record-allocation ]
{ [ dup complex? ] [ record-literal-complex-allocation ] } [ unknown-allocation ]
[ drop unknown-allocation ] if* ;
} cond ;
M: #push escape-analysis* M: #push escape-analysis*
#! Delegation. #! Delegation.
[ out-d>> first ] [ literal>> ] bi record-literal-allocation ; [ out-d>> first ] [ literal>> ] bi record-literal-allocation ;
: record-tuple-allocation ( #call -- ) : record-tuple-allocation ( #call -- )
#! Delegation. [ in-d>> but-last ] [ out-d>> first ] bi record-allocation ;
dup dup in-d>> peek node-value-info literal>>
class>> immutable-tuple-class? [
[ in-d>> but-last ] [ out-d>> first ] bi
record-allocation
] [ out-d>> unknown-allocations ] if ;
: record-complex-allocation ( #call -- ) : record-complex-allocation ( #call -- )
[ in-d>> ] [ out-d>> first ] bi record-allocation ; [ in-d>> ] [ out-d>> first ] bi record-allocation ;
@ -68,11 +62,13 @@ M: #push escape-analysis*
: record-slot-call ( #call -- ) : record-slot-call ( #call -- )
[ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri
over [ record-slot-access ] [ 2drop unknown-allocation ] if ; over [
[ record-slot-access ] [ copy-slot-value ] 3bi
] [ 2drop unknown-allocation ] if ;
M: #call escape-analysis* M: #call escape-analysis*
dup word>> { dup word>> {
{ \ <tuple-boa> [ record-tuple-allocation ] } { \ <immutable-tuple-boa> [ record-tuple-allocation ] }
{ \ <complex> [ record-complex-allocation ] } { \ <complex> [ record-complex-allocation ] }
{ \ slot [ record-slot-call ] } { \ slot [ record-slot-call ] }
[ [

View File

@ -0,0 +1,26 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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 ;
\ (tuple) { tuple-layout } { tuple } define-primitive
\ (tuple) make-flushable
: (array) ( n -- array )
"BUG: missing (array) intrinsic" throw ;
\ (array) { integer } { array } define-primitive
\ (array) make-flushable
: (byte-array) ( n -- byte-array )
"BUG: missing (byte-array) intrinsic" throw ;
\ (byte-array) { integer } { byte-array } define-primitive
\ (byte-array) make-flushable

View File

@ -0,0 +1,150 @@
IN: compiler.tree.loop.detection.tests
USING: compiler.tree.loop.detection tools.test
kernel combinators.short-circuit math sequences accessors
compiler.tree
compiler.tree.builder
compiler.tree.combinators ;
[ { f f f f } ] [ f { f t f f } (tail-calls) ] unit-test
[ { f f f t } ] [ t { f t f f } (tail-calls) ] unit-test
[ { f t t t } ] [ t { f f t t } (tail-calls) ] unit-test
[ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test
\ detect-loops must-infer
: label-is-loop? ( nodes word -- ? )
[
{
[ drop #recursive? ]
[ drop label>> loop?>> ]
[ swap label>> word>> eq? ]
} 2&&
] curry contains-node? ;
\ label-is-loop? must-infer
: label-is-not-loop? ( nodes word -- ? )
[
{
[ drop #recursive? ]
[ drop label>> loop?>> not ]
[ swap label>> word>> eq? ]
} 2&&
] curry contains-node? ;
\ label-is-not-loop? must-infer
: loop-test-1 ( a -- )
dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive
[ t ] [
[ loop-test-1 ] build-tree detect-loops
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
[ loop-test-1 1 2 3 ] build-tree detect-loops
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
[ [ loop-test-1 ] each ] build-tree detect-loops
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
[ [ loop-test-1 ] each ] build-tree detect-loops
\ (each-integer) label-is-loop?
] unit-test
: loop-test-2 ( a -- )
dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
[ t ] [
[ loop-test-2 ] build-tree detect-loops
\ loop-test-2 label-is-not-loop?
] unit-test
: loop-test-3 ( a -- )
dup [ [ loop-test-3 ] each ] [ drop ] if ; inline recursive
[ t ] [
[ loop-test-3 ] build-tree detect-loops
\ loop-test-3 label-is-not-loop?
] unit-test
: loop-test-4 ( a -- )
dup [
loop-test-4
] [
drop
] if ; inline recursive
[ f ] [
[ [ [ ] map ] map ] build-tree detect-loops
[
dup #recursive? [ label>> loop?>> not ] [ drop f ] if
] contains-node?
] unit-test
: blah f ;
DEFER: a
: b ( -- )
blah [ b ] [ a ] if ; inline recursive
: a ( -- )
blah [ b ] [ a ] if ; inline recursive
[ t ] [
[ a ] build-tree detect-loops
\ a label-is-loop?
] unit-test
[ t ] [
[ a ] build-tree detect-loops
\ b label-is-loop?
] unit-test
[ t ] [
[ b ] build-tree detect-loops
\ a label-is-loop?
] unit-test
[ t ] [
[ a ] build-tree detect-loops
\ b label-is-loop?
] unit-test
DEFER: a'
: b' ( -- )
blah [ b' b' ] [ a' ] if ; inline recursive
: a' ( -- )
blah [ b' ] [ a' ] if ; inline recursive
[ f ] [
[ a' ] build-tree detect-loops
\ a' label-is-loop?
] unit-test
[ f ] [
[ b' ] build-tree detect-loops
\ b' label-is-loop?
] unit-test
! I used to think this should be f, but doing this on pen and
! paper almost convinced me that a loop conversion here is
! sound.
[ t ] [
[ b' ] build-tree detect-loops
\ a' label-is-loop?
] unit-test
[ f ] [
[ a' ] build-tree detect-loops
\ b' label-is-loop?
] unit-test

View File

@ -1,5 +1,88 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.loop-detection USING: kernel sequences namespaces assocs accessors fry
compiler.tree dequeues search-dequeues ;
IN: compiler.tree.loop.detection
: detect-loops ( nodes -- nodes' ) ; ! A loop is a #recursive which only tail calls itself, and those
! calls are nested inside other loops only. We optimistically
! assume all #recursive nodes are loops, disqualifying them as
! we see evidence to the contrary.
: (tail-calls) ( tail? seq -- seq' )
reverse [ swap [ and ] keep ] map nip reverse ;
: tail-calls ( tail? node -- seq )
[
[ #phi? ]
[ #return? ]
[ #return-recursive? ]
tri or or
] map (tail-calls) ;
SYMBOL: loop-heights
SYMBOL: loop-calls
SYMBOL: loop-stack
SYMBOL: work-list
GENERIC: collect-loop-info* ( tail? node -- )
: non-tail-label-info ( nodes -- )
[ f swap collect-loop-info* ] each ;
: (collect-loop-info) ( tail? nodes -- )
[ tail-calls ] keep [ collect-loop-info* ] 2each ;
: remember-loop-info ( label -- )
loop-stack get length swap loop-heights get set-at ;
M: #recursive collect-loop-info*
nip
[
[
label>>
[ loop-stack [ swap suffix ] change ]
[ remember-loop-info ]
[ t >>loop? drop ]
tri
]
[ t swap child>> (collect-loop-info) ] bi
] with-scope ;
: current-loop-nesting ( label -- labels )
loop-stack get swap loop-heights get at tail ;
: disqualify-loop ( label -- )
work-list get push-front ;
M: #call-recursive collect-loop-info*
label>>
swap [ dup disqualify-loop ] unless
dup current-loop-nesting [ loop-calls get push-at ] with each ;
M: #if collect-loop-info*
children>> [ (collect-loop-info) ] with each ;
M: #dispatch collect-loop-info*
children>> [ (collect-loop-info) ] with each ;
M: node collect-loop-info* 2drop ;
: collect-loop-info ( node -- )
{ } loop-stack set
H{ } clone loop-calls set
H{ } clone loop-heights set
<hashed-dlist> work-list set
t swap (collect-loop-info) ;
: disqualify-loops ( -- )
work-list get [
dup loop?>> [
[ f >>loop? drop ]
[ loop-calls get at [ disqualify-loop ] each ]
bi
] [ drop ] if
] slurp-dequeue ;
: detect-loops ( nodes -- nodes )
dup collect-loop-info disqualify-loops ;

View File

@ -1,6 +1,6 @@
IN: compiler.tree.normalization.tests IN: compiler.tree.normalization.tests
USING: compiler.tree.builder compiler.tree.normalization USING: compiler.tree.builder compiler.tree.normalization
compiler.tree sequences accessors tools.test kernel ; compiler.tree sequences accessors tools.test kernel math ;
\ count-introductions must-infer \ count-introductions must-infer
\ fixup-enter-recursive must-infer \ fixup-enter-recursive must-infer
@ -25,3 +25,5 @@ compiler.tree sequences accessors tools.test kernel ;
[ recursive-inputs ] [ recursive-inputs ]
[ normalize recursive-inputs ] bi [ normalize recursive-inputs ] bi
] unit-test ] unit-test
[ ] [ [ [ 1 ] [ 2 ] if + * ] build-tree normalize drop ] unit-test

View File

@ -1,7 +1,10 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: fry namespaces sequences math accessors kernel arrays USING: fry namespaces sequences math accessors kernel arrays
stack-checker.backend stack-checker.inlining compiler.tree stack-checker.backend
stack-checker.branches
stack-checker.inlining
compiler.tree
compiler.tree.combinators ; compiler.tree.combinators ;
IN: compiler.tree.normalization IN: compiler.tree.normalization
@ -97,7 +100,12 @@ M: #branch eliminate-introductions*
bi ; bi ;
: eliminate-phi-introductions ( introductions seq terminated -- seq' ) : eliminate-phi-introductions ( introductions seq terminated -- seq' )
[ flip ] dip [ [ nip ] [ over length tail append ] if ] 3map flip ; [ flip ] dip [
[ nip ] [
dup [ +bottom+ eq? ] left-trim
[ [ length ] bi@ - tail* ] keep append
] if
] 3map flip ;
M: #phi eliminate-introductions* M: #phi eliminate-introductions*
remaining-introductions get swap dup terminated>> remaining-introductions get swap dup terminated>>

View File

@ -8,7 +8,7 @@ compiler.tree.tuple-unboxing
compiler.tree.def-use compiler.tree.def-use
compiler.tree.dead-code compiler.tree.dead-code
compiler.tree.strength-reduction compiler.tree.strength-reduction
compiler.tree.loop-detection compiler.tree.loop.detection
compiler.tree.branch-fusion ; compiler.tree.branch-fusion ;
IN: compiler.tree.optimizer IN: compiler.tree.optimizer
@ -16,11 +16,11 @@ IN: compiler.tree.optimizer
normalize normalize
propagate propagate
cleanup cleanup
detect-loops
invert-loops
fuse-branches
escape-analysis escape-analysis
unbox-tuples unbox-tuples
compute-def-use compute-def-use
remove-dead-code remove-dead-code
strength-reduce strength-reduce ;
detect-loops
fuse-branches
elaborate ;

View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: fry kernel sequences assocs accessors namespaces USING: fry kernel sequences assocs accessors namespaces
math.intervals arrays classes.algebra combinators math.intervals arrays classes.algebra combinators
stack-checker.branches
compiler.tree compiler.tree
compiler.tree.def-use compiler.tree.def-use
compiler.tree.combinators compiler.tree.combinators
@ -59,7 +60,14 @@ SYMBOL: infer-children-data
: compute-phi-input-infos ( phi-in -- phi-info ) : compute-phi-input-infos ( phi-in -- phi-info )
infer-children-data get infer-children-data get
'[ , [ [ [ value-info ] [ null-info ] if* ] bind ] 2map ] map ; '[
, [
[
dup +bottom+ eq?
[ drop null-info ] [ value-info ] if
] bind
] 2map
] map ;
: annotate-phi-inputs ( #phi -- ) : annotate-phi-inputs ( #phi -- )
dup phi-in-d>> compute-phi-input-infos >>phi-info-d dup phi-in-d>> compute-phi-input-infos >>phi-info-d
@ -139,10 +147,10 @@ M: #phi propagate-before ( #phi -- )
M: #phi propagate-after ( #phi -- ) M: #phi propagate-after ( #phi -- )
condition-value get [ condition-value get [
[ out-d>> ] [ phi-in-d>> ] [ phi-info-d>> ] tri [ out-d>> ] [ phi-in-d>> ] [ phi-info-d>> ] tri
3array flip [ [
first3 [ possible-boolean-values ] map [ possible-boolean-values ] map
branch-phi-constraints branch-phi-constraints
] each ] 3each
] [ drop ] if ; ] [ drop ] if ;
M: #phi propagate-around ( #phi -- ) M: #phi propagate-around ( #phi -- )

View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences assocs math kernel accessors fry USING: namespaces sequences assocs math kernel accessors fry
combinators sets locals combinators sets locals
stack-checker.branches
compiler.tree compiler.tree
compiler.tree.def-use compiler.tree.def-use
compiler.tree.combinators ; compiler.tree.combinators ;
@ -42,7 +43,7 @@ M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ;
#! An output is a copy of every input if all inputs are #! An output is a copy of every input if all inputs are
#! copies of the same original value. #! copies of the same original value.
[ [
swap sift [ resolve-copy ] map swap remove-bottom [ resolve-copy ] map
dup [ all-equal? ] [ empty? not ] bi and dup [ all-equal? ] [ empty? not ] bi and
[ first swap is-copy-of ] [ 2drop ] if [ first swap is-copy-of ] [ 2drop ] if
] 2each ; ] 2each ;

View File

@ -18,10 +18,7 @@ M: word splicing-nodes
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ; [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
M: quotation splicing-nodes M: quotation splicing-nodes
[ [ out-d>> ] [ in-d>> ] bi ] dip build-sub-tree normalize ;
build-tree-with
rot #copy suffix
normalize ;
: propagate-body ( #call -- ) : propagate-body ( #call -- )
body>> (propagate) ; body>> (propagate) ;

View File

@ -39,7 +39,7 @@ IN: compiler.tree.propagation.recursive
: unify-recursive-stacks ( stacks initial -- infos ) : unify-recursive-stacks ( stacks initial -- infos )
over empty? [ nip ] [ over empty? [ nip ] [
[ [
[ sift value-infos-union ] dip [ value-infos-union ] dip
[ generalize-counter ] keep [ generalize-counter ] keep
value-info-union value-info-union
] 2map ] 2map

View File

@ -0,0 +1,39 @@
IN: compiler.tree.tuple-unboxing.tests
USING: tools.test compiler.tree.tuple-unboxing compiler.tree
compiler.tree.builder compiler.tree.normalization
compiler.tree.propagation compiler.tree.cleanup
compiler.tree.escape-analysis compiler.tree.tuple-unboxing
compiler.tree.checker compiler.tree.def-use kernel accessors
sequences math math.private sorting math.order binary-search
sequences.private slots.private ;
\ unbox-tuples must-infer
: test-unboxing ( quot -- )
build-tree
normalize
propagate
cleanup
escape-analysis
unbox-tuples
check-nodes ;
TUPLE: cons { car read-only } { cdr read-only } ;
TUPLE: empty-tuple ;
{
[ 1 2 cons boa [ car>> ] [ cdr>> ] bi ]
[ empty-tuple boa drop ]
[ cons boa [ car>> ] [ cdr>> ] bi ]
[ [ 1 cons boa ] [ 2 cons boa ] if car>> ]
[ dup cons boa 10 [ nip dup cons boa ] each-integer car>> ]
[ 2 cons boa { [ ] [ ] } dispatch ]
[ dup [ drop f ] [ "A" throw ] if ]
[ [ ] [ ] curry curry dup 3 slot swap 4 slot dup 3 slot swap 4 slot drop ]
[ [ ] [ ] curry curry call ]
[ <complex> <complex> dup 1 slot drop 2 slot drop ]
[ 1 cons boa over [ "A" throw ] when car>> ]
[ [ <=> ] sort ]
[ [ <=> ] with search ]
} [ [ ] swap [ test-unboxing ] curry unit-test ] each

View File

@ -1,56 +1,42 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs accessors kernel combinators
classes.algebra sequences sequences.deep slots.private
classes.tuple.private math math.private arrays
stack-checker.branches
compiler.tree
compiler.tree.intrinsics
compiler.tree.combinators
compiler.tree.escape-analysis.simple
compiler.tree.escape-analysis.allocations ;
IN: compiler.tree.tuple-unboxing IN: compiler.tree.tuple-unboxing
! This pass must run after escape analysis ! This pass must run after escape analysis
! Mapping from values to sequences of values GENERIC: unbox-tuples* ( node -- node/nodes )
SYMBOL: unboxed-tuples
: unboxed-tuple ( value -- unboxed-tuple ) : unbox-output? ( node -- values )
unboxed-tuples get at ;
GENERIC: unbox-tuples* ( node -- )
: value-info-slots ( info -- slots )
#! Delegation.
[ info>> ] [ class>> ] bi {
{ [ dup tuple class<= ] [ drop 2 tail ] }
{ [ dup complex class<= ] [ drop ] }
} cond ;
: prepare-unboxed-values ( #push -- values )
out-d>> first unboxed-allocation ; out-d>> first unboxed-allocation ;
: prepare-unboxed-info ( #push -- infos values ) : (expand-#push) ( object value -- nodes )
dup prepare-unboxed-values dup dup unboxed-allocation dup [
[ [ node-output-infos first value-info-slots ] dip ] [ object-slots ] [ drop ] [ ] tri*
[ 2drop f f ] [ (expand-#push) ] 2map
if ; ] [
drop #push
] if ;
: expand-#push ( #push infos values -- ) : expand-#push ( #push -- nodes )
[ [ literal>> ] dip #push ] 2map >>body drop ; [ literal>> ] [ out-d>> first ] bi (expand-#push) ;
M: #push unbox-tuples* ( #push -- ) M: #push unbox-tuples* ( #push -- nodes )
dup prepare-unboxed-info dup [ expand-#push ] [ 3drop ] if ; dup unbox-output? [ expand-#push ] when ;
: expand-<tuple-boa> ( #call values -- quot ) : unbox-<tuple-boa> ( #call -- nodes )
[ drop in-d>> peek #drop ] dup unbox-output? [ in-d>> 1 tail* #drop ] when ;
[ [ in-d>> but-last ] dip #copy ]
2bi 2array ;
: expand-<complex> ( #call values -- quot ) : unbox-<complex> ( #call -- nodes )
[ in-d>> ] dip #copy 1array ; dup unbox-output? [ drop { } ] when ;
: expand-constructor ( #call values -- )
[ drop ] [ ] [ drop word>> ] 2tri {
{ <tuple-boa> [ expand-<tuple-boa> ] }
{ <complex> [ expand-<complex> ] }
} case unbox-tuples >>body ;
: unbox-constructor ( #call -- )
dup prepare-unboxed-values dup
[ expand-constructor ] [ 2drop ] if ;
: (flatten-values) ( values -- values' ) : (flatten-values) ( values -- values' )
[ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ; [ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ;
@ -58,52 +44,88 @@ M: #push unbox-tuples* ( #push -- )
: flatten-values ( values -- values' ) : flatten-values ( values -- values' )
(flatten-values) flatten ; (flatten-values) flatten ;
: flatten-value ( values -- values ) : prepare-slot-access ( #call -- tuple-values outputs slot-values )
1array flatten-values ; [ in-d>> flatten-values ]
: prepare-slot-access ( #call -- tuple-values slot-values outputs )
[ in-d>> first flatten-value ]
[
[ dup in-d>> second node-value-info literal>> ]
[ out-d>> first unboxed-allocation ]
bi nth flatten-value
]
[ out-d>> flatten-values ] [ out-d>> flatten-values ]
tri ; [
out-d>> first slot-accesses get at
[ slot#>> ] [ value>> ] bi allocation nth
1array flatten-values
] tri ;
: slot-access-shuffle ( tuple-values slot-values outputs -- #shuffle ) : slot-access-shuffle ( tuple-values outputs slot-values -- #shuffle )
[ nip ] [ zip ] 2bi #shuffle ; [ drop ] [ zip ] 2bi #shuffle ;
: unbox-slot-access ( #call -- ) : unbox-slot-access ( #call -- nodes )
dup unboxed-slot-access? [ dup out-d>> first unboxed-slot-access? [
dup
[ in-d>> second 1array #drop ] [ in-d>> second 1array #drop ]
[ prepare-slot-access slot-access-shuffle ] [ prepare-slot-access slot-access-shuffle ]
bi 2array unbox-tuples >>body bi 2array
] when drop ; ] when ;
M: #call unbox-tuples* ( #call -- ) M: #call unbox-tuples*
dup word>> { dup word>> {
{ \ <tuple-boa> [ unbox-<tuple-boa> ] } { \ <immutable-tuple-boa> [ unbox-<tuple-boa> ] }
{ \ <complex> [ unbox-<complex> ] } { \ <complex> [ unbox-<complex> ] }
{ \ slot [ unbox-slot-access ] } { \ slot [ unbox-slot-access ] }
[ 2drop ] [ drop ]
} case ; } case ;
M: #copy ... ; M: #declare unbox-tuples*
#! We don't look at declarations after propagation anyway.
f >>declaration ;
M: #>r ... ; M: #copy unbox-tuples*
[ flatten-values ] change-in-d
[ flatten-values ] change-out-d ;
M: #r> ... ; M: #>r unbox-tuples*
[ flatten-values ] change-in-d
[ flatten-values ] change-out-r ;
M: #shuffle ... ; M: #r> unbox-tuples*
[ flatten-values ] change-in-r
[ flatten-values ] change-out-d ;
M: #terrible ... ; M: #shuffle unbox-tuples*
[ flatten-values ] change-in-d
[ flatten-values ] change-out-d
[ unzip [ flatten-values ] bi@ zip ] change-mapping ;
M: #terminate unbox-tuples*
[ flatten-values ] change-in-d ;
M: #phi unbox-tuples*
[ flip [ flatten-values ] map pad-with-bottom flip ] change-phi-in-d
[ flip [ flatten-values ] map pad-with-bottom flip ] change-phi-in-r
[ flatten-values ] change-out-d
[ flatten-values ] change-out-r ;
M: #recursive unbox-tuples*
[ flatten-values ] change-in-d ;
M: #enter-recursive unbox-tuples*
[ flatten-values ] change-in-d
[ flatten-values ] change-out-d ;
M: #call-recursive unbox-tuples*
[ flatten-values ] change-in-d
[ flatten-values ] change-out-d ;
M: #return-recursive unbox-tuples*
[ flatten-values ] change-in-d
[ flatten-values ] change-out-d ;
! These nodes never participate in unboxing ! These nodes never participate in unboxing
M: #return drop ; : assert-not-unboxed ( values -- )
dup array?
[ [ unboxed-allocation ] contains? ] [ unboxed-allocation ] if
[ "Unboxing wrong value" throw ] when ;
M: #introduce drop ; M: #branch unbox-tuples* dup in-d>> assert-not-unboxed ;
: unbox-tuples ( nodes -- nodes ) M: #return unbox-tuples* dup in-d>> assert-not-unboxed ;
dup [ unbox-tuples* ] each-node ;
M: #introduce unbox-tuples* dup value>> assert-not-unboxed ;
: unbox-tuples ( nodes -- nodes ) [ unbox-tuples* ] map-nodes ;

View File

@ -9,21 +9,30 @@ IN: stack-checker.branches
: balanced? ( pairs -- ? ) : balanced? ( pairs -- ? )
[ second ] filter [ first2 length - ] map all-equal? ; [ second ] filter [ first2 length - ] map all-equal? ;
: unify-inputs ( max-d-in d-in meta-d -- new-meta-d ) SYMBOL: +bottom+
dup [ [ - f <repetition> ] dip append ] [ 3drop f ] if ;
: pad-with-f ( seq -- newseq ) : unify-inputs ( max-d-in d-in meta-d -- new-meta-d )
dup [ length ] map supremum '[ , f pad-left ] map ; dup [ [ - +bottom+ <repetition> ] dip append ] [ 3drop f ] if ;
: pad-with-bottom ( seq -- newseq )
dup empty? [
dup [ length ] map supremum
'[ , +bottom+ pad-left ] map
] unless ;
: phi-inputs ( max-d-in pairs -- newseq ) : phi-inputs ( max-d-in pairs -- newseq )
dup empty? [ nip ] [ dup empty? [ nip ] [
swap '[ , _ first2 unify-inputs ] map swap '[ , _ first2 unify-inputs ] map
pad-with-f pad-with-bottom
flip flip
] if ; ] if ;
: remove-bottom ( seq -- seq' )
+bottom+ swap remove ;
: unify-values ( values -- phi-out ) : unify-values ( values -- phi-out )
sift dup empty? [ drop <value> ] [ remove-bottom
dup empty? [ drop <value> ] [
[ known ] map dup all-eq? [ known ] map dup all-eq?
[ first make-known ] [ drop <value> ] if [ first make-known ] [ drop <value> ] if
] if ; ] if ;

View File

@ -17,15 +17,21 @@ IN: stack-checker.inlining
: (inline-word) ( word label -- ) : (inline-word) ( word label -- )
[ [ def>> ] keep ] dip infer-quot-recursive ; [ [ def>> ] keep ] dip infer-quot-recursive ;
TUPLE: inline-recursive TUPLE: inline-recursive < identity-tuple
id
word word
enter-out enter-recursive enter-out enter-recursive
return calls return calls
fixed-point fixed-point
introductions ; introductions
loop? ;
M: inline-recursive hashcode* id>> hashcode* ;
: <inline-recursive> ( word -- label ) : <inline-recursive> ( word -- label )
inline-recursive new swap >>word ; inline-recursive new
gensym >>id
swap >>word ;
: quotation-param? ( obj -- ? ) : quotation-param? ( obj -- ? )
dup pair? [ second effect? ] [ drop f ] if ; dup pair? [ second effect? ] [ drop f ] if ;

View File

@ -165,24 +165,27 @@ M: object infer-call*
{ call execute dispatch load-locals get-local drop-locals } { call execute dispatch load-locals get-local drop-locals }
[ t "no-compile" set-word-prop ] each [ t "no-compile" set-word-prop ] each
SYMBOL: +primitive+
: non-inline-word ( word -- ) : non-inline-word ( word -- )
dup +called+ depends-on dup +called+ depends-on
{ {
{ [ dup +shuffle+ word-prop ] [ infer-shuffle-word ] } { [ dup +shuffle+ word-prop ] [ infer-shuffle-word ] }
{ [ dup +special+ word-prop ] [ infer-special ] } { [ dup +special+ word-prop ] [ infer-special ] }
{ [ dup primitive? ] [ infer-primitive ] } { [ dup +primitive+ word-prop ] [ infer-primitive ] }
{ [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] } { [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
{ [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
{ [ dup +transform-quot+ word-prop ] [ apply-transform ] } { [ dup +transform-quot+ word-prop ] [ apply-transform ] }
{ [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
{ [ dup "macro" word-prop ] [ apply-macro ] } { [ dup "macro" word-prop ] [ apply-macro ] }
{ [ dup recursive-label ] [ call-recursive-word ] } { [ dup recursive-label ] [ call-recursive-word ] }
[ dup infer-word apply-word/effect ] [ dup infer-word apply-word/effect ]
} cond ; } cond ;
: define-primitive ( word inputs outputs -- ) : define-primitive ( word inputs outputs -- )
[ 2drop t +primitive+ set-word-prop ]
[ drop "input-classes" set-word-prop ] [ drop "input-classes" set-word-prop ]
[ nip "default-output-classes" set-word-prop ] [ nip "default-output-classes" set-word-prop ]
3bi ; 3tri ;
! Stack effects for all primitives ! Stack effects for all primitives
\ fixnum< { fixnum fixnum } { object } define-primitive \ fixnum< { fixnum fixnum } { object } define-primitive

View File

@ -11,31 +11,45 @@ IN: stack-checker.transforms
SYMBOL: +transform-quot+ SYMBOL: +transform-quot+
SYMBOL: +transform-n+ SYMBOL: +transform-n+
: (apply-transform) ( quot n -- newquot ) : give-up-transform ( word -- )
dup zero? [ dup recursive-label
drop recursive-state get 1array [ call-recursive-word ]
] [ [ dup infer-word apply-word/effect ]
consume-d if ;
[ #drop, ]
[ [ literal value>> ] map ] : ((apply-transform)) ( word quot stack -- )
[ first literal recursion>> ] tri prefix swap with-datastack first2
] if dup [ swap infer-quot drop ] [ 2drop give-up-transform ] if ;
swap with-datastack ; inline
: (apply-transform) ( word quot n -- )
consume-d dup [ known literal? ] all? [
dup empty? [
drop recursive-state get 1array
] [
[ #drop, ]
[ [ literal value>> ] map ]
[ first literal recursion>> ] tri prefix
] if
((apply-transform))
] [ 2drop give-up-transform ] if ;
: apply-transform ( word -- ) : apply-transform ( word -- )
[ +inlined+ depends-on ] [ [ +inlined+ depends-on ] [
[ ]
[ +transform-quot+ word-prop ] [ +transform-quot+ word-prop ]
[ +transform-n+ word-prop ] [ +transform-n+ word-prop ]
bi (apply-transform) tri
first2 swap infer-quot (apply-transform)
] bi ; ] bi ;
: apply-macro ( word -- ) : apply-macro ( word -- )
[ +inlined+ depends-on ] [ [ +inlined+ depends-on ] [
[ ]
[ "macro" word-prop ] [ "macro" word-prop ]
[ "declared-effect" word-prop in>> length ] [ "declared-effect" word-prop in>> length ]
bi (apply-transform) tri
first2 swap infer-quot (apply-transform)
] bi ; ] bi ;
: define-transform ( word quot n -- ) : define-transform ( word quot n -- )
@ -66,20 +80,80 @@ SYMBOL: +transform-n+
\ spread [ spread>quot ] 1 define-transform \ spread [ spread>quot ] 1 define-transform
\ (call-next-method) [
[ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
] 2 define-transform
! Constructors
\ boa [ \ boa [
dup tuple-class? [ dup tuple-class? [
dup +inlined+ depends-on dup +inlined+ depends-on
[ "boa-check" word-prop ] [ "boa-check" word-prop ]
[ tuple-layout '[ , <tuple-boa> ] ] [ tuple-layout '[ , <tuple-boa> ] ]
bi append bi append
] [ ] [ drop f ] if
\ boa \ no-method boa time-bomb
] if
] 1 define-transform ] 1 define-transform
\ (call-next-method) [ \ new [
[ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi dup tuple-class? [
] 2 define-transform dup +inlined+ depends-on
dup all-slots rest-slice ! delegate slot
[ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make
] [ drop f ] if
] 1 define-transform
! Membership testing
: bit-member-n 256 ; inline
: bit-member? ( seq -- ? )
#! Can we use a fast byte array test here?
{
{ [ dup length 8 < ] [ f ] }
{ [ dup [ integer? not ] contains? ] [ f ] }
{ [ dup [ 0 < ] contains? ] [ f ] }
{ [ dup [ bit-member-n >= ] contains? ] [ f ] }
[ t ]
} cond nip ;
: bit-member-seq ( seq -- flags )
bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ;
: exact-float? ( f -- ? )
dup float? [ dup >integer >float = ] [ drop f ] if ; inline
: bit-member-quot ( seq -- newquot )
[
[ drop ] % ! drop the sequence itself; we don't use it at run time
bit-member-seq ,
[
{
{ [ over fixnum? ] [ ?nth 1 eq? ] }
{ [ over bignum? ] [ ?nth 1 eq? ] }
{ [ over exact-float? ] [ ?nth 1 eq? ] }
[ 2drop f ]
} cond
] %
] [ ] make ;
: member-quot ( seq -- newquot )
dup bit-member? [
bit-member-quot
] [
[ literalize [ t ] ] { } map>assoc
[ drop f ] suffix [ nip case ] curry
] if ;
\ member? [
dup sequence? [ member-quot ] [ drop f ] if
] 1 define-transform
: memq-quot ( seq -- newquot )
[ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
[ drop f ] suffix [ nip cond ] curry ;
\ memq? [
dup sequence? [ memq-quot ] [ drop f ] if
] 1 define-transform
! Deprecated ! Deprecated
\ get-slots [ [ 1quotation ] map [ cleave ] curry ] 1 define-transform \ get-slots [ [ 1quotation ] map [ cleave ] curry ] 1 define-transform