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

   1 ! Copyright (C) 2008, 2009 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 UNION: fixed-length-sequence array byte-array string ;
  12
  13 : sequence-constructor? ( word -- ? )
  14     { <array> <byte-array> (byte-array) <string> } memq? ;
  15
  16 : constructor-output-class ( word -- class )
  17     {
  18         { <array> array }
  19         { <byte-array> byte-array }
  20         { (byte-array) byte-array }
  21         { <string> string }
  22     } at ;
  23
  24 : propagate-sequence-constructor ( #call word -- infos )
  25     [ in-d>> first <sequence-info> ]
  26     [ constructor-output-class <class-info> ]
  27     bi* value-info-intersect 1array ;
  28
  29 : fold-<tuple-boa> ( values class -- info )
  30     [ [ literal>> ] map ] dip prefix >tuple
  31     <literal-info> ;
  32
  33 : read-only-slots ( values class -- slots )
  34     all-slots
  35     [ read-only>> [ value-info ] [ drop f ] if ] 2map
  36     f prefix ;
  37
  38 : (propagate-tuple-constructor) ( values class -- info )
  39     [ read-only-slots ] keep
  40     over rest-slice [ dup [ literal?>> ] when ] all? [
  41         [ rest-slice ] dip fold-<tuple-boa>
  42     ] [
  43         <tuple-info>
  44     ] if ;
  45
  46 : propagate-<tuple-boa> ( #call -- infos )
  47     in-d>> unclip-last
  48     value-info literal>> first (propagate-tuple-constructor) 1array ;
  49
  50 : read-only-slot? ( n class -- ? )
  51     all-slots [ offset>> = ] with find nip
  52     dup [ read-only>> ] when ;
  53
  54 : literal-info-slot ( slot object -- info/f )
  55     2dup class read-only-slot?
  56     [ swap slot <literal-info> ] [ 2drop f ] if ;
  57
  58 : length-accessor? ( slot info -- ? )
  59     [ 1 = ] [ length>> ] bi* and ;
  60
  61 : value-info-slot ( slot info -- info' )
  62     {
  63         { [ over 0 = ] [ 2drop fixnum <class-info> ] }
  64         { [ 2dup length-accessor? ] [ nip length>> ] }
  65         { [ dup literal?>> ] [ literal>> literal-info-slot ] }
  66         [ [ 1 - ] [ slots>> ] bi* ?nth ]
  67     } cond [ object-info ] unless* ;