basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs classes.tuple.private combinators
   4 compiler.tree compiler.tree.builder compiler.tree.combinators
   5 compiler.tree.escape-analysis.allocations
   6 compiler.tree.escape-analysis.simple compiler.tree.propagation
   7 compiler.utilities fry kernel kernel.private math namespaces
   8 sequences slots.private stack-checker.branches
   9 stack-checker.values vectors ;
  10 IN: compiler.tree.tuple-unboxing
  11
  12 GENERIC: unbox-tuples* ( node -- node/nodes )
  13
  14 : unbox-output? ( node -- values )
  15     out-d>> first unboxed-allocation ;
  16
  17 : (expand-#push) ( object value -- nodes )
  18     dup unboxed-allocation dup [
  19         [ object-slots ] [ drop ] [ ] tri*
  20         [ (expand-#push) ] 2map-flat
  21     ] [
  22         drop <#push>
  23     ] if ;
  24
  25 : expand-#push ( #push -- nodes )
  26     [ literal>> ] [ out-d>> first ] bi (expand-#push) ;
  27
  28 M: #push unbox-tuples* ( #push -- nodes )
  29     dup unbox-output? [ expand-#push ] when ;
  30
  31 : unbox-<tuple-boa> ( #call -- nodes )
  32     dup unbox-output? [ in-d>> 1 tail* <#drop> ] when ;
  33
  34 : (flatten-values) ( values accum -- )
  35     dup '[
  36         dup unboxed-allocation
  37         [ _ (flatten-values) ] [ _ push ] ?if
  38     ] each ;
  39
  40 : flatten-values ( values -- values' )
  41     dup empty? [
  42         10 <vector> [ (flatten-values) ] keep
  43     ] unless ;
  44
  45 : prepare-slot-access ( #call -- tuple-values outputs slot-values )
  46     [ in-d>> flatten-values ]
  47     [ out-d>> flatten-values ]
  48     [
  49         out-d>> first slot-accesses get at
  50         [ slot#>> ] [ value>> ] bi allocation nth
  51         1array flatten-values
  52     ] tri ;
  53
  54 : slot-access-shuffle ( tuple-values outputs slot-values -- #shuffle )
  55     [ drop ] [ zip ] 2bi <#data-shuffle> ;
  56
  57 : unbox-slot-access ( #call -- nodes )
  58     dup out-d>> first unboxed-slot-access? [
  59         prepare-slot-access slot-access-shuffle
  60     ] when ;
  61
  62 M: #call unbox-tuples*
  63     dup word>> {
  64         { \ <tuple-boa> [ unbox-<tuple-boa> ] }
  65         { \ slot [ unbox-slot-access ] }
  66         [ drop ]
  67     } case ;
  68
  69 M: #declare unbox-tuples*
  70     ! We don't look at declarations after escape analysis anyway.
  71     drop f ;
  72
  73 M: #copy unbox-tuples*
  74     [ flatten-values ] change-in-d
  75     [ flatten-values ] change-out-d ;
  76
  77 M: #shuffle unbox-tuples*
  78     [ flatten-values ] change-in-d
  79     [ flatten-values ] change-out-d
  80     [ flatten-values ] change-in-r
  81     [ flatten-values ] change-out-r
  82     [ unzip [ flatten-values ] bi@ zip ] change-mapping ;
  83
  84 M: #terminate unbox-tuples*
  85     [ flatten-values ] change-in-d
  86     [ flatten-values ] change-in-r ;
  87
  88 M: #phi unbox-tuples*
  89     ! pad-with-bottom is only needed if some branches are terminated,
  90     ! which means all output values are bottom
  91     [ [ flatten-values ] map pad-with-bottom ] change-phi-in-d
  92     [ flatten-values ] change-out-d ;
  93
  94 M: #recursive unbox-tuples*
  95     [ label>> [ flatten-values ] change-enter-out drop ]
  96     [ [ flatten-values ] change-in-d ]
  97     bi ;
  98
  99 M: #enter-recursive unbox-tuples*
 100     [ flatten-values ] change-in-d
 101     [ flatten-values ] change-out-d ;
 102
 103 M: #call-recursive unbox-tuples*
 104     [ flatten-values ] change-in-d
 105     [ flatten-values ] change-out-d ;
 106
 107 M: #return-recursive unbox-tuples*
 108     [ flatten-values ] change-in-d
 109     [ flatten-values ] change-out-d ;
 110
 111 : value-declaration ( value -- quot )
 112     value-class [ 1array '[ _ declare ] ] [ [ ] ] if* ;
 113
 114 : unbox-parameter-quot ( allocation -- quot )
 115     dup unboxed-allocation {
 116         { [ dup not ] [ 2drop [ ] ] }
 117         { [ dup array? ] [
 118             [ value-declaration ] [
 119                 [
 120                     [ unbox-parameter-quot ] [ 2 + '[ _ slot ] ] bi*
 121                     prepose
 122                 ] map-index
 123             ] bi* '[ @ _ cleave ]
 124         ] }
 125     } cond ;
 126
 127 : unbox-parameters-quot ( values -- quot )
 128     [ unbox-parameter-quot ] map
 129     dup [ [ ] = ] all? [ drop [ ] ] [ '[ _ spread ] ] if ;
 130
 131 : unbox-parameters-nodes ( new-values old-values -- nodes )
 132     [ flatten-values ] [ unbox-parameters-quot ] bi build-sub-tree ;
 133
 134 : new-and-old-values ( values -- new-values old-values )
 135     [ length [ <value> ] replicate ] keep ;
 136
 137 : unbox-hairy-introduce ( #introduce -- nodes )
 138     dup out-d>> new-and-old-values
 139     [ drop >>out-d ] [ unbox-parameters-nodes ] 2bi
 140     swap prefix propagate ;
 141
 142 M: #introduce unbox-tuples*
 143     ! For every output that is unboxed, insert slot accessors
 144     ! to convert the stack value into its unboxed form
 145     dup out-d>> [ unboxed-allocation ] any? [
 146         unbox-hairy-introduce
 147     ] when ;
 148
 149 ! These nodes never participate in unboxing
 150 : assert-not-unboxed ( values -- )
 151     dup array?
 152     [ [ unboxed-allocation ] any? ] [ unboxed-allocation ] if
 153     [ "Unboxing wrong value" throw ] when ;
 154
 155 M: #branch unbox-tuples* dup in-d>> assert-not-unboxed ;
 156
 157 M: #return unbox-tuples* dup in-d>> assert-not-unboxed ;
 158
 159 M: #alien-node unbox-tuples* dup in-d>> assert-not-unboxed ;
 160
 161 M: #alien-callback unbox-tuples* ;
 162
 163 : unbox-tuples ( nodes -- nodes )
 164     (allocation) escaping-allocations get
 165     [ nip key? ] curry assoc-all?
 166     [ [ unbox-tuples* ] map-nodes ] unless ;