basis/compiler/cfg/intrinsics/allot/allot.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel math math.order sequences accessors arrays
   4 byte-arrays layouts classes.tuple.private fry locals
   5 compiler.tree.propagation.info compiler.cfg.hats
   6 compiler.cfg.instructions compiler.cfg.stacks
   7 compiler.cfg.utilities compiler.cfg.builder.blocks ;
   8 IN: compiler.cfg.intrinsics.allot
   9
  10 : ##set-slots ( regs obj class -- )
  11     '[ _ swap 1 + _ tag-number ##set-slot-imm ] each-index ;
  12
  13 : emit-simple-allot ( node -- )
  14     [ in-d>> length ] [ node-output-infos first class>> ] bi
  15     [ drop ds-load ] [ [ 1 + cells ] dip ^^allot ] [ nip ] 2tri
  16     [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
  17
  18 : tuple-slot-regs ( layout -- vregs )
  19     [ second ds-load ] [ ^^load-literal ] bi prefix ;
  20
  21 : emit-<tuple-boa> ( node -- )
  22     dup node-input-infos last literal>>
  23     dup array? [
  24         nip
  25         ds-drop
  26         [ tuple-slot-regs ] [ second ^^allot-tuple ] bi
  27         [ tuple ##set-slots ] [ ds-push drop ] 2bi
  28     ] [ drop emit-primitive ] if ;
  29
  30 : store-length ( len reg class -- )
  31     [ [ ^^load-literal ] dip 1 ] dip tag-number ##set-slot-imm ;
  32
  33 :: store-initial-element ( len reg elt class -- )
  34     len [ [ elt reg ] dip 2 + class tag-number ##set-slot-imm ] each ;
  35
  36 : expand-<array>? ( obj -- ? )
  37     dup integer? [ 0 8 between? ] [ drop f ] if ;
  38
  39 :: emit-<array> ( node -- )
  40     [let | len [ node node-input-infos first literal>> ] |
  41         len expand-<array>? [
  42             [let | elt [ ds-pop ]
  43                    reg [ len ^^allot-array ] |
  44                 ds-drop
  45                 len reg array store-length
  46                 len reg elt array store-initial-element
  47                 reg ds-push
  48             ]
  49         ] [ node emit-primitive ] if
  50     ] ;
  51
  52 : expand-<byte-array>? ( obj -- ? )
  53     dup integer? [ 0 32 between? ] [ drop f ] if ;
  54
  55 : bytes>cells ( m -- n ) cell align cell /i ;
  56
  57 : emit-allot-byte-array ( len -- dst )
  58     ds-drop
  59     dup ^^allot-byte-array
  60     [ byte-array store-length ] [ ds-push ] [ ] tri ;
  61
  62 : emit-(byte-array) ( node -- )
  63     dup node-input-infos first literal>> dup expand-<byte-array>?
  64     [ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ;
  65
  66 :: emit-<byte-array> ( node -- )
  67     node node-input-infos first literal>> dup expand-<byte-array>? [
  68         :> len
  69         0 ^^load-literal :> elt
  70         len emit-allot-byte-array :> reg
  71         len reg elt byte-array store-initial-element
  72     ] [ drop node emit-primitive ] if ;