core/inference/class/class.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays generic assocs hashtables inference kernel
   4 math namespaces sequences words parser math.intervals
   5 effects classes classes.algebra inference.dataflow
   6 inference.backend combinators accessors ;
   7 IN: inference.class
   8
   9 ! Class inference
  10
  11 ! A constraint is a statement about a value.
  12
  13 ! We need a notion of equality which doesn't recurse so cannot
  14 ! infinite loop on circular data
  15 GENERIC: eql? ( obj1 obj2 -- ? )
  16 M: object eql? eq? ;
  17 M: number eql? number= ;
  18
  19 ! Maps constraints to constraints
  20 SYMBOL: constraints
  21
  22 TUPLE: literal-constraint literal value ;
  23
  24 C: <literal-constraint> literal-constraint
  25
  26 M: literal-constraint equal?
  27     over literal-constraint? [
  28         [ [ literal>> ] bi@ eql? ]
  29         [ [ value>>   ] bi@ =    ]
  30         2bi and
  31     ] [ 2drop f ] if ;
  32
  33 TUPLE: class-constraint class value ;
  34
  35 C: <class-constraint> class-constraint
  36
  37 TUPLE: interval-constraint interval value ;
  38
  39 C: <interval-constraint> interval-constraint
  40
  41 GENERIC: apply-constraint ( constraint -- )
  42 GENERIC: constraint-satisfied? ( constraint -- ? )
  43
  44 : `input ( n -- value ) node get in-d>> nth ;
  45 : `output ( n -- value ) node get out-d>> nth ;
  46 : class, ( class value -- ) <class-constraint> , ;
  47 : literal, ( literal value -- ) <literal-constraint> , ;
  48 : interval, ( interval value -- ) <interval-constraint> , ;
  49
  50 M: f apply-constraint drop ;
  51
  52 : make-constraints ( node quot -- constraint )
  53     [ swap node set call ] { } make ; inline
  54
  55 : set-constraints ( node quot -- )
  56     make-constraints
  57     unclip [ 2array ] reduce
  58     apply-constraint ; inline
  59
  60 : assume ( constraint -- )
  61     constraints get at [ apply-constraint ] when* ;
  62
  63 ! Variables used by the class inferencer
  64
  65 ! Current value --> literal mapping
  66 SYMBOL: value-literals
  67
  68 ! Current value --> interval mapping
  69 SYMBOL: value-intervals
  70
  71 ! Current value --> class mapping
  72 SYMBOL: value-classes
  73
  74 : value-interval* ( value -- interval/f )
  75     value-intervals get at ;
  76
  77 : set-value-interval* ( interval value -- )
  78     value-intervals get set-at ;
  79
  80 : intersect-value-interval ( interval value -- )
  81     [ value-interval* interval-intersect ] keep
  82     set-value-interval* ;
  83
  84 M: interval-constraint apply-constraint
  85     [ interval>> ] [ value>> ] bi intersect-value-interval ;
  86
  87 : set-class-interval ( class value -- )
  88     over class? [
  89         >r "interval" word-prop r> over
  90         [ set-value-interval* ] [ 2drop ] if
  91     ] [ 2drop ] if ;
  92
  93 : value-class* ( value -- class )
  94     value-classes get at object or ;
  95
  96 : set-value-class* ( class value -- )
  97     over [
  98         dup value-intervals get at [
  99             2dup set-class-interval
 100         ] unless
 101         2dup <class-constraint> assume
 102     ] when
 103     value-classes get set-at ;
 104
 105 : intersect-value-class ( class value -- )
 106     [ value-class* class-and ] keep set-value-class* ;
 107
 108 M: class-constraint apply-constraint
 109     [ class>> ] [ value>> ] bi intersect-value-class ;
 110
 111 : literal-interval ( value -- interval/f )
 112     dup real? [ [a,a] ] [ drop f ] if ;
 113
 114 : set-value-literal* ( literal value -- )
 115     {
 116         [ >r class r> set-value-class* ]
 117         [ >r literal-interval r> set-value-interval* ]
 118         [ <literal-constraint> assume ]
 119         [ value-literals get set-at ]
 120     } 2cleave ;
 121
 122 M: literal-constraint apply-constraint
 123     [ literal>> ] [ value>> ] bi set-value-literal* ;
 124
 125 ! For conditionals, an assoc of child node # --> constraint
 126 GENERIC: child-constraints ( node -- seq )
 127
 128 GENERIC: infer-classes-before ( node -- )
 129
 130 GENERIC: infer-classes-around ( node -- )
 131
 132 M: node infer-classes-before drop ;
 133
 134 M: node child-constraints
 135     children>> length
 136     dup zero? [ drop f ] [ f <repetition> ] if ;
 137
 138 : value-literal* ( value -- obj ? )
 139     value-literals get at* ;
 140
 141 M: literal-constraint constraint-satisfied?
 142     dup value>> value-literal*
 143     [ swap literal>> eql? ] [ 2drop f ] if ;
 144
 145 M: class-constraint constraint-satisfied?
 146     [ value>> value-class* ] [ class>> ] bi class<= ;
 147
 148 M: pair apply-constraint
 149     first2 2dup constraints get set-at
 150     constraint-satisfied? [ apply-constraint ] [ drop ] if ;
 151
 152 M: pair constraint-satisfied?
 153     first constraint-satisfied? ;
 154
 155 : valid-keys ( seq assoc -- newassoc )
 156     extract-keys [ nip ] assoc-filter f assoc-like ;
 157
 158 : annotate-node ( node -- )
 159     #! Annotate the node with the currently-inferred set of
 160     #! value classes.
 161     dup node-values {
 162         [ value-intervals get valid-keys >>intervals ]
 163         [ value-classes   get valid-keys >>classes   ]
 164         [ value-literals  get valid-keys >>literals  ]
 165         [ 2drop ]
 166     } cleave ;
 167
 168 : intersect-classes ( classes values -- )
 169     [ intersect-value-class ] 2each ;
 170
 171 : intersect-intervals ( intervals values -- )
 172     [ intersect-value-interval ] 2each ;
 173
 174 : predicate-constraints ( class #call -- )
 175     [
 176         ! If word outputs true, input is an instance of class
 177         [
 178             0 `input class,
 179             \ f class-not 0 `output class,
 180         ] set-constraints
 181     ] [
 182         ! If word outputs false, input is not an instance of class
 183         [
 184             class-not 0 `input class,
 185             \ f 0 `output class,
 186         ] set-constraints
 187     ] 2bi ;
 188
 189 : compute-constraints ( #call -- )
 190     dup param>> "constraints" word-prop [
 191         call
 192     ] [
 193         dup param>> "predicating" word-prop dup
 194         [ swap predicate-constraints ] [ 2drop ] if
 195     ] if* ;
 196
 197 : compute-output-classes ( node word -- classes intervals )
 198     dup param>> "output-classes" word-prop
 199     dup [ call ] [ 2drop f f ] if ;
 200
 201 : output-classes ( node -- classes intervals )
 202     dup compute-output-classes >r
 203     [ ] [ param>> "default-output-classes" word-prop ] ?if
 204     r> ;
 205
 206 M: #call infer-classes-before
 207     [ compute-constraints ] keep
 208     [ output-classes ] [ out-d>> ] bi
 209     tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
 210
 211 M: #push infer-classes-before
 212     out-d>> [ [ value-literal ] keep set-value-literal* ] each ;
 213
 214 M: #if child-constraints
 215     [
 216         \ f class-not 0 `input class,
 217         f 0 `input literal,
 218     ] make-constraints ;
 219
 220 M: #dispatch child-constraints
 221     dup [
 222         children>> length [ 0 `input literal, ] each
 223     ] make-constraints ;
 224
 225 M: #declare infer-classes-before
 226     [ param>> ] [ in-d>> ] bi
 227     [ intersect-value-class ] 2each ;
 228
 229 DEFER: (infer-classes)
 230
 231 : infer-children ( node -- )
 232     [ children>> ] [ child-constraints ] bi [
 233         [
 234             value-classes [ clone ] change
 235             value-literals [ clone ] change
 236             value-intervals [ clone ] change
 237             constraints [ clone ] change
 238             apply-constraint
 239             (infer-classes)
 240         ] with-scope
 241     ] 2each ;
 242
 243 : pad-all ( seqs elt -- seq )
 244     >r dup [ length ] map supremum r> [ pad-left ] 2curry map ;
 245
 246 : (merge-classes) ( nodes -- seq )
 247     dup length 1 = [
 248         first node-input-classes
 249     ] [
 250         [ node-input-classes ] map null pad-all flip
 251         [ null [ class-or ] reduce ] map
 252     ] if ;
 253
 254 : set-classes ( seq node -- )
 255     out-d>> [ set-value-class* ] 2reverse-each ;
 256
 257 : merge-classes ( nodes node -- )
 258     >r (merge-classes) r> set-classes ;
 259
 260 : set-intervals ( seq node -- )
 261     out-d>> [ set-value-interval* ] 2reverse-each ;
 262
 263 : merge-intervals ( nodes node -- )
 264     >r
 265     [ node-input-intervals ] map f pad-all flip
 266     [ dup first [ interval-union ] reduce ] map
 267     r> set-intervals ;
 268
 269 : annotate-merge ( nodes #merge/#entry -- )
 270     [ merge-classes ] [ merge-intervals ] 2bi ;
 271
 272 : merge-children ( node -- )
 273     dup node-successor dup #merge? [
 274         swap active-children dup empty?
 275         [ 2drop ] [ swap annotate-merge ] if
 276     ] [ 2drop ] if ;
 277
 278 : classes= ( inferred current -- ? )
 279     2dup min-length [ tail* ] curry bi@ sequence= ;
 280
 281 SYMBOL: fixed-point?
 282
 283 SYMBOL: nested-labels
 284
 285 : annotate-entry ( nodes #label -- )
 286     >r (merge-classes) r> node-child
 287     2dup node-output-classes classes=
 288     [ 2drop ] [ set-classes fixed-point? off ] if ;
 289
 290 : init-recursive-calls ( #label -- )
 291     #! We set recursive calls to output the empty type, then
 292     #! repeat inference until a fixed point is reached.
 293     #! Hopefully, our type functions are monotonic so this
 294     #! will always converge.
 295     returns>> [ dup in-d>> [ null ] { } map>assoc >>classes drop ] each ;
 296
 297 M: #label infer-classes-before ( #label -- )
 298     [ init-recursive-calls ]
 299     [ [ 1array ] keep annotate-entry ] bi ;
 300
 301 : infer-label-loop ( #label -- )
 302     fixed-point? on
 303     dup node-child (infer-classes)
 304     dup [ calls>> ] [ suffix ] [ annotate-entry ] tri
 305     fixed-point? get [ drop ] [ infer-label-loop ] if ;
 306
 307 M: #label infer-classes-around ( #label -- )
 308     #! Now merge the types at every recursion point with the
 309     #! entry types.
 310     [
 311         {
 312             [ nested-labels get push ]
 313             [ annotate-node ]
 314             [ infer-classes-before ]
 315             [ infer-label-loop ]
 316             [ drop nested-labels get pop* ]
 317         } cleave
 318     ] with-scope ;
 319
 320 : find-label ( param -- #label )
 321     param>> nested-labels get [ param>> eq? ] with find nip ;
 322
 323 M: #call-label infer-classes-before ( #call-label -- )
 324     [ find-label returns>> (merge-classes) ] [ out-d>> ] bi
 325     [ set-value-class* ] 2each ;
 326
 327 M: #return infer-classes-around
 328     nested-labels get length 0 > [
 329         dup param>> nested-labels get peek param>> eq? [
 330             [ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
 331             classes= not [
 332                 fixed-point? off
 333                 [ in-d>> value-classes get valid-keys ] keep
 334                 set-node-classes
 335             ] [ drop ] if
 336         ] [ call-next-method ] if
 337     ] [ call-next-method ] if ;
 338
 339 M: object infer-classes-around
 340     {
 341         [ infer-classes-before ]
 342         [ annotate-node ]
 343         [ infer-children ]
 344         [ merge-children ]
 345     } cleave ;
 346
 347 : (infer-classes) ( node -- )
 348     [
 349         [ infer-classes-around ]
 350         [ node-successor ] bi
 351         (infer-classes)
 352     ] when* ;
 353
 354 : infer-classes-with ( node classes literals intervals -- )
 355     [
 356         V{ } clone nested-labels set
 357         H{ } assoc-like value-intervals set
 358         H{ } assoc-like value-literals set
 359         H{ } assoc-like value-classes set
 360         H{ } clone constraints set
 361         (infer-classes)
 362     ] with-scope ;
 363
 364 : infer-classes ( node -- node )
 365     dup f f f infer-classes-with ;
 366
 367 : infer-classes/node ( node existing -- )
 368     #! Infer classes, using the existing node's class info as a
 369     #! starting point.
 370     [ classes>> ] [ literals>> ] [ intervals>> ] tri
 371     infer-classes-with ;