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

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