core/compiler/optimizer/class-infer.factor

   1 ! Copyright (C) 2004, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: optimizer
   4 USING: arrays generic hashtables inference kernel
   5 kernel-internals math namespaces sequences words parser ;
   6
   7 ! Infer possible classes of values in a dataflow IR.
   8 : node-class# ( node n -- class )
   9     over node-in-d <reversed> ?nth node-class ;
  10
  11 ! Variables used by the class inferencer
  12
  13 ! Current value --> class mapping
  14 SYMBOL: value-classes
  15
  16 ! Current value --> literal mapping
  17 SYMBOL: value-literals
  18
  19 ! Maps ties to ties
  20 SYMBOL: ties
  21
  22 GENERIC: apply-tie ( tie -- )
  23
  24 M: f apply-tie drop ;
  25
  26 TUPLE: class-tie value class ;
  27
  28 : set-value-class* ( class value -- )
  29     2dup swap <class-tie> ties get hash [ apply-tie ] when*
  30     value-classes get set-hash ;
  31
  32 M: class-tie apply-tie
  33     dup class-tie-class swap class-tie-value
  34     set-value-class* ;
  35
  36 TUPLE: literal-tie value literal ;
  37
  38 : set-value-literal* ( literal value -- )
  39     over class over set-value-class*
  40     2dup swap <literal-tie> ties get hash [ apply-tie ] when*
  41     value-literals get set-hash ;
  42
  43 M: literal-tie apply-tie
  44     dup literal-tie-literal swap literal-tie-value
  45     set-value-literal* ;
  46
  47 GENERIC: infer-classes* ( node -- )
  48
  49 M: node infer-classes* drop ;
  50
  51 ! For conditionals, a map of child node # --> possibility
  52 GENERIC: child-ties ( node -- seq )
  53
  54 M: node child-ties
  55     node-children length f <array> ;
  56
  57 : value-class* ( value -- class )
  58     value-classes get hash [ object ] unless* ;
  59
  60 : value-literal* ( value -- class )
  61     value-literals get hash ;
  62
  63 : annotate-node ( node -- )
  64     #! Annotate the node with the currently-inferred set of
  65     #! value classes.
  66     dup node-values
  67     [ dup value-class* ] map>hash swap set-node-classes ;
  68
  69 : intersect-classes ( classes values -- )
  70     [
  71         [ value-class* class-and ] keep set-value-class*
  72     ] 2each ;
  73
  74 : set-tie ( tie tie -- ) ties get set-hash ;
  75
  76 : type/tag-ties ( node n -- )
  77     over node-out-d first over [ <literal-tie> ] map-with
  78     >r swap node-in-d first swap [ type>class <class-tie> ] map-with r>
  79     [ set-tie ] 2each ;
  80
  81 \ type [ num-types type/tag-ties ] "create-ties" set-word-prop
  82
  83 \ tag [ num-tags type/tag-ties ] "create-ties" set-word-prop
  84
  85 \ eq? [
  86     dup node-in-d second value? [
  87         dup node-in-d first2 value-literal* <literal-tie>
  88         over node-out-d first general-t <class-tie>
  89         set-tie
  90     ] when drop
  91 ] "create-ties" set-word-prop
  92
  93 : create-ties ( #call -- )
  94     #! If the node is calling a class test predicate, create a
  95     #! tie.
  96     dup node-param "create-ties" word-prop dup [
  97         call
  98     ] [
  99         drop dup node-param "predicating" word-prop dup [
 100             >r dup node-in-d first r> <class-tie>
 101             swap node-out-d first general-t <class-tie>
 102             set-tie
 103         ] [
 104             2drop
 105         ] if
 106     ] if ;
 107
 108 \ <tuple> [
 109     node-in-d first value-literal 1array
 110 ] "output-classes" set-word-prop
 111
 112 { clone (clone) } [
 113     [
 114         node-in-d [ value-class* ] map
 115     ] "output-classes" set-word-prop
 116 ] each
 117
 118 : output-classes ( node -- seq )
 119     dup node-param "output-classes" word-prop [
 120         call
 121     ] [
 122         node-param "inferred-effect" word-prop effect-out
 123         dup [ word? ] all? [ drop f ] unless
 124     ] if* ;
 125
 126 M: #call infer-classes*
 127     dup create-ties dup output-classes
 128     [ swap node-out-d intersect-classes ] [ drop ] if* ;
 129
 130 M: #push infer-classes*
 131     node-out-d
 132     [ [ value-literal ] keep set-value-literal* ] each ;
 133
 134 M: #if child-ties
 135     node-in-d first dup general-t <class-tie>
 136     swap f <literal-tie> 2array ;
 137
 138 M: #dispatch child-ties
 139     dup node-in-d first
 140     swap node-children length [ <literal-tie> ] map-with ;
 141
 142 M: #declare infer-classes*
 143     dup node-param swap node-in-d [ set-value-class* ] 2each ;
 144
 145 DEFER: (infer-classes)
 146
 147 : infer-children ( node -- )
 148     dup node-children swap child-ties [
 149         [
 150             value-classes [ clone ] change
 151             ties [ clone ] change
 152             apply-tie
 153             (infer-classes)
 154         ] with-scope
 155     ] 2each ;
 156
 157 : merge-value-class ( # nodes -- class )
 158     [ swap node-class# ] map-with
 159     null [ class-or ] reduce ;
 160
 161 : annotate-merge ( nodes values -- )
 162     dup length
 163     [ pick merge-value-class swap set-value-class* ] 2each
 164     drop ;
 165
 166 : active-children ( node -- seq )
 167     node-children
 168     [ last-node ] map
 169     [ #terminate? not ] subset ;
 170
 171 : merge-children ( node -- )
 172     dup node-successor dup #merge? [
 173         swap active-children dup empty? [
 174             2drop
 175         ] [
 176             swap node-out-d <reversed> annotate-merge
 177         ] if
 178     ] [
 179         2drop
 180     ] if ;
 181
 182 : (infer-classes) ( node -- )
 183     [
 184         dup infer-classes*
 185         dup annotate-node
 186         dup infer-children
 187         dup merge-children
 188         node-successor (infer-classes)
 189     ] when* ;
 190
 191 : ?<hashtable> [ H{ } clone ] unless* ;
 192
 193 : infer-classes-with ( node classes literals -- )
 194     [
 195         ?<hashtable> value-literals set
 196         ?<hashtable> value-classes set
 197         H{ } clone ties set
 198         (infer-classes)
 199     ] with-scope ;
 200
 201 : infer-classes ( node -- )
 202     f f infer-classes-with ;
 203
 204 : infer-classes/node ( existing node -- )
 205     #! Infer classes, using the existing node's class info as a
 206     #! starting point.
 207     over node-classes rot node-literals infer-classes-with ;