basis/compiler/tree/propagation/slots/slots.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: fry assocs arrays byte-arrays strings accessors sequences
   4 kernel slots classes.algebra classes.tuple classes.tuple.private
   5 words math math.private combinators sequences.private namespaces
   6 slots.private classes compiler.tree.propagation.info ;
   7 IN: compiler.tree.propagation.slots
   8
   9 ! Propagation of immutable slots and array lengths
  10
  11 ! Revisit this code when delegation is removed and when complex
  12 ! numbers become tuples.
  13
  14 UNION: fixed-length-sequence array byte-array string ;
  15
  16 : sequence-constructor? ( word -- ? )
  17     { <array> <byte-array> <string> } memq? ;
  18
  19 : constructor-output-class ( word -- class )
  20     {
  21         { <array> array }
  22         { <byte-array> byte-array }
  23         { <string> string }
  24     } at ;
  25
  26 : propagate-sequence-constructor ( #call word -- infos )
  27     [ in-d>> first <sequence-info> ]
  28     [ constructor-output-class <class-info> ]
  29     bi* value-info-intersect 1array ;
  30
  31 : tuple-constructor? ( word -- ? )
  32     { <tuple-boa> <complex> } memq? ;
  33
  34 : read-only-slots ( values class -- slots )
  35     #! Delegation.
  36     all-slots rest-slice
  37     [ read-only>> [ drop f ] unless ] 2map
  38     { f f } prepend ;
  39
  40 : fold-<tuple-boa> ( values class -- info )
  41     [ , f , [ literal>> ] map % ] { } make >tuple
  42     <literal-info> ;
  43
  44 : (propagate-tuple-constructor) ( values class -- info )
  45     [ [ value-info ] map ] dip [ read-only-slots ] keep
  46     over 2 tail-slice [ dup [ literal?>> ] when ] all? [
  47         [ 2 tail-slice ] dip fold-<tuple-boa>
  48     ] [
  49         <tuple-info>
  50     ] if ;
  51
  52 : propagate-<tuple-boa> ( #call -- info )
  53     #! Delegation
  54     in-d>> unclip-last
  55     value-info literal>> class>> (propagate-tuple-constructor) ;
  56
  57 : propagate-<complex> ( #call -- info )
  58     in-d>> [ value-info ] map complex <tuple-info> ;
  59
  60 : propagate-tuple-constructor ( #call word -- infos )
  61     {
  62         { \ <tuple-boa> [ propagate-<tuple-boa> ] }
  63         { \ <complex> [ propagate-<complex> ] }
  64     } case 1array ;
  65
  66 : read-only-slot? ( n class -- ? )
  67     all-slots [ offset>> = ] with find nip
  68     dup [ read-only>> ] when ;
  69
  70 : literal-info-slot ( slot object -- info/f )
  71     2dup class read-only-slot?
  72     [ swap slot <literal-info> ] [ 2drop f ] if ;
  73
  74 : length-accessor? ( slot info -- ? )
  75     [ 1 = ] [ length>> ] bi* and ;
  76
  77 : value-info-slot ( slot info -- info' )
  78     #! Delegation.
  79     {
  80         { [ over 0 = ] [ 2drop fixnum <class-info> ] }
  81         { [ 2dup length-accessor? ] [ nip length>> ] }
  82         { [ dup literal?>> ] [ literal>> literal-info-slot ] }
  83         [ [ 1- ] [ slots>> ] bi* ?nth ]
  84     } cond [ object-info ] unless* ;