basis/compiler/tree/propagation/info/info.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: assocs classes classes.algebra classes.tuple
   4 classes.tuple.private kernel accessors math math.intervals namespaces
   5 sequences sequences.private words combinators memoize
   6 combinators.short-circuit byte-arrays strings arrays layouts
   7 cpu.architecture compiler.tree.propagation.copy ;
   8 IN: compiler.tree.propagation.info
   9
  10 : false-class? ( class -- ? ) \ f class<= ;
  11
  12 : true-class? ( class -- ? ) \ f class-not class<= ;
  13
  14 : null-class? ( class -- ? ) null class<= ;
  15
  16 GENERIC: eql? ( obj1 obj2 -- ? )
  17 M: object eql? eq? ;
  18 M: fixnum eql? eq? ;
  19 M: bignum eql? over bignum? [ = ] [ 2drop f ] if ;
  20 M: ratio eql? over ratio? [ = ] [ 2drop f ] if ;
  21 M: float eql? over float? [ [ double>bits ] bi@ = ] [ 2drop f ] if ;
  22 M: complex eql? over complex? [ = ] [ 2drop f ] if ;
  23
  24 ! Value info represents a set of objects. Don't mutate value infos
  25 ! you receive, always construct new ones. We don't declare the
  26 ! slots read-only to allow cloning followed by writing, and to
  27 ! simplify constructors.
  28 TUPLE: value-info
  29 class
  30 interval
  31 literal
  32 literal?
  33 length
  34 slots ;
  35
  36 CONSTANT: null-info T{ value-info f null empty-interval }
  37
  38 CONSTANT: object-info T{ value-info f object full-interval }
  39
  40 : interval>literal ( class interval -- literal literal? )
  41     #! If interval has zero length and the class is sufficiently
  42     #! precise, we can turn it into a literal
  43     dup special-interval? [
  44         2drop f f
  45     ] [
  46         dup from>> first {
  47             { [ over interval-length 0 > ] [ 3drop f f ] }
  48             { [ pick bignum class<= ] [ 2nip >bignum t ] }
  49             { [ pick integer class<= ] [ 2nip >fixnum t ] }
  50             { [ pick float class<= ] [
  51                 2nip dup zero? [ drop f f ] [ >float t ] if
  52             ] }
  53             [ 3drop f f ]
  54         } cond
  55     ] if ;
  56
  57 : <value-info> ( -- info ) \ value-info new ;
  58
  59 DEFER: <literal-info>
  60
  61 : tuple-slot-infos ( tuple -- slots )
  62     [ tuple-slots ] [ class all-slots ] bi
  63     [ read-only>> [ <literal-info> ] [ drop f ] if ] 2map
  64     f prefix ;
  65
  66 UNION: fixed-length array byte-array string ;
  67
  68 : init-literal-info ( info -- info )
  69     empty-interval >>interval
  70     dup literal>> class >>class
  71     dup literal>> {
  72         { [ dup real? ] [ [a,a] >>interval ] }
  73         { [ dup tuple? ] [ tuple-slot-infos >>slots ] }
  74         { [ dup fixed-length? ] [ length <literal-info> >>length ] }
  75         [ drop ]
  76     } cond ; inline
  77
  78 : empty-set? ( info -- ? )
  79     {
  80         [ class>> null-class? ]
  81         [ [ interval>> empty-interval eq? ] [ class>> real class<= ] bi and ]
  82     } 1|| ;
  83
  84 : min-value ( class -- n )
  85     {
  86         { fixnum [ most-negative-fixnum ] }
  87         { array-capacity [ 0 ] }
  88         [ drop -1/0. ]
  89     } case ;
  90
  91 : max-value ( class -- n )
  92     {
  93         { fixnum [ most-positive-fixnum ] }
  94         { array-capacity [ max-array-capacity ] }
  95         [ drop 1/0. ]
  96     } case ;
  97
  98 : class-interval ( class -- i )
  99     {
 100         { fixnum [ fixnum-interval ] }
 101         { array-capacity [ array-capacity-interval ] }
 102         [ drop full-interval ]
 103     } case ;
 104
 105 : wrap-interval ( interval class -- interval' )
 106     {
 107         { [ over empty-interval eq? ] [ drop ] }
 108         { [ over full-interval eq? ] [ nip class-interval ] }
 109         { [ 2dup class-interval interval-subset? not ] [ nip class-interval ] }
 110         [ drop ]
 111     } cond ;
 112
 113 : init-interval ( info -- info )
 114     dup [ interval>> full-interval or ] [ class>> ] bi wrap-interval >>interval
 115     dup class>> integer class<= [ [ integral-closure ] change-interval ] when ; inline
 116
 117 : init-value-info ( info -- info )
 118     dup literal?>> [
 119         init-literal-info
 120     ] [
 121         dup empty-set? [
 122             null >>class
 123             empty-interval >>interval
 124         ] [
 125             init-interval
 126             dup [ class>> ] [ interval>> ] bi interval>literal
 127             [ >>literal ] [ >>literal? ] bi*
 128         ] if
 129     ] if ; inline
 130
 131 : <class/interval-info> ( class interval -- info )
 132     <value-info>
 133         swap >>interval
 134         swap >>class
 135     init-value-info ; foldable
 136
 137 : <class-info> ( class -- info )
 138     f <class/interval-info> ; foldable
 139
 140 : <interval-info> ( interval -- info )
 141     <value-info>
 142         real >>class
 143         swap >>interval
 144     init-value-info ; foldable
 145
 146 : <literal-info> ( literal -- info )
 147     <value-info>
 148         swap >>literal
 149         t >>literal?
 150     init-value-info ; foldable
 151
 152 : <sequence-info> ( value -- info )
 153     <value-info>
 154         object >>class
 155         swap value-info >>length
 156     init-value-info ; foldable
 157
 158 : <tuple-info> ( slots class -- info )
 159     <value-info>
 160         swap >>class
 161         swap >>slots
 162     init-value-info ;
 163
 164 : >literal< ( info -- literal literal? )
 165     [ literal>> ] [ literal?>> ] bi ;
 166
 167 : intersect-literals ( info1 info2 -- literal literal? )
 168     {
 169         { [ dup literal?>> not ] [ drop >literal< ] }
 170         { [ over literal?>> not ] [ nip >literal< ] }
 171         { [ 2dup [ literal>> ] bi@ eql? not ] [ 2drop f f ] }
 172         [ drop >literal< ]
 173     } cond ;
 174
 175 DEFER: value-info-intersect
 176
 177 DEFER: (value-info-intersect)
 178
 179 : intersect-lengths ( info1 info2 -- length )
 180     [ length>> ] bi@ {
 181         { [ dup not ] [ drop ] }
 182         { [ over not ] [ nip ] }
 183         [ value-info-intersect ]
 184     } cond ;
 185
 186 : intersect-slot ( info1 info2 -- info )
 187     {
 188         { [ dup not ] [ nip ] }
 189         { [ over not ] [ drop ] }
 190         [ (value-info-intersect) ]
 191     } cond ;
 192
 193 : intersect-slots ( info1 info2 -- slots )
 194     [ slots>> ] bi@ {
 195         { [ dup not ] [ drop ] }
 196         { [ over not ] [ nip ] }
 197         [
 198             2dup [ length ] bi@ =
 199             [ [ intersect-slot ] 2map ] [ 2drop f ] if
 200         ]
 201     } cond ;
 202
 203 : (value-info-intersect) ( info1 info2 -- info )
 204     [ <value-info> ] 2dip
 205     {
 206         [ [ class>> ] bi@ class-and >>class ]
 207         [ [ interval>> ] bi@ interval-intersect >>interval ]
 208         [ intersect-literals [ >>literal ] [ >>literal? ] bi* ]
 209         [ intersect-lengths >>length ]
 210         [ intersect-slots >>slots ]
 211     } 2cleave
 212     init-value-info ;
 213
 214 : value-info-intersect ( info1 info2 -- info )
 215     {
 216         { [ dup class>> null-class? ] [ nip ] }
 217         { [ over class>> null-class? ] [ drop ] }
 218         [ (value-info-intersect) ]
 219     } cond ;
 220
 221 : union-literals ( info1 info2 -- literal literal? )
 222     2dup [ literal?>> ] both? [
 223         [ literal>> ] bi@ 2dup eql? [ drop t ] [ 2drop f f ] if
 224     ] [ 2drop f f ] if ;
 225
 226 DEFER: value-info-union
 227
 228 DEFER: (value-info-union)
 229
 230 : union-lengths ( info1 info2 -- length )
 231     [ length>> ] bi@ {
 232         { [ dup not ] [ nip ] }
 233         { [ over not ] [ drop ] }
 234         [ value-info-union ]
 235     } cond ;
 236
 237 : union-slot ( info1 info2 -- info )
 238     {
 239         { [ dup not ] [ nip ] }
 240         { [ over not ] [ drop ] }
 241         [ (value-info-union) ]
 242     } cond ;
 243
 244 : union-slots ( info1 info2 -- slots )
 245     [ slots>> ] bi@
 246     2dup [ length ] bi@ =
 247     [ [ union-slot ] 2map ] [ 2drop f ] if ;
 248
 249 : (value-info-union) ( info1 info2 -- info )
 250     [ <value-info> ] 2dip
 251     {
 252         [ [ class>> ] bi@ class-or >>class ]
 253         [ [ interval>> ] bi@ interval-union >>interval ]
 254         [ union-literals [ >>literal ] [ >>literal? ] bi* ]
 255         [ union-lengths >>length ]
 256         [ union-slots >>slots ]
 257     } 2cleave
 258     init-value-info ;
 259
 260 : value-info-union ( info1 info2 -- info )
 261     {
 262         { [ dup class>> null-class? ] [ drop ] }
 263         { [ over class>> null-class? ] [ nip ] }
 264         [ (value-info-union) ]
 265     } cond ;
 266
 267 : value-infos-union ( infos -- info )
 268     [ null-info ]
 269     [ [ ] [ value-info-union ] map-reduce ] if-empty ;
 270
 271 : literals<= ( info1 info2 -- ? )
 272     {
 273         { [ dup literal?>> not ] [ 2drop t ] }
 274         { [ over literal?>> not ] [ drop class>> null-class? ] }
 275         [ [ literal>> ] bi@ eql? ]
 276     } cond ;
 277
 278 : value-info<= ( info1 info2 -- ? )
 279     {
 280         { [ dup not ] [ 2drop t ] }
 281         { [ over not ] [ 2drop f ] }
 282         [
 283             {
 284                 { [ 2dup [ class>> ] bi@ class<= not ] [ f ] }
 285                 { [ 2dup [ interval>> ] bi@ interval-subset? not ] [ f ] }
 286                 { [ 2dup literals<= not ] [ f ] }
 287                 { [ 2dup [ length>> ] bi@ value-info<= not ] [ f ] }
 288                 { [ 2dup [ slots>> ] bi@ [ value-info<= ] 2all? not ] [ f ] }
 289                 [ t ]
 290             } cond 2nip
 291         ]
 292     } cond ;
 293
 294 ! Assoc stack of current value --> info mapping
 295 SYMBOL: value-infos
 296
 297 : value-info* ( value -- info ? )
 298     resolve-copy value-infos get assoc-stack [ null-info or ] [ >boolean ] bi ; inline
 299
 300 : value-info ( value -- info )
 301     value-info* drop ;
 302
 303 : set-value-info ( info value -- )
 304     resolve-copy value-infos get last set-at ;
 305
 306 : refine-value-info ( info value -- )
 307     resolve-copy value-infos get
 308     [ assoc-stack [ value-info-intersect ] when* ] 2keep
 309     last set-at ;
 310
 311 : value-literal ( value -- obj ? )
 312     value-info >literal< ;
 313
 314 : possible-boolean-values ( info -- values )
 315     dup literal?>> [
 316         literal>> 1array
 317     ] [
 318         class>> {
 319             { [ dup null-class? ] [ { } ] }
 320             { [ dup true-class? ] [ { t } ] }
 321             { [ dup false-class? ] [ { f } ] }
 322             [ { t f } ]
 323         } cond nip
 324     ] if ;
 325
 326 : node-value-info ( node value -- info )
 327     swap info>> at* [ drop null-info ] unless ;
 328
 329 : node-input-infos ( node -- seq )
 330     dup in-d>> [ node-value-info ] with map ;
 331
 332 : node-output-infos ( node -- seq )
 333     dup out-d>> [ node-value-info ] with map ;
 334
 335 : first-literal ( #call -- obj )
 336     dup in-d>> first node-value-info literal>> ;
 337
 338 : last-literal ( #call -- obj )
 339     dup out-d>> last node-value-info literal>> ;
 340
 341 : immutable-tuple-boa? ( #call -- ? )
 342     dup word>> \ <tuple-boa> eq? [
 343         dup in-d>> last node-value-info
 344         literal>> first immutable-tuple-class?
 345     ] [ drop f ] if ;