Tuple unboxing progress

db4
Slava Pestov 2008-08-08 13:14:36 -05:00
parent f9900202c8
commit 2d07fd6826
13 changed files with 248 additions and 162 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

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

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

@ -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

@ -217,6 +217,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 +288,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

@ -29,10 +29,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
@ -44,11 +46,16 @@ IN: compiler.tree.escape-analysis.recursive
M: #recursive escape-analysis* ( #recursive -- ) M: #recursive escape-analysis* ( #recursive -- )
[ [
child>> child>>
[ first out-d>> introduce-values ]
[ first analyze-recursive-phi ] [ first analyze-recursive-phi ]
[ (escape-analysis) ] [ (escape-analysis) ]
bi tri
] until-fixed-point ; ] 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 +64,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 -- )
[ call-next-method ]
[
[ in-d>> ] [ label>> calls>> ] bi [ in-d>> ] [ label>> calls>> ] bi
[ out-d>> escaping-values get '[ , equate ] 2each ] with each ; [ 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,24 @@ 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
{ [ dup class immutable-tuple-class? ] [ record-literal-tuple-allocation ] } [ make-literal-slots swap record-allocation ] [ 2drop ] if ;
{ [ dup complex? ] [ record-literal-complex-allocation ] }
[ drop unknown-allocation ]
} 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 +60,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,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel ;
IN: compiler.tree.intrinsics
: <immutable-tuple-boa> ( ... class -- tuple ) "Intrinsic" throw ;

View File

@ -0,0 +1,31 @@
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.def-use kernel accessors sequences math ;
\ unbox-tuples must-infer
: test-unboxing ( quot -- )
#! Just make sure it doesn't throw errors; compute def use
#! for kicks.
build-tree
normalize
propagate
cleanup
escape-analysis
unbox-tuples
compute-def-use
drop ;
TUPLE: cons { car read-only } { cdr read-only } ;
TUPLE: empty-tuple ;
{
[ 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>> ]
} [ [ ] swap [ test-unboxing ] curry unit-test ] each

View File

@ -1,56 +1,41 @@
! 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
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 ;
@ -59,51 +44,57 @@ M: #push unbox-tuples* ( #push -- )
(flatten-values) flatten ; (flatten-values) flatten ;
: flatten-value ( values -- values ) : flatten-value ( values -- values )
1array flatten-values ; [ unboxed-allocation ] [ 1array ] bi or ;
: prepare-slot-access ( #call -- tuple-values slot-values outputs ) : prepare-slot-access ( #call -- tuple-values outputs slot-values )
[ in-d>> first flatten-value ] [ 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 flatten-value
] 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: #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: #r> ... ; M: #r> unbox-tuples*
[ flatten-values ] change-in-r
[ flatten-values ] change-out-d ;
M: #shuffle ... ; M: #shuffle unbox-tuples*
[ flatten-values ] change-in-d
[ flatten-values ] change-out-d
[ unzip [ flatten-values ] bi@ zip ] change-mapping ;
M: #terrible ... ; M: #terminate unbox-tuples*
[ flatten-values ] change-in-d ;
! These nodes never participate in unboxing ! These nodes never participate in unboxing
M: #return drop ; M: #return unbox-tuples* ;
M: #introduce drop ; M: #introduce unbox-tuples* ;
: unbox-tuples ( nodes -- nodes ) : unbox-tuples ( nodes -- nodes ) [ unbox-tuples* ] map-nodes ;
dup [ unbox-tuples* ] each-node ;