110 lines
2.8 KiB
Factor
110 lines
2.8 KiB
Factor
|
! Copyright (C) 2008 Slava Pestov.
|
||
|
|
! See http://factorcode.org/license.txt for BSD license.
|
||
|
|
IN: compiler.tree.tuple-unboxing
|
||
|
|
|
||
|
|
! This pass must run after escape analysis
|
||
|
|
|
||
|
|
! Mapping from values to sequences of values
|
||
|
|
SYMBOL: unboxed-tuples
|
||
|
|
|
||
|
|
: 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 )
|
||
|
|
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 ( #push infos values -- )
|
||
|
|
[ [ literal>> ] dip #push ] 2map >>body drop ;
|
||
|
|
|
||
|
|
M: #push unbox-tuples* ( #push -- )
|
||
|
|
dup prepare-unboxed-info dup [ expand-#push ] [ 3drop ] if ;
|
||
|
|
|
||
|
|
: expand-<tuple-boa> ( #call values -- quot )
|
||
|
|
[ drop in-d>> peek #drop ]
|
||
|
|
[ [ in-d>> but-last ] dip #copy ]
|
||
|
|
2bi 2array ;
|
||
|
|
|
||
|
|
: 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 ;
|
||
|
|
|
||
|
|
: (flatten-values) ( values -- values' )
|
||
|
|
[ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ;
|
||
|
|
|
||
|
|
: flatten-values ( values -- values' )
|
||
|
|
(flatten-values) flatten ;
|
||
|
|
|
||
|
|
: flatten-value ( values -- values )
|
||
|
|
1array 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 ]
|
||
|
|
tri ;
|
||
|
|
|
||
|
|
: slot-access-shuffle ( tuple-values slot-values outputs -- #shuffle )
|
||
|
|
[ nip ] [ zip ] 2bi #shuffle ;
|
||
|
|
|
||
|
|
: unbox-slot-access ( #call -- )
|
||
|
|
dup unboxed-slot-access? [
|
||
|
|
dup
|
||
|
|
[ in-d>> second 1array #drop ]
|
||
|
|
[ prepare-slot-access slot-access-shuffle ]
|
||
|
|
bi 2array unbox-tuples >>body
|
||
|
|
] when drop ;
|
||
|
|
|
||
|
|
M: #call unbox-tuples* ( #call -- )
|
||
|
|
dup word>> {
|
||
|
|
{ \ <tuple-boa> [ unbox-<tuple-boa> ] }
|
||
|
|
{ \ <complex> [ unbox-<complex> ] }
|
||
|
|
{ \ slot [ unbox-slot-access ] }
|
||
|
|
[ 2drop ]
|
||
|
|
} case ;
|
||
|
|
|
||
|
|
M: #copy ... ;
|
||
|
|
|
||
|
|
M: #>r ... ;
|
||
|
|
|
||
|
|
M: #r> ... ;
|
||
|
|
|
||
|
|
M: #shuffle ... ;
|
||
|
|
|
||
|
|
M: #terrible ... ;
|
||
|
|
|
||
|
|
! These nodes never participate in unboxing
|
||
|
|
M: #return drop ;
|
||
|
|
|
||
|
|
M: #introduce drop ;
|
||
|
|
|
||
|
|
: unbox-tuples ( nodes -- nodes )
|
||
|
|
dup [ unbox-tuples* ] each-node ;
|