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 GENERIC: infer-classes-after ( node -- )
 133
 134 M: node infer-classes-before drop ;
 135
 136 M: node infer-classes-after drop ;
 137
 138 M: node child-constraints
 139     children>> length
 140     dup zero? [ drop f ] [ f <repetition> ] if ;
 141
 142 : value-literal* ( value -- obj ? )
 143     value-literals get at* ;
 144
 145 M: literal-constraint constraint-satisfied?
 146     dup value>> value-literal*
 147     [ swap literal>> eql? ] [ 2drop f ] if ;
 148
 149 M: class-constraint constraint-satisfied?
 150     [ value>> value-class* ] [ class>> ] bi class<= ;
 151
 152 M: pair apply-constraint
 153     first2 2dup constraints get set-at
 154     constraint-satisfied? [ apply-constraint ] [ drop ] if ;
 155
 156 M: pair constraint-satisfied?
 157     first constraint-satisfied? ;
 158
 159 : valid-keys ( seq assoc -- newassoc )
 160     extract-keys [ nip ] assoc-filter f assoc-like ;
 161
 162 : annotate-node ( node -- )
 163     #! Annotate the node with the currently-inferred set of
 164     #! value classes.
 165     dup node-values {
 166         [ value-intervals get valid-keys >>intervals ]
 167         [ value-classes   get valid-keys >>classes   ]
 168         [ value-literals  get valid-keys >>literals  ]
 169         [ 2drop ]
 170     } cleave ;
 171
 172 : intersect-classes ( classes values -- )
 173     [ intersect-value-class ] 2each ;
 174
 175 : intersect-intervals ( intervals values -- )
 176     [ intersect-value-interval ] 2each ;
 177
 178 : predicate-constraints ( class #call -- )
 179     [
 180         ! If word outputs true, input is an instance of class
 181         [
 182             0 `input class,
 183             \ f class-not 0 `output class,
 184         ] set-constraints
 185     ] [
 186         ! If word outputs false, input is not an instance of class
 187         [
 188             class-not 0 `input class,
 189             \ f 0 `output class,
 190         ] set-constraints
 191     ] 2bi ;
 192
 193 : compute-constraints ( #call -- )
 194     dup param>> "constraints" word-prop [
 195         call
 196     ] [
 197         dup param>> "predicating" word-prop dup
 198         [ swap predicate-constraints ] [ 2drop ] if
 199     ] if* ;
 200
 201 : compute-output-classes ( node word -- classes intervals )
 202     dup param>> "output-classes" word-prop
 203     dup [ call ] [ 2drop f f ] if ;
 204
 205 : output-classes ( node -- classes intervals )
 206     dup compute-output-classes >r
 207     [ ] [ param>> "default-output-classes" word-prop ] ?if
 208     r> ;
 209
 210 : intersect-values ( classes intervals values -- )
 211     tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
 212
 213 M: #call infer-classes-before
 214     [ compute-constraints ]
 215     [ [ output-classes ] [ out-d>> ] bi intersect-values ] bi ;
 216
 217 : input-classes ( #call -- classes )
 218     param>> "input-classes" word-prop ;
 219
 220 M: #call infer-classes-after
 221     [ input-classes ] [ in-d>> ] bi intersect-classes ;
 222
 223 M: #push infer-classes-before
 224     out-d>> [ [ value-literal ] keep set-value-literal* ] each ;
 225
 226 M: #if child-constraints
 227     [
 228         \ f class-not 0 `input class,
 229         f 0 `input literal,
 230     ] make-constraints ;
 231
 232 M: #dispatch child-constraints
 233     dup [
 234         children>> length [ 0 `input literal, ] each
 235     ] make-constraints ;
 236
 237 M: #declare infer-classes-before
 238     [ param>> ] [ in-d>> ] bi
 239     [ intersect-value-class ] 2each ;
 240
 241 DEFER: (infer-classes)
 242
 243 : infer-children ( node -- )
 244     [ children>> ] [ child-constraints ] bi [
 245         [
 246             value-classes [ clone ] change
 247             value-literals [ clone ] change
 248             value-intervals [ clone ] change
 249             constraints [ clone ] change
 250             apply-constraint
 251             (infer-classes)
 252         ] with-scope
 253     ] 2each ;
 254
 255 : pad-all ( seqs elt -- seq )
 256     >r dup [ length ] map supremum r> [ pad-left ] 2curry map ;
 257
 258 : (merge-classes) ( nodes -- seq )
 259     dup length 1 = [
 260         first node-input-classes
 261     ] [
 262         [ node-input-classes ] map null pad-all flip
 263         [ null [ class-or ] reduce ] map
 264     ] if ;
 265
 266 : set-classes ( seq node -- )
 267     out-d>> [ set-value-class* ] 2reverse-each ;
 268
 269 : merge-classes ( nodes node -- )
 270     >r (merge-classes) r> set-classes ;
 271
 272 : set-intervals ( seq node -- )
 273     out-d>> [ set-value-interval* ] 2reverse-each ;
 274
 275 : merge-intervals ( nodes node -- )
 276     >r
 277     [ node-input-intervals ] map f pad-all flip
 278     [ dup first [ interval-union ] reduce ] map
 279     r> set-intervals ;
 280
 281 : annotate-merge ( nodes #merge/#entry -- )
 282     [ merge-classes ] [ merge-intervals ] 2bi ;
 283
 284 : merge-children ( node -- )
 285     dup node-successor dup #merge? [
 286         swap active-children dup empty?
 287         [ 2drop ] [ swap annotate-merge ] if
 288     ] [ 2drop ] if ;
 289
 290 : classes= ( inferred current -- ? )
 291     2dup min-length [ tail* ] curry bi@ sequence= ;
 292
 293 SYMBOL: fixed-point?
 294
 295 SYMBOL: nested-labels
 296
 297 : annotate-entry ( nodes #label -- )
 298     >r (merge-classes) r> node-child
 299     2dup node-output-classes classes=
 300     [ 2drop ] [ set-classes fixed-point? off ] if ;
 301
 302 : init-recursive-calls ( #label -- )
 303     #! We set recursive calls to output the empty type, then
 304     #! repeat inference until a fixed point is reached.
 305     #! Hopefully, our type functions are monotonic so this
 306     #! will always converge.
 307     returns>> [ dup in-d>> [ null ] { } map>assoc >>classes drop ] each ;
 308
 309 M: #label infer-classes-before ( #label -- )
 310     [ init-recursive-calls ]
 311     [ [ 1array ] keep annotate-entry ] bi ;
 312
 313 : infer-label-loop ( #label -- )
 314     fixed-point? on
 315     dup node-child (infer-classes)
 316     dup [ calls>> ] [ suffix ] [ annotate-entry ] tri
 317     fixed-point? get [ drop ] [ infer-label-loop ] if ;
 318
 319 M: #label infer-classes-around ( #label -- )
 320     #! Now merge the types at every recursion point with the
 321     #! entry types.
 322     [
 323         {
 324             [ nested-labels get push ]
 325             [ annotate-node ]
 326             [ infer-classes-before ]
 327             [ infer-label-loop ]
 328             [ drop nested-labels get pop* ]
 329         } cleave
 330     ] with-scope ;
 331
 332 : find-label ( param -- #label )
 333     param>> nested-labels get [ param>> eq? ] with find nip ;
 334
 335 M: #call-label infer-classes-before ( #call-label -- )
 336     [ find-label returns>> (merge-classes) ] [ out-d>> ] bi
 337     [ set-value-class* ] 2each ;
 338
 339 M: #return infer-classes-around
 340     nested-labels get length 0 > [
 341         dup param>> nested-labels get peek param>> eq? [
 342             [ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
 343             classes= not [
 344                 fixed-point? off
 345                 [ in-d>> value-classes get valid-keys ] keep
 346                 set-node-classes
 347             ] [ drop ] if
 348         ] [ call-next-method ] if
 349     ] [ call-next-method ] if ;
 350
 351 M: object infer-classes-around
 352     {
 353         [ infer-classes-before ]
 354         [ annotate-node ]
 355         [ infer-classes-after ]
 356         [ infer-children ]
 357         [ merge-children ]
 358     } cleave ;
 359
 360 : (infer-classes) ( node -- )
 361     [
 362         [ infer-classes-around ]
 363         [ node-successor ] bi
 364         (infer-classes)
 365     ] when* ;
 366
 367 : infer-classes-with ( node classes literals intervals -- )
 368     [
 369         V{ } clone nested-labels set
 370         H{ } assoc-like value-intervals set
 371         H{ } assoc-like value-literals set
 372         H{ } assoc-like value-classes set
 373         H{ } clone constraints set
 374         (infer-classes)
 375     ] with-scope ;
 376
 377 : infer-classes ( node -- node )
 378     dup f f f infer-classes-with ;
 379
 380 : infer-classes/node ( node existing -- )
 381     #! Infer classes, using the existing node's class info as a
 382     #! starting point.
 383     [ classes>> ] [ literals>> ] [ intervals>> ] tri
 384     infer-classes-with ;