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

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays byte-arrays compiler.cfg
   4 compiler.cfg.builder.blocks compiler.cfg.hats
   5 compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks
   6 compiler.constants compiler.tree.propagation.info cpu.architecture fry
   7 kernel layouts locals math math.order namespaces sequences ;
   8 IN: compiler.cfg.intrinsics.allot
   9
  10 : ##set-slots, ( regs obj class -- )
  11     '[ _ swap 1 + _ type-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-loc load-vregs ] [ [ 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-loc load-vregs ] [ ^^load-literal ] bi prefix ;
  20
  21 : ^^allot-tuple ( n -- dst )
  22     2 + cells tuple ^^allot ;
  23
  24 : emit-<tuple-boa> ( block #call -- block' )
  25     dup node-input-infos last literal>>
  26     dup array? [
  27         nip
  28         ds-drop
  29         [ tuple-slot-regs ] [ second ^^allot-tuple ] bi
  30         [ tuple ##set-slots, ] [ ds-push drop ] 2bi
  31     ] [ drop emit-primitive ] if ;
  32
  33 : store-length ( len reg class -- )
  34     [ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm, ;
  35
  36 :: store-initial-element ( len reg elt class -- )
  37     len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm, ] each-integer ;
  38
  39 : expand-<array>? ( obj -- ? )
  40     dup integer? [ 0 8 between? ] [ drop f ] if ;
  41
  42 : ^^allot-array ( n -- dst )
  43     2 + cells array ^^allot ;
  44
  45 :: emit-<array> ( block node -- block' )
  46     node node-input-infos first literal>> :> len
  47     len expand-<array>? [
  48         ds-pop :> elt
  49         len ^^allot-array :> reg
  50         ds-drop
  51         len reg array store-length
  52         len reg elt array store-initial-element
  53         reg ds-push block
  54     ] [ block node emit-primitive ] if ;
  55
  56 : expand-(byte-array)? ( obj -- ? )
  57     dup integer? [ 0 1024 between? ] [ drop f ] if ;
  58
  59 : expand-<byte-array>? ( obj -- ? )
  60     dup integer? [ 0 32 between? ] [ drop f ] if ;
  61
  62 : bytes>cells ( m -- n ) cell align cell /i ;
  63
  64 : ^^allot-byte-array ( len -- dst )
  65     dup 16 + byte-array ^^allot [ byte-array store-length ] keep ;
  66
  67 : emit-allot-byte-array ( len -- dst )
  68     ds-drop ^^allot-byte-array dup ds-push ;
  69
  70 : emit-(byte-array) ( block node -- block' )
  71     dup node-input-infos first literal>> dup expand-(byte-array)? [
  72         nip emit-allot-byte-array drop
  73     ] [ drop emit-primitive ] if ;
  74
  75 :: zero-byte-array ( len reg -- )
  76     0 ^^load-literal :> elt
  77     reg ^^tagged>integer :> reg
  78     len cell align cell /i <iota> [
  79         [ elt reg ] dip cells byte-array-offset + int-rep f ##store-memory-imm,
  80     ] each ;
  81
  82 :: emit-<byte-array> ( block #call -- block' )
  83     #call node-input-infos first literal>> dup expand-<byte-array>? [
  84         :> len
  85         len emit-allot-byte-array :> reg
  86         len reg zero-byte-array block
  87     ] [ drop block #call emit-primitive ] if ;