Tuple unboxing progress
Slava Pestov
parent
f9900202c8
commit
2d07fd6826
|
|
@ -66,6 +66,10 @@ M: disjoint-set add-atom
|
|||
|
||||
: 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 )
|
||||
|
||||
M: disjoint-set equiv-set-size [ representative ] keep count ;
|
||||
|
|
|
|||
|
|
@ -2,8 +2,9 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences sequences.deep combinators fry
|
||||
classes.algebra namespaces assocs math math.private
|
||||
math.partial-dispatch
|
||||
math.partial-dispatch classes.tuple classes.tuple.private
|
||||
compiler.tree
|
||||
compiler.tree.intrinsics
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.branches ;
|
||||
|
|
@ -53,11 +54,21 @@ GENERIC: cleanup* ( node -- node/nodes )
|
|||
: remove-overflow-check ( #call -- #call )
|
||||
[ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ;
|
||||
|
||||
: immutable-tuple-boa? ( #call -- ? )
|
||||
dup word>> \ <tuple-boa> eq? [
|
||||
dup in-d>> peek node-value-info
|
||||
literal>> class>> immutable-tuple-class?
|
||||
] [ drop f ] if ;
|
||||
|
||||
: immutable-tuple-boa ( #call -- #call )
|
||||
\ <immutable-tuple-boa> >>word ;
|
||||
|
||||
M: #call cleanup*
|
||||
{
|
||||
{ [ dup body>> ] [ cleanup-inlining ] }
|
||||
{ [ dup cleanup-folding? ] [ cleanup-folding ] }
|
||||
{ [ dup remove-overflow-check? ] [ remove-overflow-check ] }
|
||||
{ [ dup immutable-tuple-boa? ] [ immutable-tuple-boa ] }
|
||||
[ ]
|
||||
} cond ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: namespaces assocs sequences compiler.tree.builder
|
||||
compiler.tree.dead-code compiler.tree.def-use compiler.tree
|
||||
compiler.tree.combinators tools.test kernel math
|
||||
stack-checker.state accessors ;
|
||||
stack-checker.state accessors combinators ;
|
||||
IN: compiler.tree.dead-code.tests
|
||||
|
||||
\ remove-dead-code must-infer
|
||||
|
|
@ -10,20 +10,27 @@ IN: compiler.tree.dead-code.tests
|
|||
build-tree
|
||||
compute-def-use
|
||||
remove-dead-code
|
||||
compute-def-use
|
||||
0 swap [ dup #push? [ out-d>> length + ] [ drop ] if ] each-node ;
|
||||
0 swap [
|
||||
{
|
||||
{ [ dup #push? ] [ out-d>> length + ] }
|
||||
{ [ dup #introduce? ] [ drop 1 + ] }
|
||||
[ drop ]
|
||||
} cond
|
||||
] each-node ;
|
||||
|
||||
[ 3 ] [ [ 1 2 3 ] count-live-values ] unit-test
|
||||
|
||||
[ 1 ] [ [ drop ] count-live-values ] unit-test
|
||||
|
||||
[ 0 ] [ [ 1 drop ] count-live-values ] unit-test
|
||||
|
||||
[ 1 ] [ [ 1 2 drop ] count-live-values ] unit-test
|
||||
|
||||
[ 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
|
||||
|
||||
|
|
@ -33,9 +40,9 @@ IN: compiler.tree.dead-code.tests
|
|||
|
||||
[ 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
|
||||
|
||||
|
|
|
|||
|
|
@ -3,15 +3,18 @@
|
|||
USING: fry accessors namespaces assocs dequeues search-dequeues
|
||||
kernel sequences words sets stack-checker.inlining
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.dataflow-analysis
|
||||
compiler.tree.dataflow-analysis.backward
|
||||
compiler.tree.combinators ;
|
||||
compiler.tree.dataflow-analysis.backward ;
|
||||
IN: compiler.tree.dead-code
|
||||
|
||||
! Dead code elimination: remove #push and flushable #call whose
|
||||
! outputs are unused using backward DFA.
|
||||
GENERIC: mark-live-values ( node -- )
|
||||
|
||||
M: #introduce mark-live-values
|
||||
value>> look-at-value ;
|
||||
|
||||
M: #if 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 -- )
|
||||
|
||||
M: #introduce remove-dead-values*
|
||||
[ [ live-value? ] filter ] change-values drop ;
|
||||
|
||||
M: #>r remove-dead-values*
|
||||
dup out-r>> first live-value? [ { } >>out-r ] unless
|
||||
dup in-d>> first live-value? [ { } >>in-d ] unless
|
||||
|
|
@ -57,6 +57,30 @@ M: #push remove-dead-values*
|
|||
: filter-live ( values -- values' )
|
||||
[ 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*
|
||||
[ filter-live ] change-in-d
|
||||
[ filter-live ] change-out-d
|
||||
|
|
@ -92,24 +116,19 @@ M: #phi remove-dead-values*
|
|||
|
||||
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 )
|
||||
empty? [ successor>> ] [ drop t ] if ; inline
|
||||
: prune-if-empty ( node seq -- node/f )
|
||||
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: #call remove-dead-nodes*
|
||||
dup live-call? [ drop t ] [
|
||||
[ in-d>> #drop ] [ successor>> ] bi >>successor
|
||||
] if ;
|
||||
M: #call remove-dead-nodes* dup live-call? [ in-d>> #drop ] unless ;
|
||||
|
||||
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 ;
|
||||
|
||||
: (remove-dead-code) ( node -- newnode )
|
||||
[
|
||||
dup remove-dead-values*
|
||||
dup remove-dead-nodes* dup t eq?
|
||||
[ drop ] [ nip (remove-dead-code) ] if
|
||||
] transform-nodes ;
|
||||
M: node remove-dead-nodes* ;
|
||||
|
||||
M: #if remove-dead-nodes*
|
||||
[ (remove-dead-code) ] map-children t ;
|
||||
|
||||
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-nodes ( nodes -- nodes' )
|
||||
[ remove-dead-nodes* ] map-nodes ;
|
||||
|
||||
: remove-dead-code ( node -- newnode )
|
||||
[ [ compute-live-values ] [ (remove-dead-code) ] bi ] with-scope ;
|
||||
[ compute-live-values ]
|
||||
[ remove-dead-values ]
|
||||
[ remove-dead-nodes ]
|
||||
tri ;
|
||||
|
|
|
|||
|
|
@ -9,21 +9,13 @@ IN: compiler.tree.escape-analysis.allocations
|
|||
! may potentially become an allocation later
|
||||
! - a sequence of values -- potentially unboxed tuple allocations
|
||||
! - t -- not allocated in this procedure, can never be unboxed
|
||||
|
||||
SYMBOL: allocations
|
||||
|
||||
TUPLE: slot-access slot# value ;
|
||||
|
||||
C: <slot-access> slot-access
|
||||
|
||||
: (allocation) ( value -- value' allocations )
|
||||
allocations get ; inline
|
||||
|
||||
: allocation ( value -- allocation )
|
||||
(allocation) at dup slot-access? [
|
||||
[ slot#>> ] [ value>> allocation ] bi nth
|
||||
allocation
|
||||
] when ;
|
||||
(allocation) at ;
|
||||
|
||||
: record-allocation ( allocation value -- )
|
||||
(allocation) set-at ;
|
||||
|
|
@ -31,6 +23,17 @@ C: <slot-access> slot-access
|
|||
: record-allocations ( allocations values -- )
|
||||
[ 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.
|
||||
SYMBOL: escaping-values
|
||||
|
||||
|
|
@ -43,18 +46,15 @@ SYMBOL: +escaping+
|
|||
<escaping-values> escaping-values set ;
|
||||
|
||||
: introduce-value ( values -- )
|
||||
escaping-values get add-atom ;
|
||||
escaping-values get
|
||||
2dup disjoint-set-member?
|
||||
[ 2drop ] [ add-atom ] if ;
|
||||
|
||||
: introduce-values ( values -- )
|
||||
escaping-values get add-atoms ;
|
||||
[ introduce-value ] each ;
|
||||
|
||||
: <slot-value> ( -- value )
|
||||
<value> dup escaping-values get add-atom ;
|
||||
|
||||
: record-slot-access ( out slot# in -- )
|
||||
over zero? [ 3drop ] [
|
||||
<slot-access> swap record-allocation
|
||||
] if ;
|
||||
<value> dup introduce-value ;
|
||||
|
||||
: merge-values ( in-values out-value -- )
|
||||
escaping-values get '[ , , equate ] each ;
|
||||
|
|
@ -66,11 +66,17 @@ SYMBOL: +escaping+
|
|||
escaping-values get equate ;
|
||||
|
||||
: 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 -- )
|
||||
escaping-values get
|
||||
'[ +escaping+ , equate ] each ;
|
||||
[ add-escaping-value ] each ;
|
||||
|
||||
: unknown-allocation ( value -- )
|
||||
[ add-escaping-value ]
|
||||
|
|
@ -97,6 +103,14 @@ DEFER: copy-value
|
|||
[ [ allocation copy-allocation ] dip record-allocation ]
|
||||
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
|
||||
|
||||
: compute-escaping-allocations ( -- )
|
||||
|
|
@ -111,6 +125,5 @@ SYMBOL: escaping-allocations
|
|||
dup escaping-allocation? [ drop f ] [ allocation ] if ;
|
||||
|
||||
: unboxed-slot-access? ( value -- ? )
|
||||
(allocation) at dup slot-access?
|
||||
[ value>> unboxed-allocation >boolean ] [ drop f ] if ;
|
||||
|
||||
slot-accesses get at*
|
||||
[ value>> unboxed-allocation >boolean ] when ;
|
||||
|
|
|
|||
|
|
@ -217,6 +217,11 @@ C: <ro-box> ro-box
|
|||
|
||||
[ 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 )
|
||||
dup i>> 1 <= [
|
||||
drop 1 <ro-box>
|
||||
|
|
@ -283,3 +288,9 @@ C: <ro-box> ro-box
|
|||
[ 0 ] [ [ bad-tuple-fib-3 i>> ] 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
|
||||
|
|
|
|||
|
|
@ -16,5 +16,6 @@ IN: compiler.tree.escape-analysis
|
|||
: escape-analysis ( node -- node )
|
||||
init-escaping-values
|
||||
H{ } clone allocations set
|
||||
H{ } clone slot-accesses set
|
||||
dup (escape-analysis)
|
||||
compute-escaping-allocations ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ compiler.tree.escape-analysis.recursive
|
|||
compiler.tree.escape-analysis.allocations ;
|
||||
|
||||
H{ } clone allocations set
|
||||
H{ } clone copies set
|
||||
<escaping-values> escaping-values set
|
||||
|
||||
[ ] [ 8 [ introduce-value ] each ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -29,10 +29,12 @@ IN: compiler.tree.escape-analysis.recursive
|
|||
out-d>> [ allocation ] map ;
|
||||
|
||||
: 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 -- )
|
||||
[ ] [ recursive-stacks flip ] [ out-d>> ] tri
|
||||
[ ] [ recursive-stacks ] [ out-d>> ] tri
|
||||
[ [ merge-values ] 2each ]
|
||||
[
|
||||
[ (merge-allocations) ] dip
|
||||
|
|
@ -44,11 +46,16 @@ IN: compiler.tree.escape-analysis.recursive
|
|||
M: #recursive escape-analysis* ( #recursive -- )
|
||||
[
|
||||
child>>
|
||||
[ first out-d>> introduce-values ]
|
||||
[ first analyze-recursive-phi ]
|
||||
[ (escape-analysis) ]
|
||||
bi
|
||||
tri
|
||||
] until-fixed-point ;
|
||||
|
||||
M: #enter-recursive escape-analysis* ( #enter-recursive -- )
|
||||
#! Handled by #recursive
|
||||
drop ;
|
||||
|
||||
: return-allocations ( node -- 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 ;
|
||||
|
||||
M: #return-recursive escape-analysis* ( #return-recursive -- )
|
||||
[ in-d>> ] [ label>> calls>> ] bi
|
||||
[ out-d>> escaping-values get '[ , equate ] 2each ] with each ;
|
||||
[ call-next-method ]
|
||||
[
|
||||
[ in-d>> ] [ label>> calls>> ] bi
|
||||
[ out-d>> escaping-values get '[ , equate ] 2each ] with each
|
||||
] bi ;
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@ classes.tuple.private arrays math math.private slots.private
|
|||
combinators dequeues search-dequeues namespaces fry classes
|
||||
classes.algebra stack-checker.state
|
||||
compiler.tree
|
||||
compiler.tree.intrinsics
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.escape-analysis.nodes
|
||||
compiler.tree.escape-analysis.allocations ;
|
||||
|
|
@ -23,33 +24,24 @@ DEFER: record-literal-allocation
|
|||
: make-literal-slots ( seq -- values )
|
||||
[ <slot-value> [ swap record-literal-allocation ] keep ] map ;
|
||||
|
||||
: record-literal-tuple-allocation ( value object -- )
|
||||
tuple-slots rest-slice
|
||||
make-literal-slots
|
||||
swap record-allocation ;
|
||||
|
||||
: record-literal-complex-allocation ( value object -- )
|
||||
[ real-part ] [ imaginary-part ] bi 2array make-literal-slots
|
||||
swap record-allocation ;
|
||||
: object-slots ( object -- slots/f )
|
||||
#! Delegation
|
||||
{
|
||||
{ [ dup class immutable-tuple-class? ] [ tuple-slots rest-slice ] }
|
||||
{ [ dup complex? ] [ [ real-part ] [ imaginary-part ] bi 2array ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
||||
: record-literal-allocation ( value object -- )
|
||||
{
|
||||
{ [ dup class immutable-tuple-class? ] [ record-literal-tuple-allocation ] }
|
||||
{ [ dup complex? ] [ record-literal-complex-allocation ] }
|
||||
[ drop unknown-allocation ]
|
||||
} cond ;
|
||||
object-slots dup
|
||||
[ make-literal-slots swap record-allocation ] [ 2drop ] if ;
|
||||
|
||||
M: #push escape-analysis*
|
||||
#! Delegation.
|
||||
[ out-d>> first ] [ literal>> ] bi record-literal-allocation ;
|
||||
|
||||
: record-tuple-allocation ( #call -- )
|
||||
#! Delegation.
|
||||
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 ;
|
||||
[ in-d>> but-last ] [ out-d>> first ] bi record-allocation ;
|
||||
|
||||
: record-complex-allocation ( #call -- )
|
||||
[ in-d>> ] [ out-d>> first ] bi record-allocation ;
|
||||
|
|
@ -68,11 +60,13 @@ M: #push escape-analysis*
|
|||
|
||||
: record-slot-call ( #call -- )
|
||||
[ 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*
|
||||
dup word>> {
|
||||
{ \ <tuple-boa> [ record-tuple-allocation ] }
|
||||
{ \ <immutable-tuple-boa> [ record-tuple-allocation ] }
|
||||
{ \ <complex> [ record-complex-allocation ] }
|
||||
{ \ slot [ record-slot-call ] }
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
@ -1,56 +1,41 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! 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
|
||||
|
||||
! This pass must run after escape analysis
|
||||
|
||||
! Mapping from values to sequences of values
|
||||
SYMBOL: unboxed-tuples
|
||||
GENERIC: unbox-tuples* ( node -- node/nodes )
|
||||
|
||||
: unboxed-tuple ( value -- unboxed-tuple )
|
||||
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 )
|
||||
: unbox-output? ( node -- values )
|
||||
out-d>> first unboxed-allocation ;
|
||||
|
||||
: prepare-unboxed-info ( #push -- infos values )
|
||||
dup prepare-unboxed-values dup
|
||||
[ [ node-output-infos first value-info-slots ] dip ]
|
||||
[ 2drop f f ]
|
||||
if ;
|
||||
: (expand-#push) ( object value -- nodes )
|
||||
dup unboxed-allocation dup [
|
||||
[ object-slots ] [ drop ] [ ] tri*
|
||||
[ (expand-#push) ] 2map
|
||||
] [
|
||||
drop #push
|
||||
] if ;
|
||||
|
||||
: expand-#push ( #push infos values -- )
|
||||
[ [ literal>> ] dip #push ] 2map >>body drop ;
|
||||
: expand-#push ( #push -- nodes )
|
||||
[ literal>> ] [ out-d>> first ] bi (expand-#push) ;
|
||||
|
||||
M: #push unbox-tuples* ( #push -- )
|
||||
dup prepare-unboxed-info dup [ expand-#push ] [ 3drop ] if ;
|
||||
M: #push unbox-tuples* ( #push -- nodes )
|
||||
dup unbox-output? [ expand-#push ] when ;
|
||||
|
||||
: expand-<tuple-boa> ( #call values -- quot )
|
||||
[ drop in-d>> peek #drop ]
|
||||
[ [ in-d>> but-last ] dip #copy ]
|
||||
2bi 2array ;
|
||||
: unbox-<tuple-boa> ( #call -- nodes )
|
||||
dup unbox-output? [ in-d>> 1 tail* #drop ] when ;
|
||||
|
||||
: expand-<complex> ( #call values -- quot )
|
||||
[ in-d>> ] dip #copy 1array ;
|
||||
|
||||
: 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 ;
|
||||
: unbox-<complex> ( #call -- nodes )
|
||||
dup unbox-output? [ drop { } ] when ;
|
||||
|
||||
: (flatten-values) ( values -- values' )
|
||||
[ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ;
|
||||
|
|
@ -59,51 +44,57 @@ M: #push unbox-tuples* ( #push -- )
|
|||
(flatten-values) flatten ;
|
||||
|
||||
: 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 ]
|
||||
[
|
||||
[ dup in-d>> second node-value-info literal>> ]
|
||||
[ out-d>> first unboxed-allocation ]
|
||||
bi nth flatten-value
|
||||
]
|
||||
[ 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 )
|
||||
[ nip ] [ zip ] 2bi #shuffle ;
|
||||
: slot-access-shuffle ( tuple-values outputs slot-values -- #shuffle )
|
||||
[ drop ] [ zip ] 2bi #shuffle ;
|
||||
|
||||
: unbox-slot-access ( #call -- )
|
||||
dup unboxed-slot-access? [
|
||||
dup
|
||||
: unbox-slot-access ( #call -- nodes )
|
||||
dup out-d>> first unboxed-slot-access? [
|
||||
[ in-d>> second 1array #drop ]
|
||||
[ prepare-slot-access slot-access-shuffle ]
|
||||
bi 2array unbox-tuples >>body
|
||||
] when drop ;
|
||||
bi 2array
|
||||
] when ;
|
||||
|
||||
M: #call unbox-tuples* ( #call -- )
|
||||
M: #call unbox-tuples*
|
||||
dup word>> {
|
||||
{ \ <tuple-boa> [ unbox-<tuple-boa> ] }
|
||||
{ \ <immutable-tuple-boa> [ unbox-<tuple-boa> ] }
|
||||
{ \ <complex> [ unbox-<complex> ] }
|
||||
{ \ slot [ unbox-slot-access ] }
|
||||
[ 2drop ]
|
||||
[ drop ]
|
||||
} 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
|
||||
M: #return drop ;
|
||||
M: #return unbox-tuples* ;
|
||||
|
||||
M: #introduce drop ;
|
||||
M: #introduce unbox-tuples* ;
|
||||
|
||||
: unbox-tuples ( nodes -- nodes )
|
||||
dup [ unbox-tuples* ] each-node ;
|
||||
: unbox-tuples ( nodes -- nodes ) [ unbox-tuples* ] map-nodes ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue