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

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