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