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
10 : ##set-slots ( regs obj class -- )
11 '[ _ swap 1 + _ tag-number ##set-slot-imm ] each-index ;
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 ;
18 : tuple-slot-regs ( layout -- vregs )
19 [ second ds-load ] [ ^^load-literal ] bi prefix ;
21 : emit-<tuple-boa> ( node -- )
22 dup node-input-infos last literal>>
26 [ tuple-slot-regs ] [ second ^^allot-tuple ] bi
27 [ tuple ##set-slots ] [ ds-push drop ] 2bi
28 ] [ drop emit-primitive ] if ;
30 : store-length ( len reg class -- )
31 [ [ ^^load-literal ] dip 1 ] dip tag-number ##set-slot-imm ;
33 :: store-initial-element ( len reg elt class -- )
34 len [ [ elt reg ] dip 2 + class tag-number ##set-slot-imm ] each ;
36 : expand-<array>? ( obj -- ? )
37 dup integer? [ 0 8 between? ] [ drop f ] if ;
39 :: emit-<array> ( node -- )
40 [let | len [ node node-input-infos first literal>> ] |
43 reg [ len ^^allot-array ] |
45 len reg array store-length
46 len reg elt array store-initial-element
49 ] [ node emit-primitive ] if
52 : expand-<byte-array>? ( obj -- ? )
53 dup integer? [ 0 32 between? ] [ drop f ] if ;
55 : bytes>cells ( m -- n ) cell align cell /i ;
57 : emit-allot-byte-array ( len -- dst )
59 dup ^^allot-byte-array
60 [ byte-array store-length ] [ ds-push ] [ ] tri ;
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 ;
66 :: emit-<byte-array> ( node -- )
67 node node-input-infos first literal>> dup expand-<byte-array>? [
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 ;