1 ! Copyright (C) 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.c-types arrays assocs classes.struct
4 combinators compiler.cfg.builder.alien.params compiler.cfg.hats
5 compiler.cfg.instructions compiler.cfg.intrinsics.allot
6 compiler.cfg.registers cpu.architecture fry kernel layouts
7 locals math namespaces sequences system ;
8 QUALIFIED-WITH: alien.c-types c
9 IN: compiler.cfg.builder.alien.boxing
11 SYMBOL: struct-return-area
13 SYMBOLS: int-reg-reps float-reg-reps ;
15 : reg-reps ( reps -- int-reps float-reps )
16 [ second ] reject [ [ first int-rep? ] count ] [ length over - ] bi ;
18 : record-reg-reps ( reps -- reps )
19 dup reg-reps [ int-reg-reps +@ ] [ float-reg-reps +@ ] bi* ;
21 : unrecord-reg-reps ( reps -- reps )
22 dup reg-reps [ neg int-reg-reps +@ ] [ neg float-reg-reps +@ ] bi* ;
24 GENERIC: flatten-c-type ( c-type -- pairs )
26 M: c-type flatten-c-type
27 rep>> f f 3array 1array record-reg-reps ;
29 M: long-long-type flatten-c-type
30 drop 2 [ int-rep long-long-on-stack? f 3array ] replicate record-reg-reps ;
32 HOOK: flatten-struct-type cpu ( type -- pairs )
33 HOOK: flatten-struct-type-return cpu ( type -- pairs )
35 M: object flatten-struct-type
36 heap-size cell align cell /i { int-rep f f } <array> record-reg-reps ;
38 M: struct-c-type flatten-c-type
41 M: object flatten-struct-type-return
44 : stack-size ( c-type -- n )
45 base-type flatten-c-type keys 0 [ rep-size + ] reduce ;
47 : component-offsets ( reps -- offsets )
48 0 [ rep-size + ] accumulate nip ;
50 :: explode-struct ( src c-type -- vregs reps )
51 c-type flatten-struct-type :> reps
52 reps keys dup component-offsets
53 [| rep offset | src offset rep f ^^load-memory-imm ] 2map
56 :: explode-struct-return ( src c-type -- vregs reps )
57 c-type flatten-struct-type-return :> reps
58 reps keys dup component-offsets
59 [| rep offset | src offset rep f ^^load-memory-imm ] 2map
62 :: implode-struct ( src vregs reps -- )
63 vregs reps dup component-offsets
64 [| vreg rep offset | vreg src offset rep f ##store-memory-imm, ] 3each ;
66 GENERIC: unbox ( src c-type -- vregs reps )
69 [ rep>> ] [ unboxer>> ] bi
72 { "to_float" [ drop ] }
73 { "to_double" [ drop ] }
74 { "to_signed_1" [ drop ] }
75 { "to_unsigned_1" [ drop ] }
76 { "to_signed_2" [ drop ] }
77 { "to_unsigned_2" [ drop ] }
78 { "to_signed_4" [ drop ] }
79 { "to_unsigned_4" [ drop ] }
80 { "alien_offset" [ drop ^^unbox-any-c-ptr ] }
84 [ drop f f 3array 1array ] 2bi record-reg-reps ;
86 M: long-long-type unbox
87 [ next-vreg next-vreg 2dup ] 2dip unboxer>> ##unbox-long-long, 2array
88 int-rep long-long-on-stack? long-long-odd-register? 3array
89 int-rep long-long-on-stack? f 3array 2array record-reg-reps ;
91 M: struct-c-type unbox
92 [ ^^unbox-any-c-ptr ] dip explode-struct ;
94 : frob-struct ( c-type -- c-type )
95 dup value-struct? [ drop void* base-type ] unless ;
97 GENERIC: unbox-parameter ( src c-type -- vregs reps )
99 M: c-type unbox-parameter unbox ;
101 M: long-long-type unbox-parameter unbox ;
103 M: struct-c-type unbox-parameter
104 dup value-struct? [ unbox ] [
105 [ nip heap-size cell f ^^local-allot dup ]
106 [ [ ^^unbox-any-c-ptr ] dip explode-struct keys ] 2bi
108 1array { { int-rep f f } }
111 : store-return ( vregs reps -- triples )
112 [ [ dup next-return-reg 3array ] 2map ] with-return-regs ;
114 GENERIC: unbox-return ( src c-type -- vregs reps )
116 M: abstract-c-type unbox-return
117 ! Don't care about on-stack? flag when looking at return
121 M: struct-c-type unbox-return
122 dup return-struct-in-registers?
124 [ [ struct-return-area get ] 2dip unbox keys implode-struct { } { } ] if ;
126 GENERIC: flatten-parameter-type ( c-type -- reps )
128 M: abstract-c-type flatten-parameter-type flatten-c-type ;
130 M: struct-c-type flatten-parameter-type frob-struct flatten-c-type ;
132 GENERIC: box ( vregs reps c-type -- dst )
135 [ [ first ] bi@ ] [ boxer>> ] bi*
137 { "from_float" [ drop ] }
138 { "from_double" [ drop ] }
139 { "from_signed_1" [ drop c:char ^^convert-integer ] }
140 { "from_unsigned_1" [ drop c:uchar ^^convert-integer ] }
141 { "from_signed_2" [ drop c:short ^^convert-integer ] }
142 { "from_unsigned_2" [ drop c:ushort ^^convert-integer ] }
143 { "from_signed_4" [ drop c:int ^^convert-integer ] }
144 { "from_unsigned_4" [ drop c:uint ^^convert-integer ] }
145 { "allot_alien" [ drop ^^box-alien ] }
146 [ swap <gc-map> ^^box ]
149 M: long-long-type box
150 [ first2 ] [ drop ] [ boxer>> ] tri*
151 <gc-map> ^^box-long-long ;
154 '[ _ heap-size ^^allot-byte-array dup ^^unbox-byte-array ] 2dip
157 GENERIC: box-parameter ( vregs reps c-type -- dst )
159 M: abstract-c-type box-parameter box ;
161 M: struct-c-type box-parameter
163 [ [ [ drop first ] dip explode-struct keys ] keep ] unless
166 GENERIC: load-return ( c-type -- triples )
168 M: abstract-c-type load-return
171 [ [ next-vreg ] dip dup next-return-reg 3array ] map
174 M: struct-c-type load-return
175 dup return-struct-in-registers?
176 [ call-next-method ] [ drop { } ] if ;
178 GENERIC: box-return ( vregs reps c-type -- dst )
180 M: abstract-c-type box-return box ;
182 M: struct-c-type box-return
183 dup return-struct-in-registers?
187 [ [ { } assert-sequence= ] bi@ struct-return-area get ] dip
188 explode-struct-return keys