File: | heap.c |
Warning: | line 234, column 19 Access to field 'data' results in a dereference of a null pointer (loaded from variable 'array') |
Press '?' to see keyboard shortcuts
Keyboard shortcuts:
1 | /* | |||
2 | Copyright 2018, 2020, 2022 - 2024 Joel Svensson svenssonjoel@yahoo.se | |||
3 | 2022 Benjamin Vedder | |||
4 | ||||
5 | This program is free software: you can redistribute it and/or modify | |||
6 | it under the terms of the GNU General Public License as published by | |||
7 | the Free Software Foundation, either version 3 of the License, or | |||
8 | (at your option) any later version. | |||
9 | ||||
10 | This program is distributed in the hope that it will be useful, | |||
11 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |||
12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |||
13 | GNU General Public License for more details. | |||
14 | ||||
15 | You should have received a copy of the GNU General Public License | |||
16 | along with this program. If not, see <http://www.gnu.org/licenses/>. | |||
17 | */ | |||
18 | ||||
19 | #include <stdio.h> | |||
20 | #include <stdlib.h> | |||
21 | #include <stdint.h> | |||
22 | #include <stdarg.h> | |||
23 | #include <inttypes.h> | |||
24 | #include <lbm_memory.h> | |||
25 | #include <lbm_custom_type.h> | |||
26 | ||||
27 | #include "heap.h" | |||
28 | #include "symrepr.h" | |||
29 | #include "stack.h" | |||
30 | #include "lbm_channel.h" | |||
31 | #include "platform_mutex.h" | |||
32 | #include "eval_cps.h" | |||
33 | #ifdef VISUALIZE_HEAP | |||
34 | #include "heap_vis.h" | |||
35 | #endif | |||
36 | ||||
37 | ||||
38 | static inline lbm_value lbm_set_gc_mark(lbm_value x) { | |||
39 | return x | LBM_GC_MARKED0x00000002u; | |||
40 | } | |||
41 | ||||
42 | static inline lbm_value lbm_clr_gc_mark(lbm_value x) { | |||
43 | return x & ~LBM_GC_MASK0x00000002u; | |||
44 | } | |||
45 | ||||
46 | static inline bool_Bool lbm_get_gc_mark(lbm_value x) { | |||
47 | return x & LBM_GC_MASK0x00000002u; | |||
48 | } | |||
49 | ||||
50 | // flag is the same bit as mark, but in car | |||
51 | static inline bool_Bool lbm_get_gc_flag(lbm_value x) { | |||
52 | return x & LBM_GC_MARKED0x00000002u; | |||
53 | } | |||
54 | ||||
55 | static inline lbm_value lbm_set_gc_flag(lbm_value x) { | |||
56 | return x | LBM_GC_MARKED0x00000002u; | |||
57 | } | |||
58 | ||||
59 | static inline lbm_value lbm_clr_gc_flag(lbm_value x) { | |||
60 | return x & ~LBM_GC_MASK0x00000002u; | |||
61 | } | |||
62 | ||||
63 | ||||
64 | lbm_heap_state_t lbm_heap_state; | |||
65 | ||||
66 | lbm_const_heap_t *lbm_const_heap_state; | |||
67 | ||||
68 | lbm_cons_t *lbm_heaps[2] = {NULL((void*)0), NULL((void*)0)}; | |||
69 | ||||
70 | static mutex_t lbm_const_heap_mutex; | |||
71 | static bool_Bool lbm_const_heap_mutex_initialized = false0; | |||
72 | ||||
73 | static mutex_t lbm_mark_mutex; | |||
74 | static bool_Bool lbm_mark_mutex_initialized = false0; | |||
75 | ||||
76 | #ifdef USE_GC_PTR_REV | |||
77 | void lbm_gc_lock(void) { | |||
78 | mutex_lock(&lbm_mark_mutex); | |||
79 | } | |||
80 | void lbm_gc_unlock(void) { | |||
81 | mutex_unlock(&lbm_mark_mutex); | |||
82 | } | |||
83 | #else | |||
84 | void lbm_gc_lock(void) { | |||
85 | } | |||
86 | void lbm_gc_unlock(void) { | |||
87 | } | |||
88 | #endif | |||
89 | ||||
90 | /****************************************************/ | |||
91 | /* ENCODERS DECODERS */ | |||
92 | ||||
93 | lbm_value lbm_enc_i32(int32_t x) { | |||
94 | #ifndef LBM64 | |||
95 | lbm_value i = lbm_cons((lbm_uint)x, ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u)); | |||
96 | if (lbm_type_of(i) == LBM_TYPE_SYMBOL0x00000000u) return i; | |||
97 | return lbm_set_ptr_type(i, LBM_TYPE_I320x28000000u); | |||
98 | #else | |||
99 | return (((lbm_uint)x) << LBM_VAL_SHIFT4) | LBM_TYPE_I320x28000000u; | |||
100 | #endif | |||
101 | } | |||
102 | ||||
103 | lbm_value lbm_enc_u32(uint32_t x) { | |||
104 | #ifndef LBM64 | |||
105 | lbm_value u = lbm_cons(x, ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u)); | |||
106 | if (lbm_type_of(u) == LBM_TYPE_SYMBOL0x00000000u) return u; | |||
107 | return lbm_set_ptr_type(u, LBM_TYPE_U320x38000000u); | |||
108 | #else | |||
109 | return (((lbm_uint)x) << LBM_VAL_SHIFT4) | LBM_TYPE_U320x38000000u; | |||
110 | #endif | |||
111 | } | |||
112 | ||||
113 | lbm_value lbm_enc_float(float x) { | |||
114 | #ifndef LBM64 | |||
115 | lbm_uint t; | |||
116 | memcpy(&t, &x, sizeof(lbm_float)); | |||
117 | lbm_value f = lbm_cons(t, ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u)); | |||
118 | if (lbm_type_of(f) == LBM_TYPE_SYMBOL0x00000000u) return f; | |||
119 | return lbm_set_ptr_type(f, LBM_TYPE_FLOAT0x68000000u); | |||
120 | #else | |||
121 | lbm_uint t = 0; | |||
122 | memcpy(&t, &x, sizeof(float)); | |||
123 | return (((lbm_uint)t) << LBM_VAL_SHIFT4) | LBM_TYPE_FLOAT0x68000000u; | |||
124 | #endif | |||
125 | } | |||
126 | ||||
127 | static lbm_value enc_64_on_32(uint8_t *source, lbm_uint type_qual, lbm_uint type) { | |||
128 | lbm_value res = ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u); | |||
129 | res = lbm_cons(ENC_SYM_NIL(((0x0) << 4) | 0x00000000u),ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); | |||
130 | if (lbm_type_of(res) != LBM_TYPE_SYMBOL0x00000000u) { | |||
131 | uint8_t* storage = lbm_malloc(sizeof(uint64_t)); | |||
132 | if (storage) { | |||
133 | memcpy(storage,source, sizeof(uint64_t)); | |||
134 | lbm_set_car_and_cdr(res, (lbm_uint)storage, type_qual); | |||
135 | res = lbm_set_ptr_type(res, type); | |||
136 | } else { | |||
137 | res = ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u); | |||
138 | } | |||
139 | } | |||
140 | return res; | |||
141 | } | |||
142 | ||||
143 | lbm_value lbm_enc_i64(int64_t x) { | |||
144 | #ifndef LBM64 | |||
145 | return enc_64_on_32((uint8_t *)&x, ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u), LBM_TYPE_I640x48000000u); | |||
146 | #else | |||
147 | lbm_value u = lbm_cons((uint64_t)x, ENC_SYM_RAW_I_TYPE(((0x31) << 4) | 0x00000000u)); | |||
148 | if (lbm_type_of(u) == LBM_TYPE_SYMBOL0x00000000u) return u; | |||
149 | return lbm_set_ptr_type(u, LBM_TYPE_I640x48000000u); | |||
150 | #endif | |||
151 | } | |||
152 | ||||
153 | lbm_value lbm_enc_u64(uint64_t x) { | |||
154 | #ifndef LBM64 | |||
155 | return enc_64_on_32((uint8_t *)&x, ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u), LBM_TYPE_U640x58000000u); | |||
156 | #else | |||
157 | lbm_value u = lbm_cons(x, ENC_SYM_RAW_U_TYPE(((0x32) << 4) | 0x00000000u)); | |||
158 | if (lbm_type_of(u) == LBM_TYPE_SYMBOL0x00000000u) return u; | |||
159 | return lbm_set_ptr_type(u, LBM_TYPE_U640x58000000u); | |||
160 | #endif | |||
161 | } | |||
162 | ||||
163 | lbm_value lbm_enc_double(double x) { | |||
164 | #ifndef LBM64 | |||
165 | return enc_64_on_32((uint8_t *)&x, ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u), LBM_TYPE_DOUBLE0x78000000u); | |||
166 | #else | |||
167 | lbm_uint t; | |||
168 | memcpy(&t, &x, sizeof(double)); | |||
169 | lbm_value f = lbm_cons(t, ENC_SYM_RAW_F_TYPE(((0x33) << 4) | 0x00000000u)); | |||
170 | if (lbm_type_of(f) == LBM_TYPE_SYMBOL0x00000000u) return f; | |||
171 | return lbm_set_ptr_type(f, LBM_TYPE_DOUBLE0x78000000u); | |||
172 | #endif | |||
173 | } | |||
174 | ||||
175 | // Type specific (as opposed to the dec_as_X) functions | |||
176 | // should only be run on values KNOWN to represent a value of the type | |||
177 | // that the decoder decodes. | |||
178 | ||||
179 | float lbm_dec_float(lbm_value x) { | |||
180 | #ifndef LBM64 | |||
181 | float f_tmp; | |||
182 | lbm_uint tmp = lbm_car(x); | |||
183 | memcpy(&f_tmp, &tmp, sizeof(float)); | |||
184 | return f_tmp; | |||
185 | #else | |||
186 | uint32_t tmp = (uint32_t)(x >> LBM_VAL_SHIFT4); | |||
187 | float f_tmp; | |||
188 | memcpy(&f_tmp, &tmp, sizeof(float)); | |||
189 | return f_tmp; | |||
190 | #endif | |||
191 | } | |||
192 | ||||
193 | double lbm_dec_double(lbm_value x) { | |||
194 | #ifndef LBM64 | |||
195 | double d; | |||
196 | uint32_t *data = (uint32_t*)lbm_car(x); | |||
197 | memcpy(&d, data, sizeof(double)); | |||
198 | return d; | |||
199 | #else | |||
200 | double f_tmp; | |||
201 | lbm_uint tmp = lbm_car(x); | |||
202 | memcpy(&f_tmp, &tmp, sizeof(double)); | |||
203 | return f_tmp; | |||
204 | #endif | |||
205 | } | |||
206 | ||||
207 | uint64_t lbm_dec_u64(lbm_value x) { | |||
208 | #ifndef LBM64 | |||
209 | uint64_t u; | |||
210 | uint32_t *data = (uint32_t*)lbm_car(x); | |||
211 | memcpy(&u, data, 8); | |||
212 | return u; | |||
213 | #else | |||
214 | return (uint64_t)lbm_car(x); | |||
215 | #endif | |||
216 | } | |||
217 | ||||
218 | int64_t lbm_dec_i64(lbm_value x) { | |||
219 | #ifndef LBM64 | |||
220 | int64_t i; | |||
221 | uint32_t *data = (uint32_t*)lbm_car(x); | |||
222 | memcpy(&i, data, 8); | |||
223 | return i; | |||
224 | #else | |||
225 | return (int64_t)lbm_car(x); | |||
226 | #endif | |||
227 | } | |||
228 | ||||
229 | char *lbm_dec_str(lbm_value val) { | |||
230 | char *res = 0; | |||
231 | // If val is an array, car of val will be non-null. | |||
232 | if (lbm_is_array_r(val)) { | |||
| ||||
233 | lbm_array_header_t *array = (lbm_array_header_t *)lbm_car(val); | |||
234 | res = (char *)array->data; | |||
| ||||
235 | } | |||
236 | return res; | |||
237 | } | |||
238 | ||||
239 | lbm_char_channel_t *lbm_dec_channel(lbm_value val) { | |||
240 | lbm_char_channel_t *res = NULL((void*)0); | |||
241 | ||||
242 | if (lbm_type_of(val) == LBM_TYPE_CHANNEL0x90000000u) { | |||
243 | res = (lbm_char_channel_t *)lbm_car(val); | |||
244 | } | |||
245 | return res; | |||
246 | } | |||
247 | ||||
248 | lbm_uint lbm_dec_custom(lbm_value val) { | |||
249 | lbm_uint res = 0; | |||
250 | if (lbm_type_of(val) == LBM_TYPE_CUSTOM0xA0000000u) { | |||
251 | res = (lbm_uint)lbm_car(val); | |||
252 | } | |||
253 | return res; | |||
254 | } | |||
255 | ||||
256 | uint8_t lbm_dec_as_char(lbm_value a) { | |||
257 | switch (lbm_type_of_functional(a)) { | |||
258 | case LBM_TYPE_CHAR0x00000004u: | |||
259 | return (uint8_t) lbm_dec_char(a); | |||
260 | case LBM_TYPE_I0x00000008u: | |||
261 | return (uint8_t) lbm_dec_i(a); | |||
262 | case LBM_TYPE_U0x0000000Cu: | |||
263 | return (uint8_t) lbm_dec_u(a); | |||
264 | case LBM_TYPE_I320x28000000u: | |||
265 | return (uint8_t) lbm_dec_i32(a); | |||
266 | case LBM_TYPE_U320x38000000u: | |||
267 | return (uint8_t) lbm_dec_u32(a); | |||
268 | case LBM_TYPE_FLOAT0x68000000u: | |||
269 | return (uint8_t)lbm_dec_float(a); | |||
270 | case LBM_TYPE_I640x48000000u: | |||
271 | return (uint8_t) lbm_dec_i64(a); | |||
272 | case LBM_TYPE_U640x58000000u: | |||
273 | return (uint8_t) lbm_dec_u64(a); | |||
274 | case LBM_TYPE_DOUBLE0x78000000u: | |||
275 | return (uint8_t) lbm_dec_double(a); | |||
276 | } | |||
277 | return 0; | |||
278 | } | |||
279 | ||||
280 | uint32_t lbm_dec_as_u32(lbm_value a) { | |||
281 | switch (lbm_type_of_functional(a)) { | |||
282 | case LBM_TYPE_CHAR0x00000004u: | |||
283 | return (uint32_t) lbm_dec_char(a); | |||
284 | case LBM_TYPE_I0x00000008u: | |||
285 | return (uint32_t) lbm_dec_i(a); | |||
286 | case LBM_TYPE_U0x0000000Cu: | |||
287 | return (uint32_t) lbm_dec_u(a); | |||
288 | case LBM_TYPE_I320x28000000u: /* fall through */ | |||
289 | case LBM_TYPE_U320x38000000u: | |||
290 | return (uint32_t) lbm_dec_u32(a); | |||
291 | case LBM_TYPE_FLOAT0x68000000u: | |||
292 | return (uint32_t)lbm_dec_float(a); | |||
293 | case LBM_TYPE_I640x48000000u: | |||
294 | return (uint32_t) lbm_dec_i64(a); | |||
295 | case LBM_TYPE_U640x58000000u: | |||
296 | return (uint32_t) lbm_dec_u64(a); | |||
297 | case LBM_TYPE_DOUBLE0x78000000u: | |||
298 | return (uint32_t) lbm_dec_double(a); | |||
299 | } | |||
300 | return 0; | |||
301 | } | |||
302 | ||||
303 | int32_t lbm_dec_as_i32(lbm_value a) { | |||
304 | switch (lbm_type_of_functional(a)) { | |||
305 | case LBM_TYPE_CHAR0x00000004u: | |||
306 | return (int32_t) lbm_dec_char(a); | |||
307 | case LBM_TYPE_I0x00000008u: | |||
308 | return (int32_t) lbm_dec_i(a); | |||
309 | case LBM_TYPE_U0x0000000Cu: | |||
310 | return (int32_t) lbm_dec_u(a); | |||
311 | case LBM_TYPE_I320x28000000u: | |||
312 | return (int32_t) lbm_dec_i32(a); | |||
313 | case LBM_TYPE_U320x38000000u: | |||
314 | return (int32_t) lbm_dec_u32(a); | |||
315 | case LBM_TYPE_FLOAT0x68000000u: | |||
316 | return (int32_t) lbm_dec_float(a); | |||
317 | case LBM_TYPE_I640x48000000u: | |||
318 | return (int32_t) lbm_dec_i64(a); | |||
319 | case LBM_TYPE_U640x58000000u: | |||
320 | return (int32_t) lbm_dec_u64(a); | |||
321 | case LBM_TYPE_DOUBLE0x78000000u: | |||
322 | return (int32_t) lbm_dec_double(a); | |||
323 | ||||
324 | } | |||
325 | return 0; | |||
326 | } | |||
327 | ||||
328 | int64_t lbm_dec_as_i64(lbm_value a) { | |||
329 | switch (lbm_type_of_functional(a)) { | |||
330 | case LBM_TYPE_CHAR0x00000004u: | |||
331 | return (int64_t) lbm_dec_char(a); | |||
332 | case LBM_TYPE_I0x00000008u: | |||
333 | return lbm_dec_i(a); | |||
334 | case LBM_TYPE_U0x0000000Cu: | |||
335 | return (int64_t) lbm_dec_u(a); | |||
336 | case LBM_TYPE_I320x28000000u: | |||
337 | return (int64_t) lbm_dec_i32(a); | |||
338 | case LBM_TYPE_U320x38000000u: | |||
339 | return (int64_t) lbm_dec_u32(a); | |||
340 | case LBM_TYPE_FLOAT0x68000000u: | |||
341 | return (int64_t) lbm_dec_float(a); | |||
342 | case LBM_TYPE_I640x48000000u: | |||
343 | return (int64_t) lbm_dec_i64(a); | |||
344 | case LBM_TYPE_U640x58000000u: | |||
345 | return (int64_t) lbm_dec_u64(a); | |||
346 | case LBM_TYPE_DOUBLE0x78000000u: | |||
347 | return (int64_t) lbm_dec_double(a); | |||
348 | } | |||
349 | return 0; | |||
350 | } | |||
351 | ||||
352 | uint64_t lbm_dec_as_u64(lbm_value a) { | |||
353 | switch (lbm_type_of_functional(a)) { | |||
354 | case LBM_TYPE_CHAR0x00000004u: | |||
355 | return (uint64_t) lbm_dec_char(a); | |||
356 | case LBM_TYPE_I0x00000008u: | |||
357 | return (uint64_t) lbm_dec_i(a); | |||
358 | case LBM_TYPE_U0x0000000Cu: | |||
359 | return lbm_dec_u(a); | |||
360 | case LBM_TYPE_I320x28000000u: | |||
361 | return (uint64_t) lbm_dec_i32(a); | |||
362 | case LBM_TYPE_U320x38000000u: | |||
363 | return (uint64_t) lbm_dec_u32(a); | |||
364 | case LBM_TYPE_FLOAT0x68000000u: | |||
365 | return (uint64_t)lbm_dec_float(a); | |||
366 | case LBM_TYPE_I640x48000000u: | |||
367 | return (uint64_t) lbm_dec_i64(a); | |||
368 | case LBM_TYPE_U640x58000000u: | |||
369 | return (uint64_t) lbm_dec_u64(a); | |||
370 | case LBM_TYPE_DOUBLE0x78000000u: | |||
371 | return (uint64_t) lbm_dec_double(a); | |||
372 | } | |||
373 | return 0; | |||
374 | } | |||
375 | ||||
376 | lbm_uint lbm_dec_as_uint(lbm_value a) { | |||
377 | switch (lbm_type_of_functional(a)) { | |||
378 | case LBM_TYPE_CHAR0x00000004u: | |||
379 | return (lbm_uint) lbm_dec_char(a); | |||
380 | case LBM_TYPE_I0x00000008u: | |||
381 | return (lbm_uint) lbm_dec_i(a); | |||
382 | case LBM_TYPE_U0x0000000Cu: | |||
383 | return (lbm_uint) lbm_dec_u(a); | |||
384 | case LBM_TYPE_I320x28000000u: | |||
385 | return (lbm_uint) lbm_dec_i32(a); | |||
386 | case LBM_TYPE_U320x38000000u: | |||
387 | return (lbm_uint) lbm_dec_u32(a); | |||
388 | case LBM_TYPE_FLOAT0x68000000u: | |||
389 | return (lbm_uint) lbm_dec_float(a); | |||
390 | case LBM_TYPE_I640x48000000u: | |||
391 | return (lbm_uint) lbm_dec_i64(a); | |||
392 | case LBM_TYPE_U640x58000000u: | |||
393 | return (lbm_uint) lbm_dec_u64(a); | |||
394 | case LBM_TYPE_DOUBLE0x78000000u: | |||
395 | return (lbm_uint) lbm_dec_double(a); | |||
396 | } | |||
397 | return 0; | |||
398 | } | |||
399 | ||||
400 | lbm_int lbm_dec_as_int(lbm_value a) { | |||
401 | switch (lbm_type_of_functional(a)) { | |||
402 | case LBM_TYPE_CHAR0x00000004u: | |||
403 | return (lbm_int) lbm_dec_char(a); | |||
404 | case LBM_TYPE_I0x00000008u: | |||
405 | return (lbm_int) lbm_dec_i(a); | |||
406 | case LBM_TYPE_U0x0000000Cu: | |||
407 | return (lbm_int) lbm_dec_u(a); | |||
408 | case LBM_TYPE_I320x28000000u: | |||
409 | return (lbm_int) lbm_dec_i32(a); | |||
410 | case LBM_TYPE_U320x38000000u: | |||
411 | return (lbm_int) lbm_dec_u32(a); | |||
412 | case LBM_TYPE_FLOAT0x68000000u: | |||
413 | return (lbm_int)lbm_dec_float(a); | |||
414 | case LBM_TYPE_I640x48000000u: | |||
415 | return (lbm_int) lbm_dec_i64(a); | |||
416 | case LBM_TYPE_U640x58000000u: | |||
417 | return (lbm_int) lbm_dec_u64(a); | |||
418 | case LBM_TYPE_DOUBLE0x78000000u: | |||
419 | return (lbm_int) lbm_dec_double(a); | |||
420 | } | |||
421 | return 0; | |||
422 | } | |||
423 | ||||
424 | float lbm_dec_as_float(lbm_value a) { | |||
425 | ||||
426 | switch (lbm_type_of_functional(a)) { | |||
427 | case LBM_TYPE_CHAR0x00000004u: | |||
428 | return (float) lbm_dec_char(a); | |||
429 | case LBM_TYPE_I0x00000008u: | |||
430 | return (float) lbm_dec_i(a); | |||
431 | case LBM_TYPE_U0x0000000Cu: | |||
432 | return (float) lbm_dec_u(a); | |||
433 | case LBM_TYPE_I320x28000000u: | |||
434 | return (float) lbm_dec_i32(a); | |||
435 | case LBM_TYPE_U320x38000000u: | |||
436 | return (float) lbm_dec_u32(a); | |||
437 | case LBM_TYPE_FLOAT0x68000000u: | |||
438 | return (float) lbm_dec_float(a); | |||
439 | case LBM_TYPE_I640x48000000u: | |||
440 | return (float) lbm_dec_i64(a); | |||
441 | case LBM_TYPE_U640x58000000u: | |||
442 | return (float) lbm_dec_u64(a); | |||
443 | case LBM_TYPE_DOUBLE0x78000000u: | |||
444 | return (float) lbm_dec_double(a); | |||
445 | } | |||
446 | return 0; | |||
447 | } | |||
448 | ||||
449 | double lbm_dec_as_double(lbm_value a) { | |||
450 | ||||
451 | switch (lbm_type_of_functional(a)) { | |||
452 | case LBM_TYPE_CHAR0x00000004u: | |||
453 | return (double) lbm_dec_char(a); | |||
454 | case LBM_TYPE_I0x00000008u: | |||
455 | return (double) lbm_dec_i(a); | |||
456 | case LBM_TYPE_U0x0000000Cu: | |||
457 | return (double) lbm_dec_u(a); | |||
458 | case LBM_TYPE_I320x28000000u: | |||
459 | return (double) lbm_dec_i32(a); | |||
460 | case LBM_TYPE_U320x38000000u: | |||
461 | return (double) lbm_dec_u32(a); | |||
462 | case LBM_TYPE_FLOAT0x68000000u: | |||
463 | return (double) lbm_dec_float(a); | |||
464 | case LBM_TYPE_I640x48000000u: | |||
465 | return (double) lbm_dec_i64(a); | |||
466 | case LBM_TYPE_U640x58000000u: | |||
467 | return (double) lbm_dec_u64(a); | |||
468 | case LBM_TYPE_DOUBLE0x78000000u: | |||
469 | return (double) lbm_dec_double(a); | |||
470 | } | |||
471 | return 0; | |||
472 | } | |||
473 | ||||
474 | /****************************************************/ | |||
475 | /* HEAP MANAGEMENT */ | |||
476 | ||||
477 | static int generate_freelist(size_t num_cells) { | |||
478 | size_t i = 0; | |||
479 | ||||
480 | if (!lbm_heap_state.heap) return 0; | |||
481 | ||||
482 | lbm_heap_state.freelist = lbm_enc_cons_ptr(0); | |||
483 | ||||
484 | lbm_cons_t *t; | |||
485 | ||||
486 | // Add all cells to free list | |||
487 | for (i = 1; i < num_cells; i ++) { | |||
488 | t = lbm_ref_cell(lbm_enc_cons_ptr(i-1)); | |||
489 | t->car = ENC_SYM_RECOVERED(((0x28) << 4) | 0x00000000u); // all cars in free list are "RECOVERED" | |||
490 | t->cdr = lbm_enc_cons_ptr(i); | |||
491 | } | |||
492 | ||||
493 | // Replace the incorrect pointer at the last cell. | |||
494 | t = lbm_ref_cell(lbm_enc_cons_ptr(num_cells-1)); | |||
495 | t->cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); | |||
496 | ||||
497 | return 1; | |||
498 | } | |||
499 | ||||
500 | void lbm_nil_freelist(void) { | |||
501 | lbm_heap_state.freelist = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); | |||
502 | lbm_heap_state.num_alloc = lbm_heap_state.heap_size; | |||
503 | } | |||
504 | ||||
505 | static void heap_init_state(lbm_cons_t *addr, lbm_uint num_cells, | |||
506 | lbm_uint* gc_stack_storage, lbm_uint gc_stack_size) { | |||
507 | lbm_heap_state.heap = addr; | |||
508 | lbm_heap_state.heap_bytes = (unsigned int)(num_cells * sizeof(lbm_cons_t)); | |||
509 | lbm_heap_state.heap_size = num_cells; | |||
510 | ||||
511 | lbm_stack_create(&lbm_heap_state.gc_stack, gc_stack_storage, gc_stack_size); | |||
512 | ||||
513 | lbm_heap_state.num_alloc = 0; | |||
514 | lbm_heap_state.num_alloc_arrays = 0; | |||
515 | lbm_heap_state.gc_num = 0; | |||
516 | lbm_heap_state.gc_marked = 0; | |||
517 | lbm_heap_state.gc_recovered = 0; | |||
518 | lbm_heap_state.gc_recovered_arrays = 0; | |||
519 | lbm_heap_state.gc_least_free = num_cells; | |||
520 | lbm_heap_state.gc_last_free = num_cells; | |||
521 | } | |||
522 | ||||
523 | void lbm_heap_new_freelist_length(void) { | |||
524 | lbm_uint l = lbm_heap_state.heap_size - lbm_heap_state.num_alloc; | |||
525 | lbm_heap_state.gc_last_free = l; | |||
526 | if (l < lbm_heap_state.gc_least_free) | |||
527 | lbm_heap_state.gc_least_free = l; | |||
528 | } | |||
529 | ||||
530 | int lbm_heap_init(lbm_cons_t *addr, lbm_uint num_cells, | |||
531 | lbm_uint gc_stack_size) { | |||
532 | ||||
533 | if (((uintptr_t)addr % 8) != 0) return 0; | |||
534 | ||||
535 | memset(addr,0, sizeof(lbm_cons_t) * num_cells); | |||
536 | ||||
537 | lbm_uint *gc_stack_storage = (lbm_uint*)lbm_malloc(gc_stack_size * sizeof(lbm_uint)); | |||
538 | if (gc_stack_storage == NULL((void*)0)) return 0; | |||
539 | ||||
540 | heap_init_state(addr, num_cells, | |||
541 | gc_stack_storage, gc_stack_size); | |||
542 | ||||
543 | lbm_heaps[0] = addr; | |||
544 | ||||
545 | return generate_freelist(num_cells); | |||
546 | } | |||
547 | ||||
548 | lbm_uint lbm_heap_num_free(void) { | |||
549 | return lbm_heap_state.heap_size - lbm_heap_state.num_alloc; | |||
550 | } | |||
551 | ||||
552 | lbm_value lbm_heap_allocate_cell(lbm_type ptr_type, lbm_value car, lbm_value cdr) { | |||
553 | lbm_value res; | |||
554 | // it is a ptr replace freelist with cdr of freelist; | |||
555 | res = lbm_heap_state.freelist; | |||
556 | if (lbm_type_of(res) == LBM_TYPE_CONS0x10000000u) { | |||
557 | lbm_uint heap_ix = lbm_dec_ptr(res); | |||
558 | lbm_heap_state.freelist = lbm_heap_state.heap[heap_ix].cdr; | |||
559 | lbm_heap_state.num_alloc++; | |||
560 | lbm_heap_state.heap[heap_ix].car = car; | |||
561 | lbm_heap_state.heap[heap_ix].cdr = cdr; | |||
562 | res = lbm_set_ptr_type(res, ptr_type); | |||
563 | return res; | |||
564 | } | |||
565 | return ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u); | |||
566 | } | |||
567 | ||||
568 | lbm_value lbm_heap_allocate_list(lbm_uint n) { | |||
569 | if (n == 0) return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); | |||
570 | if (lbm_heap_num_free() < n) return ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u); | |||
571 | ||||
572 | lbm_value curr = lbm_heap_state.freelist; | |||
573 | lbm_value res = curr; | |||
574 | if (lbm_type_of(curr) == LBM_TYPE_CONS0x10000000u) { | |||
575 | ||||
576 | lbm_cons_t *c_cell = NULL((void*)0); | |||
577 | lbm_uint count = 0; | |||
578 | do { | |||
579 | c_cell = lbm_ref_cell(curr); | |||
580 | c_cell->car = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); | |||
581 | curr = c_cell->cdr; | |||
582 | count ++; | |||
583 | } while (count < n); | |||
584 | lbm_heap_state.freelist = curr; | |||
585 | c_cell->cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); | |||
586 | lbm_heap_state.num_alloc+=count; | |||
587 | return res; | |||
588 | } | |||
589 | return ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u); | |||
590 | } | |||
591 | ||||
592 | lbm_value lbm_heap_allocate_list_init_va(unsigned int n, va_list valist) { | |||
593 | if (n == 0) return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); | |||
594 | if (lbm_heap_num_free() < n) return ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u); | |||
595 | ||||
596 | lbm_value curr = lbm_heap_state.freelist; | |||
597 | lbm_value res = curr; | |||
598 | if (lbm_type_of(curr) == LBM_TYPE_CONS0x10000000u) { | |||
599 | ||||
600 | lbm_cons_t *c_cell = NULL((void*)0); | |||
601 | unsigned int count = 0; | |||
602 | do { | |||
603 | c_cell = lbm_ref_cell(curr); | |||
604 | c_cell->car = va_arg(valist, lbm_value)__builtin_va_arg(valist, lbm_value); | |||
605 | curr = c_cell->cdr; | |||
606 | count ++; | |||
607 | } while (count < n); | |||
608 | lbm_heap_state.freelist = curr; | |||
609 | c_cell->cdr = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); | |||
610 | lbm_heap_state.num_alloc+=count; | |||
611 | return res; | |||
612 | } | |||
613 | return ENC_SYM_FATAL_ERROR(((0x26) << 4) | 0x00000000u); | |||
614 | } | |||
615 | ||||
616 | lbm_value lbm_heap_allocate_list_init(unsigned int n, ...) { | |||
617 | va_list valist; | |||
618 | va_start(valist, n)__builtin_va_start(valist, n); | |||
619 | lbm_value r = lbm_heap_allocate_list_init_va(n, valist); | |||
620 | va_end(valist)__builtin_va_end(valist); | |||
621 | return r; | |||
622 | } | |||
623 | ||||
624 | lbm_uint lbm_heap_num_allocated(void) { | |||
625 | return lbm_heap_state.num_alloc; | |||
626 | } | |||
627 | lbm_uint lbm_heap_size(void) { | |||
628 | return lbm_heap_state.heap_size; | |||
629 | } | |||
630 | ||||
631 | lbm_uint lbm_heap_size_bytes(void) { | |||
632 | return lbm_heap_state.heap_bytes; | |||
633 | } | |||
634 | ||||
635 | void lbm_get_heap_state(lbm_heap_state_t *res) { | |||
636 | *res = lbm_heap_state; | |||
637 | } | |||
638 | ||||
639 | lbm_uint lbm_get_gc_stack_max(void) { | |||
640 | return lbm_heap_state.gc_stack.max_sp; | |||
641 | } | |||
642 | ||||
643 | lbm_uint lbm_get_gc_stack_size(void) { | |||
644 | return lbm_heap_state.gc_stack.size; | |||
645 | } | |||
646 | ||||
647 | #ifdef USE_GC_PTR_REV | |||
648 | static inline void value_assign(lbm_value *a, lbm_value b) { | |||
649 | lbm_value a_old = *a & LBM_GC_MASK0x00000002u; | |||
650 | *a = a_old | (b & ~LBM_GC_MASK0x00000002u); | |||
651 | } | |||
652 | ||||
653 | void lbm_gc_mark_phase(lbm_value root) { | |||
654 | bool_Bool work_to_do = true1; | |||
655 | ||||
656 | if (!lbm_is_ptr(root)) return; | |||
657 | ||||
658 | mutex_lock(&lbm_const_heap_mutex); | |||
659 | lbm_value curr = root; | |||
660 | lbm_value prev = lbm_enc_cons_ptr(LBM_PTR_NULL(0x03FFFFFCu >> 2)); | |||
661 | ||||
662 | while (work_to_do) { | |||
663 | // follow leftwards pointers | |||
664 | while (lbm_is_ptr(curr) && | |||
665 | (lbm_dec_ptr(curr) != LBM_PTR_NULL(0x03FFFFFCu >> 2)) && | |||
666 | ((curr & LBM_PTR_TO_CONSTANT_BIT0x04000000u) == 0) && | |||
667 | !lbm_get_gc_mark(lbm_cdr(curr))) { | |||
668 | // Mark the cell if not a constant cell | |||
669 | lbm_cons_t *cell = lbm_ref_cell(curr); | |||
670 | cell->cdr = lbm_set_gc_mark(cell->cdr); | |||
671 | if (lbm_is_cons_rw(curr)) { | |||
672 | lbm_value next = 0; | |||
673 | value_assign(&next, cell->car); | |||
674 | value_assign(&cell->car, prev); | |||
675 | value_assign(&prev,curr); | |||
676 | value_assign(&curr, next); | |||
677 | } | |||
678 | // Will jump out next iteration as gc mark is set in curr. | |||
679 | } | |||
680 | while (lbm_is_ptr(prev) && | |||
681 | (lbm_dec_ptr(prev) != LBM_PTR_NULL(0x03FFFFFCu >> 2)) && | |||
682 | lbm_get_gc_flag(lbm_car(prev)) ) { | |||
683 | // clear the flag | |||
684 | lbm_cons_t *cell = lbm_ref_cell(prev); | |||
685 | cell->car = lbm_clr_gc_flag(cell->car); | |||
686 | lbm_value next = 0; | |||
687 | value_assign(&next, cell->cdr); | |||
688 | value_assign(&cell->cdr, curr); | |||
689 | value_assign(&curr, prev); | |||
690 | value_assign(&prev, next); | |||
691 | } | |||
692 | if (lbm_is_ptr(prev) && | |||
693 | lbm_dec_ptr(prev) == LBM_PTR_NULL(0x03FFFFFCu >> 2)) { | |||
694 | work_to_do = false0; | |||
695 | } else if (lbm_is_ptr(prev)) { | |||
696 | // set the flag | |||
697 | lbm_cons_t *cell = lbm_ref_cell(prev); | |||
698 | cell->car = lbm_set_gc_flag(cell->car); | |||
699 | lbm_value next = 0; | |||
700 | value_assign(&next, cell->car); | |||
701 | value_assign(&cell->car, curr); | |||
702 | value_assign(&curr, cell->cdr); | |||
703 | value_assign(&cell->cdr, next); | |||
704 | } | |||
705 | } | |||
706 | mutex_unlock(&lbm_const_heap_mutex); | |||
707 | } | |||
708 | ||||
709 | #else | |||
710 | extern eval_context_t *ctx_running; | |||
711 | void lbm_gc_mark_phase(lbm_value root) { | |||
712 | lbm_value t_ptr; | |||
713 | lbm_stack_t *s = &lbm_heap_state.gc_stack; | |||
714 | s->data[s->sp++] = root; | |||
715 | ||||
716 | while (!lbm_stack_is_empty(s)) { | |||
717 | lbm_value curr; | |||
718 | lbm_pop(s, &curr); | |||
719 | ||||
720 | mark_shortcut: | |||
721 | ||||
722 | if (!lbm_is_ptr(curr) || | |||
723 | (curr & LBM_PTR_TO_CONSTANT_BIT0x04000000u)) { | |||
724 | continue; | |||
725 | } | |||
726 | ||||
727 | lbm_cons_t *cell = &lbm_heap_state.heap[lbm_dec_ptr(curr)]; | |||
728 | ||||
729 | if (lbm_get_gc_mark(cell->cdr)) { | |||
730 | continue; | |||
731 | } | |||
732 | ||||
733 | t_ptr = lbm_type_of(curr); | |||
734 | ||||
735 | // An array is marked in O(N) time using an additional 32bit | |||
736 | // value per array that keeps track of how far into the array GC | |||
737 | // has progressed. | |||
738 | if (t_ptr == LBM_TYPE_LISPARRAY0xB0000000u) { | |||
739 | lbm_push(s, curr); // put array back as bookkeeping. | |||
740 | lbm_array_header_extended_t *arr = (lbm_array_header_extended_t*)cell->car; | |||
741 | lbm_value *arrdata = (lbm_value *)arr->data; | |||
742 | uint32_t index = arr->index; | |||
743 | ||||
744 | // Potential optimization. | |||
745 | // 1. CONS pointers are set to curr and recurse. | |||
746 | // 2. Any other ptr is marked immediately and index is increased. | |||
747 | if (lbm_is_ptr(arrdata[index]) && ((arrdata[index] & LBM_PTR_TO_CONSTANT_BIT0x04000000u) == 0) && | |||
748 | !((arrdata[index] & LBM_CONTINUATION_INTERNAL0xF8000001u) == LBM_CONTINUATION_INTERNAL0xF8000001u)) { | |||
749 | lbm_cons_t *elt = &lbm_heap_state.heap[lbm_dec_ptr(arrdata[index])]; | |||
750 | if (!lbm_get_gc_mark(elt->cdr)) { | |||
751 | curr = arrdata[index]; | |||
752 | goto mark_shortcut; | |||
753 | } | |||
754 | } | |||
755 | if (index < ((arr->size/(sizeof(lbm_value))) - 1)) { | |||
756 | arr->index++; | |||
757 | continue; | |||
758 | } | |||
759 | ||||
760 | arr->index = 0; | |||
761 | cell->cdr = lbm_set_gc_mark(cell->cdr); | |||
762 | lbm_heap_state.gc_marked ++; | |||
763 | lbm_pop(s, &curr); // Remove array from GC stack as we are done marking it. | |||
764 | continue; | |||
765 | } | |||
766 | ||||
767 | cell->cdr = lbm_set_gc_mark(cell->cdr); | |||
768 | lbm_heap_state.gc_marked ++; | |||
769 | ||||
770 | if (t_ptr == LBM_TYPE_CONS0x10000000u) { | |||
771 | if (lbm_is_ptr(cell->cdr)) { | |||
772 | if (!lbm_push(s, cell->cdr)) { | |||
773 | lbm_critical_error(); | |||
774 | break; | |||
775 | } | |||
776 | } | |||
777 | curr = cell->car; | |||
778 | goto mark_shortcut; // Skip a push/pop | |||
779 | } | |||
780 | } | |||
781 | } | |||
782 | #endif | |||
783 | ||||
784 | //Environments are proper lists with a 2 element list stored in each car. | |||
785 | void lbm_gc_mark_env(lbm_value env) { | |||
786 | lbm_value curr = env; | |||
787 | lbm_cons_t *c; | |||
788 | ||||
789 | while (lbm_is_ptr(curr)) { | |||
790 | c = lbm_ref_cell(curr); | |||
791 | c->cdr = lbm_set_gc_mark(c->cdr); // mark the environent list structure. | |||
792 | lbm_cons_t *b = lbm_ref_cell(c->car); | |||
793 | b->cdr = lbm_set_gc_mark(b->cdr); // mark the binding list head cell. | |||
794 | lbm_gc_mark_phase(b->cdr); // mark the bound object. | |||
795 | lbm_heap_state.gc_marked +=2; | |||
796 | curr = c->cdr; | |||
797 | } | |||
798 | } | |||
799 | ||||
800 | ||||
801 | void lbm_gc_mark_aux(lbm_uint *aux_data, lbm_uint aux_size) { | |||
802 | for (lbm_uint i = 0; i < aux_size; i ++) { | |||
803 | if (lbm_is_ptr(aux_data[i])) { | |||
804 | lbm_type pt_t = lbm_type_of(aux_data[i]); | |||
805 | lbm_uint pt_v = lbm_dec_ptr(aux_data[i]); | |||
806 | if( pt_t >= LBM_POINTER_TYPE_FIRST0x10000000u && | |||
807 | pt_t <= LBM_POINTER_TYPE_LAST0xBC000000u && | |||
808 | pt_v < lbm_heap_state.heap_size) { | |||
809 | lbm_gc_mark_phase(aux_data[i]); | |||
810 | } | |||
811 | } | |||
812 | } | |||
813 | } | |||
814 | ||||
815 | void lbm_gc_mark_roots(lbm_uint *roots, lbm_uint num_roots) { | |||
816 | for (lbm_uint i = 0; i < num_roots; i ++) { | |||
817 | lbm_gc_mark_phase(roots[i]); | |||
818 | } | |||
819 | } | |||
820 | ||||
821 | // Sweep moves non-marked heap objects to the free list. | |||
822 | int lbm_gc_sweep_phase(void) { | |||
823 | unsigned int i = 0; | |||
824 | lbm_cons_t *heap = (lbm_cons_t *)lbm_heap_state.heap; | |||
825 | ||||
826 | for (i = 0; i < lbm_heap_state.heap_size; i ++) { | |||
827 | if ( lbm_get_gc_mark(heap[i].cdr)) { | |||
828 | heap[i].cdr = lbm_clr_gc_mark(heap[i].cdr); | |||
829 | } else { | |||
830 | // Check if this cell is a pointer to an array | |||
831 | // and free it. | |||
832 | if (lbm_type_of(heap[i].cdr) == LBM_TYPE_SYMBOL0x00000000u) { | |||
833 | switch(heap[i].cdr) { | |||
834 | ||||
835 | case ENC_SYM_IND_I_TYPE(((0x34) << 4) | 0x00000000u): /* fall through */ | |||
836 | case ENC_SYM_IND_U_TYPE(((0x35) << 4) | 0x00000000u): | |||
837 | case ENC_SYM_IND_F_TYPE(((0x36) << 4) | 0x00000000u): | |||
838 | lbm_memory_free((lbm_uint*)heap[i].car); | |||
839 | break; | |||
840 | case ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u): /* fall through */ | |||
841 | case ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u):{ | |||
842 | lbm_array_header_t *arr = (lbm_array_header_t*)heap[i].car; | |||
843 | if (lbm_memory_ptr_inside((lbm_uint*)arr->data)) { | |||
844 | lbm_memory_free((lbm_uint *)arr->data); | |||
845 | lbm_heap_state.gc_recovered_arrays++; | |||
846 | } | |||
847 | lbm_memory_free((lbm_uint *)arr); | |||
848 | } break; | |||
849 | case ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u):{ | |||
850 | lbm_char_channel_t *chan = (lbm_char_channel_t*)heap[i].car; | |||
851 | if (lbm_memory_ptr_inside((lbm_uint*)chan)) { | |||
852 | lbm_memory_free((lbm_uint*)chan->state); | |||
853 | lbm_memory_free((lbm_uint*)chan); | |||
854 | } | |||
855 | } break; | |||
856 | case ENC_SYM_CUSTOM_TYPE(((0x38) << 4) | 0x00000000u): { | |||
857 | lbm_uint *t = (lbm_uint*)heap[i].car; | |||
858 | lbm_custom_type_destroy(t); | |||
859 | lbm_memory_free(t); | |||
860 | } break; | |||
861 | default: | |||
862 | break; | |||
863 | } | |||
864 | } | |||
865 | // create pointer to use as new freelist | |||
866 | lbm_uint addr = lbm_enc_cons_ptr(i); | |||
867 | ||||
868 | // Clear the "freed" cell. | |||
869 | heap[i].car = ENC_SYM_RECOVERED(((0x28) << 4) | 0x00000000u); | |||
870 | heap[i].cdr = lbm_heap_state.freelist; | |||
871 | lbm_heap_state.freelist = addr; | |||
872 | lbm_heap_state.num_alloc --; | |||
873 | lbm_heap_state.gc_recovered ++; | |||
874 | } | |||
875 | } | |||
876 | return 1; | |||
877 | } | |||
878 | ||||
879 | void lbm_gc_state_inc(void) { | |||
880 | lbm_heap_state.gc_num ++; | |||
881 | lbm_heap_state.gc_recovered = 0; | |||
882 | lbm_heap_state.gc_marked = 0; | |||
883 | } | |||
884 | ||||
885 | // construct, alter and break apart | |||
886 | lbm_value lbm_cons(lbm_value car, lbm_value cdr) { | |||
887 | return lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, car, cdr); | |||
888 | } | |||
889 | ||||
890 | lbm_value lbm_car(lbm_value c){ | |||
891 | ||||
892 | if (lbm_is_ptr(c) ){ | |||
893 | lbm_cons_t *cell = lbm_ref_cell(c); | |||
894 | return cell->car; | |||
895 | } | |||
896 | ||||
897 | if (lbm_is_symbol_nil(c)) { | |||
898 | return c; // if nil, return nil. | |||
899 | } | |||
900 | ||||
901 | return ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u); | |||
902 | } | |||
903 | ||||
904 | // TODO: Many comparisons "is this the nil symbol" can be | |||
905 | // streamlined a bit. NIL is 0 and cannot be confused with any other | |||
906 | // lbm_value. | |||
907 | ||||
908 | lbm_value lbm_caar(lbm_value c) { | |||
909 | ||||
910 | lbm_value tmp; | |||
911 | ||||
912 | if (lbm_is_ptr(c)) { | |||
913 | tmp = lbm_ref_cell(c)->car; | |||
914 | ||||
915 | if (lbm_is_ptr(tmp)) { | |||
916 | return lbm_ref_cell(tmp)->car; | |||
917 | } else if (lbm_is_symbol_nil(tmp)) { | |||
918 | return tmp; | |||
919 | } | |||
920 | } else if (lbm_is_symbol_nil(c)){ | |||
921 | return c; | |||
922 | } | |||
923 | return ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u); | |||
924 | } | |||
925 | ||||
926 | ||||
927 | lbm_value lbm_cadr(lbm_value c) { | |||
928 | ||||
929 | lbm_value tmp; | |||
930 | ||||
931 | if (lbm_is_ptr(c)) { | |||
932 | tmp = lbm_ref_cell(c)->cdr; | |||
933 | ||||
934 | if (lbm_is_ptr(tmp)) { | |||
935 | return lbm_ref_cell(tmp)->car; | |||
936 | } else if (lbm_is_symbol_nil(tmp)) { | |||
937 | return tmp; | |||
938 | } | |||
939 | } else if (lbm_is_symbol_nil(c)) { | |||
940 | return c; | |||
941 | } | |||
942 | return ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u); | |||
943 | } | |||
944 | ||||
945 | lbm_value lbm_cdr(lbm_value c){ | |||
946 | if (lbm_is_ptr(c)) { | |||
947 | lbm_cons_t *cell = lbm_ref_cell(c); | |||
948 | return cell->cdr; | |||
949 | } | |||
950 | if (lbm_is_symbol_nil(c)) { | |||
951 | return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); // if nil, return nil. | |||
952 | } | |||
953 | return ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u); | |||
954 | } | |||
955 | ||||
956 | lbm_value lbm_cddr(lbm_value c) { | |||
957 | if (lbm_is_ptr(c)) { | |||
958 | lbm_value tmp = lbm_ref_cell(c)->cdr; | |||
959 | if (lbm_is_ptr(tmp)) { | |||
960 | return lbm_ref_cell(tmp)->cdr; | |||
961 | } | |||
962 | } | |||
963 | if (lbm_is_symbol_nil(c)) { | |||
964 | return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); | |||
965 | } | |||
966 | return ENC_SYM_TERROR(((0x21) << 4) | 0x00000000u); | |||
967 | } | |||
968 | ||||
969 | int lbm_set_car(lbm_value c, lbm_value v) { | |||
970 | int r = 0; | |||
971 | ||||
972 | if (lbm_type_of(c) == LBM_TYPE_CONS0x10000000u) { | |||
973 | lbm_cons_t *cell = lbm_ref_cell(c); | |||
974 | cell->car = v; | |||
975 | r = 1; | |||
976 | } | |||
977 | return r; | |||
978 | } | |||
979 | ||||
980 | int lbm_set_cdr(lbm_value c, lbm_value v) { | |||
981 | int r = 0; | |||
982 | if (lbm_is_cons_rw(c)){ | |||
983 | lbm_cons_t *cell = lbm_ref_cell(c); | |||
984 | cell->cdr = v; | |||
985 | r = 1; | |||
986 | } | |||
987 | return r; | |||
988 | } | |||
989 | ||||
990 | int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val) { | |||
991 | int r = 0; | |||
992 | if (lbm_is_cons_rw(c)) { | |||
993 | lbm_cons_t *cell = lbm_ref_cell(c); | |||
994 | cell->car = car_val; | |||
995 | cell->cdr = cdr_val; | |||
996 | r = 1; | |||
997 | } | |||
998 | return r; | |||
999 | } | |||
1000 | ||||
1001 | /* calculate length of a proper list */ | |||
1002 | lbm_uint lbm_list_length(lbm_value c) { | |||
1003 | lbm_uint len = 0; | |||
1004 | ||||
1005 | while (lbm_is_cons(c)){ | |||
1006 | len ++; | |||
1007 | c = lbm_cdr(c); | |||
1008 | } | |||
1009 | return len; | |||
1010 | } | |||
1011 | ||||
1012 | /* calculate the length of a list and check that each element | |||
1013 | fullfills the predicate pred */ | |||
1014 | unsigned int lbm_list_length_pred(lbm_value c, bool_Bool *pres, bool_Bool (*pred)(lbm_value)) { | |||
1015 | bool_Bool res = true1; | |||
1016 | unsigned int len = 0; | |||
1017 | ||||
1018 | while (lbm_is_cons(c)){ | |||
1019 | len ++; | |||
1020 | res = res && pred(lbm_car(c)); | |||
1021 | c = lbm_cdr(c); | |||
1022 | } | |||
1023 | *pres = res; | |||
1024 | return len; | |||
1025 | } | |||
1026 | ||||
1027 | /* reverse a proper list */ | |||
1028 | lbm_value lbm_list_reverse(lbm_value list) { | |||
1029 | if (lbm_type_of(list) == LBM_TYPE_SYMBOL0x00000000u) { | |||
1030 | return list; | |||
1031 | } | |||
1032 | ||||
1033 | lbm_value curr = list; | |||
1034 | ||||
1035 | lbm_value new_list = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); | |||
1036 | while (lbm_is_cons(curr)) { | |||
1037 | ||||
1038 | new_list = lbm_cons(lbm_car(curr), new_list); | |||
1039 | if (lbm_type_of(new_list) == LBM_TYPE_SYMBOL0x00000000u) { | |||
1040 | return ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u); | |||
1041 | } | |||
1042 | curr = lbm_cdr(curr); | |||
1043 | } | |||
1044 | return new_list; | |||
1045 | } | |||
1046 | ||||
1047 | lbm_value lbm_list_destructive_reverse(lbm_value list) { | |||
1048 | if (lbm_type_of(list) == LBM_TYPE_SYMBOL0x00000000u) { | |||
1049 | return list; | |||
1050 | } | |||
1051 | lbm_value curr = list; | |||
1052 | lbm_value last_cell = ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); | |||
1053 | ||||
1054 | while (lbm_is_cons_rw(curr)) { | |||
1055 | lbm_value next = lbm_cdr(curr); | |||
1056 | lbm_set_cdr(curr, last_cell); | |||
1057 | last_cell = curr; | |||
1058 | curr = next; | |||
1059 | } | |||
1060 | return last_cell; | |||
1061 | } | |||
1062 | ||||
1063 | ||||
1064 | lbm_value lbm_list_copy(int *m, lbm_value list) { | |||
1065 | lbm_value curr = list; | |||
1066 | lbm_uint n = lbm_list_length(list); | |||
1067 | lbm_uint copy_n = n; | |||
1068 | if (*m >= 0 && (lbm_uint)*m < n) { | |||
1069 | copy_n = (lbm_uint)*m; | |||
1070 | } else if (*m == -1) { | |||
1071 | *m = (int)n; // TODO: smaller range in target variable. | |||
1072 | } | |||
1073 | if (copy_n == 0) return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); | |||
1074 | lbm_uint new_list = lbm_heap_allocate_list(copy_n); | |||
1075 | if (lbm_is_symbol(new_list)) return new_list; | |||
1076 | lbm_value curr_targ = new_list; | |||
1077 | ||||
1078 | while (lbm_is_cons(curr) && copy_n > 0) { | |||
1079 | lbm_value v = lbm_car(curr); | |||
1080 | lbm_set_car(curr_targ, v); | |||
1081 | curr_targ = lbm_cdr(curr_targ); | |||
1082 | curr = lbm_cdr(curr); | |||
1083 | copy_n --; | |||
1084 | } | |||
1085 | ||||
1086 | return new_list; | |||
1087 | } | |||
1088 | ||||
1089 | // Append for proper lists only | |||
1090 | // Destructive update of list1. | |||
1091 | lbm_value lbm_list_append(lbm_value list1, lbm_value list2) { | |||
1092 | ||||
1093 | if(lbm_is_list_rw(list1) && | |||
1094 | lbm_is_list(list2)) { | |||
1095 | ||||
1096 | lbm_value curr = list1; | |||
1097 | while(lbm_type_of(lbm_cdr(curr)) == LBM_TYPE_CONS0x10000000u) { | |||
1098 | curr = lbm_cdr(curr); | |||
1099 | } | |||
1100 | if (lbm_is_symbol_nil(curr)) return list2; | |||
1101 | lbm_set_cdr(curr, list2); | |||
1102 | return list1; | |||
1103 | } | |||
1104 | return ENC_SYM_EERROR(((0x22) << 4) | 0x00000000u); | |||
1105 | } | |||
1106 | ||||
1107 | lbm_value lbm_list_drop(unsigned int n, lbm_value ls) { | |||
1108 | lbm_value curr = ls; | |||
1109 | while (lbm_type_of_functional(curr) == LBM_TYPE_CONS0x10000000u && | |||
1110 | n > 0) { | |||
1111 | curr = lbm_cdr(curr); | |||
1112 | n --; | |||
1113 | } | |||
1114 | return curr; | |||
1115 | } | |||
1116 | ||||
1117 | lbm_value lbm_index_list(lbm_value l, int32_t n) { | |||
1118 | lbm_value curr = l; | |||
1119 | ||||
1120 | if (n < 0) { | |||
1121 | int32_t len = (int32_t)lbm_list_length(l); | |||
1122 | n = len + n; | |||
1123 | if (n < 0) return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); | |||
1124 | } | |||
1125 | ||||
1126 | while (lbm_is_cons(curr) && | |||
1127 | n > 0) { | |||
1128 | curr = lbm_cdr(curr); | |||
1129 | n --; | |||
1130 | } | |||
1131 | if (lbm_is_cons(curr)) { | |||
1132 | return lbm_car(curr); | |||
1133 | } else { | |||
1134 | return ENC_SYM_NIL(((0x0) << 4) | 0x00000000u); | |||
1135 | } | |||
1136 | } | |||
1137 | ||||
1138 | // High-level arrays are just bytearrays but with a different tag and pointer type. | |||
1139 | // These arrays will be inspected by GC and the elements of the array will be marked. | |||
1140 | ||||
1141 | // Arrays are part of the heap module because their lifespan is managed | |||
1142 | // by the garbage collector. The data in the array is not stored | |||
1143 | // in the "heap of cons cells". | |||
1144 | int lbm_heap_allocate_array_base(lbm_value *res, bool_Bool byte_array, lbm_uint size){ | |||
1145 | ||||
1146 | lbm_array_header_t *array = NULL((void*)0); | |||
1147 | ||||
1148 | if (byte_array) { | |||
1149 | array = (lbm_array_header_t*)lbm_malloc(sizeof(lbm_array_header_t)); | |||
1150 | } else { | |||
1151 | // an extra 32bit quantity for a GC index. | |||
1152 | array = (lbm_array_header_t*)lbm_malloc(sizeof(lbm_array_header_extended_t)); | |||
1153 | } | |||
1154 | ||||
1155 | if (array == NULL((void*)0)) { | |||
1156 | *res = ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u); | |||
1157 | return 0; | |||
1158 | } | |||
1159 | ||||
1160 | lbm_uint tag = ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u); | |||
1161 | lbm_uint type = LBM_TYPE_ARRAY0x80000000u; | |||
1162 | if (!byte_array) { | |||
1163 | tag = ENC_SYM_LISPARRAY_TYPE(((0x39) << 4) | 0x00000000u); | |||
1164 | type = LBM_TYPE_LISPARRAY0xB0000000u; | |||
1165 | size = sizeof(lbm_value) * size; | |||
1166 | lbm_array_header_extended_t *ext_array = (lbm_array_header_extended_t*)array; | |||
1167 | ext_array->index = 0; | |||
1168 | } | |||
1169 | ||||
1170 | array->data = (lbm_uint*)lbm_malloc(size); | |||
1171 | ||||
1172 | if (array->data == NULL((void*)0)) { | |||
1173 | lbm_memory_free((lbm_uint*)array); | |||
1174 | *res = ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u); | |||
1175 | return 0; | |||
1176 | } | |||
1177 | // It is more important to zero out high-level arrays. | |||
1178 | // 0 is symbol NIL which is perfectly safe for the GC to inspect. | |||
1179 | memset(array->data, 0, size); | |||
1180 | array->size = size; | |||
1181 | ||||
1182 | // allocating a cell for array's heap-presence | |||
1183 | lbm_value cell = lbm_heap_allocate_cell(type, (lbm_uint) array, tag); | |||
1184 | ||||
1185 | *res = cell; | |||
1186 | ||||
1187 | if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) { // Out of heap memory | |||
1188 | lbm_memory_free((lbm_uint*)array->data); | |||
1189 | lbm_memory_free((lbm_uint*)array); | |||
1190 | *res = ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u); | |||
1191 | return 0; | |||
1192 | } | |||
1193 | ||||
1194 | lbm_heap_state.num_alloc_arrays ++; | |||
1195 | ||||
1196 | return 1; | |||
1197 | } | |||
1198 | ||||
1199 | int lbm_heap_allocate_array(lbm_value *res, lbm_uint size){ | |||
1200 | return lbm_heap_allocate_array_base(res, true1, size); | |||
1201 | } | |||
1202 | ||||
1203 | int lbm_heap_allocate_lisp_array(lbm_value *res, lbm_uint size) { | |||
1204 | return lbm_heap_allocate_array_base(res, false0, size); | |||
1205 | } | |||
1206 | ||||
1207 | // Convert a C array into an lbm_array. | |||
1208 | // if the array is in LBM_MEMORY, the lifetime will be managed by the GC after lifting. | |||
1209 | int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt) { | |||
1210 | ||||
1211 | lbm_array_header_t *array = NULL((void*)0); | |||
1212 | lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CONS0x10000000u, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_ARRAY_TYPE(((0x30) << 4) | 0x00000000u)); | |||
1213 | ||||
1214 | if (lbm_type_of(cell) == LBM_TYPE_SYMBOL0x00000000u) { // Out of heap memory | |||
1215 | *value = cell; | |||
1216 | return 0; | |||
1217 | } | |||
1218 | ||||
1219 | array = (lbm_array_header_t*)lbm_malloc(sizeof(lbm_array_header_t)); | |||
1220 | ||||
1221 | if (array == NULL((void*)0)) { | |||
1222 | lbm_set_car_and_cdr(cell, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u), ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); | |||
1223 | *value = ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u); | |||
1224 | return 0; | |||
1225 | } | |||
1226 | ||||
1227 | array->data = (lbm_uint*)data; | |||
1228 | array->size = num_elt; | |||
1229 | ||||
1230 | lbm_set_car(cell, (lbm_uint)array); | |||
1231 | ||||
1232 | cell = lbm_set_ptr_type(cell, LBM_TYPE_ARRAY0x80000000u); | |||
1233 | *value = cell; | |||
1234 | return 1; | |||
1235 | } | |||
1236 | ||||
1237 | lbm_int lbm_heap_array_get_size(lbm_value arr) { | |||
1238 | ||||
1239 | lbm_int r = -1; | |||
1240 | if (lbm_is_array_r(arr)) { | |||
1241 | lbm_array_header_t *header = (lbm_array_header_t*)lbm_car(arr); | |||
1242 | if (header == NULL((void*)0)) { | |||
1243 | return r; | |||
1244 | } | |||
1245 | r = (lbm_int)header->size; | |||
1246 | } | |||
1247 | return r; | |||
1248 | } | |||
1249 | ||||
1250 | const uint8_t *lbm_heap_array_get_data_ro(lbm_value arr) { | |||
1251 | uint8_t *r = NULL((void*)0); | |||
1252 | if (lbm_is_array_r(arr)) { | |||
1253 | lbm_array_header_t *header = (lbm_array_header_t*)lbm_car(arr); | |||
1254 | r = (uint8_t*)header->data; | |||
1255 | } | |||
1256 | return r; | |||
1257 | } | |||
1258 | ||||
1259 | uint8_t *lbm_heap_array_get_data_rw(lbm_value arr) { | |||
1260 | uint8_t *r = NULL((void*)0); | |||
1261 | if (lbm_is_array_rw(arr)) { | |||
1262 | lbm_array_header_t *header = (lbm_array_header_t*)lbm_car(arr); | |||
1263 | r = (uint8_t*)header->data; | |||
1264 | } | |||
1265 | return r; | |||
1266 | } | |||
1267 | ||||
1268 | ||||
1269 | /* Explicitly freeing an array. | |||
1270 | ||||
1271 | This is a highly unsafe operation and can only be safely | |||
1272 | used if the heap cell that points to the array has not been made | |||
1273 | accessible to the program. | |||
1274 | ||||
1275 | So This function can be used to free an array in case an array | |||
1276 | is being constructed and some error case appears while doing so | |||
1277 | If the array still have not become available it can safely be | |||
1278 | "explicitly" freed. | |||
1279 | ||||
1280 | The problem is that if the "array" heap-cell is made available to | |||
1281 | the program, this cell can easily be duplicated and we would have | |||
1282 | to search the entire heap to find all cells pointing to the array | |||
1283 | memory in question and "null"-them out before freeing the memory | |||
1284 | */ | |||
1285 | ||||
1286 | int lbm_heap_explicit_free_array(lbm_value arr) { | |||
1287 | ||||
1288 | int r = 0; | |||
1289 | if (lbm_is_array_rw(arr)) { | |||
1290 | ||||
1291 | lbm_array_header_t *header = (lbm_array_header_t*)lbm_car(arr); | |||
1292 | if (header == NULL((void*)0)) { | |||
1293 | return 0; | |||
1294 | } | |||
1295 | lbm_memory_free((lbm_uint*)header->data); | |||
1296 | lbm_memory_free((lbm_uint*)header); | |||
1297 | ||||
1298 | arr = lbm_set_ptr_type(arr, LBM_TYPE_CONS0x10000000u); | |||
1299 | lbm_set_car(arr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); | |||
1300 | lbm_set_cdr(arr, ENC_SYM_NIL(((0x0) << 4) | 0x00000000u)); | |||
1301 | r = 1; | |||
1302 | } | |||
1303 | ||||
1304 | return r; | |||
1305 | } | |||
1306 | ||||
1307 | lbm_uint lbm_size_of(lbm_type t) { | |||
1308 | lbm_uint s = 0; | |||
1309 | switch(t) { | |||
1310 | case LBM_TYPE_BYTE0x00000004u: | |||
1311 | s = 1; | |||
1312 | break; | |||
1313 | case LBM_TYPE_I0x00000008u: /* fall through */ | |||
1314 | case LBM_TYPE_U0x0000000Cu: | |||
1315 | case LBM_TYPE_SYMBOL0x00000000u: | |||
1316 | s = sizeof(lbm_uint); | |||
1317 | break; | |||
1318 | case LBM_TYPE_I320x28000000u: /* fall through */ | |||
1319 | case LBM_TYPE_U320x38000000u: | |||
1320 | case LBM_TYPE_FLOAT0x68000000u: | |||
1321 | s = 4; | |||
1322 | break; | |||
1323 | case LBM_TYPE_I640x48000000u: /* fall through */ | |||
1324 | case LBM_TYPE_U640x58000000u: | |||
1325 | case LBM_TYPE_DOUBLE0x78000000u: | |||
1326 | s = 8; | |||
1327 | break; | |||
1328 | } | |||
1329 | return s; | |||
1330 | } | |||
1331 | ||||
1332 | static bool_Bool dummy_flash_write(lbm_uint ix, lbm_uint val) { | |||
1333 | (void)ix; | |||
1334 | (void)val; | |||
1335 | return false0; | |||
1336 | } | |||
1337 | ||||
1338 | static const_heap_write_fun const_heap_write = dummy_flash_write; | |||
1339 | ||||
1340 | int lbm_const_heap_init(const_heap_write_fun w_fun, | |||
1341 | lbm_const_heap_t *heap, | |||
1342 | lbm_uint *addr, | |||
1343 | lbm_uint num_words) { | |||
1344 | if (((uintptr_t)addr % 4) != 0) return 0; | |||
1345 | if ((num_words % 2) != 0) return 0; | |||
1346 | ||||
1347 | if (!lbm_const_heap_mutex_initialized) { | |||
1348 | mutex_init(&lbm_const_heap_mutex); | |||
1349 | lbm_const_heap_mutex_initialized = true1; | |||
1350 | } | |||
1351 | ||||
1352 | if (!lbm_mark_mutex_initialized) { | |||
1353 | mutex_init(&lbm_mark_mutex); | |||
1354 | lbm_mark_mutex_initialized = true1; | |||
1355 | } | |||
1356 | ||||
1357 | const_heap_write = w_fun; | |||
1358 | ||||
1359 | heap->heap = addr; | |||
1360 | heap->size = num_words; | |||
1361 | heap->next = 0; | |||
1362 | ||||
1363 | lbm_const_heap_state = heap; | |||
1364 | // ref_cell views the lbm_uint array as an lbm_cons_t array | |||
1365 | lbm_heaps[1] = (lbm_cons_t*)addr; | |||
1366 | return 1; | |||
1367 | } | |||
1368 | ||||
1369 | lbm_flash_status lbm_allocate_const_cell(lbm_value *res) { | |||
1370 | lbm_flash_status r = LBM_FLASH_FULL; | |||
1371 | ||||
1372 | mutex_lock(&lbm_const_heap_mutex); | |||
1373 | // waste a cell if we have ended up unaligned after writing an array to flash. | |||
1374 | if (lbm_const_heap_state->next % 2 == 1) { | |||
1375 | lbm_const_heap_state->next++; | |||
1376 | } | |||
1377 | ||||
1378 | if (lbm_const_heap_state && | |||
1379 | (lbm_const_heap_state->next+1) < lbm_const_heap_state->size) { | |||
1380 | // A cons cell uses two words. | |||
1381 | lbm_value cell = lbm_const_heap_state->next; | |||
1382 | lbm_const_heap_state->next += 2; | |||
1383 | *res = (cell << LBM_ADDRESS_SHIFT2) | LBM_PTR_BIT0x00000001u | LBM_TYPE_CONS0x10000000u | LBM_PTR_TO_CONSTANT_BIT0x04000000u; | |||
1384 | r = LBM_FLASH_WRITE_OK; | |||
1385 | } | |||
1386 | mutex_unlock(&lbm_const_heap_mutex); | |||
1387 | return r; | |||
1388 | } | |||
1389 | ||||
1390 | lbm_flash_status lbm_allocate_const_raw(lbm_uint nwords, lbm_uint *res) { | |||
1391 | lbm_flash_status r = LBM_FLASH_FULL; | |||
1392 | ||||
1393 | if (lbm_const_heap_state && | |||
1394 | (lbm_const_heap_state->next + nwords) < lbm_const_heap_state->size) { | |||
1395 | lbm_uint ix = lbm_const_heap_state->next; | |||
1396 | *res = (lbm_uint)&lbm_const_heap_state->heap[ix]; | |||
1397 | lbm_const_heap_state->next += nwords; | |||
1398 | r = LBM_FLASH_WRITE_OK; | |||
1399 | } | |||
1400 | return r; | |||
1401 | } | |||
1402 | ||||
1403 | lbm_flash_status lbm_write_const_raw(lbm_uint *data, lbm_uint n, lbm_uint *res) { | |||
1404 | ||||
1405 | lbm_flash_status r = LBM_FLASH_FULL; | |||
1406 | ||||
1407 | if (lbm_const_heap_state && | |||
1408 | (lbm_const_heap_state->next + n) < lbm_const_heap_state->size) { | |||
1409 | lbm_uint ix = lbm_const_heap_state->next; | |||
1410 | ||||
1411 | for (unsigned int i = 0; i < n; i ++) { | |||
1412 | if (!const_heap_write(ix + i, ((lbm_uint*)data)[i])) | |||
1413 | return LBM_FLASH_WRITE_ERROR; | |||
1414 | } | |||
1415 | lbm_const_heap_state->next += n; | |||
1416 | *res = (lbm_uint)&lbm_const_heap_state->heap[ix]; | |||
1417 | r = LBM_FLASH_WRITE_OK; | |||
1418 | } | |||
1419 | return r; | |||
1420 | } | |||
1421 | ||||
1422 | lbm_flash_status lbm_const_write(lbm_uint *tgt, lbm_uint val) { | |||
1423 | ||||
1424 | if (lbm_const_heap_state) { | |||
1425 | lbm_uint flash = (lbm_uint)lbm_const_heap_state->heap; | |||
1426 | lbm_uint ix = (((lbm_uint)tgt - flash) / 4); // byte address to ix | |||
1427 | if (const_heap_write(ix, val)) { | |||
1428 | return LBM_FLASH_WRITE_OK; | |||
1429 | } | |||
1430 | return LBM_FLASH_WRITE_ERROR; | |||
1431 | } | |||
1432 | return LBM_FLASH_FULL; | |||
1433 | } | |||
1434 | ||||
1435 | lbm_flash_status write_const_cdr(lbm_value cell, lbm_value val) { | |||
1436 | lbm_uint addr = lbm_dec_ptr(cell); | |||
1437 | if (const_heap_write(addr+1, val)) | |||
1438 | return LBM_FLASH_WRITE_OK; | |||
1439 | return LBM_FLASH_WRITE_ERROR; | |||
1440 | } | |||
1441 | ||||
1442 | lbm_flash_status write_const_car(lbm_value cell, lbm_value val) { | |||
1443 | lbm_uint addr = lbm_dec_ptr(cell); | |||
1444 | if (const_heap_write(addr, val)) | |||
1445 | return LBM_FLASH_WRITE_OK; | |||
1446 | return LBM_FLASH_WRITE_ERROR; | |||
1447 | } | |||
1448 | ||||
1449 | lbm_uint lbm_flash_memory_usage(void) { | |||
1450 | return lbm_const_heap_state->next; | |||
1451 | } |
1 | /* |
2 | Copyright 2018, 2024 Joel Svensson svenssonjoel@yahoo.se |
3 | |
4 | This program is free software: you can redistribute it and/or modify |
5 | it under the terms of the GNU General Public License as published by |
6 | the Free Software Foundation, either version 3 of the License, or |
7 | (at your option) any later version. |
8 | |
9 | This program is distributed in the hope that it will be useful, |
10 | but WITHOUT ANY WARRANTY; without even the implied warranty of |
11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
12 | GNU General Public License for more details. |
13 | |
14 | You should have received a copy of the GNU General Public License |
15 | along with this program. If not, see <http://www.gnu.org/licenses/>. |
16 | */ |
17 | /** \file heap.h */ |
18 | |
19 | #ifndef HEAP_H_ |
20 | #define HEAP_H_ |
21 | |
22 | #include <string.h> |
23 | #include <stdarg.h> |
24 | |
25 | #include "lbm_types.h" |
26 | #include "symrepr.h" |
27 | #include "stack.h" |
28 | #include "lbm_memory.h" |
29 | #include "lbm_defines.h" |
30 | #include "lbm_channel.h" |
31 | |
32 | #ifdef __cplusplus |
33 | extern "C" { |
34 | #endif |
35 | |
36 | /* |
37 | Planning for a more space efficient heap representation. |
38 | TODO: Need to find a good reference to read up on this. |
39 | - List based heap |
40 | - Easy to implement and somewhat efficient |
41 | |
42 | 0000 0000 Size Free bits |
43 | 003F FFFF 4MB 10 |
44 | 007F FFFF 8MB 9 |
45 | 00FF FFFF 16MB 8 |
46 | 01FF FFFF 32MB 7 |
47 | 03FF FFFF 64MB 6 * Kind of heap size I am looking for |
48 | 07FF FFFF 128MB 5 |
49 | 0FFF FFFF 256MB 4 |
50 | 1FFF FFFF 512MB 3 |
51 | |
52 | |
53 | --- May 9 2021 --- |
54 | Actually now I am much more interested in way smaller memories ;) |
55 | |
56 | 0000 0000 Size Free bits |
57 | 0000 0FFF 4KB 20 | |
58 | 0000 1FFF 8KB 19 | |
59 | 0000 3FFF 16KB 18 | |
60 | 0000 7FFF 32KB 17 | |
61 | 0000 FFFF 64KB 16 | |
62 | 0001 FFFF 128KB 15 | |
63 | 0003 FFFF 256KB 14 | - This range is very interesting. |
64 | 0007 FFFF 512KB 13 |
65 | 000F FFFF 1MB 12 |
66 | 001F FFFF 2MB 11 |
67 | 003F FFFF 4MB 10 |
68 | 007F FFFF 8MB 9 |
69 | 00FF FFFF 16MB 8 |
70 | 01FF FFFF 32MB 7 |
71 | 03FF FFFF 64MB 6 |
72 | 07FF FFFF 128MB 5 |
73 | 0FFF FFFF 256MB 4 |
74 | 1FFF FFFF 512MB 3 |
75 | |
76 | Those are the kind of platforms that are fun... so a bunch of |
77 | wasted bits in heap pointers if we run on small MCUs. |
78 | |
79 | ----------------- |
80 | |
81 | it is also the case that not all addresses will be used if all "cells" are |
82 | of the same size, 8 bytes... |
83 | |
84 | value 0: 0000 0000 |
85 | value 1: 0000 0008 |
86 | value 3: 0000 0010 |
87 | value 4: 0000 0018 |
88 | |
89 | Means bits 0,1,2 will always be empty in a valid address. |
90 | |
91 | Cons cells also need to be have room for 2 pointers. So each ted cell from |
92 | memory should be 8bytes. |
93 | |
94 | Things that needs to be represented within these bits: |
95 | |
96 | - GC MARK one per cell |
97 | - TYPE: type of CAR and type of cons |
98 | |
99 | Types I would want: |
100 | - Full 32bit integer. Does not leave room for identification of type |
101 | - Float values. Same problem |
102 | |
103 | |
104 | Free bits in pointers 64MB heap: |
105 | 31 30 29 28 27 26 2 1 0 |
106 | 0 0 0 0 0 0 XX XXXX XXXX XXXX XXXX XXXX X 0 0 0 |
107 | |
108 | |
109 | Information needed for each cell: |
110 | Meaning | bits total | bits per car | bits per cdr |
111 | GC mark | 2 | 1 | 1 - only one of them will be used (the other is wasted) |
112 | Type | 2x | x | x |
113 | Ptr/!ptr | 2 | 1 | 1 |
114 | |
115 | |
116 | Types (unboxed): |
117 | - Symbols |
118 | - 28bit integer ( will need signed shift right functionality ) |
119 | - 28bit unsigned integer |
120 | - Character |
121 | |
122 | If four types is all that should be possible (unboxed). then 2 bits are needed to differentiate. |
123 | 2 + 1 + 1 = 4 => 28bits for data. |
124 | |
125 | bit 0: ptr/!ptr |
126 | bit 1: gc |
127 | bit 2-3: type (if not ptr) |
128 | bit 3 - 24 ptr (if ptr) |
129 | bit 4 - 31 value (if value) |
130 | |
131 | An unboxed value can occupy a car or cdr field in a cons cell. |
132 | |
133 | types (boxed) extra information in pointer to cell can contain information |
134 | - 32 bit integer |
135 | - 32 bit unsigned integer |
136 | - 32 bit float |
137 | |
138 | boxed representation: |
139 | [ptr| cdr] |
140 | | |
141 | [Value | Aux + GC_MARK] |
142 | |
143 | Kinds of pointers: |
144 | - Pointer to cons cell. |
145 | - Pointer to unboxed value (fixnums not in a list, I hope this is so rare that it can be removed ) |
146 | - integer |
147 | - unsigned integer |
148 | - symbol |
149 | - float |
150 | - Pointer to boxed value. |
151 | - 32 bit integer |
152 | - 32 bit unsigned integer |
153 | - 32 bit float |
154 | - (Maybe something else ? Vectors/strings allocated in memory not occupied by heap?) |
155 | - vector of int |
156 | - vector of uint |
157 | - vector of float |
158 | - vector of double |
159 | - String |
160 | |
161 | 13 pointer"types" -> needs 4 bits |
162 | for 64MB heap there are 6 free bits. So with this scheme going to 128MB or 256MB heap |
163 | is also possible |
164 | |
165 | a pointer to some off heap vector/string could be represented by |
166 | |
167 | [ptr | cdr] |
168 | | |
169 | [full pointer | Aux + GC_MARK] |
170 | | |
171 | [VECTOR] |
172 | |
173 | Aux bits could be used for storing vector size. Up to 30bits should be available there |
174 | >> This is problematic. Now the information that something is a vector is split up |
175 | >> between 2 cons cells. This means GC needs both of these intact to be able to make |
176 | >> proper decision. |
177 | >> Will try to resolve this by adding some special symbols. But these must be symbols |
178 | >> that cannot occur normally in programs. Then an array could be: |
179 | |
180 | [Full pointer | ARRAY_SYM + GC_MARK] |
181 | | |
182 | [VECTOR] |
183 | |
184 | >> Boxed values same treatment as above. |
185 | >> TODO: Could this be simpler? |
186 | |
187 | [ VALUE | TYPE_SYM + GC_MARK] |
188 | |
189 | |
190 | 0000 00XX XXXX XXXX XXXX XXXX XXXX X000 : 0x03FF FFF8 |
191 | 1111 AA00 0000 0000 0000 0000 0000 0000 : 0xFC00 0000 (AA bits left unused for now, future heap growth?) |
192 | */ |
193 | |
194 | typedef enum { |
195 | LBM_FLASH_WRITE_OK, |
196 | LBM_FLASH_FULL, |
197 | LBM_FLASH_WRITE_ERROR |
198 | } lbm_flash_status; |
199 | |
200 | /** Struct representing a heap cons-cell. |
201 | * |
202 | */ |
203 | typedef struct { |
204 | lbm_value car; |
205 | lbm_value cdr; |
206 | } lbm_cons_t; |
207 | |
208 | /** |
209 | * Heap state |
210 | */ |
211 | typedef struct { |
212 | lbm_cons_t *heap; |
213 | lbm_value freelist; // list of free cons cells. |
214 | lbm_stack_t gc_stack; |
215 | |
216 | lbm_uint heap_size; // In number of cells. |
217 | lbm_uint heap_bytes; // In bytes. |
218 | |
219 | lbm_uint num_alloc; // Number of cells allocated. |
220 | lbm_uint num_alloc_arrays; // Number of arrays allocated. |
221 | |
222 | lbm_uint gc_num; // Number of times gc has been performed. |
223 | lbm_uint gc_marked; // Number of cells marked by mark phase. |
224 | lbm_uint gc_recovered; // Number of cells recovered by sweep phase. |
225 | lbm_uint gc_recovered_arrays;// Number of arrays recovered by sweep. |
226 | lbm_uint gc_least_free; // The smallest length of the freelist. |
227 | lbm_uint gc_last_free; // Number of elements on the freelist |
228 | // after most recent GC. |
229 | } lbm_heap_state_t; |
230 | |
231 | extern lbm_heap_state_t lbm_heap_state; |
232 | |
233 | typedef bool_Bool (*const_heap_write_fun)(lbm_uint ix, lbm_uint w); |
234 | |
235 | typedef struct { |
236 | lbm_uint *heap; |
237 | lbm_uint next; // next free index. |
238 | lbm_uint size; // in lbm_uint words. (cons-cells = words / 2) |
239 | } lbm_const_heap_t; |
240 | |
241 | /** |
242 | * The header portion of an array stored in array and symbol memory. |
243 | * An array is always a byte array. use the array-extensions for |
244 | * storing and reading larger values from arrays. |
245 | */ |
246 | typedef struct { |
247 | lbm_uint size; /// Number of elements |
248 | lbm_uint *data; /// pointer to lbm_memory array or C array. |
249 | } lbm_array_header_t; |
250 | |
251 | typedef struct { |
252 | lbm_uint size; |
253 | lbm_uint *data; |
254 | uint32_t index; // Limits arrays to max 2^32-1 elements. |
255 | } lbm_array_header_extended_t; |
256 | |
257 | /** Lock GC mutex |
258 | * Locks a mutex during GC marking when using the pointer reversal algorithm. |
259 | * Does nothing when using stack based GC mark. |
260 | */ |
261 | void lbm_gc_lock(void); |
262 | /* Unlock GC mutex |
263 | */ |
264 | void lbm_gc_unlock(void); |
265 | |
266 | /** Initialize heap storage. |
267 | * \param addr Pointer to an array of lbm_cons_t elements. This array must at least be aligned 4. |
268 | * \param num_cells Number of lbm_cons_t elements in the array. |
269 | * \param gc_stack_size Size of the gc_stack in number of words. |
270 | * \return 1 on success or 0 for failure. |
271 | */ |
272 | int lbm_heap_init(lbm_cons_t *addr, lbm_uint num_cells, |
273 | lbm_uint gc_stack_size); |
274 | |
275 | /** Add GC time statistics to heap_stats |
276 | * |
277 | * \param dur Duration as reported by the timestamp callback. |
278 | */ |
279 | void lbm_heap_new_gc_time(lbm_uint dur); |
280 | /** Add a new free_list length to the heap_stats. |
281 | * Calculates a new freelist length and updates |
282 | * the GC statistics. |
283 | */ |
284 | void lbm_heap_new_freelist_length(void); |
285 | /** Check how many lbm_cons_t cells are on the free-list |
286 | * |
287 | * \return Number of free lbm_cons_t cells. |
288 | */ |
289 | lbm_uint lbm_heap_num_free(void); |
290 | /** Check how many lbm_cons_t cells are allocated. |
291 | * |
292 | * \return Number of lbm_cons_t cells that are currently allocated. |
293 | */ |
294 | lbm_uint lbm_heap_num_allocated(void); |
295 | /** Size of the heap in number of lbm_cons_t cells. |
296 | * |
297 | * \return Size of the heap in number of lbm_cons_t cells. |
298 | */ |
299 | lbm_uint lbm_heap_size(void); |
300 | /** Size of the heap in bytes. |
301 | * |
302 | * \return Size of heap in bytes. |
303 | */ |
304 | lbm_uint lbm_heap_size_bytes(void); |
305 | /** Allocate an lbm_cons_t cell from the heap. |
306 | * |
307 | * \param type A type that can be encoded onto the cell (most often LBM_PTR_TYPE_CONS). |
308 | * \param car Value to write into car position of allocated cell. |
309 | * \param cdr Value to write into cdr position of allocated cell. |
310 | * \return An lbm_value referring to a cons_cell or enc_sym(SYM_MERROR) in case the heap is full. |
311 | */ |
312 | lbm_value lbm_heap_allocate_cell(lbm_type type, lbm_value car, lbm_value cdr); |
313 | /** Allocate a list of n heap-cells. |
314 | * \param n The number of heap-cells to allocate. |
315 | * \return A list of heap-cells of Memory error if unable to allocate. |
316 | */ |
317 | lbm_value lbm_heap_allocate_list(lbm_uint n); |
318 | /** Allocate a list of n heap-cells and initialize the values. |
319 | * \pram ls The result list is passed through this ptr. |
320 | * \param n The length of list to allocate. |
321 | * \param valist The values in a va_list to initialize the list with. |
322 | * \return True of False depending on success of allocation. |
323 | */ |
324 | lbm_value lbm_heap_allocate_list_init_va(unsigned int n, va_list valist); |
325 | /** Allocate a list of n heap-cells and initialize the values. |
326 | * \param n The length of list to allocate. |
327 | * \param ... The values to initialize the list with. |
328 | * \return allocated list or error symbol. |
329 | */ |
330 | lbm_value lbm_heap_allocate_list_init(unsigned int n, ...); |
331 | /** Decode an lbm_value representing a string into a C string |
332 | * |
333 | * \param val Value |
334 | * \return allocated list or error symbol |
335 | */ |
336 | char *lbm_dec_str(lbm_value val); |
337 | /** Decode an lbm_value representing a char channel into an lbm_char_channel_t pointer. |
338 | * |
339 | * \param val Value |
340 | * \return A pointer to an lbm_char_channel_t or NULL if the value does not encode a channel. |
341 | */ |
342 | lbm_char_channel_t *lbm_dec_channel(lbm_value val); |
343 | /** Decode an lbm_value representing a custom type into a lbm_uint value. |
344 | * |
345 | * \param val Value. |
346 | * \return The custom type payload. |
347 | */ |
348 | lbm_uint lbm_dec_custom(lbm_value val); |
349 | /** Decode a numerical value as if it is char |
350 | * |
351 | * \param val Value to decode |
352 | * \return The value encoded in val casted to a char. Returns 0 if val does not encode a number. |
353 | */ |
354 | uint8_t lbm_dec_as_char(lbm_value a); |
355 | /** Decode a numerical value as if it is unsigned |
356 | * |
357 | * \param val Value to decode |
358 | * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number. |
359 | */ |
360 | uint32_t lbm_dec_as_u32(lbm_value val); |
361 | /** Decode a numerical value as a signed integer. |
362 | * |
363 | * \param val Value to decode |
364 | * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number. |
365 | */ |
366 | int32_t lbm_dec_as_i32(lbm_value val); |
367 | /** Decode a numerical value as a float. |
368 | * |
369 | * \param val Value to decode. |
370 | * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number. |
371 | */ |
372 | float lbm_dec_as_float(lbm_value val); |
373 | /** Decode a numerical value as if it is a 64bit unsigned |
374 | * |
375 | * \param val Value to decode |
376 | * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number. |
377 | */ |
378 | uint64_t lbm_dec_as_u64(lbm_value val); |
379 | /** Decode a numerical value as a 64bit signed integer. |
380 | * |
381 | * \param val Value to decode |
382 | * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number. |
383 | */ |
384 | int64_t lbm_dec_as_i64(lbm_value val); |
385 | /** Decode a numerical value as a float. |
386 | * |
387 | * \param val Value to decode. |
388 | * \return The value encoded in val casted to a float. Returns 0 if val does not encode a number. |
389 | */ |
390 | double lbm_dec_as_double(lbm_value val); |
391 | |
392 | /** Decode a numerical value into the architecture defined unsigned integer type. |
393 | * |
394 | * \param val Value to decode |
395 | * \return The value encoded in val casted to an unsigned int. Returns 0 if val does not encode a number. |
396 | */ |
397 | lbm_uint lbm_dec_as_uint(lbm_value val); |
398 | |
399 | /** Decode a numerical value into the architecture defined signed integer type. |
400 | * |
401 | * \param val Value to decode |
402 | * \return The value encoded in val casted to a signed int. Returns 0 if val does not encode a number. |
403 | */ |
404 | lbm_int lbm_dec_as_int(lbm_value val); |
405 | |
406 | lbm_uint lbm_dec_raw(lbm_value v); |
407 | /** Allocates an lbm_cons_t cell from the heap and populates it. |
408 | * |
409 | * \param car The value to put in the car field of the allocated lbm_cons_t. |
410 | * \param cdr The value to put in the cdr field of the allocated lbm_cons_t. |
411 | * \return A value referencing the lbm_cons_t or enc_sym(SYM_MERROR) if heap is full. |
412 | */ |
413 | lbm_value lbm_cons(lbm_value car, lbm_value cdr); |
414 | |
415 | /** Accesses the car field of an lbm_cons_t. |
416 | * |
417 | * \param cons Value |
418 | * \return The car field of the lbm_cons_t if cons is a reference to a heap cell. |
419 | * If cons is nil, the return value is nil. If the value |
420 | * is not cons or nil, the return value is enc_sym(SYM_TERROR) for type error. |
421 | */ |
422 | lbm_value lbm_car(lbm_value cons); |
423 | /** Accesses the car field the car field of an lbm_cons_t. |
424 | * |
425 | * \param cons Value |
426 | * \return The car of car field or nil. |
427 | */ |
428 | lbm_value lbm_caar(lbm_value c); |
429 | /** Accesses the car of the cdr of an cons cell |
430 | * |
431 | * \param c Value |
432 | * \return the cdr field or type error. |
433 | */ |
434 | lbm_value lbm_cadr(lbm_value c); |
435 | /** Accesses the cdr field of an lbm_cons_t. |
436 | * |
437 | * \param cons Value |
438 | * \return The cdr field of the lbm_cons_t if cons is a reference to a heap cell. |
439 | * If cons is nil, the return value is nil. If the value |
440 | * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error. |
441 | */ |
442 | lbm_value lbm_cdr(lbm_value cons); |
443 | /** Accesses the cdr of an cdr field of an lbm_cons_t. |
444 | * |
445 | * \param cons Value |
446 | * \return The cdr of the cdr field of the lbm_cons_t if cons is a reference to a heap cell. |
447 | * If cons is nil, the return value is nil. If the value |
448 | * if not cons or nil, the return value is enc_sym(SYM_TERROR) for type error. |
449 | */ |
450 | lbm_value lbm_cddr(lbm_value c); |
451 | /** Update the value stored in the car field of a heap cell. |
452 | * |
453 | * \param c Value referring to a heap cell. |
454 | * \param v Value to replace the car field with. |
455 | * \return 1 on success and 0 if the c value does not refer to a heap cell. |
456 | */ |
457 | int lbm_set_car(lbm_value c, lbm_value v); |
458 | /** Update the value stored in the cdr field of a heap cell. |
459 | * |
460 | * \param c Value referring to a heap cell. |
461 | * \param v Value to replace the cdr field with. |
462 | * \return 1 on success and 0 if the c value does not refer to a heap cell. |
463 | */ |
464 | int lbm_set_cdr(lbm_value c, lbm_value v); |
465 | /** Update the value stored in the car and cdr fields of a heap cell. |
466 | * |
467 | * \param c Value referring to a heap cell. |
468 | * \param car_val Value to replace the car field with. |
469 | * \param cdr_val Value to replace the cdr field with. |
470 | * \return 1 on success and 0 if the c value does not refer to a heap cell. |
471 | */ |
472 | int lbm_set_car_and_cdr(lbm_value c, lbm_value car_val, lbm_value cdr_val); |
473 | // List functions |
474 | /** Calculate the length of a proper list |
475 | * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap |
476 | * may lead to the function not terminating. |
477 | * |
478 | * \param c A list |
479 | * \return The length of the list. Unless the value is a cyclic structure on the heap, this function will terminate. |
480 | */ |
481 | lbm_uint lbm_list_length(lbm_value c); |
482 | |
483 | /** Calculate the length of a proper list and evaluate a predicate for each element. |
484 | * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap |
485 | * may lead to the function not terminating. |
486 | * |
487 | * \param c A list |
488 | * \param pres Boolean result of predicate, false if predicate is false for any of the elements in the list, otherwise true. |
489 | * \param pred Predicate to evaluate for each element of the list. |
490 | */ |
491 | unsigned int lbm_list_length_pred(lbm_value c, bool_Bool *pres, bool_Bool (*pred)(lbm_value)); |
492 | /** Reverse a proper list |
493 | * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap |
494 | * may lead to the function not terminating. |
495 | * |
496 | * \param list A list |
497 | * \return The list reversed or enc_sym(SYM_MERROR) if heap is full. |
498 | */ |
499 | lbm_value lbm_list_reverse(lbm_value list); |
500 | /** Reverse a proper list destroying the original. |
501 | * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap |
502 | * may lead to the function not terminating. |
503 | * |
504 | * \param list A list |
505 | * \return The list reversed |
506 | */ |
507 | lbm_value lbm_list_destructive_reverse(lbm_value list); |
508 | /** Copy a list |
509 | * \warning This is a dangerous function that should be used carefully. Cyclic structures on the heap |
510 | * may lead to the function not terminating. |
511 | * |
512 | * \param m Number of elements to copy or -1 for all. If 1, m will be updated with the length of the list |
513 | * \param list A list. |
514 | * \return Reversed list or enc_sym(SYM_MERROR) if heap is full. |
515 | */ |
516 | lbm_value lbm_list_copy(int *m, lbm_value list); |
517 | |
518 | /** A destructive append of two lists |
519 | * |
520 | * \param list1 A list |
521 | * \param list2 A list |
522 | * \return list1 with list2 appended at the end. |
523 | */ |
524 | lbm_value lbm_list_append(lbm_value list1, lbm_value list2); |
525 | |
526 | /** Drop values from the head of a list. |
527 | * \param n Number of values to drop. |
528 | * \param ls List to drop values from. |
529 | * \return The list with the n first elements removed. |
530 | */ |
531 | lbm_value lbm_list_drop(unsigned int n, lbm_value ls); |
532 | /** Index into a list. |
533 | * \param l List to index into. |
534 | * \param n Position to read out of the list. |
535 | * \return Value at position n of l or nil if out of bounds. |
536 | */ |
537 | lbm_value lbm_index_list(lbm_value l, int32_t n); |
538 | |
539 | // State and statistics |
540 | /** Get a copy of the heap statistics structure. |
541 | * |
542 | * \param A pointer to an lbm_heap_state_t to populate |
543 | * with the current statistics. |
544 | */ |
545 | void lbm_get_heap_state(lbm_heap_state_t *); |
546 | /** Get the maximum stack level of the GC stack |
547 | * \return maximum value the gc stack sp reached so far. |
548 | */ |
549 | lbm_uint lbm_get_gc_stack_max(void); |
550 | /** Get the size of the GC stack. |
551 | * \return the size of the gc stack. |
552 | */ |
553 | lbm_uint lbm_get_gc_stack_size(void); |
554 | // Garbage collection |
555 | /** Increment the counter that is counting the number of times GC ran |
556 | * |
557 | */ |
558 | void lbm_gc_state_inc(void); |
559 | /** Set the freelist to NIL. Means that no memory will be available |
560 | * until after a garbage collection. |
561 | */ |
562 | void lbm_nil_freelist(void); |
563 | /** Mark all heap cells reachable from an environment. |
564 | * \param environment. |
565 | */ |
566 | void lbm_gc_mark_env(lbm_value); |
567 | /** Mark heap cells reachable from the lbm_value v. |
568 | * \param root |
569 | */ |
570 | void lbm_gc_mark_phase(lbm_value root); |
571 | /** Performs lbm_gc_mark_phase on all the values of an array. |
572 | * This function is similar to lbm_gc_mark_roots but performs |
573 | * extra checks to not traverse into non-standard values. |
574 | * TODO: Check if this function is really needed. |
575 | * \param data Array of roots to traverse from. |
576 | * \param n Number of elements in roots-array. |
577 | */ |
578 | void lbm_gc_mark_aux(lbm_uint *data, lbm_uint n); |
579 | /** Performs lbm_gc_mark_phase on all the values in the roots array. |
580 | * \param roots pointer to array of roots. |
581 | * \param num_roots size of array of roots. |
582 | */ |
583 | void lbm_gc_mark_roots(lbm_uint *roots, lbm_uint num_roots); |
584 | /** Sweep up all non marked heap cells and place them on the free list. |
585 | * |
586 | * \return 1 |
587 | */ |
588 | int lbm_gc_sweep_phase(void); |
589 | |
590 | // Array functionality |
591 | /** Allocate an bytearray in symbols and arrays memory (lispbm_memory.h) |
592 | * and create a heap cell that refers to this bytearray. |
593 | * \param res The resulting lbm_value is returned through this argument. |
594 | * \param size Array size in number of 32 bit words. |
595 | * \return 1 for success of 0 for failure. |
596 | */ |
597 | int lbm_heap_allocate_array(lbm_value *res, lbm_uint size); |
598 | /** Allocate an array in symbols and arrays memory (lispbm_memory.h) |
599 | * and create a heap cell that refers to this array. |
600 | * \param res The resulting lbm_value is returned through this argument. |
601 | * \param size Array size in number of 32 bit words. |
602 | * \return 1 for success of 0 for failure. |
603 | */ |
604 | int lbm_heap_allocate_lisp_array(lbm_value *res, lbm_uint size); |
605 | /** Convert a C array into an lbm array. If the C array is allocated in LBM MEMORY |
606 | * the lifetime of the array will be managed by GC. |
607 | * \param res lbm_value result pointer for storage of the result array. |
608 | * \param data C array. |
609 | * \param type The type tag to assign to the resulting LBM array. |
610 | * \param num_elt Number of elements in the array. |
611 | * \return 1 for success and 0 for failure. |
612 | */ |
613 | int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt); |
614 | /** Get the size of an array value. |
615 | * \param arr lbm_value array to get size of. |
616 | * \return -1 for failure or length of array. |
617 | */ |
618 | lbm_int lbm_heap_array_get_size(lbm_value arr); |
619 | /** Get a pointer to the data of an array for read only purposes. |
620 | * \param arr lbm_value array to get pointer from. |
621 | * \return NULL or valid pointer. |
622 | */ |
623 | const uint8_t *lbm_heap_array_get_data_ro(lbm_value arr); |
624 | /** Get a pointer to the data of an array for read/write purposes. |
625 | * \param arr lbm_value array to get pointer from. |
626 | * \return NULL or valid pointer. |
627 | */ |
628 | uint8_t *lbm_heap_array_get_data_rw(lbm_value arr); |
629 | /** Explicitly free an array. |
630 | * This function needs to be used with care and knowledge. |
631 | * \param arr Array value. |
632 | */ |
633 | int lbm_heap_explicit_free_array(lbm_value arr); |
634 | /** Query the size in bytes of an lbm_type. |
635 | * \param t Type |
636 | * \return Size in bytes of type or 0 if the type represents a composite. |
637 | */ |
638 | lbm_uint lbm_size_of(lbm_type t); |
639 | |
640 | int lbm_const_heap_init(const_heap_write_fun w_fun, |
641 | lbm_const_heap_t *heap, |
642 | lbm_uint *addr, |
643 | lbm_uint num_words); |
644 | |
645 | lbm_flash_status lbm_allocate_const_cell(lbm_value *res); |
646 | lbm_flash_status lbm_write_const_raw(lbm_uint *data, lbm_uint n, lbm_uint *res); |
647 | lbm_flash_status lbm_allocate_const_raw(lbm_uint nwords, lbm_uint *res); |
648 | lbm_flash_status write_const_cdr(lbm_value cell, lbm_value val); |
649 | lbm_flash_status write_const_car(lbm_value cell, lbm_value val); |
650 | lbm_flash_status lbm_const_write(lbm_uint *tgt, lbm_uint val); |
651 | lbm_uint lbm_flash_memory_usage(void); |
652 | |
653 | /** Query the type information of a value. |
654 | * |
655 | * \param x Value to check the type of. |
656 | * \return The type information. |
657 | */ |
658 | static inline lbm_type lbm_type_of(lbm_value x) { |
659 | return (x & LBM_PTR_BIT0x00000001u) ? (x & LBM_PTR_TYPE_MASK0xFC000000u) : (x & LBM_VAL_TYPE_MASK0x0000000Cu); |
660 | } |
661 | |
662 | // type-of check that is safe in functional code |
663 | static inline lbm_type lbm_type_of_functional(lbm_value x) { |
664 | return (x & LBM_PTR_BIT0x00000001u) ? |
665 | (x & (LBM_PTR_TO_CONSTANT_MASK~0x04000000u & LBM_PTR_TYPE_MASK0xFC000000u)) : |
666 | (x & LBM_VAL_TYPE_MASK0x0000000Cu); |
667 | } |
668 | |
669 | static inline lbm_value lbm_enc_cons_ptr(lbm_uint x) { |
670 | return ((x << LBM_ADDRESS_SHIFT2) | LBM_TYPE_CONS0x10000000u | LBM_PTR_BIT0x00000001u); |
671 | } |
672 | |
673 | static inline lbm_uint lbm_dec_ptr(lbm_value p) { |
674 | return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) >> LBM_ADDRESS_SHIFT2); |
675 | } |
676 | |
677 | extern lbm_cons_t *lbm_heaps[2]; |
678 | |
679 | static inline lbm_uint lbm_dec_cons_cell_ptr(lbm_value p) { |
680 | lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26; |
681 | return lbm_dec_ptr(p) >> h; |
682 | } |
683 | |
684 | static inline lbm_cons_t *lbm_dec_heap(lbm_value p) { |
685 | lbm_uint h = (p & LBM_PTR_TO_CONSTANT_BIT0x04000000u) >> LBM_PTR_TO_CONSTANT_SHIFT26; |
686 | return lbm_heaps[h]; |
687 | } |
688 | |
689 | static inline lbm_value lbm_set_ptr_type(lbm_value p, lbm_type t) { |
690 | return ((LBM_PTR_VAL_MASK0x03FFFFFCu & p) | t | LBM_PTR_BIT0x00000001u); |
691 | } |
692 | |
693 | static inline lbm_value lbm_enc_sym(lbm_uint s) { |
694 | return (s << LBM_VAL_SHIFT4) | LBM_TYPE_SYMBOL0x00000000u; |
695 | } |
696 | |
697 | static inline lbm_value lbm_enc_i(lbm_int x) { |
698 | return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_I0x00000008u; |
699 | } |
700 | |
701 | static inline lbm_value lbm_enc_u(lbm_uint x) { |
702 | return (x << LBM_VAL_SHIFT4) | LBM_TYPE_U0x0000000Cu; |
703 | } |
704 | |
705 | /** Encode 32 bit integer into an lbm_value. |
706 | * \param x Value to encode. |
707 | * \return result encoded value. |
708 | */ |
709 | extern lbm_value lbm_enc_i32(int32_t x); |
710 | |
711 | /** Encode 32 bit unsigned integer into an lbm_value. |
712 | * \param x Value to encode. |
713 | * \return result encoded value. |
714 | */ |
715 | extern lbm_value lbm_enc_u32(uint32_t x); |
716 | |
717 | /** Encode a float into an lbm_value. |
718 | * \param x float value to encode. |
719 | * \return result encoded value. |
720 | */ |
721 | extern lbm_value lbm_enc_float(float x); |
722 | |
723 | /** Encode a 64 bit integer into an lbm_value. |
724 | * \param x 64 bit integer to encode. |
725 | * \return result encoded value. |
726 | */ |
727 | extern lbm_value lbm_enc_i64(int64_t x); |
728 | |
729 | /** Encode a 64 bit unsigned integer into an lbm_value. |
730 | * \param x 64 bit unsigned integer to encode. |
731 | * \return result encoded value. |
732 | */ |
733 | extern lbm_value lbm_enc_u64(uint64_t x); |
734 | |
735 | /** Encode a double into an lbm_value. |
736 | * \param x double to encode. |
737 | * \return result encoded value. |
738 | */ |
739 | extern lbm_value lbm_enc_double(double x); |
740 | |
741 | static inline lbm_value lbm_enc_char(uint8_t x) { |
742 | return ((lbm_uint)x << LBM_VAL_SHIFT4) | LBM_TYPE_CHAR0x00000004u; |
743 | } |
744 | |
745 | static inline lbm_int lbm_dec_i(lbm_value x) { |
746 | return (lbm_int)x >> LBM_VAL_SHIFT4; |
747 | } |
748 | |
749 | static inline lbm_uint lbm_dec_u(lbm_value x) { |
750 | return x >> LBM_VAL_SHIFT4; |
751 | } |
752 | |
753 | static inline uint8_t lbm_dec_char(lbm_value x) { |
754 | return (uint8_t)(x >> LBM_VAL_SHIFT4); |
755 | } |
756 | |
757 | static inline lbm_uint lbm_dec_sym(lbm_value x) { |
758 | return x >> LBM_VAL_SHIFT4; |
759 | } |
760 | |
761 | /** Decode an lbm_value representing a float. |
762 | * \param x Value to decode. |
763 | * \return decoded float. |
764 | */ |
765 | extern float lbm_dec_float(lbm_value x); |
766 | |
767 | /** Decode an lbm_value representing a double. |
768 | * \param x Value to decode. |
769 | * \return decoded float. |
770 | */ |
771 | extern double lbm_dec_double(lbm_value x); |
772 | |
773 | |
774 | static inline uint32_t lbm_dec_u32(lbm_value x) { |
775 | #ifndef LBM64 |
776 | return (uint32_t)lbm_car(x); |
777 | #else |
778 | return (uint32_t)(x >> LBM_VAL_SHIFT4); |
779 | #endif |
780 | } |
781 | |
782 | /** Decode an lbm_value representing a 64 bit unsigned integer. |
783 | * \param x Value to decode. |
784 | * \return decoded uint64_t. |
785 | */ |
786 | extern uint64_t lbm_dec_u64(lbm_value x); |
787 | |
788 | static inline int32_t lbm_dec_i32(lbm_value x) { |
789 | #ifndef LBM64 |
790 | return (int32_t)lbm_car(x); |
791 | #else |
792 | return (int32_t)(x >> LBM_VAL_SHIFT4); |
793 | #endif |
794 | } |
795 | |
796 | /** Decode an lbm_value representing a 64 bit integer. |
797 | * \param x Value to decode. |
798 | * \return decoded int64_t. |
799 | */ |
800 | extern int64_t lbm_dec_i64(lbm_value x); |
801 | |
802 | /** |
803 | * Check if a value is a heap pointer |
804 | * \param x Value to check |
805 | * \return true if x is a pointer to a heap cell, false otherwise. |
806 | */ |
807 | static inline bool_Bool lbm_is_ptr(lbm_value x) { |
808 | return (x & LBM_PTR_BIT0x00000001u); |
809 | } |
810 | |
811 | /** |
812 | * Check if a value is a Read/Writeable cons cell |
813 | * \param x Value to check |
814 | * \return true if x is a Read/Writeable cons cell, false otherwise. |
815 | */ |
816 | static inline bool_Bool lbm_is_cons_rw(lbm_value x) { |
817 | return (lbm_type_of(x) == LBM_TYPE_CONS0x10000000u); |
818 | } |
819 | |
820 | /** |
821 | * Check if a value is a Readable cons cell |
822 | * \param x Value to check |
823 | * \return true if x is a readable cons cell, false otherwise. |
824 | */ |
825 | static inline bool_Bool lbm_is_cons(lbm_value x) { |
826 | return lbm_is_ptr(x) && ((x & LBM_CONS_TYPE_MASK0xF0000000u) == LBM_TYPE_CONS0x10000000u); |
827 | } |
828 | |
829 | /** Check if a value represents a number |
830 | * \param x Value to check. |
831 | * \return true is x represents a number and false otherwise. |
832 | */ |
833 | static inline bool_Bool lbm_is_number(lbm_value x) { |
834 | return |
835 | (x & LBM_PTR_BIT0x00000001u) ? |
836 | ((x & LBM_NUMBER_MASK0x08000000u) == LBM_NUMBER_MASK0x08000000u) : |
837 | (x & LBM_VAL_TYPE_MASK0x0000000Cu); |
838 | } |
839 | |
840 | /** Check if value is an array that can be READ |
841 | * \param x Value to check. |
842 | * \return true if x represents a readable array and false otherwise. |
843 | */ |
844 | static inline bool_Bool lbm_is_array_r(lbm_value x) { |
845 | lbm_type t = lbm_type_of(x); |
846 | return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_ARRAY0x80000000u); |
847 | } |
848 | |
849 | static inline bool_Bool lbm_is_array_rw(lbm_value x) { |
850 | return( (lbm_type_of(x) == LBM_TYPE_ARRAY0x80000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u)); |
851 | } |
852 | |
853 | static inline bool_Bool lbm_is_lisp_array_r(lbm_value x) { |
854 | lbm_type t = lbm_type_of(x); |
855 | return ((t & LBM_PTR_TO_CONSTANT_MASK~0x04000000u) == LBM_TYPE_LISPARRAY0xB0000000u); |
856 | } |
857 | |
858 | static inline bool_Bool lbm_is_lisp_array_rw(lbm_value x) { |
859 | return( (lbm_type_of(x) == LBM_TYPE_LISPARRAY0xB0000000u) && !(x & LBM_PTR_TO_CONSTANT_BIT0x04000000u)); |
860 | } |
861 | |
862 | |
863 | static inline bool_Bool lbm_is_channel(lbm_value x) { |
864 | return (lbm_type_of(x) == LBM_TYPE_CHANNEL0x90000000u && |
865 | lbm_type_of(lbm_cdr(x)) == LBM_TYPE_SYMBOL0x00000000u && |
866 | lbm_cdr(x) == ENC_SYM_CHANNEL_TYPE(((0x37) << 4) | 0x00000000u)); |
867 | } |
868 | static inline bool_Bool lbm_is_char(lbm_value x) { |
869 | return (lbm_type_of(x) == LBM_TYPE_CHAR0x00000004u); |
870 | } |
871 | |
872 | static inline bool_Bool lbm_is_special(lbm_value symrep) { |
873 | return ((lbm_type_of(symrep) == LBM_TYPE_SYMBOL0x00000000u) && |
874 | (lbm_dec_sym(symrep) < SPECIAL_SYMBOLS_END0xFFFF)); |
875 | } |
876 | |
877 | static inline bool_Bool lbm_is_closure(lbm_value exp) { |
878 | return ((lbm_is_cons(exp)) && |
879 | (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) && |
880 | (lbm_car(exp) == ENC_SYM_CLOSURE(((0x10F) << 4) | 0x00000000u))); |
881 | } |
882 | |
883 | static inline bool_Bool lbm_is_continuation(lbm_value exp) { |
884 | return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) && |
885 | (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) && |
886 | (lbm_car(exp) == ENC_SYM_CONT(((0x10E) << 4) | 0x00000000u))); |
887 | } |
888 | |
889 | static inline bool_Bool lbm_is_macro(lbm_value exp) { |
890 | return ((lbm_type_of(exp) == LBM_TYPE_CONS0x10000000u) && |
891 | (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) && |
892 | (lbm_car(exp) == ENC_SYM_MACRO(((0x10D) << 4) | 0x00000000u))); |
893 | } |
894 | |
895 | static inline bool_Bool lbm_is_match_binder(lbm_value exp) { |
896 | return (lbm_is_cons(exp) && |
897 | (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) && |
898 | (lbm_car(exp) == ENC_SYM_MATCH_ANY(((0x41) << 4) | 0x00000000u))); |
899 | } |
900 | |
901 | static inline bool_Bool lbm_is_comma_qualified_symbol(lbm_value exp) { |
902 | return (lbm_is_cons(exp) && |
903 | (lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL0x00000000u) && |
904 | (lbm_car(exp) == ENC_SYM_COMMA(((0x73) << 4) | 0x00000000u)) && |
905 | (lbm_type_of(lbm_cadr(exp)) == LBM_TYPE_SYMBOL0x00000000u)); |
906 | } |
907 | |
908 | static inline bool_Bool lbm_is_symbol(lbm_value exp) { |
909 | return !(exp & LBM_LOW_RESERVED_BITS0x0000000Fu); |
910 | } |
911 | |
912 | static inline bool_Bool lbm_is_symbol_nil(lbm_value exp) { |
913 | return !exp; |
914 | } |
915 | |
916 | static inline bool_Bool lbm_is_symbol_true(lbm_value exp) { |
917 | return (lbm_is_symbol(exp) && exp == ENC_SYM_TRUE(((0x2) << 4) | 0x00000000u)); |
918 | } |
919 | |
920 | static inline bool_Bool lbm_is_symbol_eval(lbm_value exp) { |
921 | return (lbm_is_symbol(exp) && exp == ENC_SYM_EVAL(((0x30008) << 4) | 0x00000000u)); |
922 | } |
923 | |
924 | static inline bool_Bool lbm_is_symbol_merror(lbm_value exp) { |
925 | return lbm_is_symbol(exp) && (exp == ENC_SYM_MERROR(((0x23) << 4) | 0x00000000u)); |
926 | } |
927 | |
928 | static inline bool_Bool lbm_is_list(lbm_value x) { |
929 | return (lbm_is_cons(x) || lbm_is_symbol_nil(x)); |
930 | } |
931 | |
932 | static inline bool_Bool lbm_is_list_rw(lbm_value x) { |
933 | return (lbm_is_cons_rw(x) || lbm_is_symbol_nil(x)); |
934 | } |
935 | |
936 | static inline bool_Bool lbm_is_quoted_list(lbm_value x) { |
937 | return (lbm_is_cons(x) && |
938 | lbm_is_symbol(lbm_car(x)) && |
939 | (lbm_car(x) == ENC_SYM_QUOTE(((0x100) << 4) | 0x00000000u)) && |
940 | lbm_is_cons(lbm_cdr(x)) && |
941 | lbm_is_cons(lbm_cadr(x))); |
942 | } |
943 | |
944 | #ifndef LBM64 |
945 | #define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFF0 |
946 | #else |
947 | #define ERROR_SYMBOL_MASK0xFFFFFFF0 0xFFFFFFFFFFFFFFF0 |
948 | #endif |
949 | |
950 | /* all error signaling symbols are in the range 0x20 - 0x2F */ |
951 | static inline bool_Bool lbm_is_error(lbm_value v){ |
952 | return (lbm_is_symbol(v) && |
953 | ((lbm_dec_sym(v) & ERROR_SYMBOL_MASK0xFFFFFFF0) == 0x20)); |
954 | } |
955 | |
956 | // ref_cell: returns a reference to the cell addressed by bits 3 - 26 |
957 | // Assumes user has checked that is_ptr was set |
958 | static inline lbm_cons_t* lbm_ref_cell(lbm_value addr) { |
959 | return &lbm_dec_heap(addr)[lbm_dec_cons_cell_ptr(addr)]; |
960 | //return &lbm_heap_state.heap[lbm_dec_ptr(addr)]; |
961 | } |
962 | |
963 | |
964 | // lbm_uint a = lbm_heaps[0]; |
965 | // lbm_uint b = lbm_heaps[1]; |
966 | // lbm_uint i = (addr & LBM_PTR_TO_CONSTANT_BIT) >> LBM_PTR_TO_CONSTANT_SHIFT) - 1; |
967 | // lbm_uint h = (a & i) | (b & ~i); |
968 | |
969 | #ifdef __cplusplus |
970 | } |
971 | #endif |
972 | #endif |