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

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See https://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 compiler.utilities 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     dup special-interval? [
  38         2drop f f
  39     ] [
  40         dup from>> first {
  41             { [ over interval-length 0 > ] [ 3drop f f ] }
  42             { [ pick bignum class<= ] [ 2nip >bignum t ] }
  43             { [ pick integer class<= ] [ 2nip >fixnum t ] }
  44             { [ pick float class<= ] [ 2nip [ f f ] [ >float t ] if-zero ] }
  45             [ 3drop f f ]
  46         } cond
  47     ] if ;
  48
  49 : <value-info> ( -- info ) \ value-info-state new ; inline
  50
  51 DEFER: <literal-info>
  52
  53 : tuple-slot-infos ( tuple -- slots )
  54     [ tuple-slots ] [ class-of all-slots ] bi
  55     [ read-only>> [ <literal-info> ] [ drop f ] if ] 2map
  56     f prefix ;
  57
  58 UNION: fixed-length array byte-array string ;
  59
  60 : literal-class ( obj -- class )
  61     dup singleton-class? [
  62         class-of dup class? [
  63             drop tuple
  64         ] unless
  65     ] unless ;
  66
  67 : (slots-with-length) ( length class -- slots )
  68     "slots" word-prop length 1 - f <array> swap prefix ;
  69
  70 : slots-with-length ( seq -- slots )
  71     [ length <literal-info> ] [ class-of ] bi (slots-with-length) ;
  72
  73 : init-literal-info ( info -- info )
  74     empty-interval >>interval
  75     dup literal>> literal-class >>class
  76     dup literal>> {
  77         { [ dup real? ] [ [a,a] >>interval ] }
  78         { [ dup tuple? ] [ tuple-slot-infos >>slots ] }
  79         { [ dup fixed-length? ] [ slots-with-length >>slots ] }
  80         [ drop ]
  81     } cond ; inline
  82
  83 : empty-set? ( info -- ? )
  84     {
  85         [ class>> null-class? ]
  86         [ [ interval>> empty-interval? ] [ class>> real class<= ] bi and ]
  87     } 1|| ;
  88
  89 ! Hardcoding classes is kind of a hack.
  90 : min-value ( class -- n )
  91     {
  92         { fixnum [ most-negative-fixnum ] }
  93         { array-capacity [ 0 ] }
  94         { integer-array-capacity [ 0 ] }
  95         [ drop -1/0. ]
  96     } case ;
  97
  98 : max-value ( class -- n )
  99     {
 100         { fixnum [ most-positive-fixnum ] }
 101         { array-capacity [ max-array-capacity ] }
 102         { integer-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         { integer-array-capacity [ array-capacity-interval ] }
 111         [ drop full-interval ]
 112     } case ;
 113
 114 : fix-capacity-class ( class -- class' )
 115     {
 116         { array-capacity fixnum }
 117         { integer-array-capacity integer }
 118     } ?at drop ;
 119
 120 : wrap-interval ( interval class -- interval' )
 121     class-interval 2dup interval-subset? [ drop ] [ nip ] if ;
 122
 123 : init-interval ( info -- info )
 124     dup [ interval>> full-interval or ] [ class>> ] bi wrap-interval >>interval
 125     dup class>> integer class<= [ [ integral-closure ] change-interval ] when ; inline
 126
 127 : init-value-info ( info -- info )
 128     dup literal?>> [
 129         init-literal-info
 130     ] [
 131         dup empty-set? [
 132             null >>class
 133             empty-interval >>interval
 134         ] [
 135             init-interval
 136             dup [ class>> ] [ interval>> ] bi interval>literal
 137             [ >>literal ] [ >>literal? ] bi*
 138             [ fix-capacity-class ] change-class
 139         ] if
 140     ] if ; inline
 141
 142 : <class/interval-info> ( class interval -- info )
 143     <value-info>
 144         swap >>interval
 145         swap >>class
 146     init-value-info ; foldable
 147
 148 : <class-info> ( class -- info )
 149     f <class/interval-info> ; foldable
 150
 151 : <interval-info> ( interval -- info )
 152     <value-info>
 153         real >>class
 154         swap >>interval
 155     init-value-info ; foldable
 156
 157 : <literal-info> ( literal -- info )
 158     <value-info>
 159         swap >>literal
 160         t >>literal?
 161     init-value-info ; foldable
 162
 163 : <sequence-info> ( length class -- info )
 164     <value-info>
 165         over >>class
 166         [ (slots-with-length) ] dip swap >>slots
 167     init-value-info ;
 168
 169 : <tuple-info> ( slots class -- info )
 170     <value-info>
 171         swap >>class
 172         swap >>slots
 173     init-value-info ;
 174
 175 : >literal< ( info -- literal literal? )
 176     [ literal>> ] [ literal?>> ] bi ;
 177
 178 : intersect-literals ( info1 info2 -- literal literal? )
 179     {
 180         { [ dup literal?>> not ] [ drop >literal< ] }
 181         { [ over literal?>> not ] [ nip >literal< ] }
 182         { [ 2dup [ literal>> ] bi@ eql? not ] [ 2drop f f ] }
 183         [ drop >literal< ]
 184     } cond ;
 185
 186 DEFER: value-info-intersect
 187
 188 DEFER: (value-info-intersect)
 189
 190 : intersect-slot ( info1 info2 -- info )
 191     {
 192         { [ dup not ] [ nip ] }
 193         { [ over not ] [ drop ] }
 194         [ (value-info-intersect) ]
 195     } cond ;
 196
 197 : intersect-slots ( info1 info2 -- slots )
 198     [ slots>> ] bi@ {
 199         { [ dup not ] [ drop ] }
 200         { [ over not ] [ nip ] }
 201         [
 202             2dup [ length ] same?
 203             [ [ intersect-slot ] 2map ] [ 2drop f ] if
 204         ]
 205     } cond ;
 206
 207 : (value-info-intersect) ( info1 info2 -- info )
 208     [ <value-info> ] 2dip
 209     {
 210         [ [ class>> ] bi@ class-and >>class ]
 211         [ [ interval>> ] bi@ interval-intersect >>interval ]
 212         [ intersect-literals [ >>literal ] [ >>literal? ] bi* ]
 213         [ intersect-slots >>slots ]
 214     } 2cleave
 215     init-value-info ;
 216
 217 : value-info-intersect ( info1 info2 -- info )
 218     {
 219         { [ dup class>> null-class? ] [ nip ] }
 220         { [ over class>> null-class? ] [ drop ] }
 221         [ (value-info-intersect) ]
 222     } cond ;
 223
 224 : union-literals ( info1 info2 -- literal literal? )
 225     2dup [ literal?>> ] both? [
 226         [ literal>> ] bi@ 2dup eql? [ drop t ] [ 2drop f f ] if
 227     ] [ 2drop f f ] if ;
 228
 229 DEFER: value-info-union
 230
 231 DEFER: (value-info-union)
 232
 233 : union-slot ( info1 info2 -- info )
 234     {
 235         { [ dup not ] [ nip ] }
 236         { [ over not ] [ drop ] }
 237         [ (value-info-union) ]
 238     } cond ;
 239
 240 : union-slots ( info1 info2 -- slots )
 241     [ slots>> ] bi@
 242     2dup [ length ] same?
 243     [ [ union-slot ] 2map ] [ 2drop f ] if ;
 244
 245 : (value-info-union) ( info1 info2 -- info )
 246     [ <value-info> ] 2dip
 247     {
 248         [ [ class>> ] bi@ class-or >>class ]
 249         [ [ interval>> ] bi@ interval-union >>interval ]
 250         [ union-literals [ >>literal ] [ >>literal? ] bi* ]
 251         [ union-slots >>slots ]
 252     } 2cleave
 253     init-value-info ;
 254
 255 : value-info-union ( info1 info2 -- info )
 256     {
 257         { [ dup class>> null-class? ] [ drop ] }
 258         { [ over class>> null-class? ] [ nip ] }
 259         [ (value-info-union) ]
 260     } cond ;
 261
 262 : value-infos-union ( infos -- info )
 263     [ null-info ]
 264     [ [ ] [ value-info-union ] map-reduce ] if-empty ;
 265
 266 : literals<= ( info1 info2 -- ? )
 267     {
 268         { [ dup literal?>> not ] [ 2drop t ] }
 269         { [ over literal?>> not ] [ drop class>> null-class? ] }
 270         [ [ literal>> ] bi@ eql? ]
 271     } cond ;
 272
 273 DEFER: value-info<=
 274
 275 : slots<= ( info1 info2 -- ? )
 276     2dup [ class>> ] bi@ class< [ 2drop t ] [
 277         [ slots>> ] bi@ f pad-tail-shorter [ value-info<= ] 2all?
 278     ] if ;
 279
 280 : value-info<= ( info1 info2 -- ? )
 281     [ [ object-info ] unless* ] bi@
 282     {
 283         [ [ class>> ] bi@ class<= ]
 284         [ [ interval>> ] bi@ interval-subset? ]
 285         [ literals<= ]
 286         [ slots<= ]
 287     } 2&& ;
 288
 289 SYMBOL: value-infos
 290
 291 : value-info* ( value -- info ? )
 292     resolve-copy value-infos get assoc-stack
 293     [ 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 ;
 337
 338 : class-infos ( classes/f -- infos )
 339     [ <class-info> ] map ;
 340
 341 : word>input-infos ( word -- input-infos/f )
 342     "input-classes" word-prop class-infos ;