//! @file rts-heap.c
//! @author J. Marcel van der Veer

//! @section Copyright
//!
//! This file is part of Algol68G - an Algol 68 compiler-interpreter.
//! Copyright 2001-2026 J. Marcel van der Veer [algol68g@algol68genie.nl].

//! @section License
//!
//! This program is free software; you can redistribute it and/or modify it 
//! under the terms of the GNU General Public License as published by the 
//! Free Software Foundation; either version 3 of the License, or 
//! (at your option) any later version.
//!
//! This program is distributed in the hope that it will be useful, but 
//! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 
//! or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for 
//! more details. You should have received a copy of the GNU General Public 
//! License along with this program. If not, see [http://www.gnu.org/licenses/].

//! @section Synopsis
//!
//! Generator and garbage collector routines.

// The generator allocates space in stack or heap and initialises dynamically sized objects.
// 
// A mark-and-gc garbage collector defragments the heap. When called, it walks
// the stack frames and marks the heap space that is still active. This marking
// process is called "colouring" here since we "pour paint" into the heap.
// The active blocks are then joined, the non-active blocks are forgotten.
// 
// When colouring the heap, "cookies" are placed in objects as to find circular
// references.
// 
// Algol68G introduces several anonymous tags in the symbol tables that save
// temporary REF or ROW results, so that they do not get prematurely swept.
// 
// The genie is not smart enough to handle every heap clog, e.g. when copying
// STOWED objects. This seems not very elegant, but garbage collectors in general
// cannot solve all core management problems. To avoid many of the "unforeseen"
// heap clogs, we try to keep heap occupation low by garbage collecting 
// occasionally, before it fills up completely. If this automatic mechanism does
// not help, one can always invoke the garbage collector by calling "gc heap"
// from Algol 68 source text.
// 
// Mark-and-collect is simple but since it walks recursive structures, it could
// exhaust the C-stack (segment violation). A rough check is in place.
// 
// For dynamically sized objects, first bounds are evaluated (right first, then down).
// The object is generated keeping track of the bound-count.
// 
//      ...
//      [#1]
//      STRUCT
//      (
//      [#2]
//      STRUCT
//      (
//      [#3] A a, b, ...
//      )
//      ,                       Advance bound-count here, max is #3
//      [#4] B a, b, ...
//      )
//      ,                       Advance bound-count here, max is #4
//      [#5] C a, b, ...
//      ...
// 
// Bound-count is maximised when generator_stowed is entered recursively. 
// Bound-count is advanced when completing a STRUCTURED_FIELD.
// Note that A68G will not extend stack frames. Thus only 'static' LOC generators
// are in the stack, and 'dynamic' LOC generators go into the heap. These local 
// REFs in the heap get local scope however, and A68G's approach differs from the 
// CDC ALGOL 68 approach that put all generators in the heap.
// Note that part of memory is called 'COMMON'. This is meant for future extension
// where a68g would need to point to external objects. The adressing scheme is that
// of a HEAP pointer - handle pointer + offset.

#include "a68g.h"
#include "a68g-genie.h"
#include "a68g-frames.h"
#include "a68g-prelude.h"
#include "a68g-parser.h"

#define DEF_NODE(p) (NEXT_NEXT (NODE (TAX (p))))

//! @brief Check overflow at size multiplication.

BOOL_T size_mul_overflow (size_t u, size_t v)
{
  if (u == 0 || v == 0) {
    return (A68G_FALSE);
  } else {
    return v > (MAX_MEM_SIZE / u);
  }
}

//! @brief PROC VOID gc heap

void genie_gc_heap (NODE_T * p)
{
  gc_heap (p, A68G_FP);
}

//! @brief PROC VOID preemptive gc heap

void genie_preemptive_gc_heap (NODE_T * p)
{
  if (A68G_GC (preemptive)) {
    gc_heap (p, A68G_FP);
    A68G_GC (preemptive) = A68G_FALSE;
  }
}

//! @brief INT blocks

void genie_block (NODE_T * p)
{
  PUSH_VALUE (p, 0, A68G_INT);
}

//! @brief INT garbage collections

void genie_garbage_collections (NODE_T * p)
{
  PUSH_VALUE (p, A68G_GC (sweeps), A68G_INT);
}

//! @brief INT garbage refused

void genie_garbage_refused (NODE_T * p)
{
  PUSH_VALUE (p, A68G_GC (refused), A68G_INT);
}

//! @brief LONG INT garbage freed

void genie_garbage_freed (NODE_T * p)
{
  PUSH_VALUE (p, A68G_GC (total), A68G_INT);
}

//! @brief REAL garbage seconds

void genie_garbage_seconds (NODE_T * p)
{
// Note that this timing is a rough cut.
  PUSH_VALUE (p, A68G_GC (seconds), A68G_REAL);
}

//! @brief Size available for an object in the heap.

size_t heap_available (void)
{
  if (A68G (temp_heap_pointer) > A68G_HP) {
    return A68G (temp_heap_pointer) - A68G_HP;
  } else {
    return 0;
  }
}

//! @brief Initialise heap management.

void genie_init_heap (NODE_T * p)
{
  (void) p;
  if (A68G_HEAP == NO_BYTE) {
    diagnostic (A68G_RUNTIME_ERROR, TOP_NODE (&A68G_JOB), ERROR_MEMORY_FULL);
    exit_genie (TOP_NODE (&A68G_JOB), A68G_RUNTIME_ERROR);
  }
  if (A68G_HANDLES == NO_BYTE) {
    diagnostic (A68G_RUNTIME_ERROR, TOP_NODE (&A68G_JOB), ERROR_MEMORY_FULL);
    exit_genie (TOP_NODE (&A68G_JOB), A68G_RUNTIME_ERROR);
  }
  A68G_GC (seconds) = 0;
  A68G_GC (total) = 0;
  A68G_GC (sweeps) = 0;
  A68G_GC (refused) = 0;
  A68G_GC (preemptive) = A68G_FALSE;
  // Make sure we have some space for an A68 heap.
  ABEND ((A68G (fixed_heap_pointer) + 2 * A68G (storage_overhead)) >= A68G (temp_heap_pointer), ERROR_MEMORY_FULL, NO_TEXT);
  A68G_HP = A68G (fixed_heap_pointer);
  A68G (heap_is_fluid) = A68G_FALSE;
  // Assign handle space.
  A68G_HANDLE *z = (A68G_HANDLE *) A68G_HANDLES;
  A68G_GC (available_handles) = z;
  A68G_GC (busy_handles) = NO_HANDLE;
  size_t N = A68G (handle_pool_size) / SIZE_ALIGNED (A68G_HANDLE);
  A68G_GC (free_handles) = N;
  A68G_GC (max_handles) = N;
  for (int k = 0; k < N; k++) {
    STATUS (&(z[k])) = NULL_MASK;
    POINTER (&(z[k])) = NO_BYTE;
    SIZE (&(z[k])) = 0;
    NEXT (&z[k]) = (k == N - 1 ? NO_HANDLE : &z[k + 1]);
    PREVIOUS (&z[k]) = (k == 0 ? NO_HANDLE : &z[k - 1]);
  }
}

//! @brief Whether mode must be coloured.

BOOL_T moid_needs_colouring (MOID_T * m)
{
  if (IS_REF (m)) {
    return A68G_TRUE;
  } else if (IS (m, PROC_SYMBOL)) {
    return A68G_TRUE;
  } else if (IS_FLEX (m) || IS_ROW (m)) {
    return A68G_TRUE;
  } else if (IS_STRUCT (m) || IS_UNION (m)) {
    for (PACK_T *p = PACK (m); p != NO_PACK; FORWARD (p)) {
      if (moid_needs_colouring (MOID (p))) {
        return A68G_TRUE;
      }
    }
    return A68G_FALSE;
  } else if (m == M_SIMPLIN || m == M_SIMPLOUT) {
    return A68G_TRUE;
  } else if (m == M_SOUND) {
    return A68G_TRUE;
  } else {
    return A68G_FALSE;
  }
}

//! @brief Colour all elements of a row.

void colour_row_elements (A68G_REF * z)
{
  A68G_ARRAY *arr; A68G_TUPLE *tup;
  GET_DESCRIPTOR (arr, tup, z);
  int dim = DIM (arr);
  MOID_T *df = DEFLEX (SLICE (arr));
  BYTE_T *elem = ADDRESS (&ARRAY (arr));
  if (get_row_size (tup, dim) == 0) {
    // Empty rows have a ghost elements.
    colour_object (&elem[0], df);
  } else {
    // Colour all elements.
    initialise_internal_index (tup, dim);
    BOOL_T done = A68G_FALSE;
    while (!done) {
      ADDR_T index = calculate_internal_index (tup, dim);
      colour_object (&elem[ROW_ELEMENT (arr, index)], df);
      done = increment_internal_index (tup, dim);
    }
  }
}

//! @brief Colour an (active) object.

void colour_object (BYTE_T * item, MOID_T * m)
{
  if (item == NO_BYTE || m == NO_MOID) {
    return;
  }
  if (!moid_needs_colouring (m)) {
    return;
  }
  // Deeply recursive objects might exhaust the stack.
  LOW_STACK_ALERT (NO_NODE);
  if (IS_REF (m)) {
    // REF AMODE colour pointer and object to which it refers.
    A68G_REF *z = (A68G_REF *) item;
    if (INITIALISED (z) && IS_IN_HEAP (z)) {
      if (STATUS_TEST (REF_HANDLE (z), COOKIE_MASK)) {
        return;
      }
      STATUS_SET (REF_HANDLE (z), (COOKIE_MASK | COLOUR_MASK));
      if (!IS_NIL (*z)) {
        colour_object (ADDRESS (z), SUB (m));
      }
      // STATUS_CLEAR (REF_HANDLE (z), COOKIE_MASK);.
    }
  } else if (IS_FLEXETY_ROW (m)) {
    // Claim the descriptor and the row itself.
    A68G_REF *z = (A68G_REF *) item;
    if (INITIALISED (z) && IS_IN_HEAP (z)) {
      if (STATUS_TEST (REF_HANDLE (z), COOKIE_MASK)) {
        return;
      }
      // An array is ALWAYS in the heap.
      STATUS_SET (REF_HANDLE (z), (COOKIE_MASK | COLOUR_MASK));
      A68G_ARRAY *arr; A68G_TUPLE *tup;
      GET_DESCRIPTOR (arr, tup, z);
      if (REF_HANDLE (&(ARRAY (arr))) != NO_HANDLE) {
        // Assume row initialisation.
        MOID_T *n = DEFLEX (m);
        STATUS_SET (REF_HANDLE (&(ARRAY (arr))), COLOUR_MASK);
        if (moid_needs_colouring (SUB (n))) {
          colour_row_elements (z);
        }
      }
      // STATUS_CLEAR (REF_HANDLE (z), COOKIE_MASK);.
      (void) tup;
    }
  } else if (IS_STRUCT (m)) {
    // STRUCTures - colour fields.
    for (PACK_T *p = PACK (m); p != NO_PACK; FORWARD (p)) {
      colour_object (&item[OFFSET (p)], MOID (p));
    }
  } else if (IS_UNION (m) || m == M_SIMPLIN || m == M_SIMPLOUT) {
    // UNIONs - a united object may contain a value that needs colouring.
    // SIMPLIN and SIMPLOUT are UNIONs.
    A68G_UNION *z = (A68G_UNION *) item;
    if (INITIALISED (z)) {
      MOID_T *united_moid = (MOID_T *) VALUE (z);
      colour_object (&item[A68G_UNION_SIZE], united_moid);
    }
  } else if (IS (m, PROC_SYMBOL)) {
    // PROCs - save a locale and the objects it points to.
    A68G_PROCEDURE *z = (A68G_PROCEDURE *) item;
    if (INITIALISED (z) && LOCALE (z) != NO_HANDLE && !(STATUS_TEST (LOCALE (z), COOKIE_MASK))) {
      BYTE_T *u = POINTER (LOCALE (z));
      STATUS_SET (LOCALE (z), (COOKIE_MASK | COLOUR_MASK));
      for (PACK_T *s = PACK (MOID (z)); s != NO_PACK; FORWARD (s)) {
        if (VALUE ((A68G_BOOL *) & u[0]) == A68G_TRUE) {
          colour_object (&u[SIZE (M_BOOL)], MOID (s));
        }
        u = &(u[SIZE (M_BOOL) + SIZE (MOID (s))]);
      }
      // STATUS_CLEAR (LOCALE (z), COOKIE_MASK);.
    }
  } else if (m == M_SOUND) {
    // Claim the data of a SOUND object, that is in the heap.
    A68G_SOUND *w = (A68G_SOUND *) item;
    if (INITIALISED (w)) {
      STATUS_SET (REF_HANDLE (&(DATA (w))), (COOKIE_MASK | COLOUR_MASK));
    }
  } else {
    ABEND (A68G_TRUE, ERROR_INTERNAL_CONSISTENCY, moid_to_string (m, 80, NO_NODE));
  }
}

//! @brief Colour active objects in the heap.

void colour_heap (ADDR_T fp)
{
  while (fp != 0) {
    NODE_T *p = FRAME_TREE (fp);
    TABLE_T *t = TABLE (p);
    if (t != NO_TABLE) {
      for (TAG_T *q = IDENTIFIERS (t); q != NO_TAG; FORWARD (q)) {
        colour_object (FRAME_LOCAL (fp, OFFSET (q)), MOID (q));
      }
      for (TAG_T *q = ANONYMOUS (t); q != NO_TAG; FORWARD (q)) {
        colour_object (FRAME_LOCAL (fp, OFFSET (q)), MOID (q));
      }
    }
    fp = FRAME_DYNAMIC_LINK (fp);
  }
}

//! @brief Join all active blocks in the heap.

void defragment_heap (void)
{
  // Free handles.
  A68G_HANDLE *z = A68G_GC (busy_handles);
  while (z != NO_HANDLE) {
    if (!(STATUS_TEST (z, COLOUR_MASK)) && !(STATUS_TEST (z, BLOCK_GC_MASK))) {
      A68G_HANDLE *y = NEXT (z);
      if (PREVIOUS (z) == NO_HANDLE) {
        A68G_GC (busy_handles) = NEXT (z);
      } else {
        NEXT (PREVIOUS (z)) = NEXT (z);
      }
      if (NEXT (z) != NO_HANDLE) {
        PREVIOUS (NEXT (z)) = PREVIOUS (z);
      }
      NEXT (z) = A68G_GC (available_handles);
      PREVIOUS (z) = NO_HANDLE;
      if (NEXT (z) != NO_HANDLE) {
        PREVIOUS (NEXT (z)) = z;
      }
      A68G_GC (available_handles) = z;
      STATUS_CLEAR (z, ALLOCATED_MASK);
      A68G_GC (freed) += SIZE (z);
      A68G_GC (free_handles)++;
      z = y;
    } else {
      FORWARD (z);
    }
  }
  // There can be no uncoloured allocated handle.
  for (z = A68G_GC (busy_handles); z != NO_HANDLE; FORWARD (z)) {
    ABEND (!(STATUS_TEST (z, COLOUR_MASK)) && !(STATUS_TEST (z, BLOCK_GC_MASK)), ERROR_INTERNAL_CONSISTENCY, NO_TEXT);
  }
  // Defragment the heap.
  A68G_HP = A68G (fixed_heap_pointer);
  for (z = A68G_GC (busy_handles); z != NO_HANDLE && NEXT (z) != NO_HANDLE; FORWARD (z)) {
    ;
  }
  for (; z != NO_HANDLE; BACKWARD (z)) {
    BYTE_T *dst = HEAP_ADDRESS (A68G_HP);
    if (dst != POINTER (z)) {
      MOVE (dst, POINTER (z), SIZE (z));
    }
    STATUS_CLEAR (z, (COLOUR_MASK | COOKIE_MASK));
    POINTER (z) = dst;
    A68G_HP += (SIZE (z));
    ABEND (A68G_HP % A68G_ALIGNMENT != 0, ERROR_ALIGNMENT, NO_TEXT);
  }
}

//! @brief Clean up garbage and defragment the heap.

void gc_heap (NODE_T * p, ADDR_T fp)
{
  // Must start with fp = current frame_pointer.
  A68G_HANDLE *z;
  REAL_T t0, t1;
  #if defined (BUILD_PARALLEL_CLAUSE)
    if (OTHER_THREAD (FRAME_THREAD_ID (A68G_FP), A68G_PAR (main_thread_id))) {
      A68G_GC (refused)++;
      return;
    }
  #endif
  if (STATUS_TEST (p, BLOCK_GC_MASK)) {
    A68G_GC (refused)++;
    return;
  }
  if (OPTION_CONSERVATIVE_GC (&A68G_JOB) == A68G_GC_HALT) {
    A68G_GC (refused)++;
    return;
  }
  if (OPTION_CONSERVATIVE_GC (&A68G_JOB) == A68G_GC_SAFE && (A68G_GC (sema) > 0)) {
    A68G_GC (refused)++;
    return;
  }
  // Take no risk when intermediate results are on the stack.
  if (OPTION_CONSERVATIVE_GC (&A68G_JOB) && (A68G_SP != A68G (stack_start))) {
    A68G_GC (refused)++;
    return;
  }
  // Give it a whirl then.
  t0 = seconds ();
  // Unfree handles are subject to inspection.
  // Release them all before colouring.
  for (z = A68G_GC (busy_handles); z != NO_HANDLE; FORWARD (z)) {
    STATUS_CLEAR (z, (COLOUR_MASK | COOKIE_MASK));
  }
  // Pour paint into the heap to reveal active objects.
  colour_heap (fp);
  // Start freeing and compacting.
  A68G_GC (freed) = 0;
  defragment_heap ();
  // Stats and logging.
  A68G_GC (total) += A68G_GC (freed);
  A68G_GC (sweeps)++;
  A68G_GC (preemptive) = A68G_FALSE;
  t1 = seconds ();
  // C optimiser can make last digit differ, so next condition is 
  // needed to determine a positive time difference
  if ((t1 - t0) > ((REAL_T) A68G (clock_res) / 2.0)) {
    A68G_GC (seconds) += (t1 - t0);
  } else {
    A68G_GC (seconds) += ((REAL_T) A68G (clock_res) / 2.0);
  }
  // Call the event handler.
  genie_call_event_routine (p, M_PROC_VOID, &A68G (on_gc_event), A68G_SP, A68G_FP);
}

//! @brief Yield a handle that will point to a block in the heap.

A68G_HANDLE *give_handle (NODE_T * p, MOID_T * a68m)
{
  if (A68G_GC (available_handles) != NO_HANDLE) {
    A68G_HANDLE *x = A68G_GC (available_handles);
    A68G_GC (available_handles) = NEXT (x);
    if (A68G_GC (available_handles) != NO_HANDLE) {
      PREVIOUS (A68G_GC (available_handles)) = NO_HANDLE;
    }
    STATUS (x) = ALLOCATED_MASK;
    POINTER (x) = NO_BYTE;
    SIZE (x) = 0;
    MOID (x) = a68m;
    NEXT (x) = A68G_GC (busy_handles);
    PREVIOUS (x) = NO_HANDLE;
    if (NEXT (x) != NO_HANDLE) {
      PREVIOUS (NEXT (x)) = x;
    }
    A68G_GC (busy_handles) = x;
    A68G_GC (free_handles)--;
    return x;
  } else {
    // Do not auto-GC! Really, don't.
    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_MEMORY_FULL);
    exit_genie (p, A68G_RUNTIME_ERROR);
  }
  return NO_HANDLE;
}

//! @brief Allocate heap for an object of indicated mode.

A68G_REF heap_generator (NODE_T * p, MOID_T * mode, size_t size)
{
  if (size == 0) {
    // Empty arrays for instance can have zero length. If we allow zero length,
    // two REFs to not-equivalent objects could point to a same heap area.
    // That is harmless in A68G, but it feels conceptually wrong ;-).
    size = 1;
  }
  size = A68G_ALIGN (size);
  if (heap_available () >= size) {
    A68G_REF z;
    STATUS (&z) = (STATUS_MASK_T) (INIT_MASK | IN_HEAP_MASK);
    OFFSET (&z) = 0;
    A68G_HANDLE *x = give_handle (p, mode);
    SIZE (x) = size;
    POINTER (x) = HEAP_ADDRESS (A68G_HP);
    FILL (POINTER (x), 0, size);
    REF_SCOPE (&z) = PRIMAL_SCOPE;
    REF_HANDLE (&z) = x;
    ABEND (((size_t) ADDRESS (&z)) % A68G_ALIGNMENT != 0, ERROR_ALIGNMENT, NO_TEXT);
    A68G_HP += size;
    // Raise a flag for a preemptive sweep at a convenient moment.
    if (heap_available () < (A68G (storage_overhead) + size) || A68G_GC (free_handles) < 100) {
      // Emergency break.
      A68G_GC (preemptive) = A68G_TRUE;
    } else {
      // General case.
      REAL_T _f_ = (REAL_T) A68G_HP / (REAL_T) heap_available ();
      REAL_T _g_ = (REAL_T) (A68G_GC (max_handles) - A68G_GC (free_handles)) / (REAL_T) A68G_GC (max_handles);
      if (_f_ > PREEMPTIVE_FRACTION || _g_ > PREEMPTIVE_FRACTION) {
         A68G_GC (preemptive) = A68G_TRUE;
      }
    }
    return z;
  } else {
    // Do not auto-GC! Really, don't.
    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_MEMORY_FULL);
    exit_genie (p, A68G_RUNTIME_ERROR);
    return nil_ref;
  }
}

//! @brief Allocate heap for an object of indicated mode.

A68G_REF heap_generator_2 (NODE_T * p, MOID_T * mode, size_t len, size_t size)
{
  if (len == 0 || size == 0) {
    return heap_generator (p, mode, 0);
  } else if (size_mul_overflow (len, size)) {
    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_OBJECT_TOO_LARGE, mode);
    exit_genie (p, A68G_RUNTIME_ERROR);
  } else {
    return heap_generator (p, mode, len * size);
  }
  return nil_ref;
}

//! @brief Allocate heap for an object of indicated mode.

A68G_REF heap_generator_3 (NODE_T * p, MOID_T * mode, size_t len1, size_t len2, size_t size)
{
  if (len1 == 0 || len2 == 0) {
    return heap_generator (p, mode, 0);
  } else if (size_mul_overflow (len1, len2)) {
    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_OBJECT_TOO_LARGE, mode);
    exit_genie (p, A68G_RUNTIME_ERROR);
  } else {
    return heap_generator_2 (p, mode, len1 * len2, size);
  }
  return nil_ref;
}

// Following implements the generator.

//! @brief Whether a moid needs work in allocation.

BOOL_T mode_needs_allocation (MOID_T * m)
{
  if (IS_UNION (m)) {
    return A68G_FALSE;
  } else {
    return HAS_ROWS (m);
  }
}

//! @brief Prepare bounds for a row.

void genie_compute_bounds (NODE_T * p)
{
  for (; p != NO_NODE; FORWARD (p)) {
    if (IS (p, BOUNDS_LIST)) {
      genie_compute_bounds (SUB (p));
    } else if (IS (p, BOUND)) {
      genie_compute_bounds (SUB (p));
    } else if (IS (p, UNIT)) {
      if (NEXT (p) != NO_NODE && (is_one_of (NEXT (p), COLON_SYMBOL, DOTDOT_SYMBOL, STOP))) {
        GENIE_UNIT (p);
        p = NEXT_NEXT (p);
      } else {
        // Default lower bound.
        PUSH_VALUE (p, 1, A68G_INT);
      }
      GENIE_UNIT (p);
    }
  }
}

//! @brief Prepare bounds for a row.

void genie_generator_bounds (NODE_T * p)
{
  LOW_STACK_ALERT (p);
  for (; p != NO_NODE; FORWARD (p)) {
    if (IS (p, BOUNDS)) {
      genie_compute_bounds (SUB (p));
    } else if (IS (p, INDICANT) && IS_LITERALLY (p, "STRING")) {
      return;
    } else if (IS (p, INDICANT)) {
      if (TAX (p) != NO_TAG && HAS_ROWS (MOID (TAX (p)))) {
        // Continue from definition at MODE A = ... in the tree.
        genie_generator_bounds (DEF_NODE (p));
      }
    } else if (IS (p, DECLARER) && !mode_needs_allocation (MOID (p))) {
      return;
    } else {
      genie_generator_bounds (SUB (p));
    }
  }
}

//! @brief Allocate a structure.

void genie_generator_field (NODE_T * p, BYTE_T ** faddr, NODE_T ** decl, ADDR_T * cur_sp, ADDR_T * top_sp)
{
  for (; p != NO_NODE; FORWARD (p)) {
    if (IS (p, STRUCTURED_FIELD)) {
      genie_generator_field (SUB (p), faddr, decl, cur_sp, top_sp);
    }
    if (IS (p, DECLARER)) {
      (*decl) = SUB (p);
      FORWARD (p);
    }
    if (IS (p, FIELD_IDENTIFIER)) {
      MOID_T *fmoid = MOID (*decl);
      if (HAS_ROWS (fmoid) && ISNT (fmoid, UNION_SYMBOL)) {
        ADDR_T pop_sp = *cur_sp;
        genie_generator_stowed (*decl, *faddr, NO_REF, cur_sp);
        *top_sp = *cur_sp;
        *cur_sp = pop_sp;
      }
      (*faddr) += SIZE (fmoid);
    }
  }
}

//! @brief Allocate a structure.

void genie_generator_struct (NODE_T * p, BYTE_T ** faddr, ADDR_T * cur_sp)
{
  for (; p != NO_NODE; FORWARD (p)) {
    if (IS (p, STRUCTURED_FIELD_LIST)) {
      genie_generator_struct (SUB (p), faddr, cur_sp);
    } else if (IS (p, STRUCTURED_FIELD)) {
      NODE_T *decl = NO_NODE;
      ADDR_T top_sp = *cur_sp;
      genie_generator_field (SUB (p), faddr, &decl, cur_sp, &top_sp);
      *cur_sp = top_sp;
    }
  }
}

//! @brief Allocate a stowed object.

void genie_generator_stowed (NODE_T * p, BYTE_T * addr, NODE_T ** decl, ADDR_T * cur_sp)
{
  if (p == NO_NODE) {
    return;
  } else if (IS (p, INDICANT) && IS_LITERALLY (p, "STRING")) {
    // The standard prelude definition is hard coded here.
    *((A68G_REF *) addr) = empty_string (p);
    return;
  } else if (IS (p, INDICANT) && TAX (p) != NO_TAG) {
    // Continue from definition at MODE A = ... in the tree.
    genie_generator_stowed (DEF_NODE (p), addr, decl, cur_sp);
    return;
  } else if (IS (p, DECLARER) && mode_needs_allocation (MOID (p))) {
    genie_generator_stowed (SUB (p), addr, decl, cur_sp);
    return;
  } else if (IS_STRUCT (p)) {
    BYTE_T *faddr = addr;
    genie_generator_struct (SUB_NEXT (p), &faddr, cur_sp);
    return;
  } else if (IS_FLEX (p)) {
    genie_generator_stowed (NEXT (p), addr, decl, cur_sp);
    return;
  } else if (IS (p, BOUNDS)) {
    A68G_REF desc;
    MOID_T *rmod = MOID (p), *smod = MOID (NEXT (p));
    BYTE_T *bounds = STACK_ADDRESS (*cur_sp);
    int dim = DIM (DEFLEX (rmod)), esiz = SIZE (smod), rsiz = 1;
    BOOL_T alloc_sub = A68G_FALSE, alloc_str = A68G_FALSE;
    NODE_T *in = SUB_NEXT (p);
    if (IS (in, INDICANT) && IS_LITERALLY (in, "STRING")) {
      alloc_str = A68G_TRUE;
      alloc_sub = A68G_FALSE;
    } else {
      alloc_sub = mode_needs_allocation (smod);
      alloc_str = A68G_FALSE;
    }
    desc = heap_generator (p, rmod, DESCRIPTOR_SIZE (dim));
    A68G_ARRAY *arr; A68G_TUPLE *tup;
    GET_DESCRIPTOR (arr, tup, &desc);
    for (int k = 0; k < dim; k++) {
      CHECK_INIT (p, INITIALISED ((A68G_INT *) bounds), M_INT);
      LWB (&tup[k]) = VALUE ((A68G_INT *) bounds);
      bounds += SIZE (M_INT);
      CHECK_INIT (p, INITIALISED ((A68G_INT *) bounds), M_INT);
      UPB (&tup[k]) = VALUE ((A68G_INT *) bounds);
      bounds += SIZE (M_INT);
      SPAN (&tup[k]) = rsiz;
      SHIFT (&tup[k]) = LWB (&tup[k]) * SPAN (&tup[k]);
      rsiz *= ROW_SIZE (&tup[k]);
    }
    DIM (arr) = dim;
    SLICE (arr) = smod;
    SLICE_SIZE (arr) = esiz;
    SLICE_OFFSET (arr) = 0;
    FIELD_OFFSET (arr) = 0;
    (*cur_sp) += (dim * 2 * SIZE (M_INT));
    // Generate a new row. STRING is handled explicitly. 
    if (rsiz == 0) {
      // Generate a ghost element.
      ADDR_T top_sp = *cur_sp;
      ARRAY (arr) = heap_generator (p, rmod, esiz);
      BYTE_T *elem = ADDRESS (&(ARRAY (arr)));
      if (alloc_sub) {
        genie_generator_stowed (NEXT (p), &(elem[0]), NO_REF, cur_sp);
        top_sp = *cur_sp;
      } else if (alloc_str) {
        *(A68G_REF *) elem = empty_string (p);
      }
      (*cur_sp) = top_sp;
    } else {
      ADDR_T pop_sp = *cur_sp, top_sp = *cur_sp;
      ARRAY (arr) = heap_generator_2 (p, rmod, rsiz, esiz);
      BYTE_T *elem = ADDRESS (&(ARRAY (arr)));
      for (int k = 0; k < rsiz; k++) {
        if (alloc_sub) {
          (*cur_sp) = pop_sp;
          genie_generator_stowed (NEXT (p), &(elem[k * esiz]), NO_REF, cur_sp);
          top_sp = *cur_sp;
        } else if (alloc_str) {
          *(A68G_REF *) (&(elem[k * esiz])) = empty_string (p);
        }
      }
      (*cur_sp) = top_sp;
    }
    *(A68G_REF *) addr = desc;
    return;
  }
}

//! @brief Generate space and push a REF.

void genie_generator_internal (NODE_T * p, MOID_T * ref_mode, TAG_T * tag, LEAP_T leap, ADDR_T sp)
{
  // Set up a REF MODE object, either in the stack or in the heap.
  MOID_T *mode = SUB (ref_mode);
  A68G_REF name = nil_ref;
  if (leap == LOC_SYMBOL) {
    STATUS (&name) = (STATUS_MASK_T) (INIT_MASK | IN_FRAME_MASK);
    REF_HANDLE (&name) = (A68G_HANDLE *) & nil_handle;
    OFFSET (&name) = A68G_FP + FRAME_INFO_SIZE + OFFSET (tag);
    REF_SCOPE (&name) = A68G_FP;
  } else if (leap == -LOC_SYMBOL && NON_LOCAL (p) != NO_TABLE) {
    name = heap_generator (p, mode, SIZE (mode));
    ADDR_T lev;
    FOLLOW_SL (lev, LEVEL (NON_LOCAL (p)));
    REF_SCOPE (&name) = lev;
  } else if (leap == -LOC_SYMBOL) {
    name = heap_generator (p, mode, SIZE (mode));
    REF_SCOPE (&name) = A68G_FP;
  } else if (leap == HEAP_SYMBOL || leap == -HEAP_SYMBOL) {
    name = heap_generator (p, mode, SIZE (mode));
    REF_SCOPE (&name) = PRIMAL_SCOPE;
  } else if (leap == NEW_SYMBOL || leap == -NEW_SYMBOL) {
    name = heap_generator (p, mode, SIZE (mode));
    REF_SCOPE (&name) = PRIMAL_SCOPE;
  } else {
    ABEND (A68G_TRUE, ERROR_INTERNAL_CONSISTENCY, NO_TEXT);
  }
  if (HAS_ROWS (mode)) {
    ADDR_T cur_sp = sp;
    genie_generator_stowed (p, ADDRESS (&name), NO_REF, &cur_sp);
  }
  PUSH_REF (p, name);
}

//! @brief Push a name refering to allocated space.

PROP_T genie_generator (NODE_T * p)
{
  ADDR_T pop_sp = A68G_SP;
  if (NEXT_SUB (p) != NO_NODE) {
    genie_generator_bounds (NEXT_SUB (p));
  }
  genie_generator_internal (NEXT_SUB (p), MOID (p), TAX (p), -ATTRIBUTE (SUB (p)), pop_sp);
  A68G_REF z;
  POP_REF (p, &z);
  A68G_SP = pop_sp;
  PUSH_REF (p, z);
  PROP_T self;
  UNIT (&self) = genie_generator;
  SOURCE (&self) = p;
  return self;
}

// Control of C heap

//! @brief Discard_heap.

void discard_heap (void)
{
  a68g_free (A68G_HEAP);
  A68G (fixed_heap_pointer) = 0;
  A68G (temp_heap_pointer) = 0;
}
