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
10 : ##set-slots, ( regs obj class -- )
11 '[ _ swap 1 + _ type-number ##set-slot-imm, ] each-index ;
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 ;
18 : tuple-slot-regs ( layout -- vregs )
19 [ second ds-loc load-vregs ] [ ^^load-literal ] bi prefix ;
21 : ^^allot-tuple ( n -- dst )
22 2 + cells tuple ^^allot ;
24 : emit-<tuple-boa> ( block #call -- block' )
25 dup node-input-infos last literal>>
29 [ tuple-slot-regs ] [ second ^^allot-tuple ] bi
30 [ tuple ##set-slots, ] [ ds-push drop ] 2bi
31 ] [ drop emit-primitive ] if ;
33 : store-length ( len reg class -- )
34 [ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm, ;
36 :: store-initial-element ( len reg elt class -- )
37 len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm, ] each-integer ;
39 : expand-<array>? ( obj -- ? )
40 dup integer? [ 0 8 between? ] [ drop f ] if ;
42 : ^^allot-array ( n -- dst )
43 2 + cells array ^^allot ;
45 :: emit-<array> ( block node -- block' )
46 node node-input-infos first literal>> :> len
49 len ^^allot-array :> reg
51 len reg array store-length
52 len reg elt array store-initial-element
54 ] [ block node emit-primitive ] if ;
56 : expand-(byte-array)? ( obj -- ? )
57 dup integer? [ 0 1024 between? ] [ drop f ] if ;
59 : expand-<byte-array>? ( obj -- ? )
60 dup integer? [ 0 32 between? ] [ drop f ] if ;
62 : bytes>cells ( m -- n ) cell align cell /i ;
64 : ^^allot-byte-array ( len -- dst )
65 dup 16 + byte-array ^^allot [ byte-array store-length ] keep ;
67 : emit-allot-byte-array ( len -- dst )
68 ds-drop ^^allot-byte-array dup ds-push ;
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 ;
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,
82 :: emit-<byte-array> ( block #call -- block' )
83 #call node-input-infos first literal>> dup expand-<byte-array>? [
85 len emit-allot-byte-array :> reg
86 len reg zero-byte-array block
87 ] [ drop block #call emit-primitive ] if ;