rts-heap.c
1 //! @file rts-heap.c
2 //! @author J. Marcel van der Veer
3 //!
4 //! @section Copyright
5 //!
6 //! This file is part of Algol68G - an Algol 68 compiler-interpreter.
7 //! Copyright 2001-2023 J. Marcel van der Veer [algol68g@xs4all.nl].
8 //!
9 //! @section License
10 //!
11 //! This program is free software; you can redistribute it and/or modify it
12 //! under the terms of the GNU General Public License as published by the
13 //! Free Software Foundation; either version 3 of the License, or
14 //! (at your option) any later version.
15 //!
16 //! This program is distributed in the hope that it will be useful, but
17 //! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
18 //! or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
19 //! more details. You should have received a copy of the GNU General Public
20 //! License along with this program. If not, see [http://www.gnu.org/licenses/].
21
22 //! @section Synopsis
23 //!
24 //! Generator and garbage collector routines.
25
26 // The generator allocates space in stack or heap and initialises dynamically sized objects.
27 //
28 // A mark-and-gc garbage collector defragments the heap. When called, it walks
29 // the stack frames and marks the heap space that is still active. This marking
30 // process is called "colouring" here since we "pour paint" into the heap.
31 // The active blocks are then joined, the non-active blocks are forgotten.
32 //
33 // When colouring the heap, "cookies" are placed in objects as to find circular
34 // references.
35 //
36 // Algol68G introduces several anonymous tags in the symbol tables that save
37 // temporary REF or ROW results, so that they do not get prematurely swept.
38 //
39 // The genie is not smart enough to handle every heap clog, e.g. when copying
40 // STOWED objects. This seems not very elegant, but garbage collectors in general
41 // cannot solve all core management problems. To avoid many of the "unforeseen"
42 // heap clogs, we try to keep heap occupation low by garbage collecting
43 // occasionally, before it fills up completely. If this automatic mechanism does
44 // not help, one can always invoke the garbage collector by calling "gc heap"
45 // from Algol 68 source text.
46 //
47 // Mark-and-collect is simple but since it walks recursive structures, it could
48 // exhaust the C-stack (segment violation). A rough check is in place.
49 //
50 // For dynamically sized objects, first bounds are evaluated (right first, then down).
51 // The object is generated keeping track of the bound-count.
52 //
53 // ...
54 // [#1]
55 // STRUCT
56 // (
57 // [#2]
58 // STRUCT
59 // (
60 // [#3] A a, b, ...
61 // )
62 // , Advance bound-count here, max is #3
63 // [#4] B a, b, ...
64 // )
65 // , Advance bound-count here, max is #4
66 // [#5] C a, b, ...
67 // ...
68 //
69 // Bound-count is maximised when generator_stowed is entered recursively.
70 // Bound-count is advanced when completing a STRUCTURED_FIELD.
71 //
72 // Note that A68G will not extend stack frames. Thus only 'static' LOC generators
73 // are in the stack, and 'dynamic' LOC generators go into the heap. These local
74 // REFs in the heap get local scope however, and A68G's approach differs from the
75 // CDC ALGOL 68 approach that put all generators in the heap.
76 //
77 // Note that part of memory is called 'COMMON'. This is meant for future extension
78 // where a68g would need to point to external objects. The adressing scheme is that
79 // of a HEAP pointer - handle pointer + offset.
80
81 #include "a68g.h"
82 #include "a68g-genie.h"
83 #include "a68g-frames.h"
84 #include "a68g-prelude.h"
85 #include "a68g-mp.h"
86 #include "a68g-double.h"
87 #include "a68g-parser.h"
88 #include "a68g-transput.h"
89
90 #define DEF_NODE(p) (NEXT_NEXT (NODE (TAX (p))))
91
92 //! @brief PROC VOID gc heap
93
94 void genie_gc_heap (NODE_T * p)
95 {
96 gc_heap (p, A68_FP);
97 }
98
99 //! @brief PROC VOID preemptive gc heap
100
101 void genie_preemptive_gc_heap (NODE_T * p)
102 {
103 if (A68_GC (preemptive)) {
104 gc_heap ((NODE_T *) (p), A68_FP);
105 }
106 }
107
108 //! @brief INT blocks
109
110 void genie_block (NODE_T * p)
111 {
112 PUSH_VALUE (p, 0, A68_INT);
113 }
114
115 //! @brief INT garbage collections
116
117 void genie_garbage_collections (NODE_T * p)
118 {
119 PUSH_VALUE (p, A68_GC (sweeps), A68_INT);
120 }
121
122 //! @brief INT garbage refused
123
124 void genie_garbage_refused (NODE_T * p)
125 {
126 PUSH_VALUE (p, A68_GC (refused), A68_INT);
127 }
128
129 //! @brief LONG INT garbage freed
130
131 void genie_garbage_freed (NODE_T * p)
132 {
133 PUSH_VALUE (p, A68_GC (total), A68_INT);
134 }
135
136 //! @brief REAL garbage seconds
137
138 void genie_garbage_seconds (NODE_T * p)
139 {
140 // Note that this timing is a rough cut.
141 PUSH_VALUE (p, A68_GC (seconds), A68_REAL);
142 }
143
144 //! @brief Size available for an object in the heap.
145
146 unt heap_available (void)
147 {
148 return A68 (heap_size) - A68_HP;
149 }
150
151 //! @brief Initialise heap management.
152
153 void genie_init_heap (NODE_T * p)
154 {
155 (void) p;
156 if (A68_HEAP == NO_BYTE) {
157 diagnostic (A68_RUNTIME_ERROR, TOP_NODE (&A68_JOB), ERROR_OUT_OF_CORE);
158 exit_genie (TOP_NODE (&A68_JOB), A68_RUNTIME_ERROR);
159 }
160 if (A68_HANDLES == NO_BYTE) {
161 diagnostic (A68_RUNTIME_ERROR, TOP_NODE (&A68_JOB), ERROR_OUT_OF_CORE);
162 exit_genie (TOP_NODE (&A68_JOB), A68_RUNTIME_ERROR);
163 }
164 A68_GC (seconds) = 0;
165 A68_GC (total) = 0;
166 A68_GC (sweeps) = 0;
167 A68_GC (refused) = 0;
168 A68_GC (preemptive) = A68_FALSE;
169 ABEND (A68 (fixed_heap_pointer) >= (A68 (heap_size) - MIN_MEM_SIZE), ERROR_OUT_OF_CORE, __func__);
170 A68_HP = A68 (fixed_heap_pointer);
171 A68 (heap_is_fluid) = A68_FALSE;
172 // Assign handle space.
173 A68_HANDLE *z = (A68_HANDLE *) A68_HANDLES;
174 A68_GC (available_handles) = z;
175 A68_GC (busy_handles) = NO_HANDLE;
176 int N = (unt) A68 (handle_pool_size) / SIZE_ALIGNED (A68_HANDLE);
177 A68_GC (free_handles) = N;
178 A68_GC (max_handles) = N;
179 for (int k = 0; k < N; k++) {
180 STATUS (&(z[k])) = NULL_MASK;
181 POINTER (&(z[k])) = NO_BYTE;
182 SIZE (&(z[k])) = 0;
183 NEXT (&z[k]) = (k == N - 1 ? NO_HANDLE : &z[k + 1]);
184 PREVIOUS (&z[k]) = (k == 0 ? NO_HANDLE : &z[k - 1]);
185 }
186 }
187
188 //! @brief Whether mode must be coloured.
189
190 BOOL_T moid_needs_colouring (MOID_T * m)
191 {
192 if (IS_REF (m)) {
193 return A68_TRUE;
194 } else if (IS (m, PROC_SYMBOL)) {
195 return A68_TRUE;
196 } else if (IS_FLEX (m) || IS_ROW (m)) {
197 return A68_TRUE;
198 } else if (IS_STRUCT (m) || IS_UNION (m)) {
199 PACK_T *p = PACK (m);
200 for (; p != NO_PACK; FORWARD (p)) {
201 if (moid_needs_colouring (MOID (p))) {
202 return A68_TRUE;
203 }
204 }
205 return A68_FALSE;
206 } else {
207 return A68_FALSE;
208 }
209 }
210
211 //! @brief Colour all elements of a row.
212
213 void colour_row_elements (A68_REF * z, MOID_T * m)
214 {
215 A68_ARRAY *arr;
216 A68_TUPLE *tup;
217 GET_DESCRIPTOR (arr, tup, z);
218 if (get_row_size (tup, DIM (arr)) == 0) {
219 // Empty rows have a ghost elements.
220 BYTE_T *elem = ADDRESS (&ARRAY (arr));
221 colour_object (&elem[0], SUB (m));
222 } else {
223 // The multi-dimensional garbage collector.
224 BYTE_T *elem = ADDRESS (&ARRAY (arr));
225 BOOL_T done = A68_FALSE;
226 initialise_internal_index (tup, DIM (arr));
227 while (!done) {
228 ADDR_T iindex = calculate_internal_index (tup, DIM (arr));
229 ADDR_T addr = ROW_ELEMENT (arr, iindex);
230 colour_object (&elem[addr], SUB (m));
231 done = increment_internal_index (tup, DIM (arr));
232 }
233 }
234 }
235
236 //! @brief Colour an (active) object.
237
238 void colour_object (BYTE_T * item, MOID_T * m)
239 {
240 if (item == NO_BYTE || m == NO_MOID) {
241 return;
242 }
243 if (!moid_needs_colouring (m)) {
244 return;
245 }
246 // Deeply recursive objects might exhaust the stack.
247 LOW_STACK_ALERT (NO_NODE);
248 if (IS_REF (m)) {
249 // REF AMODE colour pointer and object to which it refers.
250 A68_REF *z = (A68_REF *) item;
251 if (INITIALISED (z) && IS_IN_HEAP (z)) {
252 if (STATUS_TEST (REF_HANDLE (z), COOKIE_MASK)) {
253 return;
254 }
255 STATUS_SET (REF_HANDLE (z), (COOKIE_MASK | COLOUR_MASK));
256 if (!IS_NIL (*z)) {
257 colour_object (ADDRESS (z), SUB (m));
258 }
259 // STATUS_CLEAR (REF_HANDLE (z), COOKIE_MASK);.
260 }
261 } else if (IF_ROW (m)) {
262 // Claim the descriptor and the row itself.
263 A68_REF *z = (A68_REF *) item;
264 if (INITIALISED (z) && IS_IN_HEAP (z)) {
265 A68_ARRAY *arr;
266 A68_TUPLE *tup;
267 if (STATUS_TEST (REF_HANDLE (z), COOKIE_MASK)) {
268 return;
269 }
270 // An array is ALWAYS in the heap.
271 STATUS_SET (REF_HANDLE (z), (COOKIE_MASK | COLOUR_MASK));
272 GET_DESCRIPTOR (arr, tup, z);
273 if (REF_HANDLE (&(ARRAY (arr))) != NO_HANDLE) {
274 // Assume its initialisation.
275 MOID_T *n = DEFLEX (m);
276 STATUS_SET (REF_HANDLE (&(ARRAY (arr))), COLOUR_MASK);
277 if (moid_needs_colouring (SUB (n))) {
278 colour_row_elements (z, n);
279 }
280 }
281 // STATUS_CLEAR (REF_HANDLE (z), COOKIE_MASK);.
282 (void) tup;
283 }
284 } else if (IS_STRUCT (m)) {
285 // STRUCTures - colour fields.
286 PACK_T *p = PACK (m);
287 for (; p != NO_PACK; FORWARD (p)) {
288 colour_object (&item[OFFSET (p)], MOID (p));
289 }
290 } else if (IS_UNION (m)) {
291 // UNIONs - a united object may contain a value that needs colouring.
292 A68_UNION *z = (A68_UNION *) item;
293 if (INITIALISED (z)) {
294 MOID_T *united_moid = (MOID_T *) VALUE (z);
295 colour_object (&item[A68_UNION_SIZE], united_moid);
296 }
297 } else if (IS (m, PROC_SYMBOL)) {
298 // PROCs - save a locale and the objects it points to.
299 A68_PROCEDURE *z = (A68_PROCEDURE *) item;
300 if (INITIALISED (z) && LOCALE (z) != NO_HANDLE && !(STATUS_TEST (LOCALE (z), COOKIE_MASK))) {
301 BYTE_T *u = POINTER (LOCALE (z));
302 PACK_T *s = PACK (MOID (z));
303 STATUS_SET (LOCALE (z), (COOKIE_MASK | COLOUR_MASK));
304 for (; s != NO_PACK; FORWARD (s)) {
305 if (VALUE ((A68_BOOL *) & u[0]) == A68_TRUE) {
306 colour_object (&u[SIZE (M_BOOL)], MOID (s));
307 }
308 u = &(u[SIZE (M_BOOL) + SIZE (MOID (s))]);
309 }
310 // STATUS_CLEAR (LOCALE (z), COOKIE_MASK);.
311 }
312 } else if (m == M_SOUND) {
313 // Claim the data of a SOUND object, that is in the heap.
314 A68_SOUND *w = (A68_SOUND *) item;
315 if (INITIALISED (w)) {
316 STATUS_SET (REF_HANDLE (&(DATA (w))), (COOKIE_MASK | COLOUR_MASK));
317 }
318 }
319 }
320
321 //! @brief Colour active objects in the heap.
322
323 void colour_heap (ADDR_T fp)
324 {
325 while (fp != 0) {
326 NODE_T *p = FRAME_TREE (fp);
327 TABLE_T *q = TABLE (p);
328 if (q != NO_TABLE) {
329 TAG_T *i;
330 for (i = IDENTIFIERS (q); i != NO_TAG; FORWARD (i)) {
331 colour_object (FRAME_LOCAL (fp, OFFSET (i)), MOID (i));
332 }
333 for (i = ANONYMOUS (q); i != NO_TAG; FORWARD (i)) {
334 if (PRIO (i) == GENERATOR) {
335 colour_object (FRAME_LOCAL (fp, OFFSET (i)), MOID (i));
336 }
337 }
338 }
339 fp = FRAME_DYNAMIC_LINK (fp);
340 }
341 }
342
343 //! @brief Join all active blocks in the heap.
344
345 void defragment_heap (void)
346 {
347 A68_HANDLE *z;
348 // Free handles.
349 z = A68_GC (busy_handles);
350 while (z != NO_HANDLE) {
351 if (!(STATUS_TEST (z, COLOUR_MASK)) && !(STATUS_TEST (z, BLOCK_GC_MASK))) {
352 A68_HANDLE *y = NEXT (z);
353 if (PREVIOUS (z) == NO_HANDLE) {
354 A68_GC (busy_handles) = NEXT (z);
355 } else {
356 NEXT (PREVIOUS (z)) = NEXT (z);
357 }
358 if (NEXT (z) != NO_HANDLE) {
359 PREVIOUS (NEXT (z)) = PREVIOUS (z);
360 }
361 NEXT (z) = A68_GC (available_handles);
362 PREVIOUS (z) = NO_HANDLE;
363 if (NEXT (z) != NO_HANDLE) {
364 PREVIOUS (NEXT (z)) = z;
365 }
366 A68_GC (available_handles) = z;
367 STATUS_CLEAR (z, ALLOCATED_MASK);
368 A68_GC (freed) += SIZE (z);
369 A68_GC (free_handles)++;
370 z = y;
371 } else {
372 FORWARD (z);
373 }
374 }
375 // There can be no uncoloured allocated handle.
376 for (z = A68_GC (busy_handles); z != NO_HANDLE; FORWARD (z)) {
377 ABEND (!(STATUS_TEST (z, COLOUR_MASK)) && !(STATUS_TEST (z, BLOCK_GC_MASK)), ERROR_INTERNAL_CONSISTENCY, __func__);
378 }
379 // Defragment the heap.
380 A68_HP = A68 (fixed_heap_pointer);
381 for (z = A68_GC (busy_handles); z != NO_HANDLE && NEXT (z) != NO_HANDLE; FORWARD (z)) {
382 ;
383 }
384 for (; z != NO_HANDLE; BACKWARD (z)) {
385 BYTE_T *dst = HEAP_ADDRESS (A68_HP);
386 if (dst != POINTER (z)) {
387 MOVE (dst, POINTER (z), (unt) SIZE (z));
388 }
389 STATUS_CLEAR (z, (COLOUR_MASK | COOKIE_MASK));
390 POINTER (z) = dst;
391 A68_HP += (SIZE (z));
392 ABEND (A68_HP % A68_ALIGNMENT != 0, ERROR_ALIGNMENT, __func__);
393 }
394 }
395
396 //! @brief Clean up garbage and defragment the heap.
397
398 void gc_heap (NODE_T * p, ADDR_T fp)
399 {
400 // Must start with fp = current frame_pointer.
401 A68_HANDLE *z;
402 REAL_T t0, t1;
403 #if defined (BUILD_PARALLEL_CLAUSE)
404 if (OTHER_THREAD (FRAME_THREAD_ID (A68_FP), A68_PAR (main_thread_id))) {
405 A68_GC (refused)++;
406 return;
407 }
408 #endif
409 // Take no risk when intermediate results are on the stack.
410 if (A68_SP != A68 (stack_start)) {
411 A68_GC (refused)++;
412 return;
413 }
414 // Give it a whirl then.
415 t0 = seconds ();
416 // Unfree handles are subject to inspection.
417 // Release them all before colouring.
418 for (z = A68_GC (busy_handles); z != NO_HANDLE; FORWARD (z)) {
419 STATUS_CLEAR (z, (COLOUR_MASK | COOKIE_MASK));
420 }
421 // Pour paint into the heap to reveal active objects.
422 colour_heap (fp);
423 // Start freeing and compacting.
424 A68_GC (freed) = 0;
425 defragment_heap ();
426 // Stats and logging.
427 A68_GC (total) += A68_GC (freed);
428 A68_GC (sweeps)++;
429 A68_GC (preemptive) = A68_FALSE;
430 t1 = seconds ();
431 // C optimiser can make last digit differ, so next condition is
432 // needed to determine a positive time difference
433 if ((t1 - t0) > ((REAL_T) A68 (clock_res) / 2.0)) {
434 A68_GC (seconds) += (t1 - t0);
435 } else {
436 A68_GC (seconds) += ((REAL_T) A68 (clock_res) / 2.0);
437 }
438 // Call the event handler.
439 genie_call_event_routine (p, M_PROC_VOID, &A68 (on_gc_event), A68_SP, A68_FP);
440 }
441
442 //! @brief Yield a handle that will point to a block in the heap.
443
444 A68_HANDLE *give_handle (NODE_T * p, MOID_T * a68m)
445 {
446 if (A68_GC (available_handles) != NO_HANDLE) {
447 A68_HANDLE *x = A68_GC (available_handles);
448 A68_GC (available_handles) = NEXT (x);
449 if (A68_GC (available_handles) != NO_HANDLE) {
450 PREVIOUS (A68_GC (available_handles)) = NO_HANDLE;
451 }
452 STATUS (x) = ALLOCATED_MASK;
453 POINTER (x) = NO_BYTE;
454 SIZE (x) = 0;
455 MOID (x) = a68m;
456 NEXT (x) = A68_GC (busy_handles);
457 PREVIOUS (x) = NO_HANDLE;
458 if (NEXT (x) != NO_HANDLE) {
459 PREVIOUS (NEXT (x)) = x;
460 }
461 A68_GC (busy_handles) = x;
462 A68_GC (free_handles)--;
463 return x;
464 } else {
465 // Do not auto-GC!.
466 diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
467 exit_genie (p, A68_RUNTIME_ERROR);
468 }
469 return NO_HANDLE;
470 }
471
472 //! @brief Give a block of heap for an object of indicated mode.
473
474 A68_REF heap_generator (NODE_T * p, MOID_T * mode, int size)
475 {
476 // Align.
477 ABEND (size < 0, ERROR_INVALID_SIZE, __func__);
478 size = A68_ALIGN (size);
479 // Now give it.
480 if (heap_available () >= size) {
481 A68_HANDLE *x;
482 A68_REF z;
483 STATUS (&z) = (STATUS_MASK_T) (INIT_MASK | IN_HEAP_MASK);
484 OFFSET (&z) = 0;
485 x = give_handle (p, mode);
486 SIZE (x) = size;
487 POINTER (x) = HEAP_ADDRESS (A68_HP);
488 FILL (POINTER (x), 0, size);
489 REF_SCOPE (&z) = PRIMAL_SCOPE;
490 REF_HANDLE (&z) = x;
491 ABEND (((long) ADDRESS (&z)) % A68_ALIGNMENT != 0, ERROR_ALIGNMENT, __func__);
492 A68_HP += size;
493 REAL_T _f_ = (REAL_T) A68_HP / (REAL_T) A68 (heap_size);
494 REAL_T _g_ = (REAL_T) (A68_GC (max_handles) - A68_GC (free_handles)) / (REAL_T) A68_GC (max_handles);
495 if (_f_ > DEFAULT_PREEMPTIVE || _g_ > DEFAULT_PREEMPTIVE) {
496 A68_GC (preemptive) = A68_TRUE;
497 }
498 return z;
499 } else {
500 // Do not auto-GC!.
501 diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
502 exit_genie (p, A68_RUNTIME_ERROR);
503 return nil_ref;
504 }
505 }
506
507 // Following implements the generator.
508
509 //! @brief Whether a moid needs work in allocation.
510
511 BOOL_T mode_needs_allocation (MOID_T * m)
512 {
513 if (IS_UNION (m)) {
514 return A68_FALSE;
515 } else {
516 return HAS_ROWS (m);
517 }
518 }
519
520 //! @brief Prepare bounds.
521
522 void genie_compute_bounds (NODE_T * p)
523 {
524 for (; p != NO_NODE; FORWARD (p)) {
525 if (IS (p, BOUNDS_LIST)) {
526 genie_compute_bounds (SUB (p));
527 } else if (IS (p, BOUND)) {
528 genie_compute_bounds (SUB (p));
529 } else if (IS (p, UNIT)) {
530 if (NEXT (p) != NO_NODE && (is_one_of (NEXT (p), COLON_SYMBOL, DOTDOT_SYMBOL, STOP))) {
531 EXECUTE_UNIT (p);
532 p = NEXT_NEXT (p);
533 } else {
534 // Default lower bound.
535 PUSH_VALUE (p, 1, A68_INT);
536 }
537 EXECUTE_UNIT (p);
538 }
539 }
540 }
541
542 //! @brief Prepare bounds for a row.
543
544 void genie_generator_bounds (NODE_T * p)
545 {
546 LOW_STACK_ALERT (p);
547 for (; p != NO_NODE; FORWARD (p)) {
548 if (IS (p, BOUNDS)) {
549 genie_compute_bounds (SUB (p));
550 } else if (IS (p, INDICANT) && IS_LITERALLY (p, "STRING")) {
551 return;
552 } else if (IS (p, INDICANT)) {
553 if (TAX (p) != NO_TAG && HAS_ROWS (MOID (TAX (p)))) {
554 // Continue from definition at MODE A = ....
555 genie_generator_bounds (DEF_NODE (p));
556 }
557 } else if (IS (p, DECLARER) && !mode_needs_allocation (MOID (p))) {
558 return;
559 } else {
560 genie_generator_bounds (SUB (p));
561 }
562 }
563 }
564
565 //! @brief Allocate a structure.
566
567 void genie_generator_field (NODE_T * p, BYTE_T ** faddr, NODE_T ** decl, ADDR_T * cur_sp, ADDR_T * top_sp)
568 {
569 for (; p != NO_NODE; FORWARD (p)) {
570 if (IS (p, STRUCTURED_FIELD)) {
571 genie_generator_field (SUB (p), faddr, decl, cur_sp, top_sp);
572 }
573 if (IS (p, DECLARER)) {
574 (*decl) = SUB (p);
575 FORWARD (p);
576 }
577 if (IS (p, FIELD_IDENTIFIER)) {
578 MOID_T *fmoid = MOID (*decl);
579 if (HAS_ROWS (fmoid) && ISNT (fmoid, UNION_SYMBOL)) {
580 ADDR_T pop_sp = *cur_sp;
581 genie_generator_stowed (*decl, *faddr, NO_VAR, cur_sp);
582 *top_sp = *cur_sp;
583 *cur_sp = pop_sp;
584 }
585 (*faddr) += SIZE (fmoid);
586 }
587 }
588 }
589
590 //! @brief Allocate a structure.
591
592 void genie_generator_struct (NODE_T * p, BYTE_T ** faddr, ADDR_T * cur_sp)
593 {
594 for (; p != NO_NODE; FORWARD (p)) {
595 if (IS (p, STRUCTURED_FIELD_LIST)) {
596 genie_generator_struct (SUB (p), faddr, cur_sp);
597 } else if (IS (p, STRUCTURED_FIELD)) {
598 NODE_T *decl = NO_NODE;
599 ADDR_T top_sp = *cur_sp;
600 genie_generator_field (SUB (p), faddr, &decl, cur_sp, &top_sp);
601 *cur_sp = top_sp;
602 }
603 }
604 }
605
606 //! @brief Allocate a stowed object.
607
608 void genie_generator_stowed (NODE_T * p, BYTE_T * addr, NODE_T ** decl, ADDR_T * cur_sp)
609 {
610 if (p == NO_NODE) {
611 return;
612 } else if (IS (p, INDICANT) && IS_LITERALLY (p, "STRING")) {
613 // The standard prelude definition is hard coded here.
614 *((A68_REF *) addr) = empty_string (p);
615 return;
616 } else if (IS (p, INDICANT) && TAX (p) != NO_TAG) {
617 // Continue from definition at MODE A = ..
618 genie_generator_stowed (DEF_NODE (p), addr, decl, cur_sp);
619 return;
620 } else if (IS (p, DECLARER) && mode_needs_allocation (MOID (p))) {
621 genie_generator_stowed (SUB (p), addr, decl, cur_sp);
622 return;
623 } else if (IS_STRUCT (p)) {
624 BYTE_T *faddr = addr;
625 genie_generator_struct (SUB_NEXT (p), &faddr, cur_sp);
626 return;
627 } else if (IS_FLEX (p)) {
628 genie_generator_stowed (NEXT (p), addr, decl, cur_sp);
629 return;
630 } else if (IS (p, BOUNDS)) {
631 A68_REF desc;
632 MOID_T *rmod = MOID (p), *smod = MOID (NEXT (p));
633 A68_ARRAY *arr;
634 A68_TUPLE *tup;
635 BYTE_T *bounds = STACK_ADDRESS (*cur_sp);
636 int k, dim = DIM (DEFLEX (rmod));
637 int esiz = SIZE (smod), rsiz = 1;
638 BOOL_T alloc_sub, alloc_str;
639 NODE_T *in = SUB_NEXT (p);
640 if (IS (in, INDICANT) && IS_LITERALLY (in, "STRING")) {
641 alloc_str = A68_TRUE;
642 alloc_sub = A68_FALSE;
643 } else {
644 alloc_sub = mode_needs_allocation (smod);
645 alloc_str = A68_FALSE;
646 }
647 desc = heap_generator (p, rmod, DESCRIPTOR_SIZE (dim));
648 GET_DESCRIPTOR (arr, tup, &desc);
649 for (k = 0; k < dim; k++) {
650 CHECK_INIT (p, INITIALISED ((A68_INT *) bounds), M_INT);
651 LWB (&tup[k]) = VALUE ((A68_INT *) bounds);
652 bounds += SIZE (M_INT);
653 CHECK_INIT (p, INITIALISED ((A68_INT *) bounds), M_INT);
654 UPB (&tup[k]) = VALUE ((A68_INT *) bounds);
655 bounds += SIZE (M_INT);
656 SPAN (&tup[k]) = rsiz;
657 SHIFT (&tup[k]) = LWB (&tup[k]) * SPAN (&tup[k]);
658 rsiz *= ROW_SIZE (&tup[k]);
659 }
660 DIM (arr) = dim;
661 MOID (arr) = smod;
662 ELEM_SIZE (arr) = esiz;
663 SLICE_OFFSET (arr) = 0;
664 FIELD_OFFSET (arr) = 0;
665 (*cur_sp) += (dim * 2 * SIZE (M_INT));
666 // Generate a new row. Note that STRING is handled explicitly since
667 // it has implicit bounds
668 if (rsiz == 0) {
669 // Generate a ghost element.
670 ADDR_T top_sp = *cur_sp;
671 BYTE_T *elem;
672 ARRAY (arr) = heap_generator (p, rmod, esiz);
673 elem = ADDRESS (&(ARRAY (arr)));
674 if (alloc_sub) {
675 genie_generator_stowed (NEXT (p), &(elem[0]), NO_VAR, cur_sp);
676 top_sp = *cur_sp;
677 } else if (alloc_str) {
678 *(A68_REF *) elem = empty_string (p);
679 }
680 (*cur_sp) = top_sp;
681 } else {
682 ADDR_T pop_sp = *cur_sp, top_sp = *cur_sp;
683 BYTE_T *elem;
684 ARRAY (arr) = heap_generator (p, rmod, rsiz * esiz);
685 elem = ADDRESS (&(ARRAY (arr)));
686 for (k = 0; k < rsiz; k++) {
687 if (alloc_sub) {
688 (*cur_sp) = pop_sp;
689 genie_generator_stowed (NEXT (p), &(elem[k * esiz]), NO_VAR, cur_sp);
690 top_sp = *cur_sp;
691 } else if (alloc_str) {
692 *(A68_REF *) (&(elem[k * esiz])) = empty_string (p);
693 }
694 }
695 (*cur_sp) = top_sp;
696 }
697 *(A68_REF *) addr = desc;
698 return;
699 }
700 }
701
702 //! @brief Generate space and push a REF.
703
704 void genie_generator_internal (NODE_T * p, MOID_T * ref_mode, TAG_T * tag, LEAP_T leap, ADDR_T sp)
705 {
706 // Set up a REF MODE object, either in the stack or in the heap.
707 MOID_T *mode = SUB (ref_mode);
708 A68_REF name = nil_ref;
709 if (leap == LOC_SYMBOL) {
710 STATUS (&name) = (STATUS_MASK_T) (INIT_MASK | IN_FRAME_MASK);
711 REF_HANDLE (&name) = (A68_HANDLE *) & nil_handle;
712 OFFSET (&name) = A68_FP + FRAME_INFO_SIZE + OFFSET (tag);
713 REF_SCOPE (&name) = A68_FP;
714 } else if (leap == -LOC_SYMBOL && NON_LOCAL (p) != NO_TABLE) {
715 ADDR_T lev;
716 name = heap_generator (p, mode, SIZE (mode));
717 FOLLOW_SL (lev, LEVEL (NON_LOCAL (p)));
718 REF_SCOPE (&name) = lev;
719 } else if (leap == -LOC_SYMBOL) {
720 name = heap_generator (p, mode, SIZE (mode));
721 REF_SCOPE (&name) = A68_FP;
722 } else if (leap == HEAP_SYMBOL || leap == -HEAP_SYMBOL) {
723 name = heap_generator (p, mode, SIZE (mode));
724 REF_SCOPE (&name) = PRIMAL_SCOPE;
725 } else if (leap == NEW_SYMBOL || leap == -NEW_SYMBOL) {
726 name = heap_generator (p, mode, SIZE (mode));
727 REF_SCOPE (&name) = PRIMAL_SCOPE;
728 } else {
729 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
730 }
731 if (HAS_ROWS (mode)) {
732 ADDR_T cur_sp = sp;
733 genie_generator_stowed (p, ADDRESS (&name), NO_VAR, &cur_sp);
734 }
735 PUSH_REF (p, name);
736 }
737
738 //! @brief Push a name refering to allocated space.
739
740 PROP_T genie_generator (NODE_T * p)
741 {
742 PROP_T self;
743 ADDR_T pop_sp = A68_SP;
744 A68_REF z;
745 if (NEXT_SUB (p) != NO_NODE) {
746 genie_generator_bounds (NEXT_SUB (p));
747 }
748 genie_generator_internal (NEXT_SUB (p), MOID (p), TAX (p), -ATTRIBUTE (SUB (p)), pop_sp);
749 POP_REF (p, &z);
750 A68_SP = pop_sp;
751 PUSH_REF (p, z);
752 UNIT (&self) = genie_generator;
753 SOURCE (&self) = p;
754 return self;
755 }
756
757 // Control of C heap
758
759 //! @brief Discard_heap.
760
761 void discard_heap (void)
762 {
763 if (A68_HEAP != NO_BYTE) {
764 a68_free (A68_HEAP);
765 }
766 A68 (fixed_heap_pointer) = 0;
767 A68 (temp_heap_pointer) = 0;
768 }
