basis/compiler/tree/propagation/slots/slots.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.tuple classes.tuple.private combinators
   5 combinators.short-circuit compiler.tree.propagation.info kernel
   6 math sequences slots.private strings words ;
   7 IN: compiler.tree.propagation.slots
   8
   9 : sequence-constructor? ( word -- ? )
  10     { <array> <byte-array> (byte-array) <string> } member-eq? ;
  11
  12 : propagate-sequence-constructor ( #call word -- infos )
  13     [ in-d>> first value-info ]
  14     [ "default-output-classes" word-prop first ] bi*
  15     <sequence-info> 1array ;
  16
  17 : fold-<tuple-boa> ( values class -- info )
  18     [ [ literal>> ] map ] dip slots>tuple
  19     <literal-info> ;
  20
  21 : read-only-slots ( values class -- slots )
  22     all-slots
  23     [ read-only>> [ value-info ] [ drop f ] if ] 2map
  24     f prefix ;
  25
  26 : fold-<tuple-boa>? ( values class -- ? )
  27     [ rest-slice [ dup [ literal?>> ] when ] all? ]
  28     [ identity-tuple class<= not ]
  29     bi* and ;
  30
  31 : (propagate-<tuple-boa>) ( values class -- info )
  32     [ read-only-slots ] keep 2dup fold-<tuple-boa>?
  33     [ [ rest-slice ] dip fold-<tuple-boa> ] [ <tuple-info> ] if ;
  34
  35 : propagate-<tuple-boa> ( #call -- infos )
  36     in-d>> unclip-last
  37     value-info literal>> first (propagate-<tuple-boa>) 1array ;
  38
  39 : read-only-slot? ( n class -- ? )
  40     all-slots [ offset>> = ] with find nip
  41     dup [ read-only>> ] when ;
  42
  43 : literal-info-slot ( slot object -- info/f )
  44     {
  45         [ class-of read-only-slot? ]
  46         [ nip layout-up-to-date? ]
  47         [ swap slot <literal-info> ]
  48     } 2&& ;
  49
  50 : value-info-slot ( slot info -- info' )
  51     {
  52         { [ over 0 = ] [ 2drop fixnum <class-info> ] }
  53         { [ dup literal?>> ] [ literal>> literal-info-slot ] }
  54         [ [ 1 - ] [ slots>> ] bi* ?nth ]
  55     } cond [ object-info ] unless* ;