1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors sequences sequences.private classes.tuple
4 classes.tuple.private kernel effects words quotations namespaces
5 definitions math math.order layouts alien.accessors
6 slots.private arrays byte-arrays inference.dataflow
7 inference.known-words inference.state optimizer.inlining
11 ! Expand memory allocation primitives into simpler constructs
12 ! to simplify the backend.
14 : first-input ( #call -- obj ) dup in-d>> first node-literal ;
16 : (tuple) ( layout -- tuple ) "BUG: missing (tuple) intrinsic" throw ;
18 \ (tuple) { tuple-layout } { tuple } <effect> set-primitive-effect
19 \ (tuple) make-flushable
21 ! if the input to new is a literal tuple class, we can expand it
22 : literal-new? ( #call -- ? )
23 first-input tuple-class? ;
25 : new-quot ( class -- quot )
26 dup all-slots 1 tail ! delegate slot
27 [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make ;
29 : expand-new ( #call -- node )
31 [ +inlined+ depends-on ] [ new-quot ] bi
35 { [ dup literal-new? ] [ expand-new ] }
38 : tuple-boa-quot ( layout -- quot )
42 size>> 1 - [ 3 + ] map <reversed>
43 [ [ set-slot ] curry [ keep ] curry % ] each
44 [ f over 2 set-slot ] %
47 : expand-tuple-boa ( #call -- node )
48 dup in-d>> peek value-literal tuple-boa-quot f splice-quot ;
51 { [ t ] [ expand-tuple-boa ] }
54 : (array) ( n -- array ) "BUG: missing (array) intrinsic" throw ;
56 \ (array) { integer } { array } <effect> set-primitive-effect
57 \ (array) make-flushable
59 : <array>-quot ( n -- quot )
63 [ \ 2dup , , [ swap set-array-nth ] % ] each
67 : literal-<array>? ( #call -- ? )
68 first-input dup integer? [ 0 32 between? ] [ drop f ] if ;
70 : expand-<array> ( #call -- node )
71 dup first-input <array>-quot f splice-quot ;
74 { [ dup literal-<array>? ] [ expand-<array> ] }
77 : (byte-array) ( n -- byte-array ) "BUG: missing (byte-array) intrinsic" throw ;
79 \ (byte-array) { integer } { byte-array } <effect> set-primitive-effect
80 \ (byte-array) make-flushable
82 : bytes>cells ( m -- n ) cell align cell /i ;
84 : <byte-array>-quot ( n -- quot )
87 [ nip (byte-array) ] %
88 bytes>cells [ cell * ] map
89 [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
92 : literal-<byte-array>? ( #call -- ? )
93 first-input dup integer? [ 0 128 between? ] [ drop f ] if ;
95 : expand-<byte-array> ( #call -- node )
96 dup first-input <byte-array>-quot f splice-quot ;
99 { [ dup literal-<byte-array>? ] [ expand-<byte-array> ] }