1 /* g/a.c
2 **
3 */
4 #include "all.h"
5
6 /* _box_count(): adjust memory count.
7 */
8 #ifdef U3_CPU_DEBUG
9 static void
_box_count(c3_ws siz_ws)10 _box_count(c3_ws siz_ws)
11 {
12 u3R->all.fre_w += siz_ws;
13 {
14 c3_w end_w = _(u3a_is_north(u3R))
15 ? (u3R->hat_p - u3R->rut_p)
16 : (u3R->rut_p - u3R->hat_p);
17 c3_w all_w = (end_w - u3R->all.fre_w);
18
19 if ( all_w > u3R->all.max_w ) {
20 u3R->all.max_w = all_w;
21 }
22 }
23 }
24 #else
25 static void
_box_count(c3_ws siz_ws)26 _box_count(c3_ws siz_ws) { }
27 #endif
28
29 /* _box_slot(): select the right free list to search for a block.
30 */
31 static c3_w
_box_slot(c3_w siz_w)32 _box_slot(c3_w siz_w)
33 {
34 if ( siz_w < u3a_minimum ) {
35 return 0;
36 }
37 else {
38 c3_w i_w = 1;
39
40 while ( 1 ) {
41 if ( i_w == u3a_fbox_no ) {
42 return (i_w - 1);
43 }
44 if ( siz_w < 16 ) {
45 return i_w;
46 }
47 siz_w = (siz_w + 1) >> 1;
48 i_w += 1;
49 }
50 }
51 }
52
53 /* _box_make(): construct a box.
54 */
55 static u3a_box*
_box_make(void * box_v,c3_w siz_w,c3_w use_w)56 _box_make(void* box_v, c3_w siz_w, c3_w use_w)
57 {
58 u3a_box* box_u = box_v;
59 c3_w* box_w = box_v;
60
61 c3_assert(siz_w >= u3a_minimum);
62
63 box_w[0] = siz_w;
64 box_w[siz_w - 1] = siz_w;
65 box_u->use_w = use_w;
66
67 # ifdef U3_MEMORY_DEBUG
68 box_u->cod_w = u3_Code;
69 box_u->eus_w = 0;
70 # endif
71
72 return box_u;
73 }
74
75 /* _box_attach(): attach a box to the free list.
76 */
77 static void
_box_attach(u3a_box * box_u)78 _box_attach(u3a_box* box_u)
79 {
80 c3_assert(box_u->siz_w >= (1 + c3_wiseof(u3a_fbox)));
81 c3_assert(0 != u3of(u3a_fbox, box_u));
82
83 #if 0
84 // For debugging, fill the box with beef.
85 {
86 c3_w* box_w = (void *)box_u;
87 c3_w i_w;
88
89 for ( i_w = c3_wiseof(u3a_box); (i_w + 1) < box_u->siz_w; i_w++ ) {
90 box_w[i_w] = 0xdeadbeef;
91 }
92 }
93 #endif
94
95 _box_count(box_u->siz_w);
96 {
97 c3_w sel_w = _box_slot(box_u->siz_w);
98 u3p(u3a_fbox) fre_p = u3of(u3a_fbox, box_u);
99 u3p(u3a_fbox)* pfr_p = &u3R->all.fre_p[sel_w];
100 u3p(u3a_fbox) nex_p = *pfr_p;
101
102 u3to(u3a_fbox, fre_p)->pre_p = 0;
103 u3to(u3a_fbox, fre_p)->nex_p = nex_p;
104 if ( u3to(u3a_fbox, fre_p)->nex_p ) {
105 u3to(u3a_fbox, u3to(u3a_fbox, fre_p)->nex_p)->pre_p = fre_p;
106 }
107 (*pfr_p) = fre_p;
108 }
109 }
110
111 /* _box_detach(): detach a box from the free list.
112 */
113 static void
_box_detach(u3a_box * box_u)114 _box_detach(u3a_box* box_u)
115 {
116 u3p(u3a_fbox) fre_p = u3of(u3a_fbox, box_u);
117 u3p(u3a_fbox) pre_p = u3to(u3a_fbox, fre_p)->pre_p;
118 u3p(u3a_fbox) nex_p = u3to(u3a_fbox, fre_p)->nex_p;
119
120 _box_count(-(box_u->siz_w));
121
122 if ( nex_p ) {
123 c3_assert(u3to(u3a_fbox, nex_p)->pre_p == fre_p);
124 u3to(u3a_fbox, nex_p)->pre_p = pre_p;
125 }
126 if ( pre_p ) {
127 c3_assert(u3to(u3a_fbox, pre_p)->nex_p == fre_p);
128 u3to(u3a_fbox, pre_p)->nex_p = nex_p;
129 }
130 else {
131 c3_w sel_w = _box_slot(box_u->siz_w);
132
133 c3_assert(fre_p == u3R->all.fre_p[sel_w]);
134 u3R->all.fre_p[sel_w] = nex_p;
135 }
136 }
137
138 /* _box_free(): free and coalesce.
139 */
140 static void
_box_free(u3a_box * box_u)141 _box_free(u3a_box* box_u)
142 {
143 c3_w* box_w = (c3_w *)(void *)box_u;
144
145 c3_assert(box_u->use_w != 0);
146 box_u->use_w -= 1;
147 if ( 0 != box_u->use_w ) {
148 return;
149 }
150
151 #if 0
152 /* Clear the contents of the block, for debugging.
153 */
154 {
155 c3_w i_w;
156
157 for ( i_w = c3_wiseof(u3a_box); (i_w + 1) < box_u->siz_w; i_w++ ) {
158 box_w[i_w] = 0xdeadbeef;
159 }
160 }
161 #endif
162
163 if ( c3y == u3a_is_north(u3R) ) {
164 /* Try to coalesce with the block below.
165 */
166 if ( box_w != u3a_into(u3R->rut_p) ) {
167 c3_w laz_w = *(box_w - 1);
168 u3a_box* pox_u = (u3a_box*)(void *)(box_w - laz_w);
169
170 if ( 0 == pox_u->use_w ) {
171 _box_detach(pox_u);
172 _box_make(pox_u, (laz_w + box_u->siz_w), 0);
173
174 box_u = pox_u;
175 box_w = (c3_w*)(void *)pox_u;
176 }
177 }
178
179 /* Try to coalesce with the block above, or the wilderness.
180 */
181 if ( (box_w + box_u->siz_w) == u3a_into(u3R->hat_p) ) {
182 u3R->hat_p = u3a_outa(box_w);
183 }
184 else {
185 u3a_box* nox_u = (u3a_box*)(void *)(box_w + box_u->siz_w);
186
187 if ( 0 == nox_u->use_w ) {
188 _box_detach(nox_u);
189 _box_make(box_u, (box_u->siz_w + nox_u->siz_w), 0);
190 }
191 _box_attach(box_u);
192 }
193 }
194 else {
195 /* Try to coalesce with the block above.
196 */
197 if ( (box_w + box_u->siz_w) != u3a_into(u3R->rut_p) ) {
198 u3a_box* nox_u = (u3a_box*)(void *)(box_w + box_u->siz_w);
199
200 if ( 0 == nox_u->use_w ) {
201 _box_detach(nox_u);
202 _box_make(box_u, (box_u->siz_w + nox_u->siz_w), 0);
203 }
204 }
205
206 /* Try to coalesce with the block below, or with the wilderness.
207 */
208 if ( box_w == u3a_into(u3R->hat_p) ) {
209 u3R->hat_p = u3a_outa(box_w + box_u->siz_w);
210 }
211 else {
212 c3_w laz_w = *(box_w - 1);
213 u3a_box* pox_u = (u3a_box*)(void *)(box_w - laz_w);
214
215 if ( 0 == pox_u->use_w ) {
216 _box_detach(pox_u);
217 _box_make(pox_u, (laz_w + box_u->siz_w), 0);
218 box_u = pox_u;
219 }
220 _box_attach(box_u);
221 }
222 }
223 }
224
225 /* _me_align_pad(): pad to first point after pos_p aligned at (ald_w, alp_w).
226 */
227 static __inline__ c3_w
_me_align_pad(u3_post pos_p,c3_w ald_w,c3_w alp_w)228 _me_align_pad(u3_post pos_p, c3_w ald_w, c3_w alp_w)
229 {
230 c3_w adj_w = (ald_w - (alp_w + 1));
231 c3_p off_p = (pos_p + adj_w);
232 c3_p orp_p = off_p &~ (ald_w - 1);
233 c3_p fin_p = orp_p + alp_w;
234 c3_w pad_w = (fin_p - pos_p);
235
236 return pad_w;
237 }
238
239 /* _me_align_dap(): pad to last point before pos_p aligned at (ald_w, alp_w).
240 */
241 static __inline__ c3_w
_me_align_dap(u3_post pos_p,c3_w ald_w,c3_w alp_w)242 _me_align_dap(u3_post pos_p, c3_w ald_w, c3_w alp_w)
243 {
244 c3_w adj_w = alp_w;
245 c3_p off_p = (pos_p - adj_w);
246 c3_p orp_p = (off_p &~ (ald_w - 1));
247 c3_p fin_p = orp_p + alp_w;
248 c3_w pad_w = (pos_p - fin_p);
249
250 return pad_w;
251 }
252
253 /* _ca_box_make_hat(): in u3R, allocate directly on the hat.
254 */
255 static u3a_box*
_ca_box_make_hat(c3_w len_w,c3_w ald_w,c3_w alp_w,c3_w use_w)256 _ca_box_make_hat(c3_w len_w, c3_w ald_w, c3_w alp_w, c3_w use_w)
257 {
258 c3_w pad_w, siz_w;
259 u3_post all_p;
260
261 if ( c3y == u3a_is_north(u3R) ) {
262 all_p = u3R->hat_p;
263 pad_w = _me_align_pad(all_p, ald_w, alp_w);
264 siz_w = (len_w + pad_w);
265
266 if ( (siz_w >= (u3R->cap_p - u3R->hat_p)) ) {
267 return 0;
268 }
269 u3R->hat_p = (all_p + siz_w);
270 }
271 else {
272 all_p = (u3R->hat_p - len_w);
273 pad_w = _me_align_dap(all_p, ald_w, alp_w);
274 siz_w = (len_w + pad_w);
275 all_p -= pad_w;
276
277 if ( siz_w >= (u3R->hat_p - u3R->cap_p) ) {
278 return 0;
279 }
280 u3R->hat_p = all_p;
281 }
282 return _box_make(u3a_into(all_p), siz_w, use_w);
283 }
284
285 #if 0
286 /* _me_road_all_hat(): in u3R, allocate directly on the hat.
287 */
288 static u3a_box*
289 _ca_box_make_hat(c3_w len_w, c3_w alm_w, c3_w use_w)
290 {
291 return _box_make(_me_road_all_hat(len_w), len_w, use_w);
292 }
293 #endif
294
295 #if 0 // not yet used
296 /* _me_road_all_cap(): in u3R, allocate directly on the cap.
297 */
298 static c3_w*
299 _me_road_all_cap(c3_w len_w)
300 {
301 if ( len_w > u3a_open(u3R) ) {
302 u3m_bail(c3__meme); return 0;
303 }
304
305 if ( c3y == u3a_is_north(u3R) ) {
306 u3R->cap_p -= len_w;
307 return u3a_into(u3R->cap_p);
308 }
309 else {
310 u3_post all_p;
311
312 all_p = u3R->cap_p;
313 u3R->cap_p += len_w;
314 return u3a_into(all_p);
315 }
316 }
317 #endif
318
319 #if 0
320 /* u3a_sane(): check allocator sanity.
321 */
322 void
323 u3a_sane(void)
324 {
325 c3_w i_w;
326
327 for ( i_w = 0; i_w < u3a_fbox_no; i_w++ ) {
328 u3a_fbox* fre_u = u3R->all.fre_u[i_w];
329
330 while ( fre_u ) {
331 if ( fre_u == u3R->all.fre_u[i_w] ) {
332 c3_assert(fre_u->pre_u == 0);
333 }
334 else {
335 c3_assert(fre_u->pre_u != 0);
336 c3_assert(fre_u->pre_u->nex_u == fre_u);
337 if ( fre_u->nex_u != 0 ) {
338 c3_assert(fre_u->nex_u->pre_u == fre_u);
339 }
340 }
341 fre_u = fre_u->nex_u;
342 }
343 }
344 }
345 #endif
346
347 /* u3a_reflux(): dump 1K cells from the cell list into regular memory.
348 */
349 void
u3a_reflux(void)350 u3a_reflux(void)
351 {
352 c3_w i_w;
353
354 for ( i_w = 0; u3R->all.cel_p && (i_w < 1024); i_w++ ) {
355 u3_post cel_p = u3R->all.cel_p;
356 u3a_box* box_u = &(u3to(u3a_fbox, cel_p)->box_u);
357
358 u3R->all.cel_p = u3to(u3a_fbox, cel_p)->nex_p;
359
360 // otherwise _box_free() will double-count it
361 //
362 _box_count(-(u3a_minimum));
363 _box_free(box_u);
364
365 }
366 }
367
368 /* u3a_reclaim(): reclaim from memoization cache.
369 */
370 void
u3a_reclaim(void)371 u3a_reclaim(void)
372 {
373 if ( (0 == u3R->cax.har_p) ||
374 (0 == u3to(u3h_root, u3R->cax.har_p)->use_w) )
375 {
376 fprintf(stderr, "allocate: reclaim: memo cache: empty\r\n");
377 u3m_bail(c3__meme);
378 }
379
380 #if 1
381 fprintf(stderr, "allocate: reclaim: half of %d entries\r\n",
382 u3to(u3h_root, u3R->cax.har_p)->use_w);
383
384 u3h_trim_to(u3R->cax.har_p, u3to(u3h_root, u3R->cax.har_p)->use_w / 2);
385 #else
386 /* brutal and guaranteed effective
387 */
388 u3h_free(u3R->cax.har_p);
389 u3R->cax.har_p = u3h_new();
390 #endif
391 }
392
393 /* _ca_willoc(): u3a_walloc() internals.
394 */
395 static void*
_ca_willoc(c3_w len_w,c3_w ald_w,c3_w alp_w)396 _ca_willoc(c3_w len_w, c3_w ald_w, c3_w alp_w)
397 {
398 c3_w siz_w = c3_max(u3a_minimum, u3a_boxed(len_w));
399 c3_w sel_w = _box_slot(siz_w);
400
401 alp_w = (alp_w + c3_wiseof(u3a_box)) % ald_w;
402
403 // XX: this logic is totally bizarre, but preserve it.
404 //
405 if ( (sel_w != 0) && (sel_w != u3a_fbox_no - 1) ) {
406 sel_w += 1;
407 }
408
409 // fprintf(stderr, "walloc %d: *pfr_p %x\n", len_w, u3R->all.fre_p[sel_w]);
410 while ( 1 ) {
411 u3p(u3a_fbox) *pfr_p = &u3R->all.fre_p[sel_w];
412
413 while ( 1 ) {
414 if ( 0 == *pfr_p ) {
415 if ( sel_w < (u3a_fbox_no - 1) ) {
416 sel_w += 1;
417 break;
418 }
419 else {
420 // nothing in top free list; chip away at the hat
421 //
422 u3a_box* box_u;
423
424 // memory nearly empty; reclaim; should not be needed
425 //
426 // if ( (u3a_open(u3R) + u3R->all.fre_w) < 65536 ) { u3a_reclaim(); }
427 box_u = _ca_box_make_hat(siz_w, ald_w, alp_w, 1);
428
429 /* Flush a bunch of cell cache, then try again.
430 */
431 if ( 0 == box_u ) {
432 if ( u3R->all.cel_p ) {
433 u3a_reflux();
434
435 return _ca_willoc(len_w, ald_w, alp_w);
436 }
437 else {
438 u3a_reclaim();
439 return _ca_willoc(len_w, ald_w, alp_w);
440 }
441 }
442 else return u3a_boxto(box_u);
443 }
444 }
445 else {
446 c3_w pad_w = _me_align_pad(*pfr_p, ald_w, alp_w);
447
448 if ( 1 == ald_w ) c3_assert(0 == pad_w);
449
450 if ( (siz_w + pad_w) > u3to(u3a_fbox, *pfr_p)->box_u.siz_w ) {
451 /* This free block is too small. Continue searching.
452 */
453 pfr_p = &(u3to(u3a_fbox, *pfr_p)->nex_p);
454 continue;
455 }
456 else {
457 u3a_box* box_u = &(u3to(u3a_fbox, *pfr_p)->box_u);
458
459 /* We have found a free block of adequate size. Remove it
460 ** from the free list.
461 */
462 siz_w += pad_w;
463 _box_count(-(box_u->siz_w));
464 {
465 {
466 c3_assert((0 == u3to(u3a_fbox, *pfr_p)->pre_p) ||
467 (u3to(u3a_fbox, u3to(u3a_fbox, *pfr_p)->pre_p)->nex_p
468 == (*pfr_p)));
469
470 c3_assert((0 == u3to(u3a_fbox, *pfr_p)->nex_p) ||
471 (u3to(u3a_fbox, u3to(u3a_fbox, *pfr_p)->nex_p)->pre_p
472 == (*pfr_p)));
473 }
474
475 if ( 0 != u3to(u3a_fbox, *pfr_p)->nex_p ) {
476 u3to(u3a_fbox, u3to(u3a_fbox, *pfr_p)->nex_p)->pre_p =
477 u3to(u3a_fbox, *pfr_p)->pre_p;
478 }
479 *pfr_p = u3to(u3a_fbox, *pfr_p)->nex_p;
480 }
481
482 /* If we can chop off another block, do it.
483 */
484 if ( (siz_w + u3a_minimum) <= box_u->siz_w ) {
485 /* Split the block.
486 */
487 c3_w* box_w = ((c3_w *)(void *)box_u);
488 c3_w* end_w = box_w + siz_w;
489 c3_w lef_w = (box_u->siz_w - siz_w);
490
491 _box_attach(_box_make(end_w, lef_w, 0));
492 return u3a_boxto(_box_make(box_w, siz_w, 1));
493 }
494 else {
495 c3_assert(0 == box_u->use_w);
496 box_u->use_w = 1;
497
498 #ifdef U3_MEMORY_DEBUG
499 box_u->cod_w = u3_Code;
500 #endif
501 return u3a_boxto(box_u);
502 }
503 }
504 }
505 }
506 }
507 }
508
509 /* _ca_walloc(): u3a_walloc() internals.
510 */
511 static void*
_ca_walloc(c3_w len_w,c3_w ald_w,c3_w alp_w)512 _ca_walloc(c3_w len_w, c3_w ald_w, c3_w alp_w)
513 {
514 void* ptr_v;
515
516 while ( 1 ) {
517 ptr_v = _ca_willoc(len_w, ald_w, alp_w);
518 if ( 0 != ptr_v ) {
519 break;
520 }
521 u3a_reclaim();
522 }
523 return ptr_v;
524 }
525
526 /* u3a_walloc(): allocate storage words on hat heap.
527 */
528 void*
u3a_walloc(c3_w len_w)529 u3a_walloc(c3_w len_w)
530 {
531 void* ptr_v;
532
533 ptr_v = _ca_walloc(len_w, 1, 0);
534
535 #if 0
536 if ( (703 == u3_Code) &&
537 u3a_botox(ptr_v) == (u3a_box*)(void *)0x200dfe3e4 ) {
538 static int xuc_i;
539
540 printf("xuc_i %d\r\n", xuc_i);
541 if ( 1 == xuc_i ) {
542 u3a_box* box_u = u3a_botox(ptr_v);
543
544 box_u->cod_w = 999;
545 }
546 xuc_i++;
547 }
548 #endif
549 return ptr_v;
550 }
551
552 /* u3a_wealloc(): realloc in words.
553 */
554 void*
u3a_wealloc(void * lag_v,c3_w len_w)555 u3a_wealloc(void* lag_v, c3_w len_w)
556 {
557 if ( !lag_v ) {
558 return u3a_malloc(len_w);
559 }
560 else {
561 u3a_box* box_u = u3a_botox(lag_v);
562 c3_w* old_w = lag_v;
563 c3_w tiz_w = c3_min(box_u->siz_w, len_w);
564 {
565 c3_w* new_w = u3a_walloc(len_w);
566 c3_w i_w;
567
568 for ( i_w = 0; i_w < tiz_w; i_w++ ) {
569 new_w[i_w] = old_w[i_w];
570 }
571 u3a_wfree(lag_v);
572 return new_w;
573 }
574 }
575 }
576 /* u3a_push(): allocate space on the road stack
577 */
578 void*
u3a_push(c3_w len_w)579 u3a_push(c3_w len_w)
580 {
581 void *cur, *top = u3to(void, u3R->cap_p);
582 if ( c3y == u3a_is_north(u3R) ) {
583 top -= len_w;
584 cur = top;
585 u3p(void) cap_p = u3R->cap_p = u3of(void, top);
586 c3_assert(cap_p < u3R->mat_p);
587 c3_assert(cap_p > u3R->hat_p);
588 return cur;
589 }
590 else {
591 cur = top;
592 top += len_w;
593 u3R->cap_p = u3of(void, top);
594 u3p(void) cap_p = u3R->cap_p = u3of(void, top);
595 c3_assert(cap_p > u3R->mat_p);
596 c3_assert(cap_p < u3R->hat_p);
597 return cur;
598 }
599 }
600
601 /* u3a_pop(): deallocate space on the road stack
602 */
603 void
u3a_pop(c3_w len_w)604 u3a_pop(c3_w len_w)
605 {
606 void* top = u3to(void, u3R->cap_p);
607 if ( c3y == u3a_is_north(u3R) ) {
608 top += len_w;
609 u3p(void) cap_p = u3R->cap_p = u3of(void, top);
610 c3_assert(cap_p <= u3R->mat_p);
611 c3_assert(cap_p > u3R->hat_p);
612 }
613 else {
614 top -= len_w;
615 u3p(void) cap_p = u3R->cap_p = u3of(void, top);
616 c3_assert(cap_p >= u3R->mat_p);
617 c3_assert(cap_p < u3R->hat_p);
618 }
619 }
620
621 /* u3a_peek(): examine the top of the road stack
622 */
623 void*
u3a_peek(c3_w len_w)624 u3a_peek(c3_w len_w)
625 {
626 return u3to(void, u3R->cap_p) - (c3y == u3a_is_north(u3R) ? 0 : len_w);
627 }
628
629 /* u3a_wfree(): free storage.
630 */
631 void
u3a_wfree(void * tox_v)632 u3a_wfree(void* tox_v)
633 {
634 _box_free(u3a_botox(tox_v));
635 }
636
637 /* u3a_calloc(): allocate and zero-initialize array
638 */
639 void*
u3a_calloc(size_t num_i,size_t len_i)640 u3a_calloc(size_t num_i, size_t len_i)
641 {
642 size_t byt_i = num_i * len_i;
643 c3_w* out_w;
644
645 c3_assert(byt_i / len_i == num_i);
646 out_w = u3a_malloc(byt_i);
647 memset(out_w, 0, byt_i);
648
649 return out_w;
650 }
651
652 /* u3a_malloc(): aligned storage measured in bytes.
653 */
654 void*
u3a_malloc(size_t len_i)655 u3a_malloc(size_t len_i)
656 {
657 c3_w len_w = (c3_w)((len_i + 3) >> 2);
658 c3_w* ptr_w = _ca_walloc(len_w + 1, 4, 3);
659 u3_post ptr_p = u3a_outa(ptr_w);
660 c3_w pad_w = _me_align_pad(ptr_p, 4, 3);
661 c3_w* out_w = u3a_into(ptr_p + pad_w + 1);
662
663 #if 0
664 if ( u3a_botox(out_w) == (u3a_box*)(void *)0x3bdd1c80) {
665 static int xuc_i = 0;
666
667 fprintf(stderr,"xuc_i %d\r\n", xuc_i);
668 // if ( 1 == xuc_i ) { abort(); }
669 xuc_i++;
670 }
671 #endif
672 out_w[-1] = pad_w;
673
674 return out_w;
675 }
676
677 /* u3a_cellblock(): allocate a block of cells on the hat.
678 */
679 static c3_o
u3a_cellblock(c3_w num_w)680 u3a_cellblock(c3_w num_w)
681 {
682 u3p(u3a_fbox) fre_p;
683 c3_w i_w;
684
685 if ( c3y == u3a_is_north(u3R) ) {
686 if ( u3R->cap_p <= (u3R->hat_p + (num_w * u3a_minimum)) ) {
687 return c3n;
688 }
689 else {
690 u3_post hat_p = u3R->hat_p;
691 u3_post cel_p = u3R->all.cel_p;
692
693 for ( i_w = 0; i_w < num_w; i_w++) {
694 u3_post all_p = hat_p;
695 void* box_v = u3a_into(all_p);
696 u3a_box* box_u = box_v;
697 c3_w* box_w = box_v;
698
699 // hand inline of _box_make(u3a_into(all_p), u3a_minimum, 1)
700 {
701 box_w[0] = u3a_minimum;
702 box_w[u3a_minimum - 1] = u3a_minimum;
703 box_u->use_w = 1;
704 #ifdef U3_MEMORY_DEBUG
705 box_u->cod_w = 0;
706 box_u->eus_w = 0;
707 #endif
708 }
709 hat_p += u3a_minimum;
710
711 fre_p = u3of(u3a_fbox, box_u);
712 u3to(u3a_fbox, fre_p)->nex_p = cel_p;
713 cel_p = fre_p;
714 }
715 u3R->hat_p = hat_p;
716 u3R->all.cel_p = cel_p;
717 }
718 }
719 else {
720 if ( (u3R->cap_p + (num_w * u3a_minimum)) >= u3R->hat_p ) {
721 return c3n;
722 }
723 else {
724 u3_post hat_p = u3R->hat_p;
725 u3_post cel_p = u3R->all.cel_p;
726
727 for ( i_w = 0; i_w < num_w; i_w++ ) {
728 u3_post all_p = (hat_p -= u3a_minimum);
729 void* box_v = u3a_into(all_p);
730 u3a_box* box_u = box_v;
731 c3_w* box_w = box_v;
732
733 // hand inline of _box_make(u3a_into(all_p), u3a_minimum, 1);
734 {
735 box_w[0] = u3a_minimum;
736 box_w[u3a_minimum - 1] = u3a_minimum;
737 box_u->use_w = 1;
738 # ifdef U3_MEMORY_DEBUG
739 box_u->cod_w = 0;
740 box_u->eus_w = 0;
741 # endif
742 }
743 fre_p = u3of(u3a_fbox, box_u);
744 u3to(u3a_fbox, fre_p)->nex_p = cel_p;
745 cel_p = fre_p;
746 }
747 u3R->hat_p = hat_p;
748 u3R->all.cel_p = cel_p;
749 }
750 }
751 _box_count(num_w * u3a_minimum);
752 return c3y;
753 }
754
755 /* u3a_celloc(): allocate a cell.
756 */
757 c3_w*
u3a_celloc(void)758 u3a_celloc(void)
759 {
760 #ifdef U3_MEMORY_DEBUG
761 if ( u3C.wag_w & u3o_debug_ram ) {
762 return u3a_walloc(c3_wiseof(u3a_cell));
763 }
764 #endif
765
766 u3p(u3a_fbox) cel_p;
767
768 if ( !(cel_p = u3R->all.cel_p) ) {
769 if ( u3R == &(u3H->rod_u) ) {
770 // no cell allocator on home road
771 //
772 return u3a_walloc(c3_wiseof(u3a_cell));
773 }
774 else {
775 if ( c3n == u3a_cellblock(256 << 10) ) {
776 return u3a_walloc(c3_wiseof(u3a_cell));
777 }
778 cel_p = u3R->all.cel_p;
779 }
780 }
781
782 {
783 u3a_box* box_u = &(u3to(u3a_fbox, cel_p)->box_u);
784
785
786 box_u->use_w = 1;
787 u3R->all.cel_p = u3to(u3a_fbox, cel_p)->nex_p;
788
789 _box_count(-(u3a_minimum));
790
791 return u3a_boxto(box_u);
792 }
793 }
794
795 /* u3a_cfree(): free a cell.
796 */
797 void
u3a_cfree(c3_w * cel_w)798 u3a_cfree(c3_w* cel_w)
799 {
800 #ifdef U3_MEMORY_DEBUG
801 if ( u3C.wag_w & u3o_debug_ram ) {
802 return u3a_wfree(cel_w);
803 }
804 #endif
805
806 if ( u3R == &(u3H->rod_u) ) {
807 return u3a_wfree(cel_w);
808 }
809 else {
810 u3a_box* box_u = u3a_botox(cel_w);
811 u3p(u3a_fbox) fre_p = u3of(u3a_fbox, box_u);
812
813 _box_count(u3a_minimum);
814
815 u3to(u3a_fbox, fre_p)->nex_p = u3R->all.cel_p;
816 u3R->all.cel_p = fre_p;
817 }
818 }
819
820 /* u3a_realloc(): aligned realloc in bytes.
821 */
822 void*
u3a_realloc(void * lag_v,size_t len_i)823 u3a_realloc(void* lag_v, size_t len_i)
824 {
825 if ( !lag_v ) {
826 return u3a_malloc(len_i);
827 }
828 else {
829 c3_w len_w = (c3_w)((len_i + 3) >> 2);
830 c3_w* lag_w = lag_v;
831 c3_w pad_w = lag_w[-1];
832 c3_w* org_w = lag_w - (pad_w + 1);
833 u3a_box* box_u = u3a_botox((void *)org_w);
834 c3_w* old_w = lag_v;
835 c3_w tiz_w = c3_min(box_u->siz_w, len_w);
836 {
837 c3_w* new_w = u3a_malloc(len_i);
838 c3_w i_w;
839
840 for ( i_w = 0; i_w < tiz_w; i_w++ ) {
841 new_w[i_w] = old_w[i_w];
842 }
843 u3a_wfree(org_w);
844 return new_w;
845 }
846 }
847 c3_w len_w = (c3_w)len_i;
848
849 return u3a_wealloc(lag_v, (len_w + 3) >> 2);
850 }
851
852 /* u3a_realloc2(): gmp-shaped realloc.
853 */
854 void*
u3a_realloc2(void * lag_v,size_t old_i,size_t new_i)855 u3a_realloc2(void* lag_v, size_t old_i, size_t new_i)
856 {
857 return u3a_realloc(lag_v, new_i);
858 }
859
860 /* u3a_free(): free for aligned malloc.
861 */
862 void
u3a_free(void * tox_v)863 u3a_free(void* tox_v)
864 {
865 if (NULL == tox_v)
866 return;
867
868 c3_w* tox_w = tox_v;
869 c3_w pad_w = tox_w[-1];
870 c3_w* org_w = tox_w - (pad_w + 1);
871
872 // printf("free %p %p\r\n", org_w, tox_w);
873 u3a_wfree(org_w);
874 }
875
876 /* u3a_free2(): gmp-shaped free.
877 */
878 void
u3a_free2(void * tox_v,size_t siz_i)879 u3a_free2(void* tox_v, size_t siz_i)
880 {
881 return u3a_free(tox_v);
882 }
883
884 #if 1
885 /* _me_wash_north(): clean up mug slots after copy.
886 */
887 static void _me_wash_north(u3_noun dog);
888 static void
_me_wash_north_in(u3_noun som)889 _me_wash_north_in(u3_noun som)
890 {
891 if ( _(u3a_is_cat(som)) ) return;
892 if ( !_(u3a_north_is_junior(u3R, som)) ) return;
893
894 _me_wash_north(som);
895 }
896 static void
_me_wash_north(u3_noun dog)897 _me_wash_north(u3_noun dog)
898 {
899 c3_assert(c3y == u3a_is_dog(dog));
900 // c3_assert(c3y == u3a_north_is_junior(u3R, dog));
901 {
902 u3a_noun* dog_u = u3a_to_ptr(dog);
903
904 if ( dog_u->mug_w == 0 ) return;
905
906 dog_u->mug_w = 0; // power wash
907 // if ( dog_u->mug_w >> 31 ) { dog_u->mug_w = 0; }
908
909 if ( _(u3a_is_pom(dog)) ) {
910 u3a_cell* god_u = (u3a_cell *)(void *)dog_u;
911
912 _me_wash_north_in(god_u->hed);
913 _me_wash_north_in(god_u->tel);
914 }
915 }
916 }
917
918 /* _me_wash_south(): clean up mug slots after copy.
919 */
920 static void _me_wash_south(u3_noun dog);
921 static void
_me_wash_south_in(u3_noun som)922 _me_wash_south_in(u3_noun som)
923 {
924 if ( _(u3a_is_cat(som)) ) return;
925 if ( !_(u3a_south_is_junior(u3R, som)) ) return;
926
927 _me_wash_south(som);
928 }
929 static void
_me_wash_south(u3_noun dog)930 _me_wash_south(u3_noun dog)
931 {
932 c3_assert(c3y == u3a_is_dog(dog));
933 // c3_assert(c3y == u3a_south_is_junior(u3R, dog));
934 {
935 u3a_noun* dog_u = u3a_to_ptr(dog);
936
937 if ( dog_u->mug_w == 0 ) return;
938
939 dog_u->mug_w = 0; // power wash
940 // if ( dog_u->mug_w >> 31 ) { dog_u->mug_w = 0; }
941
942 if ( _(u3a_is_pom(dog)) ) {
943 u3a_cell* god_u = (u3a_cell *)(void *)dog_u;
944
945 _me_wash_south_in(god_u->hed);
946 _me_wash_south_in(god_u->tel);
947 }
948 }
949 }
950
951 /* u3a_wash(): wash all lazy mugs. RETAIN.
952 */
953 void
u3a_wash(u3_noun som)954 u3a_wash(u3_noun som)
955 {
956 if ( _(u3a_is_cat(som)) ) {
957 return;
958 }
959 if ( _(u3a_is_north(u3R)) ) {
960 if ( _(u3a_north_is_junior(u3R, som)) ) {
961 _me_wash_north(som);
962 }
963 }
964 else {
965 if ( _(u3a_south_is_junior(u3R, som)) ) {
966 _me_wash_south(som);
967 }
968 }
969 }
970 #endif
971
972 extern u3_noun BDA, BDB;
973
974 /* _me_gain_use(): increment use count.
975 */
976 static void
_me_gain_use(u3_noun dog)977 _me_gain_use(u3_noun dog)
978 {
979 c3_w* dog_w = u3a_to_ptr(dog);
980 u3a_box* box_u = u3a_botox(dog_w);
981
982 if ( 0x7fffffff == box_u->use_w ) {
983 u3m_bail(c3__fail);
984 }
985 else {
986 if ( box_u->use_w == 0 ) {
987 u3m_bail(c3__foul);
988 }
989 box_u->use_w += 1;
990
991 #ifdef U3_MEMORY_DEBUG
992 // if ( u3_Code && !box_u->cod_w ) { box_u->cod_w = u3_Code; }
993
994 #if 0
995 if ( u3r_mug(dog) == 0x15d47649 ) {
996 static c3_w bug_w = 0;
997
998 printf("bad %x %d %d\r\n", dog, bug_w, box_u->use_w);
999 if ( bug_w == 0 ) { abort(); }
1000 bug_w++;
1001 }
1002 #endif
1003 #if 0
1004 {
1005 static c3_w bug_w = 0;
1006
1007 if ( BDA == dog ) {
1008 printf("BDA %d %d\r\n", bug_w, box_u->use_w);
1009 // if ( bug_w == 0 ) { abort(); }
1010 bug_w++;
1011 }
1012 }
1013 #endif
1014
1015 #if 0
1016 {
1017 static c3_w bug_w = 0;
1018
1019 if ( FOO && u3a_botox(u3a_to_ptr(dog)) == (void *)0x200dfe3e4 ) {
1020 u3a_box* box_u = u3a_botox(u3a_to_ptr(dog));
1021
1022 printf("GAIN %d %d\r\n", bug_w, box_u->use_w);
1023 if ( bug_w == 8 ) { abort(); }
1024 bug_w++;
1025 }
1026 }
1027 #endif
1028 #endif
1029
1030 }
1031 }
1032
1033 /* _me_copy_north_in(): copy subjuniors on a north road.
1034 */
1035 static u3_noun _me_copy_north(u3_noun);
1036 static u3_noun
_me_copy_north_in(u3_noun som)1037 _me_copy_north_in(u3_noun som)
1038 {
1039 c3_assert(u3_none != som);
1040 if ( _(u3a_is_cat(som)) ) {
1041 return som;
1042 }
1043 else {
1044 u3_noun dog = som;
1045
1046 if ( _(u3a_north_is_senior(u3R, dog)) ) {
1047 return dog;
1048 }
1049 else if ( _(u3a_north_is_junior(u3R, dog)) ) {
1050 return _me_copy_north(dog);
1051 }
1052 else {
1053 _me_gain_use(dog);
1054 return dog;
1055 }
1056 }
1057 }
1058 /* _me_copy_north(): copy juniors on a north road.
1059 */
1060 static u3_noun
_me_copy_north(u3_noun dog)1061 _me_copy_north(u3_noun dog)
1062 {
1063 c3_assert(c3y == u3a_north_is_junior(u3R, dog));
1064
1065 if ( !_(u3a_north_is_junior(u3R, dog)) ) {
1066 if ( !_(u3a_north_is_senior(u3R, dog)) ) {
1067 _me_gain_use(dog);
1068 }
1069 return dog;
1070 }
1071 else {
1072 u3a_noun* dog_u = u3a_to_ptr(dog);
1073
1074 /* Borrow mug slot to record new destination.
1075 */
1076 if ( dog_u->mug_w >> 31 ) {
1077 u3_noun nov = (u3_noun) dog_u->mug_w;
1078
1079 c3_assert(_(u3a_north_is_normal(u3R, nov)));
1080 _me_gain_use(nov);
1081
1082 return nov;
1083 }
1084 else {
1085 if ( c3y == u3a_is_pom(dog) ) {
1086 u3a_cell* old_u = u3a_to_ptr(dog);
1087 c3_w* new_w = u3a_walloc(c3_wiseof(u3a_cell));
1088 u3_noun new = u3a_de_twin(dog, new_w);
1089 u3a_cell* new_u = (u3a_cell*)(void *)new_w;
1090
1091 new_u->mug_w = old_u->mug_w;
1092 new_u->hed = _me_copy_north_in(old_u->hed);
1093 new_u->tel = _me_copy_north_in(old_u->tel);
1094
1095 /* Borrow mug slot to record new destination.
1096 */
1097 old_u->mug_w = new;
1098 return new;
1099 }
1100 else {
1101 u3a_atom* old_u = u3a_to_ptr(dog);
1102 c3_w* new_w = u3a_walloc(old_u->len_w + c3_wiseof(u3a_atom));
1103 u3_noun new = u3a_de_twin(dog, new_w);
1104 u3a_atom* new_u = (u3a_atom*)(void *)new_w;
1105
1106 new_u->mug_w = old_u->mug_w;
1107 new_u->len_w = old_u->len_w;
1108 {
1109 c3_w i_w;
1110
1111 for ( i_w=0; i_w < old_u->len_w; i_w++ ) {
1112 new_u->buf_w[i_w] = old_u->buf_w[i_w];
1113 }
1114 }
1115
1116 /* Borrow mug slot to record new destination.
1117 */
1118 old_u->mug_w = new;
1119 return new;
1120 }
1121 }
1122 }
1123 }
1124
1125 /* _me_copy_south_in(): copy subjuniors on a south road.
1126 */
1127 static u3_noun _me_copy_south(u3_noun);
1128 static u3_noun
_me_copy_south_in(u3_noun som)1129 _me_copy_south_in(u3_noun som)
1130 {
1131 c3_assert(u3_none != som);
1132 if ( _(u3a_is_cat(som)) ) {
1133 return som;
1134 }
1135 else {
1136 u3_noun dog = som;
1137
1138 if ( _(u3a_south_is_senior(u3R, dog)) ) {
1139 return dog;
1140 }
1141 else if ( _(u3a_south_is_junior(u3R, dog)) ) {
1142 return _me_copy_south(dog);
1143 }
1144 else {
1145 _me_gain_use(dog);
1146 return dog;
1147 }
1148 }
1149 }
1150 /* _me_copy_south(): copy juniors on a south road.
1151 */
1152 static u3_noun
_me_copy_south(u3_noun dog)1153 _me_copy_south(u3_noun dog)
1154 {
1155 c3_assert(c3y == u3a_south_is_junior(u3R, dog));
1156
1157 if ( !_(u3a_south_is_junior(u3R, dog)) ) {
1158 if ( !_(u3a_south_is_senior(u3R, dog)) ) {
1159 _me_gain_use(dog);
1160 }
1161 return dog;
1162 }
1163 else {
1164 u3a_noun* dog_u = u3a_to_ptr(dog);
1165
1166 /* Borrow mug slot to record new destination.
1167 */
1168 if ( dog_u->mug_w >> 31 ) {
1169 u3_noun nov = (u3_noun) dog_u->mug_w;
1170
1171 // printf("south: %p is already %p\r\n", dog_u, u3a_to_ptr(nov));
1172
1173 c3_assert(_(u3a_south_is_normal(u3R, nov)));
1174 _me_gain_use(nov);
1175
1176 return nov;
1177 }
1178 else {
1179 if ( c3y == u3a_is_pom(dog) ) {
1180 u3a_cell* old_u = u3a_to_ptr(dog);
1181 c3_w* new_w = u3a_walloc(c3_wiseof(u3a_cell));
1182 u3_noun new = u3a_de_twin(dog, new_w);
1183 u3a_cell* new_u = (u3a_cell*)(void *)new_w;
1184
1185 // printf("south: cell %p to %p\r\n", old_u, new_u);
1186 #if 0
1187 if ( old_u->mug_w == 0x730e66cc ) {
1188 fprintf(stderr, "BAD: take %p\r\n", new_u);
1189 }
1190 #endif
1191 new_u->mug_w = old_u->mug_w;
1192 // new_u->mug_w = 0;
1193 new_u->hed = _me_copy_south_in(old_u->hed);
1194 new_u->tel = _me_copy_south_in(old_u->tel);
1195
1196 /* Borrow mug slot to record new destination.
1197 */
1198 old_u->mug_w = new;
1199 return new;
1200 }
1201 else {
1202 u3a_atom* old_u = u3a_to_ptr(dog);
1203 c3_w* new_w = u3a_walloc(old_u->len_w + c3_wiseof(u3a_atom));
1204 u3_noun new = u3a_de_twin(dog, new_w);
1205 u3a_atom* new_u = (u3a_atom*)(void *)new_w;
1206
1207 // printf("south: atom %p to %p\r\n", old_u, new_u);
1208
1209 new_u->mug_w = old_u->mug_w;
1210 // new_u->mug_w = 0;
1211 new_u->len_w = old_u->len_w;
1212 {
1213 c3_w i_w;
1214
1215 for ( i_w=0; i_w < old_u->len_w; i_w++ ) {
1216 new_u->buf_w[i_w] = old_u->buf_w[i_w];
1217 }
1218 }
1219
1220 /* Borrow mug slot to record new destination.
1221 */
1222 old_u->mug_w = new;
1223 return new;
1224 }
1225 }
1226 }
1227 }
1228
1229 /* _me_take_north(): take on a north road.
1230 */
1231 static u3_noun
_me_take_north(u3_noun dog)1232 _me_take_north(u3_noun dog)
1233 {
1234 if ( c3y == u3a_north_is_senior(u3R, dog) ) {
1235 /* senior pointers are not refcounted
1236 */
1237 return dog;
1238 }
1239 else if ( c3y == u3a_north_is_junior(u3R, dog) ) {
1240 /* junior pointers are copied
1241 */
1242 u3_noun mos = _me_copy_north(dog);
1243
1244 // printf("north: %p to %p\r\n", u3a_to_ptr(dog), u3a_to_ptr(mos));
1245 return mos;
1246 }
1247 else {
1248 /* normal pointers are refcounted
1249 */
1250 _me_gain_use(dog);
1251 return dog;
1252 }
1253 }
1254
1255 /* _me_take_south(): take on a south road.
1256 */
1257 static u3_noun
_me_take_south(u3_noun dog)1258 _me_take_south(u3_noun dog)
1259 {
1260 if ( c3y == u3a_south_is_senior(u3R, dog) ) {
1261 /* senior pointers are not refcounted
1262 */
1263 return dog;
1264 }
1265 else if ( c3y == u3a_south_is_junior(u3R, dog) ) {
1266 /* junior pointers are copied
1267 */
1268 u3_noun mos = _me_copy_south(dog);
1269
1270 // printf("south: %p to %p\r\n", u3a_to_ptr(dog), u3a_to_ptr(mos));
1271 return mos;
1272 }
1273 else {
1274 /* normal pointers are refcounted
1275 */
1276 _me_gain_use(dog);
1277 return dog;
1278 }
1279 }
1280
1281 /* u3a_take(): gain, copying juniors.
1282 */
1283 u3_noun
u3a_take(u3_noun som)1284 u3a_take(u3_noun som)
1285 {
1286 c3_assert(u3_none != som);
1287
1288 if ( _(u3a_is_cat(som)) ) {
1289 return som;
1290 }
1291 else {
1292 u3t_on(coy_o);
1293
1294 som = _(u3a_is_north(u3R))
1295 ? _me_take_north(som)
1296 : _me_take_south(som);
1297
1298 u3t_off(coy_o);
1299 return som;
1300 }
1301 }
1302
1303 /* u3a_left(): true of junior if preserved.
1304 */
1305 c3_o
u3a_left(u3_noun som)1306 u3a_left(u3_noun som)
1307 {
1308 if ( _(u3a_is_cat(som)) ||
1309 !_(u3a_is_junior(u3R, som)) )
1310 {
1311 return c3y;
1312 }
1313 else {
1314 u3a_noun* dog_u = u3a_to_ptr(som);
1315
1316 return __(0 != (dog_u->mug_w >> 31));
1317 }
1318 }
1319
1320 /* _me_gain_north(): gain on a north road.
1321 */
1322 static u3_noun
_me_gain_north(u3_noun dog)1323 _me_gain_north(u3_noun dog)
1324 {
1325 if ( c3y == u3a_north_is_senior(u3R, dog) ) {
1326 /* senior pointers are not refcounted
1327 */
1328 return dog;
1329 }
1330 else {
1331 /* junior nouns are disallowed
1332 */
1333 c3_assert(!_(u3a_north_is_junior(u3R, dog)));
1334
1335 /* normal pointers are refcounted
1336 */
1337 _me_gain_use(dog);
1338 return dog;
1339 }
1340 }
1341
1342 /* _me_gain_south(): gain on a south road.
1343 */
1344 static u3_noun
_me_gain_south(u3_noun dog)1345 _me_gain_south(u3_noun dog)
1346 {
1347 if ( c3y == u3a_south_is_senior(u3R, dog) ) {
1348 /* senior pointers are not refcounted
1349 */
1350 return dog;
1351 }
1352 else {
1353 /* junior nouns are disallowed
1354 */
1355 c3_assert(!_(u3a_south_is_junior(u3R, dog)));
1356
1357 /* normal nouns are refcounted
1358 */
1359 _me_gain_use(dog);
1360 return dog;
1361 }
1362 }
1363
1364 /* _me_lose_north(): lose on a north road.
1365 */
1366 static void
_me_lose_north(u3_noun dog)1367 _me_lose_north(u3_noun dog)
1368 {
1369 top:
1370 if ( c3y == u3a_north_is_normal(u3R, dog) ) {
1371 c3_w* dog_w = u3a_to_ptr(dog);
1372 u3a_box* box_u = u3a_botox(dog_w);
1373
1374 if ( box_u->use_w > 1 ) {
1375 box_u->use_w -= 1;
1376 }
1377 else {
1378 if ( 0 == box_u->use_w ) {
1379 u3m_bail(c3__foul);
1380 }
1381 else {
1382 if ( _(u3a_is_pom(dog)) ) {
1383 u3a_cell* dog_u = (void *)dog_w;
1384 u3_noun h_dog = dog_u->hed;
1385 u3_noun t_dog = dog_u->tel;
1386
1387 if ( !_(u3a_is_cat(h_dog)) ) {
1388 _me_lose_north(h_dog);
1389 }
1390 u3a_cfree(dog_w);
1391 if ( !_(u3a_is_cat(t_dog)) ) {
1392 dog = t_dog;
1393 goto top;
1394 }
1395 }
1396 else {
1397 u3a_wfree(dog_w);
1398 }
1399 }
1400 }
1401 }
1402 }
1403
1404 /* _me_lose_south(): lose on a south road.
1405 */
1406 static void
_me_lose_south(u3_noun dog)1407 _me_lose_south(u3_noun dog)
1408 {
1409 top:
1410 if ( c3y == u3a_south_is_normal(u3R, dog) ) {
1411 c3_w* dog_w = u3a_to_ptr(dog);
1412 u3a_box* box_u = u3a_botox(dog_w);
1413
1414 if ( box_u->use_w > 1 ) {
1415 box_u->use_w -= 1;
1416 }
1417 else {
1418 if ( 0 == box_u->use_w ) {
1419 u3m_bail(c3__foul);
1420 }
1421 else {
1422 if ( _(u3a_is_pom(dog)) ) {
1423 u3a_cell* dog_u = (void *)dog_w;
1424 u3_noun h_dog = dog_u->hed;
1425 u3_noun t_dog = dog_u->tel;
1426
1427 if ( !_(u3a_is_cat(h_dog)) ) {
1428 _me_lose_south(h_dog);
1429 }
1430 u3a_cfree(dog_w);
1431 if ( !_(u3a_is_cat(t_dog)) ) {
1432 dog = t_dog;
1433 goto top;
1434 }
1435 }
1436 else {
1437 u3a_wfree(dog_w);
1438 }
1439 }
1440 }
1441 }
1442 }
1443
1444 /* u3a_gain(): gain a reference count in normal space.
1445 */
1446 u3_noun
u3a_gain(u3_noun som)1447 u3a_gain(u3_noun som)
1448 {
1449 u3t_on(mal_o);
1450 c3_assert(u3_none != som);
1451
1452 if ( !_(u3a_is_cat(som)) ) {
1453 som = _(u3a_is_north(u3R))
1454 ? _me_gain_north(som)
1455 : _me_gain_south(som);
1456 }
1457 u3t_off(mal_o);
1458
1459 return som;
1460 }
1461
1462 /* u3a_lose(): lose a reference count.
1463 */
1464 void
u3a_lose(u3_noun som)1465 u3a_lose(u3_noun som)
1466 {
1467 u3t_on(mal_o);
1468 if ( !_(u3a_is_cat(som)) ) {
1469 if ( _(u3a_is_north(u3R)) ) {
1470 _me_lose_north(som);
1471 } else {
1472 _me_lose_south(som);
1473 }
1474 }
1475 u3t_off(mal_o);
1476 }
1477
1478 /* u3a_use(): reference count.
1479 */
1480 c3_w
u3a_use(u3_noun som)1481 u3a_use(u3_noun som)
1482 {
1483 if ( _(u3a_is_cat(som)) ) {
1484 return 1;
1485 }
1486 else {
1487 c3_w* dog_w = u3a_to_ptr(som);
1488 u3a_box* box_u = u3a_botox(dog_w);
1489
1490 return box_u->use_w;
1491 }
1492 }
1493
1494 /* u3a_luse(): check refcount sanity.
1495 */
1496 void
u3a_luse(u3_noun som)1497 u3a_luse(u3_noun som)
1498 {
1499 if ( 0 == u3a_use(som) ) {
1500 fprintf(stderr, "luse: insane %d 0x%x\r\n", som, som);
1501 abort();
1502 }
1503 if ( _(u3du(som)) ) {
1504 u3a_luse(u3h(som));
1505 u3a_luse(u3t(som));
1506 }
1507 }
1508
1509 /* u3a_mark_ptr(): mark a pointer for gc. Produce size if first mark.
1510 */
1511 c3_w
u3a_mark_ptr(void * ptr_v)1512 u3a_mark_ptr(void* ptr_v)
1513 {
1514 if ( _(u3a_is_north(u3R)) ) {
1515 if ( !((ptr_v >= u3a_into(u3R->rut_p)) &&
1516 (ptr_v < u3a_into(u3R->hat_p))) )
1517 {
1518 return 0;
1519 }
1520 }
1521 else {
1522 if ( !((ptr_v >= u3a_into(u3R->hat_p)) &&
1523 (ptr_v < u3a_into(u3R->rut_p))) )
1524 {
1525 return 0;
1526 }
1527 }
1528 {
1529 u3a_box* box_u = u3a_botox(ptr_v);
1530 c3_w siz_w;
1531
1532 #ifdef U3_MEMORY_DEBUG
1533 if ( 0 == box_u->eus_w ) {
1534 siz_w = box_u->siz_w;
1535 }
1536 else if ( 0xffffffff == box_u->eus_w ) { // see _raft_prof()
1537 siz_w = 0xffffffff;
1538 box_u->eus_w = 0;
1539 }
1540 else {
1541 siz_w = 0;
1542 }
1543 box_u->eus_w += 1;
1544 #else
1545 c3_ws use_ws = (c3_ws)box_u->use_w;
1546
1547 if ( use_ws == 0 ) {
1548 fprintf(stderr, "%p is bogus\r\n", ptr_v);
1549 siz_w = 0;
1550 }
1551 else {
1552 c3_assert(use_ws != 0);
1553
1554 if ( 0x80000000 == (c3_w)use_ws ) { // see _raft_prof()
1555 use_ws = -1;
1556 siz_w = 0xffffffff;
1557 }
1558 else if ( use_ws < 0 ) {
1559 use_ws -= 1;
1560 siz_w = 0;
1561 }
1562 else {
1563 use_ws = -1;
1564 siz_w = box_u->siz_w;
1565 }
1566 box_u->use_w = (c3_w)use_ws;
1567 }
1568 #endif
1569 return siz_w;
1570 }
1571 }
1572
1573 /* u3a_mark_mptr(): mark a malloc-allocated ptr for gc.
1574 */
1575 c3_w
u3a_mark_mptr(void * ptr_v)1576 u3a_mark_mptr(void* ptr_v)
1577 {
1578 c3_w* ptr_w = ptr_v;
1579 c3_w pad_w = ptr_w[-1];
1580 c3_w* org_w = ptr_w - (pad_w + 1);
1581
1582 // printf("free %p %p\r\n", org_w, ptr_w);
1583 return u3a_mark_ptr(org_w);
1584 }
1585
1586 /* u3a_mark_noun(): mark a noun for gc. Produce size.
1587 */
1588 c3_w
u3a_mark_noun(u3_noun som)1589 u3a_mark_noun(u3_noun som)
1590 {
1591 c3_w siz_w = 0;
1592
1593 while ( 1 ) {
1594 if ( _(u3a_is_senior(u3R, som)) ) {
1595 return siz_w;
1596 }
1597 else {
1598 c3_w* dog_w = u3a_to_ptr(som);
1599 c3_w new_w = u3a_mark_ptr(dog_w);
1600
1601 if ( 0 == new_w || 0xffffffff == new_w ) { // see u3a_mark_ptr()
1602 return siz_w;
1603 }
1604 else {
1605 siz_w += new_w;
1606 if ( _(u3du(som)) ) {
1607 siz_w += u3a_mark_noun(u3h(som));
1608 som = u3t(som);
1609 }
1610 else return siz_w;
1611 }
1612 }
1613 }
1614 }
1615
1616 /* u3a_print_memory: print memory amount.
1617 */
1618 void
u3a_print_memory(c3_c * cap_c,c3_w wor_w)1619 u3a_print_memory(c3_c* cap_c, c3_w wor_w)
1620 {
1621 FILE *fil_f = u3_term_io_hija();
1622
1623 c3_w byt_w = (wor_w * 4);
1624 c3_w gib_w = (byt_w / 1000000000);
1625 c3_w mib_w = (byt_w % 1000000000) / 1000000;
1626 c3_w kib_w = (byt_w % 1000000) / 1000;
1627 c3_w bib_w = (byt_w % 1000);
1628
1629 if ( byt_w ) {
1630 if ( gib_w ) {
1631 fprintf(fil_f, "%s: GB/%d.%03d.%03d.%03d\r\n",
1632 cap_c, gib_w, mib_w, kib_w, bib_w);
1633 }
1634 else if ( mib_w ) {
1635 fprintf(fil_f, "%s: MB/%d.%03d.%03d\r\n", cap_c, mib_w, kib_w, bib_w);
1636 }
1637 else if ( kib_w ) {
1638 fprintf(fil_f, "%s: KB/%d.%03d\r\n", cap_c, kib_w, bib_w);
1639 }
1640 else if ( bib_w ) {
1641 fprintf(fil_f, "%s: B/%d\r\n", cap_c, bib_w);
1642 }
1643 }
1644 u3_term_io_loja(0);
1645 }
1646
1647 /* u3a_sweep(): sweep a fully marked road.
1648 */
1649 c3_w
u3a_sweep(void)1650 u3a_sweep(void)
1651 {
1652 c3_w neg_w, pos_w, leq_w, weq_w;
1653 #ifdef U3_MEMORY_DEBUG
1654 c3_w tot_w, caf_w;
1655 #endif
1656
1657 /* Measure allocated memory by counting the free list.
1658 */
1659 {
1660 c3_w end_w;
1661 c3_w fre_w = 0;
1662 c3_w i_w;
1663
1664 end_w = _(u3a_is_north(u3R))
1665 ? (u3R->hat_p - u3R->rut_p)
1666 : (u3R->rut_p - u3R->hat_p);
1667
1668 for ( i_w = 0; i_w < u3a_fbox_no; i_w++ ) {
1669 u3p(u3a_fbox) fre_p = u3R->all.fre_p[i_w];
1670
1671 while ( fre_p ) {
1672 u3a_fbox* fre_u = u3to(u3a_fbox, fre_p);
1673
1674 fre_w += fre_u->box_u.siz_w;
1675 fre_p = fre_u->nex_p;
1676 }
1677 }
1678 #ifdef U3_CPU_DEBUG
1679 if ( fre_w != u3R->all.fre_w ) {
1680 fprintf(stderr, "fre discrepancy (%x): %x, %x, %x\r\n", u3R->par_p,
1681 fre_w, u3R->all.fre_w, (u3R->all.fre_w - fre_w));
1682 }
1683 #endif
1684 neg_w = (end_w - fre_w);
1685 }
1686
1687 /* Sweep through the arena, repairing and counting leaks.
1688 */
1689 pos_w = leq_w = weq_w = 0;
1690 {
1691 u3_post box_p = _(u3a_is_north(u3R)) ? u3R->rut_p : u3R->hat_p;
1692 u3_post end_p = _(u3a_is_north(u3R)) ? u3R->hat_p : u3R->rut_p;
1693 c3_w* box_w = u3a_into(box_p);
1694 c3_w* end_w = u3a_into(end_p);
1695
1696 while ( box_w < end_w ) {
1697 u3a_box* box_u = (void *)box_w;
1698
1699 #ifdef U3_MEMORY_DEBUG
1700 /* I suspect these printfs fail hilariously in the case
1701 * of non-direct atoms. We shouldn't unconditionally run
1702 * u3a_to_pom(). In general, the condition
1703 * box_u->siz_w > u3a_mimimum is sufficient, but not necessary,
1704 * for the box to represent an atom. The atoms between
1705 * 2^31 and 2^32 are the exceptions.
1706 *
1707 * Update: so, apparently u3.md is incorrect, and a pug is just
1708 * an indirect atom. This code should be altered to handle
1709 * that.
1710 */
1711 if ( box_u->use_w != box_u->eus_w ) {
1712 if ( box_u->eus_w != 0 ) {
1713 if ( box_u->use_w == 0 ) {
1714 printf("dank %p (%d, %d)\r\n", box_u, box_u->use_w, box_u->eus_w);
1715 }
1716 else {
1717 printf("weak %p %x (cell) %x (%d, %d)\r\n",
1718 box_u,
1719 (u3_noun)u3a_to_pom(u3a_outa(u3a_boxto(box_w))),
1720 ((u3a_noun *)(u3a_boxto(box_w)))->mug_w,
1721 box_u->use_w, box_u->eus_w);
1722 u3a_print_memory("weak (minimum)", box_u->siz_w);
1723 // u3m_p("weak", u3a_to_pom(u3a_outa(u3a_boxto(box_w))));
1724 }
1725 weq_w += box_u->siz_w;
1726 }
1727 else {
1728 printf("leak %p %x (cell)/%x (%d)\r\n",
1729 box_u,
1730 (u3_noun)u3a_to_pom(u3a_outa(u3a_boxto(box_w))),
1731 ((u3a_noun *)(u3a_boxto(box_w)))->mug_w
1732 ? ((u3a_noun *)(u3a_boxto(box_w)))->mug_w
1733 : u3r_mug(u3a_to_pom(u3a_outa(u3a_boxto(box_w)))),
1734 box_u->use_w);
1735 u3a_print_memory("leak (minimum)", box_u->siz_w);
1736 // u3m_p("leak", u3a_to_pom(u3a_outa(u3a_boxto(box_w))));
1737 leq_w += box_u->siz_w;
1738 }
1739 if ( box_u->cod_w ) {
1740 u3m_p(" code", box_u->cod_w);
1741 }
1742 box_u->use_w = box_u->eus_w;
1743 }
1744 else {
1745 if ( box_u->use_w ) {
1746 pos_w += box_u->siz_w;
1747 }
1748 }
1749 box_u->eus_w = 0;
1750 #else
1751 c3_ws use_ws = (c3_ws)box_u->use_w;
1752
1753 if ( use_ws > 0 ) {
1754 printf("leak %p %x\r\n",
1755 box_u,
1756 ((u3a_noun *)(u3a_boxto(box_w)))->mug_w
1757 ? ((u3a_noun *)(u3a_boxto(box_w)))->mug_w
1758 : u3r_mug(u3a_to_pom(u3a_outa(u3a_boxto(box_w)))));
1759 // u3a_print_memory("leak (minimum)", box_u->siz_w);
1760
1761 #if 0
1762 /* For those times when you've really just got to crack open
1763 * the box and see what's inside
1764 */
1765 {
1766 int i;
1767 for ( i = 0; i < box_u->siz_w; i++ ) {
1768 printf("%08x ", (unsigned int)(((c3_w*)box_u)[i]));
1769 }
1770 printf("\r\n");
1771 }
1772 #endif
1773
1774 leq_w += box_u->siz_w;
1775 box_u->use_w = 0;
1776
1777 _box_attach(box_u);
1778 }
1779 else if ( use_ws < 0 ) {
1780 pos_w += box_u->siz_w;
1781 box_u->use_w = (c3_w)(0 - use_ws);
1782 }
1783 #endif
1784 box_w += box_u->siz_w;
1785 }
1786 }
1787
1788 #ifdef U3_MEMORY_DEBUG
1789 tot_w = _(u3a_is_north(u3R))
1790 ? u3R->mat_p - u3R->rut_p
1791 : u3R->rut_p - u3R->mat_p;
1792 caf_w = _(u3a_is_north(u3R))
1793 ? u3R->mat_p - u3R->cap_p
1794 : u3R->cap_p - u3R->mat_p;
1795
1796 #ifdef U3_CPU_DEBUG
1797 if ( (0 != u3R->par_p) && (u3R->all.max_w > 1000000) ) {
1798 u3a_print_memory("available", (tot_w - pos_w));
1799 u3a_print_memory("allocated", pos_w);
1800 u3a_print_memory("volatile", caf_w);
1801
1802 u3a_print_memory("maximum", u3R->all.max_w);
1803 }
1804 #else
1805 #if 0
1806 u3a_print_memory("available", (tot_w - pos_w));
1807 u3a_print_memory("allocated", pos_w);
1808 u3a_print_memory("volatile", caf_w);
1809 #endif
1810 #endif
1811 #endif
1812 u3a_print_memory("leaked", leq_w);
1813 u3a_print_memory("weaked", weq_w);
1814
1815 c3_assert((pos_w + leq_w + weq_w) == neg_w);
1816
1817 if ( 0 != leq_w || (0 != weq_w) ) { c3_assert(0); }
1818
1819 return neg_w;
1820 }
1821
1822 /* u3a_slab(): create a length-bounded proto-atom.
1823 */
1824 c3_w*
u3a_slab(c3_w len_w)1825 u3a_slab(c3_w len_w)
1826 {
1827 c3_w* nov_w = u3a_walloc(len_w + c3_wiseof(u3a_atom));
1828 u3a_atom* pug_u = (void *)nov_w;
1829
1830 pug_u->mug_w = 0;
1831 pug_u->len_w = len_w;
1832
1833 /* Clear teh slab.
1834 */
1835 {
1836 c3_w i_w;
1837
1838 for ( i_w=0; i_w < len_w; i_w++ ) {
1839 pug_u->buf_w[i_w] = 0;
1840 }
1841 }
1842 return pug_u->buf_w;
1843 }
1844
1845 /* u3a_slaq(): u3a_slaq() with a defined blocksize.
1846 */
1847 c3_w*
u3a_slaq(c3_g met_g,c3_w len_w)1848 u3a_slaq(c3_g met_g, c3_w len_w)
1849 {
1850 return u3a_slab(((len_w << met_g) + 31) >> 5);
1851 }
1852
1853 /* u3a_malt(): measure and finish a proto-atom.
1854 */
1855 u3_noun
u3a_malt(c3_w * sal_w)1856 u3a_malt(c3_w* sal_w)
1857 {
1858 c3_w* nov_w = (sal_w - c3_wiseof(u3a_atom));
1859 u3a_atom* nov_u = (void *)nov_w;
1860 c3_w len_w;
1861
1862 for ( len_w = nov_u->len_w; len_w; len_w-- ) {
1863 if ( 0 != nov_u->buf_w[len_w - 1] ) {
1864 break;
1865 }
1866 }
1867 return u3a_mint(sal_w, len_w);
1868 }
1869
1870 /* u3a_moot(): finish a pre-measured proto-atom; dangerous.
1871 */
1872 u3_noun
u3a_moot(c3_w * sal_w)1873 u3a_moot(c3_w* sal_w)
1874 {
1875 c3_w* nov_w = (sal_w - c3_wiseof(u3a_atom));
1876 u3a_atom* nov_u = (void*)nov_w;
1877 c3_w len_w = nov_u->len_w;
1878 c3_w las_w = nov_u->buf_w[len_w - 1];
1879
1880 c3_assert(0 != len_w);
1881 c3_assert(0 != las_w);
1882
1883 if ( 1 == len_w ) {
1884 if ( _(u3a_is_cat(las_w)) ) {
1885 u3a_wfree(nov_w);
1886
1887 return las_w;
1888 }
1889 }
1890 return u3a_to_pug(u3a_outa(nov_w));
1891 }
1892
1893 #if 0
1894 /* _ca_detect(): in u3a_detect().
1895 */
1896 static c3_d
1897 _ca_detect(u3p(u3h_root) har_p, u3_noun fum, u3_noun som, c3_d axe_d)
1898 {
1899 while ( 1 ) {
1900 if ( som == fum ) {
1901 return axe_d;
1902 }
1903 else if ( !_(u3du(fum)) || (u3_none != u3h_get(har_p, fum)) ) {
1904 return 0;
1905 }
1906 else {
1907 c3_d eax_d;
1908
1909 u3h_put(har_p, fum, 0);
1910
1911 if ( 0 != (eax_d = _ca_detect(har_p, u3h(fum), som, 2ULL * axe_d)) ) {
1912 return c3y;
1913 }
1914 else {
1915 fum = u3t(fum);
1916 axe_d = (2ULL * axe_d) + 1;
1917 }
1918 }
1919 }
1920 }
1921
1922 /* u3a_detect(): for debugging, check if (som) is referenced from (fum).
1923 **
1924 ** (som) and (fum) are both RETAINED.
1925 */
1926 c3_d
1927 u3a_detect(u3_noun fum, u3_noun som)
1928 {
1929 u3p(u3h_root) har_p = u3h_new();
1930 c3_o ret_o;
1931
1932 ret_o = _ca_detect(har_p, fum, som, 1);
1933 u3h_free(har_p);
1934
1935 return ret_o;
1936 }
1937 #endif
1938
1939 /* u3a_mint(): finish a measured proto-atom.
1940 */
1941 u3_noun
u3a_mint(c3_w * sal_w,c3_w len_w)1942 u3a_mint(c3_w* sal_w, c3_w len_w)
1943 {
1944 c3_w* nov_w = (sal_w - c3_wiseof(u3a_atom));
1945 u3a_atom* nov_u = (void*)nov_w;
1946
1947 /* See if we can free the slab entirely.
1948 */
1949 if ( len_w == 0 ) {
1950 u3a_wfree(nov_w);
1951
1952 return 0;
1953 }
1954 else if ( len_w == 1 ) {
1955 c3_w low_w = nov_u->buf_w[0];
1956
1957 if ( _(u3a_is_cat(low_w)) ) {
1958 u3a_wfree(nov_w);
1959
1960 return low_w;
1961 }
1962 }
1963
1964 /* See if we can strip off a block on the end.
1965 */
1966 {
1967 c3_w old_w = nov_u->len_w;
1968 c3_w dif_w = (old_w - len_w);
1969
1970 if ( dif_w >= u3a_minimum ) {
1971 c3_w* box_w = (void *)u3a_botox(nov_w);
1972 c3_w* end_w = (nov_w + c3_wiseof(u3a_atom) + len_w + 1);
1973 c3_w asz_w = (end_w - box_w);
1974 c3_w bsz_w = box_w[0] - asz_w;
1975
1976 _box_attach(_box_make(end_w, bsz_w, 0));
1977
1978 box_w[0] = asz_w;
1979 box_w[asz_w - 1] = asz_w;
1980 }
1981 nov_u->len_w = len_w;
1982 }
1983 return u3a_to_pug(u3a_outa(nov_w));
1984 }
1985
1986 #ifdef U3_MEMORY_DEBUG
1987 /* u3a_lush(): leak push.
1988 */
1989 c3_w
u3a_lush(c3_w lab_w)1990 u3a_lush(c3_w lab_w)
1991 {
1992 c3_w cod_w = u3_Code;
1993
1994 u3_Code = lab_w;
1995 return cod_w;
1996 }
1997
1998 /* u3a_lop(): leak pop.
1999 */
2000 void
u3a_lop(c3_w lab_w)2001 u3a_lop(c3_w lab_w)
2002 {
2003 u3_Code = lab_w;
2004 }
2005 #else
2006 /* u3a_lush(): leak push.
2007 */
2008 c3_w
u3a_lush(c3_w lab_w)2009 u3a_lush(c3_w lab_w)
2010 {
2011 return 0;
2012 }
2013
2014 /* u3a_lop(): leak pop.
2015 */
2016 void
u3a_lop(c3_w lab_w)2017 u3a_lop(c3_w lab_w)
2018 {
2019 }
2020 #endif
2021