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