basis/compiler/tree/propagation/slots/slots.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.tuple classes.tuple.private combinators
   5 combinators.short-circuit compiler.tree.propagation.info kernel
   6 math sequences slots.private strings ;
   7 IN: compiler.tree.propagation.slots
   8
   9 ! Propagation of immutable slots and array lengths
  10
  11 : sequence-constructor? ( word -- ? )
  12     { <array> <byte-array> (byte-array) <string> } member-eq? ;
  13
  14 : constructor-output-class ( word -- class )
  15     {
  16         { <array> array }
  17         { <byte-array> byte-array }
  18         { (byte-array) byte-array }
  19         { <string> string }
  20     } at ;
  21
  22 : propagate-sequence-constructor ( #call word -- infos )
  23     [ in-d>> first value-info ]
  24     [ constructor-output-class ] bi*
  25     <sequence-info> 1array ;
  26
  27 : fold-<tuple-boa> ( values class -- info )
  28     [ [ literal>> ] map ] dip slots>tuple
  29     <literal-info> ;
  30
  31 : read-only-slots ( values class -- slots )
  32     all-slots
  33     [ read-only>> [ value-info ] [ drop f ] if ] 2map
  34     f prefix ;
  35
  36 : fold-<tuple-boa>? ( values class -- ? )
  37     [ rest-slice [ dup [ literal?>> ] when ] all? ]
  38     [ identity-tuple class<= not ]
  39     bi* and ;
  40
  41 : (propagate-<tuple-boa>) ( values class -- info )
  42     [ read-only-slots ] keep 2dup fold-<tuple-boa>?
  43     [ [ rest-slice ] dip fold-<tuple-boa> ] [ <tuple-info> ] if ;
  44
  45 : propagate-<tuple-boa> ( #call -- infos )
  46     in-d>> unclip-last
  47     value-info literal>> first (propagate-<tuple-boa>) 1array ;
  48
  49 : read-only-slot? ( n class -- ? )
  50     all-slots [ offset>> = ] with find nip
  51     dup [ read-only>> ] when ;
  52
  53 : literal-info-slot ( slot object -- info/f )
  54     ! literal-info-slot makes an unsafe call to 'slot'.
  55     ! Check that the layout is up to date to avoid accessing the
  56     ! wrong slot during a compilation unit where reshaping took
  57     ! place. This could happen otherwise because the "slots" word
  58     ! property would reflect the new layout, but instances in the
  59     ! heap would use the old layout since instances are updated
  60     ! immediately after compilation.
  61     {
  62         [ class-of read-only-slot? ]
  63         [ nip layout-up-to-date? ]
  64         [ swap slot <literal-info> ]
  65     } 2&& ;
  66
  67 : length-accessor? ( slot info -- ? )
  68     [ 1 = ] [ length>> ] bi* and ;
  69
  70 : value-info-slot ( slot info -- info' )
  71     {
  72         { [ over 0 = ] [ 2drop fixnum <class-info> ] }
  73         { [ dup literal?>> ] [ literal>> literal-info-slot ] }
  74         [ [ 1 - ] [ slots>> ] bi* ?nth ]
  75     } cond [ object-info ] unless* ;