text: /* File: "mem.c" */
  
  /* Copyright (c) 1994-2018 by Marc Feeley, All Rights Reserved.  */
  
  #define ___INCLUDED_FROM_MEM
  #define ___VERSION 408009
  #include "gambit.h"
  
  #include "os_setup.h"
  #include "os_base.h"
  #include "os_time.h"
  #include "setup.h"
  #include "mem.h"
  #include "c_intf.h"
  #include "actlog.h"
  
  /* The following includes are needed for debugging. */
  
  #include <stdlib.h>
  #include <string.h>
  
  LC_CTX lc_global_ctx = {0,NULL,NULL,0,0,NULL,NULL,NULL,0};
  
  #define LC_CALLBACK_NONE 0
  #define LC_CALLBACK_FN   1
  #define LC_CALLBACK_CONT 2
  #define LC_CALLBACK_STUB 3
  #define LC_GENERIC_REST  4
  #define LC_GAMBIT_CALL   5
  
  //#define LC_DEBUG
  
  /*---------------------------------------------------------------------------*/
  
  #ifdef ___DEBUG_GARBAGE_COLLECT
  
  /*
   * Defining the symbol ENABLE_CONSISTENCY_CHECKS will enable the GC to
   * perform checks that detect when the heap is in an inconsistent
   * state.  This is useful to detect bugs in the GC and the rest of the
   * system.  To perform the consistency checks, the verbosity level in
   * ___GSTATE->setup_params.debug_settings must be at least 1.  The checks are
   * very extensive and consequently are expensive.  They should only be
   * used for debugging.
   */
  
  #define ENABLE_CONSISTENCY_CHECKS
  
  
  /*
   * Defining the symbol SHOW_FRAMES will cause the GC to print out a
   * trace of the continuation frames that are processed.
   */
  
  #undef SHOW_FRAMES
  
  
  #define ENABLE_GC_TRACE_PHASES
  #define ENABLE_GC_ACTLOG_PHASES
  #define ENABLE_GC_ACTLOG_SCAN_COMPLETE_HEAP_CHUNK
  
  #endif
  
  
  /*---------------------------------------------------------------------------*/
  
  /*
   * Object representation.
   *
   * Memory allocated Scheme objects can be allocated using one of three
   * allocation strategies:
   *
   *    Permanently allocated:
   *      These objects, called 'permanent objects' for short, are never
   *      moved or reclaimed, and all pointers to memory allocated
   *      objects they contain must point to permanent objects.  As a
   *      consequence, the GC does not have to scan permanent objects.
   *      Permanent objects can be allocated on the C heap, but they are
   *      typically allocated in C global variables and structures that
   *      are set up when the program starts up or when a module is
   *      dynamically loaded.
   *
   *    Still dynamically allocated:
   *      These objects, called 'still objects' for short, are allocated
   *      on the C heap.  Still objects are never moved but they can be
   *      reclaimed by the GC.  A mark-and-sweep GC is used to
   *      garbage-collect still objects.
   *
   *    Movable dynamically allocated:
   *      These objects, called 'movable objects' for short, are allocated
   *      in an area of memory that is managed by a compacting GC.  The GC
   *      can move and reclaim movable objects.
   *
   * Scheme objects are encoded using integers of type ___WORD.  A
   * ___WORD either encodes an immediate value or encodes a pointer
   * when the object is memory allocated.  The two lower bits of a
   * ___WORD contain a primary type tag for the object and the other
   * bits contain the immediate value or the pointer.  Because all
   * memory allocated objects are aligned on ___WORD boundaries (and a
   * ___WORD is either 4 or 8 bytes), the two lower bits of pointers
   * are zero and can be used to store the tag without reducing the
   * address space.  The four tags are:
   *
   *  immediate:
   *    ___tFIXNUM    object is a small integer (fixnum)
   *    ___tSPECIAL   object is a boolean, character, or other immediate
   *
   *  memory allocated:
   *    if ___USE_SAME_TAG_FOR_PAIRS_AND_SUBTYPED is defined
   *    ___tMEM1 = ___tSUBTYPED = ___tPAIR   subtyped object, possibly a pair
   *    ___tMEM2                             contained object, or a pair
   *    otherwise
   *    ___tMEM1 = ___tSUBTYPED              subtyped object, but not a pair
   *    ___tMEM2 = ___tPAIR                  a pair
   *
   * A special type of object exists to support object finalization:
   * 'will' objects.  Wills contain a weak reference to an object, the
   * testator and a strong reference to a procedure, the action
   * procedure.  A will becomes executable when its testator object is
   * not strongly reachable (i.e. the testator object is either
   * unreachable or only reachable using paths from the roots that
   * traverse at least one weak reference).  When the GC detects that a
   * will has become executable it is placed on a list of executable
   * wills.  Following the GC, this list is traversed to invoke the
   * action procedures.
   *
   * All memory allocated objects, including pairs, are composed of at
   * least a head and a body.  The head is a single ___WORD that
   * contains 3 "head" tag bits (the 3 lower bits), a subtype tag (the
   * next 5 bits), and the length of the object in bytes (the remaining
   * bits).  The head immediately precedes the body of the object, which
   * contains the rest of the information associated with the object.
   * Depending on the subtype, the body can contain raw binary data
   * (such as when the object is a string) and Scheme objects (such as
   * when the object is a vector).  Memory allocated objects have the
   * following layout:
   *
   *      _head_   _____body______
   *     /      \ /               \
   *    +--------+--------+--------+
   *    |llllssst|        |        |
   *    +--------+--------+--------+
   *      ^   ^ ^
   *      |   | |
   * length   | |
   *    subtype head tag
   *
   * Of the 8 possible head tags, only 5 are currently used:
   *
   *    ___PERM     (P) the object is a permanent object
   *    ___STILL    (S) the object is a still object
   *    ___MOVABLE0 (M) the object is a movable object in generation 0
   *    ___FORW     (F) the object has been moved by the GC (counts as 2 tags)
   *
   * Permanent objects have the following layout:
   *
   *      _head_   _____body______
   *     /      \ /               \
   *    +--------+--------+--------+
   *    |       P|        |        |
   *    +--------+--------+--------+
   *
   * Still objects have the following layout:
   *
   *      _link_   _ref__   length   _mark_   _head_   _____body______
   *     /      \ / count\ /      \ /      \ /      \ /               \
   *    +--------+--------+--------+--------+--------+--------+--------+
   *    |        |        |        |        |       S|        |        |
   *    +--------+--------+--------+--------+--------+--------+--------+
   *
   * All still objects are linked in a list using the 'link' field.  The
   * 'refcount' field contains a reference count, which counts the
   * number of pointers to this object that are hidden from the GC
   * (typically these hidden pointers are in C data structures).  When
   * 'refcount' is zero, the object will survive a GC only if it is
   * pointed to by a GC root or a live Scheme object.  The 'length'
   * field contains the length of the object and is only used to
   * maintain statistics on the space allocated.  The 'mark' field is
   * used by the GC to indicate that the object has been marked (at the
   * start of a GC it is set to -1).  The 'mark' field links all objects
   * that have been marked but have not yet been scanned.  It contains a
   * pointer to the next still object that needs to be scanned.
   *
   * Movable objects have the following layout:
   *
   *      _head_   _____body______
   *     /      \ /               \
   *    +--------+--------+--------+
   *    |       M|        |        |
   *    +--------+--------+--------+
   *
   * When a movable object is moved by the GC, the head is replaced
   * with a pointer to the copy, tagged with ___FORW.
   *
   * Layout of body.
   *
   *      _head_   __________body__________
   *     /      \ /                        \
   *    +--------+--------+--------+--------+
   *    |        | field_0| field_1|  etc.  |
   *    +--------+--------+--------+--------+
   *
   * Some types of objects have bodies that only contain pointers to
   * other Scheme objects.  For example, pairs have two fields (car and
   * cdr) and vectors have one field per element.  Other object types
   * have bodies that only contain raw binary data (such as strings and
   * bignums).  The remaining object types have bodies that contain both
   * pointers to Scheme objects and raw binary data.  Their layout is
   * summarized below.
   *
   * Symbols:
   *     subtype = ___sSYMBOL
   *     field_0 = name (a string or a fixnum <n> for a symbol named "g<n>")
   *     field_1 = hash code (non-negative fixnum)
   *     field_2 = link to next symbol in symbol table (#f for uninterned)
   *     field_3 = C pointer to global variable (0 if none exists)
   *
   *     Note: interned symbols must be permanently allocated;
   *           uninterned symbols can be permanent, still or movable
   *
   * Keywords:
   *     subtype = ___sKEYWORD
   *     field_0 = name (a string or a fixnum <n> for a keyword named "g<n>")
   *     field_1 = hash code (non-negative fixnum)
   *     field_2 = link to next symbol in keyword table (#f for uninterned)
   *
   * Procedures:
   *
   *   nonclosures (toplevel procedures)
   *     subtype = ___sPROCEDURE (length contains parameter descriptor)
   *     field_0 = C pointer to field_0 - ___BODY_OFS
   *     field_1 = C pointer to label (only when using gcc)
   *     field_2 = C pointer to host C procedure
   *
   *   closures:
   *     subtype = ___sPROCEDURE
   *     field_0 = C pointer to field_0 of entry procedure - ___BODY_OFS
   *     field_1 = free variable 1
   *     field_2 = free variable 2
   *     ...
   *
   *     Note: the entry procedure must be a nonclosure procedure
   *
   * Return points:
   *     subtype = ___sPROCEDURE
   *     field_0 = return frame descriptor
   *     field_1 = C pointer to label (only when using gcc)
   *     field_2 = C pointer to host C procedure
   *
   * Wills:
   *     subtype = ___sWEAK
   *     field_0 = next will in list with special tag in lower bits
   *     field_1 = testator object
   *     field_2 = action procedure
   *
   *     Note: wills must be movable
   *
   * GC hash tables:
   *     subtype = ___sWEAK
   *     field_0 = next GC hash table in list with special tag in lower bits
   *     field_1 = flags
   *     field_2 = count*2 (twice number of active key-value entries)
   *     field_3 = used*2 (twice number of total entries including deleted)
   *     field_4 = key of entry #0
   *     field_5 = value of entry #0
   *     ...
   *
   * Continuations:
   *     subtype = ___sCONTINUATION
   *     field_0 = first frame (C pointer to stack at first and then Scheme obj)
   *     field_1 = dynamic environment (#f when continuation is delimited)
   *
   * Frame:
   *     subtype = ___sFRAME
   *     field_0 = return address
   *     field_1 = frame slot 1
   *     field_2 = frame slot 2
   *     ...
   */
  
  
  /*---------------------------------------------------------------------------*/
  
  #define ___PSTATE_MEM(var) ___ps->mem.var
  #define ___VMSTATE_MEM(var) ___VMSTATE_FROM_PSTATE(___ps)->mem.var
  
  #define tospace_offset          ___PSTATE_MEM(tospace_offset_)
  #define msection_free_list      ___PSTATE_MEM(msection_free_list_)
  #define stack_msection          ___PSTATE_MEM(stack_msection_)
  #define alloc_stack_start       ___PSTATE_MEM(alloc_stack_start_)
  #define alloc_stack_ptr         ___PSTATE_MEM(alloc_stack_ptr_)
  #define alloc_stack_limit       ___PSTATE_MEM(alloc_stack_limit_)
  #define heap_msection           ___PSTATE_MEM(heap_msection_)
  #define alloc_heap_start        ___PSTATE_MEM(alloc_heap_start_)
  #define alloc_heap_ptr          ___PSTATE_MEM(alloc_heap_ptr_)
  #define alloc_heap_limit        ___PSTATE_MEM(alloc_heap_limit_)
  #define alloc_heap_chunk_start  ___PSTATE_MEM(alloc_heap_chunk_start_)
  #define alloc_heap_chunk_limit  ___PSTATE_MEM(alloc_heap_chunk_limit_)
  
  #ifndef ___SINGLE_THREADED_VMS
  #define heap_chunks_to_scan_lock ___PSTATE_MEM(heap_chunks_to_scan_lock_)
  #endif
  
  #define heap_chunks_to_scan     ___PSTATE_MEM(heap_chunks_to_scan_)
  #define heap_chunks_to_scan_head ___PSTATE_MEM(heap_chunks_to_scan_head_)
  #define heap_chunks_to_scan_tail ___PSTATE_MEM(heap_chunks_to_scan_tail_)
  #define scan_ptr                ___PSTATE_MEM(scan_ptr_)
  #define still_objs_to_scan      ___PSTATE_MEM(still_objs_to_scan_)
  #define still_objs              ___PSTATE_MEM(still_objs_)
  #define words_still_objs        ___PSTATE_MEM(words_still_objs_)
  #define words_still_objs_deferred ___PSTATE_MEM(words_still_objs_deferred_)
  #define bytes_allocated_minus_occupied ___PSTATE_MEM(bytes_allocated_minus_occupied_)
  #define rc_head                 ___PSTATE_MEM(rc_head_)
  #define traverse_weak_refs      ___PSTATE_MEM(traverse_weak_refs_)
  #define nonexecutable_wills     ___PSTATE_MEM(nonexecutable_wills_)
  #define executable_wills        ___PSTATE_MEM(executable_wills_)
  #define reached_gc_hash_tables  ___PSTATE_MEM(reached_gc_hash_tables_)
  #define words_prev_msections    ___PSTATE_MEM(words_prev_msections_)
  #define stack_fudge_used        ___PSTATE_MEM(stack_fudge_used_)
  #define heap_fudge_used         ___PSTATE_MEM(heap_fudge_used_)
  
  #ifdef ___DEBUG_GARBAGE_COLLECT
  #define reference_location      ___PSTATE_MEM(reference_location_)
  #define container_body          ___PSTATE_MEM(container_body_)
  #define mark_array_call_line    ___PSTATE_MEM(mark_array_call_line_)
  #endif
  
  #define heap_size               ___VMSTATE_MEM(heap_size_)
  #define normal_overflow_reserve ___VMSTATE_MEM(normal_overflow_reserve_)
  #define overflow_reserve        ___VMSTATE_MEM(overflow_reserve_)
  #define occupied_words_movable  ___VMSTATE_MEM(occupied_words_movable_)
  #define occupied_words_still    ___VMSTATE_MEM(occupied_words_still_)
  #define the_msections           ___VMSTATE_MEM(the_msections_)
  #define alloc_msection          ___VMSTATE_MEM(alloc_msection_)
  #define nb_msections_assigned   ___VMSTATE_MEM(nb_msections_assigned_)
  #define target_processor_count  ___VMSTATE_MEM(target_processor_count_)
  
  #ifndef ___SINGLE_THREADED_VMS
  #define misc_mem_lock           ___VMSTATE_MEM(misc_mem_lock_)
  #define alloc_mem_lock          ___VMSTATE_MEM(alloc_mem_lock_)
  #define scan_termination_mutex  ___VMSTATE_MEM(scan_termination_mutex_)
  #define scan_termination_condvar ___VMSTATE_MEM(scan_termination_condvar_)
  #define scan_workers_count      ___VMSTATE_MEM(scan_workers_count_)
  #endif
  
  #define nb_gcs                  ___VMSTATE_MEM(nb_gcs_)
  #define gc_user_time            ___VMSTATE_MEM(gc_user_time_)
  #define gc_sys_time             ___VMSTATE_MEM(gc_sys_time_)
  #define gc_real_time            ___VMSTATE_MEM(gc_real_time_)
  
  #define latest_gc_user_time     ___VMSTATE_MEM(latest_gc_user_time_)
  #define latest_gc_sys_time      ___VMSTATE_MEM(latest_gc_sys_time_)
  #define latest_gc_real_time     ___VMSTATE_MEM(latest_gc_real_time_)
  #define latest_gc_heap_size     ___VMSTATE_MEM(latest_gc_heap_size_)
  #define latest_gc_alloc         ___VMSTATE_MEM(latest_gc_alloc_)
  #define latest_gc_live          ___VMSTATE_MEM(latest_gc_live_)
  #define latest_gc_movable       ___VMSTATE_MEM(latest_gc_movable_)
  #define latest_gc_still         ___VMSTATE_MEM(latest_gc_still_)
  
  /* words occupied by this processor by movable objects */
  
  #define words_movable_objs(ps) \
  (2*(ps->mem.words_prev_msections_ \
      + (ps->mem.alloc_heap_ptr_ - ps->mem.alloc_heap_start_) \
      + (ps->mem.alloc_stack_start_ - ps->mem.alloc_stack_ptr_)))
  
  /* bytes occupied by this processor */
  
  #define bytes_occupied(ps) \
  (___CAST(___F64,ps->mem.words_still_objs_ \
                  + ps->mem.words_still_objs_deferred_ \
                  + words_movable_objs(___ps)) * ___WS)
  
  /*---------------------------------------------------------------------------*/
  
  #ifdef ___SINGLE_THREADED_VMS
  
  #define ALLOC_MEM_LOCK()
  #define ALLOC_MEM_UNLOCK()
  #define MISC_MEM_LOCK()
  #define MISC_MEM_UNLOCK()
  
  #else
  
  #define ALLOC_MEM_LOCK() ___SPINLOCK_LOCK(alloc_mem_lock)
  #define ALLOC_MEM_UNLOCK() ___SPINLOCK_UNLOCK(alloc_mem_lock)
  #define MISC_MEM_LOCK() ___SPINLOCK_LOCK(misc_mem_lock)
  #define MISC_MEM_UNLOCK() ___SPINLOCK_UNLOCK(misc_mem_lock)
  
  #endif
  
  
  /*---------------------------------------------------------------------------*/
  
  /*
   * Memory for movable objects (including continuation frames) are
   * allocated in fixed size msections.  Each processor starts off with
   * an msection for its stack (for allocating continuation frames) and
   * an msection for allocating small objects.  Stack allocations are
   * done by decrementing the stack pointer and small objects are
   * allocated by incrementing the heap pointer.  Each msection is
   * divided in two zones of equal size, used as a fromspace and tospace
   * by the garbage collector.  When a processor fills a fromspace, a
   * new msection is obtained from a list of free msections to continue
   * allocating.  The diagram below shows a possible layout of msections
   * for a situation with 3 processors and 12 msections:
   *
   *      sp                                                       hp
   *       v                                                       v
   *   +---+---+-------+  +-----+-+-------+  +----+--+-------+  +--+----+-------+
   * 0 |   |###|       |  |#####| |       |  |####|  |       |  |##|    |       |
   *   +---+---+-------+  +-----+-+-------+  +----+--+-------+  +--+----+-------+
   *
   *    sp                   hp
   *     v                   v
   *   +-+-----+-------+  +--+----+-------+
   * 1 | |#####|       |  |##|    |       |
   *   +-+-----+-------+  +--+----+-------+
   *
   *       sp                                      hp
   *        v                                      v
   *   +----+--+-------+  +----+--+-------+  +-----+-+-------+
   * 2 |    |##|       |  |####|  |       |  |#####| |       |
   *   +----+--+-------+  +----+--+-------+  +-----+-+-------+
   *
   *
   * free list of msections (msections yet to be assigned to processors):
   *   +-------+-------+  +-------+-------+  +-------+-------+
   *   |       |       |  |       |       |  |       |       |
   *   +-------+-------+  +-------+-------+  +-------+-------+
   *
   *
   * In this example, 4 msections are assigned to processor 0.  The first one
   * is being used as a stack to allocate continuation frames.  The other
   * msections of that processor are being used for allocating small objects
   * (two msections are full and the last is not yet full).  There are
   * three msections in the free list of msections.
   *
   * The heap size is defined as the space occupied by still objects and
   * msections at the end of the latest garbage collection.  To determine
   * when to trigger a garbage collection, the memory manager needs to know
   * approximately (but conservatively) how much of the heap is free.  The
   * free heap space is defined as the heap size minus the space of the
   * msections assigned to processors minus the space occupied by still
   * objects minus the overflow reserve.  When an allocation request would
   * cause the free heap space to become negative, a garbage collection is
   * performed first to free space and possibly resize the heap.
   *
   * A given msection can be used for allocating small objects or for
   * allocating continuation frames or for both.  The position of the
   * various pointers is as follows (only the fromspace is shown).
   *
   * Msection only used for allocating movable objects:
   *
   *   <-------------------------- ___MSECTION_SIZE/2 ------------------------->
   *  +----+----+---------------------------------------------------------------+
   *  |obj1|obj2|                                         |<-___MSECTION_FUDGE->|
   *  +----+----+---------------------------------------------------------------+
   *  ^         ^                                         ^                     ^
   *  |         |                                         |                     |
   *  |         alloc_heap_ptr            ___ps->heap_limit      alloc_heap_limit
   *  alloc_heap_start
   *
   * Msection only used for allocating continuation frames:
   *
   *   <-------------------------- ___MSECTION_SIZE/2 ------------------------->
   *  +-----------------------------------------------------------+------+------+
   *  |<-___MSECTION_FUDGE->|                                     |frame2|frame1|
   *  +-----------------------------------------------------------+------+------+
   *  ^                     ^                                     ^             ^
   *  |                     |                                     |             |
   *  alloc_stack_limit     ___ps->stack_limit      alloc_stack_ptr             |
   *                                                            alloc_stack_start
   *
   * Msection used for allocating movable objects and allocating
   * continuation frames:
   *
   *   <-------------------------- ___MSECTION_SIZE/2 ------------------------->
   *  +----+-------------------------------------------------------------+------+
   *  |objs|        |<-___MSECTION_FUDGE->|<-___MSECTION_FUDGE->|        |frames|
   *  +----+-------------------------------------------------------------+------+
   *  ^    ^        ^                     ^                     ^        ^      ^
   *  |    |        |                     |                     |        |      |
   *  |    |        |     alloc_heap_limit alloc_stack_limit    |        |      |
   *  |    |        ___ps->heap_limit          ___ps->stack_limit        |      |
   *  |    alloc_heap_ptr                                  alloc_stack_ptr      |
   *  alloc_heap_start                                          alloc_stack_start
   */
  
  #define compute_heap_space() \
  (___CAST(___SIZE_TS,the_msections->nb_sections) * ___MSECTION_SIZE + occupied_words_still)
  
  #define compute_assigned_heap_space() \
  (___CAST(___SIZE_TS,nb_msections_assigned) * ___MSECTION_SIZE + occupied_words_still)
  
  #define compute_free_heap_space() \
  (heap_size - compute_assigned_heap_space() - overflow_reserve)
  
  /*---------------------------------------------------------------------------*/
  
  /* Constants related to representation of permanent and still objects: */
  
  #ifdef ___USE_HANDLES
  #define ___PERM_HAND_OFS 0
  #define ___PERM_BODY_OFS 2
  #else
  #define ___PERM_HAND_OFS ___PERM_BODY_OFS
  #define ___PERM_BODY_OFS 1
  #endif
  
  #define ___STILL_LINK_OFS 0
  #define ___STILL_REFCOUNT_OFS 1
  #define ___STILL_LENGTH_OFS 2
  #define ___STILL_MARK_OFS 3
  #ifdef ___USE_HANDLES
  #define ___STILL_HAND_OFS 4
  #define ___STILL_BODY_OFS 6
  #else
  #define ___STILL_HAND_OFS ___STILL_BODY_OFS
  #define ___STILL_BODY_OFS (5+1)/************/
  #endif
  
  
  /*---------------------------------------------------------------------------*/
  
  /* Allocation and reclamation of aligned blocks of memory.  */
  
  
  /*
   * 'alloc_mem_aligned (words, multiplier, modulus)' allocates an
   * aligned block of memory through the '___alloc_mem' function.
   * 'words' is the size of the block in words and 'multiplier' and
   * 'modulus' specify its alignment in words.  'multiplier' must be a
   * power of two and 0<=modulus<multiplier.  The pointer returned
   * corresponds to an address that is equal to
   * (i*multiplier+modulus)*sizeof (___WORD) for some 'i'.
   */
  
  ___HIDDEN void *alloc_mem_aligned
     ___P((___SIZE_TS words,
           unsigned int multiplier,
           unsigned int modulus),
          (words,
           multiplier,
           modulus)
  ___SIZE_TS words;
  unsigned int multiplier;
  unsigned int modulus;)
  {
    void *container; /* pointer to block returned by ___alloc_mem */
    unsigned int extra; /* space for alignment to multiplier */
  
    /* Make sure alignment is sufficient for pointers */
  
    if (multiplier < sizeof (void*) / ___WS)
      multiplier = sizeof (void*) / ___WS;
  
    /* How many extra bytes are needed for padding */
  
    extra = (multiplier * ___WS) - 1;
    if (modulus < sizeof (void*) / ___WS)
      extra += sizeof (void*);
  
    container = ___ALLOC_MEM(extra + (words+modulus) * ___WS);
  
    if (container == 0)
      return 0;
    else
      {
        void *ptr = ___CAST(void*,
                            (((___CAST(___WORD,container) + extra) &
                              -___CAST(___WORD,multiplier * ___WS)) +
                             modulus * ___WS));
        void **cptr = ___CAST(void**,
                              (___CAST(___WORD,ptr) - ___CAST(___WORD,sizeof (void*))) &
                              -___CAST(___WORD,sizeof (void*)));
  
        *cptr = container;
        return ptr;
      }
  }
  
  
  /*
   * 'free_mem_aligned (ptr)' reclaims the aligned block of memory 'ptr'
   * that was allocated using 'alloc_mem_aligned'.
   */
  
  ___HIDDEN void free_mem_aligned
     ___P((void *ptr),
          (ptr)
  void *ptr;)
  {
    void **cptr = ___CAST(void**,
                          (___CAST(___WORD,ptr) - ___CAST(___WORD,sizeof (void*))) &
                          -___CAST(___WORD,sizeof (void*)));
    ___FREE_MEM(*cptr);
  }
  
  
  /*---------------------------------------------------------------------------*/
  
  /* Allocation of reference counted blocks of memory. */
  
  ___HIDDEN void setup_rc
     ___P((___processor_state ___ps),
          (___ps)
  ___processor_state ___ps;)
  {
    rc_head.prev = &rc_head;
    rc_head.next = &rc_head;
    rc_head.refcount = 1;
    rc_head.data = ___FAL;
  }
  
  ___HIDDEN void cleanup_rc
     ___P((___processor_state ___ps),
          (___ps)
  ___processor_state ___ps;)
  {
    ___rc_header *h = rc_head.next;
  
    rc_head.prev = &rc_head;
    rc_head.next = &rc_head;
  
    while (h != &rc_head)
      {
        ___rc_header *next = h->next;
        ___FREE_MEM(h);
        h = next;
      }
  }
  
  
  ___EXP_FUNC(void*,___alloc_rc)
     ___P((___PSD
           ___SIZE_T bytes),
          (___PSV
           bytes)
  ___PSDKR
  ___SIZE_T bytes;)
  {
    ___PSGET
    ___rc_header *h = ___CAST(___rc_header*,
                              ___ALLOC_MEM(bytes + sizeof (___rc_header)));
  
    if (h != 0)
      {
        ___rc_header *head = &rc_head;
        ___rc_header *tail = head->prev;
  
        h->prev = tail;
        h->next = head;
        head->prev = h;
        tail->next = h;
  
        h->refcount = 1;
        h->data = ___FAL;
  
        return ___CAST(void*,h+1);
      }
  
    return 0;
  }
  
  
  ___EXP_FUNC(void,___release_rc)
     ___P((void *ptr),
          (ptr)
  void *ptr;)
  {
    if (ptr != 0)
      {
        ___rc_header *h = ___CAST(___rc_header*,ptr) - 1;
  
        if (--h->refcount == 0)
          {
            ___rc_header *prev = h->prev;
            ___rc_header *next = h->next;
  
            next->prev = prev;
            prev->next = next;
  
            ___FREE_MEM(h);
          }
      }
  }
  
  
  ___EXP_FUNC(void,___addref_rc)
     ___P((void *ptr),
          (ptr)
  void *ptr;)
  {
    if (ptr != 0)
      {
        ___rc_header *h = ___CAST(___rc_header*,ptr) - 1;
        h->refcount++;
      }
  }
  
  
  ___EXP_FUNC(___SCMOBJ,___data_rc)
     ___P((void *ptr),
          (ptr)
  void *ptr;)
  {
    ___rc_header *h = ___CAST(___rc_header*,ptr) - 1;
    return h->data;
  }
  
  
  ___EXP_FUNC(void,___set_data_rc)
     ___P((void *ptr,
           ___SCMOBJ val),
          (ptr,
           val)
  void *ptr;
  ___SCMOBJ val;)
  {
    ___rc_header *h = ___CAST(___rc_header*,ptr) - 1;
    h->data = val;
  }
  
  
  /*---------------------------------------------------------------------------*/
  
  /* Allocation of movable objects.  */
  
  /*
   * 'find_msection (ms, ptr)' finds the position in the 'ms->sections'
   * array of the msection that contains the pointer 'ptr'.  More
   * precisely, if ___ALLOC_MEM_UP is defined, it returns the integer
   * 'i' (-1<=i<=n-1) such that 'ptr' is between the start of section i
   * and section i+1.  -1 is returned if 'ptr' is lower than the lowest
   * section and 'n' is returned if 'ptr' is not lower than the highest
   * section.  If ___ALLOC_MEM_UP is not defined, it returns the integer
   * 'i' (0<=i<=n) such that 'ptr' is between the start of section i and
   * section i-1.  n is returned if 'ptr' is lower than the lowest
   * section and 0 is returned if 'ptr' is not lower than the highest
   * section.
   */
  
  ___HIDDEN int find_msection
     ___P((___msections *ms,
           void *ptr),
          (ms,
           ptr)
  ___msections *ms;
  void *ptr;)
  {
    int ns = ms->nb_sections;
    ___msection **sections = ms->sections;
    int lo, hi;
  
  #ifdef ___ALLOC_MEM_UP
    if (ns == 0 ||
        ptr < ___CAST(void*,sections[0]))
      return -1;
  #else
    if (ns == 0 ||
        ptr < ___CAST(void*,sections[ns-1]))
      return ns;
  #endif
  
    /* binary search */
  
    lo = 0;
    hi = ns-1;
  
    /* loop invariant: lo <= find_msection (ms, ptr) <= hi */
  
    while (lo < hi)
      {
        int mid = (lo+hi) / 2; /* lo <= mid < hi */
  #ifdef ___ALLOC_MEM_UP
        if (ptr < ___CAST(void*,sections[mid+1])) hi = mid; else lo = mid+1;
  #else
        if (ptr < ___CAST(void*,sections[mid])) lo = mid+1; else hi = mid;
  #endif
      }
  
    return lo;
  }
  
  
  /*
   * 'adjust_msections (msp, n)' contracts or expands the msections
   * pointed to by 'msp' so that it contains 'n' sections.  When the
   * msections is contracted, the last sections allocated (i.e. those at
   * the end of the doubly-linked list of sections) will be reclaimed.
   * When expanding the msections there may not be enough memory to
   * allocate new sections so the operation may fail.  However
   * 'adjust_msections' will always leave the msections in a consistent
   * state and there will be at least as many sections as when the
   * expansion was started.  Failure can be detected by checking the
   * 'nb_sections' field.
   */
  
  ___HIDDEN void adjust_msections
     ___P((___msections **msp,
           int n),
          (msp,
           n)
  ___msections **msp;
  int n;)
  {
    int max_ns, ns;
    ___msections *ms = *msp;
    ___msection *hd;
    ___msection *tl;
  
    if (ms == 0)
      {
        max_ns = 0;
        ns = 0;
        hd = 0;
        tl = 0;
      }
    else
      {
        max_ns = ms->max_nb_sections;
        ns = ms->nb_sections;
        hd = ms->head;
        tl = ms->tail;
      }
  
    if (ms == 0 || n > max_ns)
      {
        /* must allocate a new msections structure */
  
        ___msections *new_ms;
        int i;
  
        while (n > max_ns) /* grow max_nb_sections until big enough */
          max_ns = 2*max_ns + 1;
  
        new_ms = ___CAST(___msections*,
                         alloc_mem_aligned
                           (___WORDS(___sizeof_msections(max_ns)),
                            1,
                            0));
  
        if (new_ms == 0)
          return;
  
        new_ms->max_nb_sections = max_ns;
        new_ms->nb_sections = ns;
        new_ms->head = hd;
        new_ms->tail = tl;
  
        for (i=ns-1; i>=0; i--)
          new_ms->sections[i] = ms->sections[i];
  
        if (ms != 0)
          free_mem_aligned (ms);
  
        ms = new_ms;
  
        *msp = ms;
      }
  
    if (n < ns)
      {
        /* contraction of the msections */
  
        int j;
  
        while (ns > n)
          {
            ___msection *s = tl;
  
            tl = tl->prev;
  
            if (tl == 0)
              hd = 0;
            else
              tl->next = 0;
  
            for (j=s->pos; j<ns-1; j++)
              {
                ms->sections[j] = ms->sections[j+1];
                ms->sections[j]->pos = j;
              }
  
            free_mem_aligned (s);
  
            ns--;
          }
  
        ms->nb_sections = ns;
        ms->head = hd;
        ms->tail = tl;
  
        /*
         * Contraction of the msections structure is not performed
         * because there is typically very little memory to be
         * reclaimed.
         */
      }
    else
      {
        /* expansion of the msections */
  
        int i, j;
  
        while (ns < n)
          {
            ___msection *s = ___CAST(___msection*,
                                     alloc_mem_aligned
                                       (___WORDS(___sizeof_msection(___MSECTION_SIZE)),
                                        1,
                                        0));
  
            if (s == 0)
              return;
  
            i = find_msection (ms, ___CAST(void*,s));
  
  #ifdef ___ALLOC_MEM_UP
            i++;
  #endif
  
            for (j=ns; j>i; j--)
              {
                ms->sections[j] = ms->sections[j-1];
                ms->sections[j]->pos = j;
              }
  
            ms->sections[i] = s;
  
            if (tl == 0)
              {
                hd = s;
                s->index = 0;
              }
            else
              {
                tl->next = s;
                s->index = tl->index + 1;
              }
  
            s->pos = i;
            s->prev = tl;
            s->next = 0;
  
            tl = s;
  
            ms->nb_sections = ++ns;
            ms->head = hd;
            ms->tail = tl;
          }
      }
  }
  
  
  /*
   * 'free_msections (msp)' releases all memory associated with the
   * msections pointed to by 'msp'.
   */
  
  ___HIDDEN void free_msections
     ___P((___msections **msp),
          (msp)
  ___msections **msp;)
  {
    ___msections *ms = *msp;
  
    if (ms != 0)
      {
        int i;
  
        for (i=ms->nb_sections-1; i>=0; i--)
          free_mem_aligned (ms->sections[i]);
  
        free_mem_aligned (ms);
  
        *msp = 0;
      }
  }
  
  
  /*---------------------------------------------------------------------------*/
  
  /* Allocation of permanent objects.  */
  
  /*
   * 'alloc_mem_aligned_psection (words, multiplier, modulus)' allocates
   * an aligned block of memory inside a new psection.  'words' is the
   * size of the block in words and 'multiplier' and 'modulus' specify
   * its alignment in words.  'multiplier' must be a power of two and
   * 0<=modulus<multiplier.  The pointer returned corresponds to an
   * address that is equal to (i*multiplier+modulus)*sizeof (___WORD) for
   * some 'i'.
   */
  
  ___HIDDEN void *alloc_mem_aligned_psection
     ___P((___SIZE_TS words,
           unsigned int multiplier,
           unsigned int modulus),
          (words,
           multiplier,
           modulus)
  ___SIZE_TS words;
  unsigned int multiplier;
  unsigned int modulus;)
  {
    void *container;
  
    /* Make sure alignment is sufficient for pointers */
  
    if (multiplier < sizeof (void*) / ___WS)
      multiplier = sizeof (void*) / ___WS;
  
    /* Make space for psection link and modulus */
  
    if (modulus < (sizeof (void*) + ___WS - 1) / ___WS)
      modulus += ((sizeof (void*) + multiplier * ___WS - 1) / ___WS) &
                 -multiplier;
  
    /* Allocate container */
  
    container = alloc_mem_aligned (words+modulus, multiplier, 0);
  
    if (container == 0)
      return 0;
  
    *___CAST(void**,container) = ___GSTATE->mem.psections;
    ___GSTATE->mem.psections = container;
    return ___CAST(void*,___CAST(___WORD*,container) + modulus);
  }
  
  
  /*
   * 'alloc_mem_aligned_perm (words, multiplier, modulus)' allocates an
   * aligned block of memory inside a psection.  If there is enough free
   * space in a previously allocated psection that psection is used,
   * otherwise a new psection is allocated.  'words' is the size of the
   * block in words and 'multiplier' and 'modulus' specify its alignment
   * in words.  'multiplier' must be a power of two and
   * 0<=modulus<multiplier.  The pointer returned corresponds to an
   * address that is equal to (i*multiplier+modulus)*sizeof (___WORD) for
   * some 'i'.
   */
  
  ___HIDDEN void *alloc_mem_aligned_perm
     ___P((___SIZE_TS words,
           int multiplier,
           int modulus),
          (words,
           multiplier,
           modulus)
  ___SIZE_TS words;
  int multiplier;
  int modulus;)
  {
    ___SIZE_TS waste;
    ___WORD *base;
  
    /*
     * Try to satisfy request in current psection.
     */
  
    if (___GSTATE->mem.palloc_ptr != 0)
      {
        ___WORD *new_palloc_ptr;
  
        base = ___CAST(___WORD*,
                       ___CAST(___WORD,___GSTATE->mem.palloc_ptr+multiplier-1-modulus) &
                       (multiplier * -___WS)) +
               modulus;
  
        new_palloc_ptr = base + words;
  
        if (new_palloc_ptr <= ___GSTATE->mem.palloc_limit) /* did it fit in the psection? */
          {
            ___GSTATE->mem.palloc_ptr = new_palloc_ptr;
            return base;
          }
  
        waste = ___GSTATE->mem.palloc_limit - ___GSTATE->mem.palloc_ptr;
      }
    else
      waste = 0;
  
    /*
     * Request can't be satisfied in current psection so we must
     * allocate a new psection.
     */
  
    if (waste > ___PSECTION_WASTE || words > ___PSECTION_SIZE)
      return alloc_mem_aligned_psection (words, multiplier, modulus);
  
    base = ___CAST(___WORD*,
                   alloc_mem_aligned_psection
                     (___PSECTION_SIZE,
                      multiplier,
                      modulus));
  
    if (base != 0)
      {
        ___GSTATE->mem.palloc_ptr = base + words;
        ___GSTATE->mem.palloc_limit = base + ___PSECTION_SIZE;
      }
  
    return base;
  }
  
  
  ___HIDDEN void free_psections ___PVOID
  {
    void *base = ___GSTATE->mem.psections;
  
    ___GSTATE->mem.psections = 0;
  
    while (base != 0)
      {
        void *link = *___CAST(void**,base);
        free_mem_aligned (base);
        base = link;
      }
  }
  
  
  void ___glo_list_setup ___PVOID
  {
    int i;
  
    ___GSTATE->mem.glo_list.count = 0;
  
    for (i=___GLO_SUBLIST_COUNT-1; i>=0; i--)
      {
        ___glo_sublist_struct *sl = &___GSTATE->mem.glo_list.sublist[i];
        sl->head = 0;
        sl->tail = 0;
      }
  }
  
  
  void ___glo_list_add
     ___P((___glo_struct *glo),
          (glo)
  ___glo_struct *glo;)
  {
    int i = ___GSTATE->mem.glo_list.count++ % ___GLO_SUBLIST_COUNT;
    ___glo_sublist_struct *sl = &___GSTATE->mem.glo_list.sublist[i];
  
    glo->next = 0;
  
    if (sl->head == 0)
      sl->head = glo;
    else
      sl->tail->next = glo;
  
    sl->tail = glo;
  }
  
  
  ___glo_struct *___glo_list_search_obj
     ___P((___SCMOBJ obj,
           ___BOOL prm),
          (obj,
           prm)
  ___SCMOBJ obj;
  ___BOOL prm;)
  {
    ___glo_struct *glo = 0;
    int glo_depth = 999999999;
    int i;
  
    for (i=___GLO_SUBLIST_COUNT-1; i>=0; i--)
      {
        ___glo_sublist_struct *sl = &___GSTATE->mem.glo_list.sublist[i];
        ___glo_struct *probe = sl->head;
        int probe_depth = 0;
  
        if (prm)
          {
            while (probe != 0 && ___PRMCELL(probe->prm) != obj)
              {
                probe = probe->next;
                if (++probe_depth > glo_depth) break;
              }
          }
        else
          {
            while (probe != 0 && ___GLOCELL(probe->val) != obj)
              {
                probe = probe->next;
                if (++probe_depth > glo_depth) break;
              }
          }
  
        if (probe != 0)
          {
            if (glo == 0 || probe_depth <= glo_depth)
              {
                glo = probe;
                glo_depth = probe_depth;
              }
          }
      }
  
    return glo;
  }
  
  
  ___SCMOBJ ___glo_struct_to_global_var
     ___P((___glo_struct *glo),
          (glo)
  ___glo_struct *glo;)
  {
    ___SCMOBJ result = ___FAL;
  
    if (glo != 0)
      {
        int len = ___INT(___VECTORLENGTH(___GSTATE->symbol_table));
        int i;
  
        for (i=1; i<len; i++)
          {
            ___SCMOBJ probe = ___FIELD(___GSTATE->symbol_table,i);
  
            while (probe != ___NUL)
              {
                if (___GLOBALVARSTRUCT(probe) == glo)
                  {
                    result = probe;
                    goto end_search;
                  }
                probe = ___FIELD(probe,___SYMKEY_NEXT);
              }
          }
      end_search:;
      }
  
    return result;
  }
  
  
  ___SCMOBJ ___obj_to_global_var
     ___P((___SCMOBJ obj,
           ___BOOL prm),
          (obj,
           prm)
  ___SCMOBJ obj;
  ___BOOL prm;)
  {
    /*
     * Find the global variable that is bound to the object obj.
     * If prm is true then the prm field of the global variable
     * is checked, otherwise the val field is checked.
     */
  
    return ___glo_struct_to_global_var (___glo_list_search_obj (obj, prm));
  }
  
  
  ___SCMOBJ ___make_global_var
     ___P((___SCMOBJ sym),
          (sym)
  ___SCMOBJ sym;)
  {
    if (___GLOBALVARSTRUCT(sym) == 0)
      {
        ___glo_struct *glo = ___CAST(___glo_struct*,
                                     alloc_mem_aligned_perm
                                       (___WORDS(sizeof (___glo_struct)),
                                        1,
                                        0));
  
        if (glo == 0)
          return ___FIX(___HEAP_OVERFLOW_ERR);
  
  #ifdef ___SINGLE_VM
        glo->val = ___UNB1;
  #else
        glo->val = ___GSTATE->mem.glo_list.count;
  #endif
  
        ___glo_list_add (glo);
  
        ___PRMCELL(glo->prm) = ___FAL;
  
        ___FIELD(sym,___SYMBOL_GLOBAL) = ___CAST(___SCMOBJ,glo);
      }
  
    return sym;
  }
  
  
  #ifdef ___USE_find_global_var_bound_to
  
  ___SCMOBJ ___find_global_var_bound_to
     ___P((___SCMOBJ val),
          (val)
  ___SCMOBJ val;)
  {
    ___SCMOBJ sym = ___NUL;
    int i;
  
    for (i = ___INT(___VECTORLENGTH(___GSTATE->symbol_table)) - 1; i>0; i--)
      {
        sym = ___FIELD(___GSTATE->symbol_table,i);
  
        while (sym != ___NUL)
         {
            ___glo_struct *g = ___GLOBALVARSTRUCT(sym);
  
            if (g != 0 &&
                (___PRMCELL(g->prm) == val || ___GLOCELL(g->val) == val))
              {
                i = 0;
                break;
              }
  
            sym = ___FIELD(sym,___SYMKEY_NEXT);
          }
      }
  
    return sym;
  }
  
  #endif
  
  
  /*---------------------------------------------------------------------------*/
  
  /*
   * '___still_obj_refcount_inc (obj)' increments the reference count of
   * the still object 'obj'.
   */
  
  ___EXP_FUNC(void,___still_obj_refcount_inc)
     ___P((___WORD obj),
          (obj)
  ___WORD obj;)
  {
    ___UNTAG(obj)[___BODY_OFS - ___STILL_BODY_OFS + ___STILL_REFCOUNT_OFS]++;
  }
  
  
  /*
   * '___still_obj_refcount_dec (obj)' decrements the reference count of
   * the still object 'obj'.
   */
  
  ___EXP_FUNC(void,___still_obj_refcount_dec)
     ___P((___WORD obj),
          (obj)
  ___WORD obj;)
  {
    ___UNTAG(obj)[___BODY_OFS - ___STILL_BODY_OFS + ___STILL_REFCOUNT_OFS]--;
  }
  
  
  /*---------------------------------------------------------------------------*/
  
  /*
   * '___alloc_scmobj (___ps, subtype, bytes)' allocates a permanent or
   * still Scheme object (depending on '___ps') of subtype 'subtype'
   * with a body containing 'bytes' bytes, and returns it as an encoded
   * Scheme object.  When '___ps' is NULL, a permanent object is
   * allocated, and when '___ps' is not NULL, a still object is
   * allocated in the heap of that processor's VM.  The initialization
   * of the object's body must be done by the caller.  In the case of
   * still objects this initialization must be done before the next
   * allocation is requested.  The 'refcount' field of still objects is
   * initially 1.  A fixnum error code is returned when there is an
   * error.
   */
  
  ___HIDDEN ___WORD alloc_scmobj_perm
     ___P((int subtype,
           ___SIZE_TS bytes),
          (subtype,
           bytes)
  int subtype;
  ___SIZE_TS bytes;)
  {
    void *ptr;
    ___WORD *base;
    ___SIZE_TS words = ___PERM_BODY_OFS + ___WORDS(bytes);
  
    /*
     * Some objects, such as ___sFOREIGN, ___sS64VECTOR, ___sU64VECTOR,
     * ___sF64VECTOR, ___sFLONUM and ___sBIGNUM, must have a body that
     * is aligned on a multiple of 8 on some machines.  Here, we force
     * alignment to a multiple of 8 even if not necessary in all cases
     * because it is typically more efficient due to a better
     * utilization of the cache.
     */
  
    ptr = alloc_mem_aligned_perm (words,
                                  8>>___LWS,
                                  (-___PERM_BODY_OFS)&((8>>___LWS)-1));
  
    if (ptr == 0)
      return ___FIX(___HEAP_OVERFLOW_ERR);
  
    base = ___CAST(___WORD*,ptr);
  
  #ifdef ___USE_HANDLES
    base[___PERM_HAND_OFS] = ___CAST(___WORD,base+___PERM_BODY_OFS-___BODY_OFS);
  #endif
    base[___PERM_BODY_OFS-1] = ___MAKE_HD(bytes, subtype, ___PERM);
  
    return ___TAG((base + ___PERM_HAND_OFS - ___BODY_OFS),
                  (subtype == ___sPAIR ? ___tPAIR : ___tSUBTYPED));
  }
  
  
  ___HIDDEN ___WORD alloc_scmobj_still
     ___P((___processor_state ___ps,
           int subtype,
           ___SIZE_TS bytes),
          (___ps,
           subtype,
           bytes)
  ___processor_state ___ps;
  int subtype;
  ___SIZE_TS bytes;)
  {
    void *ptr;
    ___WORD *base;
    ___SIZE_TS words = ___STILL_BODY_OFS + ___WORDS(bytes);
    ___SIZE_TS words_including_deferred = words + words_still_objs_deferred;
  
  #ifdef CALL_GC_FREQUENTLY
    if (--___gc_calls_to_punt < 0) goto invoke_gc;
  #endif
  
    if (words_including_deferred <= ___MAX_STILL_DEFERRED)
      {
        /*
         * Allocate the still object and defer its accounting at the VM
         * level.
         */
  
        /*
         * Some objects, such as ___sFOREIGN, ___sS64VECTOR,
         * ___sU64VECTOR, ___sF64VECTOR, ___sFLONUM and ___sBIGNUM, must
         * have a body that is aligned on a multiple of 8 on some
         * machines.  Here, we force alignment to a multiple of 8 even
         * if not necessary in all cases because it is typically more
         * efficient due to a better utilization of the cache.
         */
  
        if ((ptr = alloc_mem_aligned (words,
                                      8>>___LWS,
                                      (-___STILL_BODY_OFS)&((8>>___LWS)-1)))
            == 0)
          {
            /*
             * Couldn't allocate the still object (probably the C heap is full).
             */
  
            return ___FIX(___HEAP_OVERFLOW_ERR);
          }
  
        words_still_objs_deferred = words_including_deferred;
      }
    else
      {
        /*
         * The space for the still object (and the deferred previous
         * ones) is considerable, so the availability of the space must
         * be checked at the VM level.  The VM's memory allocation lock
         * must be acquired to ensure correct bookkeeping.
         */
  
        ALLOC_MEM_LOCK();
  
        if (words_including_deferred <= compute_free_heap_space())
          {
            /*
             * There is sufficient free heap space, so no need to call GC.
             */
  
            occupied_words_still += words_including_deferred;
  
            ALLOC_MEM_UNLOCK();
  
            /*
             * Space accounting for previous still objects is now accounted
             * for at the VM level.
             */
  
            words_still_objs_deferred = 0;
          }
        else
          {
            /*
             * There is insufficient free heap space, so call GC.
             */
  
            ALLOC_MEM_UNLOCK();
  
  #ifdef CALL_GC_FREQUENTLY
          invoke_gc:
  #endif
  
            if (___garbage_collect (___PSP words))
              return ___FIX(___HEAP_OVERFLOW_ERR);
          }
  
        /*
         * Allocate the still object.  See comments above for other call
         * to alloc_mem_aligned.
         */
  
        if ((ptr = alloc_mem_aligned (words,
                                      8>>___LWS,
                                      (-___STILL_BODY_OFS)&((8>>___LWS)-1)))
            == 0)
          {
            /*
             * Couldn't allocate the still object (probably the C heap is full).
             * So undo its accounting at the VM level.
             */
  
            ALLOC_MEM_LOCK();
  
            occupied_words_still -= words;
  
            ALLOC_MEM_UNLOCK();
  
            return ___FIX(___HEAP_OVERFLOW_ERR);
          }
      }
  
    /* Initialize still object and add it to the still_objs list. */
  
    base = ___CAST(___WORD*,ptr);
  
    base[___STILL_LINK_OFS] = still_objs;
    still_objs = ___CAST(___WORD,base);
    base[___STILL_REFCOUNT_OFS] = 1;
    base[___STILL_LENGTH_OFS] = words;
  #ifdef ___USE_HANDLES
    base[___STILL_HAND_OFS] = ___CAST(___WORD,base+___STILL_BODY_OFS-___BODY_OFS);
  #endif
    base[___STILL_BODY_OFS-1] = ___MAKE_HD(bytes, subtype, ___STILL);
  
    /* Return tagged reference to still object. */
  
    return ___TAG((base + ___STILL_HAND_OFS - ___BODY_OFS),
                  (subtype == ___sPAIR ? ___tPAIR : ___tSUBTYPED));
  }
  
  
  ___EXP_FUNC(___WORD,___alloc_scmobj)
     ___P((___processor_state ___ps,
           int subtype,
           ___SIZE_TS bytes),
          (___ps,
           subtype,
           bytes)
  ___processor_state ___ps;
  int subtype;
  ___SIZE_TS bytes;)
  {
    if (___ps == NULL)
      return alloc_scmobj_perm (subtype, bytes);
    else
      return alloc_scmobj_still (___ps, subtype, bytes);
  }
  
  
  ___EXP_FUNC(___SCMOBJ,___release_scmobj)
     ___P((___SCMOBJ obj),
          (obj)
  ___SCMOBJ obj;)
  {
    if (___MEM_ALLOCATED(obj) &&
        ___HD_TYP(___BODY(obj)[-1]) == ___STILL)
      ___still_obj_refcount_dec (obj);
    return obj;
  }
  
  
  /*
   * '___make_pair (___ps, car, cdr)' creates a Scheme pair having the
   * values 'car' and 'cdr' in its CAR and CDR fields.  The 'car' and
   * 'cdr' arguments must not be movable objects and any still object
   * must be reachable some other way or have a nonzero refcount.  A
   * permanent or still object is allocated, depending on '___ps'.  When
   * '___ps' is NULL, a permanent object is allocated, and when '___ps'
   * is not NULL, a still object is allocated in the heap of that
   * processor.  The 'refcount' field of still objects is initially 1.
   * A fixnum error code is returned when there is an error.
   */
  
  ___EXP_FUNC(___WORD,___make_pair)
     ___P((___processor_state ___ps,
           ___WORD car,
           ___WORD cdr),
          (___ps,
           car,
           cdr)
  ___processor_state ___ps;
  ___WORD car;
  ___WORD cdr;)
  {
    ___WORD obj = ___alloc_scmobj (___ps, ___sPAIR, ___PAIR_SIZE<<___LWS);
  
    if (!___FIXNUMP(obj))
      {
        ___PAIR_CAR(obj) = car;
        ___PAIR_CDR(obj) = cdr;
      }
  
    return obj;
  }
  
  
  /*
   * '___make_vector (___ps, length, init)' creates a Scheme vector of
   * length 'length' and initialized with the value 'init'.  The 'init'
   * argument must not be a movable object and if it is a still object
   * it must be reachable some other way or have a nonzero refcount.  A
   * permanent or still object is allocated, depending on '___ps'.  When
   * '___ps' is NULL, a permanent object is allocated, and when '___ps'
   * is not NULL, a still object is allocated in the heap of that
   * processor.  The 'refcount' field of still objects is initially 1.
   * A fixnum error code is returned when there is an error.
   */
  
  ___EXP_FUNC(___WORD,___make_vector)
     ___P((___processor_state ___ps,
           ___SIZE_TS length,
           ___WORD init),
          (___ps,
           length,
           init)
  ___processor_state ___ps;
  ___SIZE_TS length;
  ___WORD init;)
  {
    if (length > ___CAST(___WORD,___LMASK >> (___LF+___LWS)))
      return ___FIX(___HEAP_OVERFLOW_ERR);
    else
      {
        ___WORD obj = ___alloc_scmobj (___ps, ___sVECTOR, length<<___LWS);
  
        if (!___FIXNUMP(obj))
          {
            int i;
            for (i=0; i<length; i++)
              ___FIELD(obj, i) = init;
          }
  
        return obj;
      }
  }
  
  
  /*---------------------------------------------------------------------------*/
  
  /*
   * Routines to manage symbol table, keyword table and global variable
   * table.
   */
  
  /*
   * The hashing functions '___hash_UTF_8_string (str)' and
   * '___hash_scheme_string (str)' must compute the same value as the
   * function 'targ-hash' in the file gsc/_t-c-3.scm.  A fixnum error
   * code is returned when there is an error.
   *
   * These functions implement an adaptation of the FNV1a hash algorithm
   * (see https://tools.ietf.org/html/draft-eastlake-fnv-12).  Instead
   * of iterating over bytes, an iteration over Unicode code points is
   * used.  This will give the same result if the string contains only
   * ISO-8859-1 characters.  However, only the lower 29 bits of the
   * standard 32 bit FNV1a algorithm are returned so the result fits in
   * a fixnum on a 32 bit word architecture.
   */
  
  #define FN1a_prime        0x01000193
  #define FN1a_offset_basis 0x011C9DC5
  
  #define HASH_STEP(h,c) (((h)^(c)) * FN1a_prime) & ___MAX_FIX32
  
  ___SCMOBJ ___hash_UTF_8_string
     ___P((___UTF_8STRING str),
          (str)
  ___UTF_8STRING str;)
  {
    ___UM32 h = FN1a_offset_basis;
    ___UTF_8STRING p = str;
    ___UCS_4 c;
  
    for (;;)
      {
        ___UTF_8STRING start = p;
        c = ___UTF_8_get (&p);
        if (p == start || c > ___MAX_CHR)
          return ___FIX(___CTOS_UTF_8STRING_ERR);
        if (c == 0)
          break;
        h = HASH_STEP(h,c);
      }
  
    return ___FIX(h);
  }
  
  
  ___SCMOBJ ___hash_scheme_string
     ___P((___SCMOBJ str),
          (str)
  ___SCMOBJ str;)
  {
    ___SIZE_T i, n = ___INT(___STRINGLENGTH(str));
    ___UM32 h = FN1a_offset_basis;
  
    for (i=0; i<n; i++)
      h = HASH_STEP(h,___INT(___STRINGREF(str,___FIX(i))));
  
    return ___FIX(h);
  }
  
  
  ___HIDDEN ___SCMOBJ symkey_table
     ___P((unsigned int subtype),
          (subtype)
  unsigned int subtype;)
  {
    switch (subtype)
      {
      case ___sKEYWORD:
        return ___GSTATE->keyword_table;
      default: /* assume ___sSYMBOL */
        return ___GSTATE->symbol_table;
      }
  }
  
  
  ___HIDDEN void symkey_table_set
     ___P((unsigned int subtype,
           ___SCMOBJ new_table),
          (subtype,
           new_table)
  unsigned int subtype;
  ___SCMOBJ new_table;)
  {
    switch (subtype)
      {
      case ___sKEYWORD:
        ___GSTATE->keyword_table = new_table;
        break;
      default: /* assume ___sSYMBOL */
        ___GSTATE->symbol_table = new_table;
        break;
      }
  }
  
  
  ___HIDDEN ___SCMOBJ alloc_symkey_table
     ___P((unsigned int subtype,
           ___SIZE_TS length),
          (subtype,
           length)
  unsigned int subtype;
  ___SIZE_TS length;)
  {
    ___SCMOBJ tbl = ___make_vector (NULL, length+1, ___NUL);
  
    if (!___FIXNUMP(tbl))
      ___FIELD(tbl,0) = ___FIX(0);
  
    return tbl;
  }
  
  
  void ___intern_symkey
     ___P((___SCMOBJ symkey),
          (symkey)
  ___SCMOBJ symkey;)
  {
    unsigned int subtype = ___INT(___SUBTYPE(symkey));
    ___SCMOBJ tbl = symkey_table (subtype);
    int i = ___INT(___FIELD(symkey,___SYMKEY_HASH))
            % (___INT(___VECTORLENGTH(tbl)) - 1)
            + 1;
  
    /*
     * Add symbol/keyword to the appropriate list.
     */
  
    ___FIELD(symkey,___SYMKEY_NEXT) = ___FIELD(tbl,i);
    ___FIELD(tbl,i) = symkey;
  
    ___FIELD(tbl,0) = ___FIXADD(___FIELD(tbl,0),___FIX(1));
  
    /*
     * Grow and rehash the table when it is too loaded (above an average
     * list length of 4).
     */
  
    if (___INT(___FIELD(tbl,0)) > ___INT(___VECTORLENGTH(tbl)) * 4)
      {
        int new_len = (___INT(___VECTORLENGTH(tbl))-1) * 2;
        ___SCMOBJ newtbl = alloc_symkey_table (subtype, new_len);
  
        if (!___FIXNUMP(newtbl))
          {
            for (i=___INT(___VECTORLENGTH(tbl))-1; i>0; i--)
              {
                ___SCMOBJ probe = ___FIELD(tbl,i);
  
                while (probe != ___NUL)
                  {
                    ___SCMOBJ symkey = probe;
                    int j = ___INT(___FIELD(symkey,___SYMKEY_HASH))%new_len + 1;
  
                    probe = ___FIELD(symkey,___SYMKEY_NEXT);
                    ___FIELD(symkey,___SYMKEY_NEXT) = ___FIELD(newtbl,j);
                    ___FIELD(newtbl,j) = symkey;
                  }
              }
  
            ___FIELD(newtbl,0) = ___FIELD(tbl,0);
  
            symkey_table_set (subtype, newtbl);
          }
      }
  }
  
  
  ___SCMOBJ ___new_symkey
     ___P((___SCMOBJ name, /* name must be a permanent object */
           unsigned int subtype),
          (name,
           subtype)
  ___SCMOBJ name;
  unsigned int subtype;)
  {
    ___SCMOBJ obj;
    ___SCMOBJ tbl;
  
    switch (subtype)
      {
      case ___sKEYWORD:
        obj = ___alloc_scmobj (NULL, ___sKEYWORD, ___KEYWORD_SIZE<<___LWS);
        break;
      default: /* assume ___sSYMBOL */
        obj = ___alloc_scmobj (NULL, ___sSYMBOL, ___SYMBOL_SIZE<<___LWS);
        break;
      }
  
    if (___FIXNUMP(obj))
      return obj;
  
    tbl = symkey_table (subtype);
  
    /* object layout is same for ___sSYMBOL and ___sKEYWORD */
  
    ___FIELD(obj,___SYMKEY_NAME) = name;
    ___FIELD(obj,___SYMKEY_HASH) = ___hash_scheme_string (name);
  
    if (subtype == ___sSYMBOL)
      ___FIELD(obj,___SYMBOL_GLOBAL) = ___CAST(___SCMOBJ,___CAST(___glo_struct*,0));
  
    ___intern_symkey (obj);
  
    return obj;
  }
  
  
  ___SCMOBJ ___find_symkey_from_UTF_8_string
     ___P((char *str,
           unsigned int subtype),
          (str,
           subtype)
  char *str;
  unsigned int subtype;)
  {
    ___SCMOBJ tbl;
    ___SCMOBJ probe;
    ___SCMOBJ h = ___hash_UTF_8_string (str);
  
    if (h < ___FIX(0))
      return h;
  
    tbl = symkey_table (subtype);
    probe = ___FIELD(tbl, ___INT(h) % (___INT(___VECTORLENGTH(tbl))-1) + 1);
  
    while (probe != ___NUL)
      {
        ___SCMOBJ name = ___FIELD(probe,___SYMKEY_NAME);
        ___SIZE_T i;
        ___SIZE_T n = ___INT(___STRINGLENGTH(name));
        ___UTF_8STRING p = str;
        for (i=0; i<n; i++)
          if (___UTF_8_get (&p) !=
              ___CAST(___UCS_4,___INT(___STRINGREF(name,___FIX(i)))))
            goto next;
        if (___UTF_8_get (&p) == 0)
          return probe;
      next:
        probe = ___FIELD(probe,___SYMKEY_NEXT);
      }
  
    return ___FAL;
  }
  
  
  ___SCMOBJ ___find_symkey_from_scheme_string
     ___P((___SCMOBJ str,
           unsigned int subtype),
          (str,
           subtype)
  ___SCMOBJ str;
  unsigned int subtype;)
  {
    ___SCMOBJ tbl;
    ___SCMOBJ probe;
    ___SCMOBJ h = ___hash_scheme_string (str);
  
    tbl = symkey_table (subtype);
    probe = ___FIELD(tbl, ___INT(h) % (___INT(___VECTORLENGTH(tbl))-1) + 1);
  
    while (probe != ___NUL)
      {
        ___SCMOBJ name = ___FIELD(probe,___SYMKEY_NAME);
        ___SIZE_TS i = 0;
        ___SIZE_TS n = ___INT(___STRINGLENGTH(name));
        if (___INT(___STRINGLENGTH(str)) == n)
          {
            for (i=0; i<n; i++)
              if (___STRINGREF(str,___FIX(i)) != ___STRINGREF(name,___FIX(i)))
                goto next;
            return probe;
          }
      next:
        probe = ___FIELD(probe,___SYMKEY_NEXT);
      }
  
    return ___FAL;
  }
  
  
  ___SCMOBJ ___make_symkey_from_UTF_8_string
     ___P((___UTF_8STRING str,
           unsigned int subtype),
          (str,
           subtype)
  ___UTF_8STRING str;
  unsigned int subtype;)
  {
    ___SCMOBJ obj = ___find_symkey_from_UTF_8_string (str, subtype);
  
    if (obj == ___FAL)
      {
        ___SCMOBJ name;
        ___SCMOBJ err;
  
        if ((err = ___NONNULLUTF_8STRING_to_SCMOBJ
                     (NULL, /* allocate as permanent object */
                      str,
                      &name,
                      -1))
            != ___FIX(___NO_ERR))
          return err;
  
        obj = ___new_symkey (name, subtype);
      }
  
    return obj;
  }
  
  
  ___SCMOBJ ___make_symkey_from_scheme_string
     ___P((___SCMOBJ str,
           unsigned int subtype),
          (str,
           subtype)
  ___SCMOBJ str;
  unsigned int subtype;)
  {
    ___SCMOBJ obj = ___find_symkey_from_scheme_string (str, subtype);
  
    if (obj == ___FAL)
      {
        ___SIZE_T n = ___INT(___STRINGLENGTH(str));
        ___SCMOBJ name = ___alloc_scmobj (NULL, ___sSTRING, n<<___LCS);
  
        if (___FIXNUMP(name))
          return name;
  
        memmove (___BODY_AS(name,___tSUBTYPED),
                 ___BODY_AS(str,___tSUBTYPED),
                 n<<___LCS);
  
        obj = ___new_symkey (name, subtype);
      }
  
    return obj;
  }
  
  
  void ___for_each_symkey
     ___P((unsigned int subtype,
           void (*visit) (___SCMOBJ symkey, void *data),
           void *data),
          (subtype,
           visit,
           data)
  unsigned int subtype;
  void (*visit) ();
  void *data;)
  {
    ___SCMOBJ tbl = symkey_table (subtype);
    int i;
  
    for (i=___INT(___VECTORLENGTH(tbl))-1; i>0; i--)
      {
        ___SCMOBJ probe = ___FIELD(tbl, i);
  
        while (probe != ___NUL)
          {
            visit (probe, data);
            probe = ___FIELD(probe,___SYMKEY_NEXT);
          }
      }
  }
  
  
  /*---------------------------------------------------------------------------*/
  
  
  #define fromspace_offset ((___MSECTION_SIZE>>1) - tospace_offset)
  
  #define start_of_fromspace(ms) ms->base + fromspace_offset
  
  #define start_of_tospace(ms) ms->base + tospace_offset
  
  
  /*---------------------------------------------------------------------------*/
  
  #ifdef ___DEBUG_GARBAGE_COLLECT
  
  
  #define ZAP_USING_INVALID_HEAD_TAG_not
  #define ZAP_PATTERN ___CAST(___WORD,0xcafebabe)
  #define INVALID_HEAD_TAG 4
  
  
  char *subtype_to_string
     ___P((int subtype),
          (subtype)
  int subtype;)
  {
    switch (subtype)
      {
      case ___sVECTOR:       return "vector";
      case ___sPAIR:         return "pair";
      case ___sRATNUM:       return "ratnum";
      case ___sCPXNUM:       return "cpxnum";
      case ___sSTRUCTURE:    return "structure";
      case ___sBOXVALUES:    return "boxvalues";
      case ___sMEROON:       return "meroon";
      case ___sJAZZ:         return "jazz";
      case ___sSYMBOL:       return "symbol";
      case ___sKEYWORD:      return "keyword";
      case ___sFRAME:        return "frame";
      case ___sCONTINUATION: return "continuation";
      case ___sPROMISE:      return "promise";
      case ___sWEAK:         return "weak";
      case ___sPROCEDURE:    return "procedure";
      case ___sRETURN:       return "return";
      case ___sFOREIGN:      return "foreign";
      case ___sSTRING:       return "string";
      case ___sS8VECTOR:     return "s8vector";
      case ___sU8VECTOR:     return "u8vector";
      case ___sS16VECTOR:    return "s16vector";
      case ___sU16VECTOR:    return "u16vector";
      case ___sS32VECTOR:    return "s32vector";
      case ___sU32VECTOR:    return "u32vector";
      case ___sF32VECTOR:    return "f32vector";
      case ___sS64VECTOR:    return "s64vector";
      case ___sU64VECTOR:    return "u64vector";
      case ___sF64VECTOR:    return "f64vector";
      case ___sFLONUM:       return "flonum";
      case ___sBIGNUM:       return "bignum";
      default:               return "UNKNOWN SUBTYPE";
      }
  }
  
  void print_value
     ___P((___SCMOBJ val),
          (val)
  ___SCMOBJ val;)
  {
    ___SCMOBJ ___temp;
    if (___MEM_ALLOCATED(val))
      {
        ___WORD* body = ___BODY(val);
        ___WORD head = body[-1];
        int subtype;
        int shift = 0;
  
        if (___TYP(head) == ___FORW)
          {
            /* indirect forwarding pointer */
            body = ___UNTAG_AS(head, ___FORW) + ___BODY_OFS;
            head = body[-1];
          }
  
        if (head == ZAP_PATTERN)
          ___printf ("[WARNING: HEAD=ZAP_PATTERN] ");
        else if (___HD_TYP(head) == INVALID_HEAD_TAG)
          {
            ___printf ("[WARNING: HEAD HAS INVALID TAG] ");
            shift = ___HTB;
          }
  
        head >>= shift;
        subtype = ___HD_SUBTYPE(head);
  
        if (subtype == ___sPAIR)
          {
            ___printf ("0x%016x (... . ...)", val);
          }
        else
          {
            ___SCMOBJ sym;
            if (subtype == ___sPROCEDURE || subtype == ___sRETURN)
              {
                if (subtype == ___sPROCEDURE)
                  ___printf ("#<procedure ");
                else
                  ___printf ("#<return ");
                if ((sym = ___find_global_var_bound_to (val)) != ___NUL)
                  print_value (___FIELD(sym,___SYMKEY_NAME));
                else
                  {
                    if (___HD_TYP(head) == ___PERM)
                      {
                        ___SCMOBJ *start = &body[-1];
                        ___SCMOBJ *ptr = start;
                        while (!___TESTHEADERTAG(*ptr,___sVECTOR))
                          ptr -= ___LS;
                        ptr += ___LS;
                        if (ptr == start)
                          ___printf ("???");
                        else
                          {
                            ___printf ("%d in ", (start-ptr)/___LS);
                            print_value (___TAG(ptr,___tSUBTYPED));
                          }
                      }
                    else
                      ___printf ("???");
                  }
                ___printf (">");
              }
            else if (subtype == ___sSTRING)
              {
                int i;
                ___SCMOBJ str = ___TAG((body-1),___tSUBTYPED);
                ___printf ("\"");
                for (i=0; i<___INT(___STRINGLENGTH(str)); i++)
                  ___printf ("%c", ___INT(___STRINGREF(str,___FIX(i))));
                ___printf ("\"");
              }
            else if (subtype == ___sSYMBOL)
              {
                ___printf ("#<symbol ");
                print_value (body[___SYMKEY_NAME]>>shift);
                ___printf (">");
              }
            else
              {
                ___printf ("#<%s>", subtype_to_string (subtype));
              }
          }
      }
    else if (___FIXNUMP(val))
      ___printf ("%d", ___INT(val));
    else if (___CHARP(val))
      ___printf ("#\\x%x", ___INT(val));
    else if (val == ___FAL)
      ___printf ("#f");
    else if (val == ___TRU)
      ___printf ("#t");
    else if (val == ___NUL)
      ___printf ("()");
    else if (val == ___EOF)
      ___printf ("#!eof");
    else if (val == ___VOID)
      ___printf ("#!void");
    else if (val == ___ABSENT)
      ___printf ("#absent");
    else if (val == ___UNB1)
      ___printf ("#!unbound");
    else if (val == ___UNB2)
      ___printf ("#!unbound2");
    else if (val == ___OPTIONAL)
      ___printf ("#!optional");
    else if (val == ___KEYOBJ)
      ___printf ("#!key");
    else if (val == ___REST)
      ___printf ("#!rest");
    else if (val == ___UNUSED)
      ___printf ("#unused");
    else if (val == ___DELETED)
      ___printf ("#deleted");
    else
      ___printf ("#unknown(0x%016x)", val);
  }
  
  #endif
  
  
  #ifdef ENABLE_CONSISTENCY_CHECKS
  
  #define IN_OBJECT           0
  #define IN_REGISTER         1
  #define IN_PROCESSOR_SCMOBJ 2
  #define IN_VM_SCMOBJ        3
  #define IN_SYMKEY_TABLE     4
  #define IN_GLOBAL_VAR       5
  #define IN_WILL_LIST        6
  #define IN_CONTINUATION     7
  #define IN_RC               8
  
  
  ___HIDDEN void print_prefix
     ___P((char *prefix,
           int indent),
          (prefix,
           indent)
  char *prefix;
  int indent;)
  {
    int i;
  
    ___printf ("%s", prefix);
  
    for (i=0; i<indent; i++)
      ___printf (" ");
  }
  
  
  ___HIDDEN void print_object
     ___P((___WORD obj,
           int max_depth,
           char *prefix,
           int indent),
          (obj,
           max_depth,
           prefix,
           indent)
  ___WORD obj;
  int max_depth;
  char *prefix;
  int indent;)
  {
    int typ = ___TYP(obj);
  
    print_prefix (prefix, indent);
  
    if (typ == ___tFIXNUM)
      ___printf ("%d\n", ___INT(obj));
    else if (typ == ___tSPECIAL)
      {
        if (obj >= 0)
          ___printf ("#\\%c\n", ___INT(obj));
        else if (obj == ___FAL)
          ___printf ("#f\n");
        else if (obj == ___TRU)
          ___printf ("#t\n");
        else if (obj == ___NUL)
          ___printf ("()\n");
        else if (obj == ___EOF)
          ___printf ("#!eof\n");
        else if (obj == ___VOID)
          ___printf ("#!void\n");
        else if (obj == ___ABSENT)
          ___printf ("#<absent>\n");
        else if (obj == ___UNB1)
          ___printf ("#<unbound1>\n");
        else if (obj == ___UNB2)
          ___printf ("#<unbound2>\n");
        else if (obj == ___OPTIONAL)
          ___printf ("#!optional\n");
        else if (obj == ___KEYOBJ)
          ___printf ("#!key\n");
        else if (obj == ___REST)
          ___printf ("#!rest\n");
        else if (obj == ___UNUSED)
          ___printf ("#<unused>\n");
        else if (obj == ___DELETED)
          ___printf ("#<deleted>\n");
        else
          ___printf ("#<unknown>\n");
      }
    else
      {
        ___WORD* body = ___BODY(obj);
        ___WORD head = body[-1];
        int subtype;
        int shift = 0;
  
        if (___TYP(head) == ___FORW)
          {
            /* indirect forwarding pointer */
            body = ___UNTAG_AS(head, ___FORW) + ___BODY_OFS;
            head = body[-1];
          }
  
        if (___HD_TYP(head) == INVALID_HEAD_TAG)
          shift = ___HTB;
  
        head >>= shift;
        subtype = ___HD_SUBTYPE(head);
  
        switch (subtype)
          {
          case ___sVECTOR:
            if (max_depth > 0)
              {
                int i;
                ___printf ("#(\n");
                for (i=0; i<___CAST(int,___HD_WORDS(head)); i++)
                  print_object (___FIELD(obj,i)>>shift, max_depth-1, prefix, indent+2);
                print_prefix (prefix, indent);
                ___printf (")\n");
              }
            else
              ___printf ("#(...)\n");
            break;
          case ___sPAIR:
            if (max_depth > 0)
              {
                ___printf ("(\n");
                print_object (___CAR(obj)>>shift, max_depth-1, prefix, indent+1);
                print_prefix (prefix, indent);
                ___printf (" .\n");
                print_object (___CDR(obj)>>shift, max_depth-1, prefix, indent+1);
                print_prefix (prefix, indent);
                ___printf (")\n");
              }
            else
              ___printf ("(...)\n");
            break;
          case ___sRATNUM:
            ___printf ("RATNUM\n");
            break;
          case ___sCPXNUM:
            ___printf ("CPXNUM\n");
            break;
          case ___sSTRUCTURE:
            ___printf ("STRUCTURE\n");
            break;
          case ___sBOXVALUES:
            ___printf ("BOXVALUES\n");
            break;
          case ___sMEROON:
            ___printf ("MEROON\n");
            break;
          case ___sSYMBOL:
            ___printf ("SYMBOL ");
            print_object (___FIELD(obj,___SYMKEY_NAME)>>shift, max_depth-1, "", 0);
            break;
          case ___sKEYWORD:
            ___printf ("KEYWORD ");
            print_object (___FIELD(obj,___SYMKEY_NAME)>>shift, max_depth-1, "", 0);
            break;
          case ___sFRAME:
            ___printf ("FRAME\n");
            break;
          case ___sCONTINUATION:
            ___printf ("CONTINUATION\n");
            break;
          case ___sPROMISE:
            ___printf ("PROMISE\n");
            break;
          case ___sWEAK:
            ___printf ("WEAK\n");
            break;
          case ___sPROCEDURE:
            ___printf ("PROCEDURE\n");
            break;
          case ___sRETURN:
            ___printf ("RETURN\n");
            break;
          case ___sFOREIGN:
            ___printf ("FOREIGN\n");
            break;
          case ___sSTRING:
            {
              int i;
              int len = ___HD_BYTES(head)>>___LCS;
              ___printf ("STRING ");
              for (i=0; i<len; i++)
                ___printf ("%c", ___INT(___STRINGREF(obj,___FIX(i))));
              ___printf ("\n");
            }
            break;
          case ___sS8VECTOR:
            ___printf ("S8VECTOR\n");
            break;
          case ___sU8VECTOR:
            ___printf ("U8VECTOR\n");
            break;
          case ___sS16VECTOR:
            ___printf ("S16VECTOR\n");
            break;
          case ___sU16VECTOR:
            ___printf ("U16VECTOR\n");
            break;
          case ___sS32VECTOR:
            ___printf ("S32VECTOR\n");
            break;
          case ___sU32VECTOR:
            ___printf ("U32VECTOR\n");
            break;
          case ___sF32VECTOR:
            ___printf ("F32VECTOR\n");
            break;
          case ___sS64VECTOR:
            ___printf ("S64VECTOR\n");
            break;
          case ___sU64VECTOR:
            ___printf ("U64VECTOR\n");
            break;
          case ___sF64VECTOR:
            ___printf ("F64VECTOR\n");
            break;
          case ___sFLONUM:
            ___printf ("FLONUM\n");
            break;
          case ___sBIGNUM:
            ___printf ("BIGNUM\n");
            break;
          default:
            ___printf ("UNKNOWN\n");
            break;
          }
      }
  }
  
  
  ___HIDDEN void print_global_var_name
     ___P((___glo_struct *glo),
          (glo)
  ___glo_struct *glo;)
  {
    ___SCMOBJ sym = ___NUL;
    int i;
  
    for (i = ___INT(___VECTORLENGTH(___GSTATE->symbol_table)) - 1; i>0; i--)
      {
        sym = ___FIELD(___GSTATE->symbol_table,i);
  
        while (sym != ___NUL)
          {
            ___SCMOBJ g = ___FIELD(sym,___SYMBOL_GLOBAL);
  
            if (g != ___FIX(0))
              {
                ___glo_struct *p = ___CAST(___glo_struct*,g);
  
                if (p == glo)
                  {
                    ___SCMOBJ name = ___FIELD(sym,___SYMKEY_NAME);
                    for (i=0; i<___INT(___STRINGLENGTH(name)); i++)
                      ___printf ("%c", ___INT(___STRINGREF(name,___FIX(i))));
                    i = 0;
                    break;
                  }
              }
  
            sym = ___FIELD(sym,___SYMKEY_NEXT);
          }
      }
  }
  
  
  ___HIDDEN void dump_memory_map
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
    int ns = the_msections->nb_sections;
    ___msection **sections = the_msections->sections;
    int i;
  
    ___printf (">>> Memory map:\n");
  
    for (i=0; i<ns; i++)
      ___printf (">>>  msection %2d:  %p .. %p .. %p\n",
                 i,
                 sections[i]->base,
                 sections[i]->base + (___MSECTION_SIZE>>1),
                 sections[i]->base + ___MSECTION_SIZE);
  
    ___printf (">>>  alloc_msection       = %p\n", alloc_msection);
    ___printf (">>>  stack_msection       = %p\n", stack_msection);
    ___printf (">>>  heap_msection        = %p\n", heap_msection);
    ___printf (">>>  alloc_stack_ptr      = %p\n", alloc_stack_ptr);
    ___printf (">>>  alloc_stack_limit    = %p\n", alloc_stack_limit);
    ___printf (">>>  alloc_heap_limit     = %p\n", alloc_heap_limit);
    ___printf (">>>  alloc_heap_ptr       = %p\n", alloc_heap_ptr);
    ___printf (">>>  scan_ptr             = %p\n", scan_ptr);
  }
  
  ___HIDDEN void explain_problem
     ___P((___PSD
           ___WORD obj,
           int shift,
           char *msg),
          (___PSV
           obj,
           shift,
           msg)
  ___PSDKR
  ___WORD obj;
  int shift;
  char *msg;)
  {
    ___PSGET
  
    dump_memory_map (___PSPNC);
  
    ___printf (">>> The object 0x%016lx %s\n", obj, msg);
  
    {
      int j;
      ___WORD head = ___BODY(obj)[-1]>>shift;
      ___SIZE_TS words = ___HD_WORDS(head);
      if (words > 10)
        words = 10;
      for (j=-1; j<words; j++)
        {
          ___printf (">>>  body[%2d] = 0x%016lx\n", j, ___BODY(obj)[j]>>shift);
          print_object (___BODY(obj)[j]>>shift, 1, ">>>             ", 0);
        }
    }
  
    switch (reference_location)
      {
      case IN_OBJECT:
        {
          ___WORD container;
          ___WORD head = container_body[-1];
          ___SIZE_TS words = ___HD_WORDS(head);
          int subtype = ___HD_SUBTYPE(head);
          int i;
  
  #if ___tPAIR != ___tSUBTYPED
          if (subtype == ___sPAIR)
            container = ___TAG(container_body-___BODY_OFS,___tPAIR);
          else
  #endif
            container = ___TAG(container_body-___BODY_OFS,___tSUBTYPED);
  
          ___printf (">>> The reference was found in ");
          if (___HD_TYP(head) == ___PERM)
            ___printf ("___PERM ");
          else if (___HD_TYP(head) == ___STILL)
            ___printf ("___STILL ");
          else if (___HD_TYP(head) == ___MOVABLE0)
            ___printf ("___MOVABLE0 ");
          else if (___TYP(head) == ___FORW)
            ___printf ("___FORW ");
          else
            ___printf ("UNKNOWN ");
          ___printf ("object with body at %p:\n", container_body);
  
          ___printf (">>>  subtype = %d\n", subtype);
          ___printf (">>>  length  = %ld words\n", words);
          if (words <= 100)
            {
              for (i=-1; i<words; i++)
                ___printf (">>>  body[%2d] = 0x%016lx\n", i, container_body[i]);
            }
          else
            {
              for (i=0; i<50; i++)
                ___printf (">>>  body[%2d] = 0x%016lx\n", i, container_body[i]);
              ___printf ("...\n");
              for (i=words-50; i<words; i++)
                ___printf (">>>  body[%2d] = 0x%016lx\n", i, container_body[i]);
            }
          ___printf (">>> container =\n");
          print_object (container, 4, ">>>   ", 0);
          break;
        }
  
      case IN_REGISTER:
        ___printf (">>> The reference was found in a register\n");
        break;
  
      case IN_PROCESSOR_SCMOBJ:
        ___printf (">>> The reference was found in the processor object\n");
        break;
  
      case IN_VM_SCMOBJ:
        ___printf (">>> The reference was found in the VM object\n");
        break;
  
      case IN_SYMKEY_TABLE:
        ___printf (">>> The reference was found in the symbol or keyword table\n");
        break;
  
      case IN_GLOBAL_VAR:
        ___printf (">>> The reference was found in a global variable\n");
        break;
  
      case IN_WILL_LIST:
        ___printf (">>> The reference was found in a will list\n");
        break;
  
      case IN_CONTINUATION:
        ___printf (">>> The reference was found in a continuation\n");
        break;
  
      case IN_RC:
        ___printf (">>> The reference was found in a reference counted object\n");
        break;
      }
  }
  
  
  ___HIDDEN void bug
     ___P((___PSD
           ___WORD obj,
           int shift,
           char *msg),
          (___PSV
           obj,
           shift,
           msg)
  ___PSDKR
  ___WORD obj;
  int shift;
  char *msg;)
  {
    ___PSGET
    char *msgs[2];
  
    ___printf (">>> P%d: the GC has detected the following inconsistency\n",
               ___PROCESSOR_ID(___ps,___VMSTATE_FROM_PSTATE(___ps)));
    ___printf (">>> during call of mark_array on line %d of mem.c:\n",
               mark_array_call_line);
    explain_problem (___PSP obj, shift, msg);
    msgs[0] = "GC inconsistency detected";
    msgs[1] = 0;
    ___fatal_error (msgs);
  }
  
  
  ___HIDDEN void validate_old_obj
     ___P((___PSD
           ___WORD obj),
          (___PSV
           obj)
  ___PSDKR
  ___WORD obj;)
  {
    ___PSGET
    ___WORD *hd_ptr = ___BODY(obj)-1;
    ___WORD head;
    int i = find_msection (the_msections, hd_ptr);
    if (i >= 0 && i < the_msections->nb_sections)
      {
        ___PTRDIFF_T pos = hd_ptr - the_msections->sections[i]->base;
        if (pos >= 0 && pos < ___MSECTION_SIZE)
          {
            head = *hd_ptr;
            if (___TYP(head) == ___FORW)
              {
                ___WORD *hd_ptr2 = ___UNTAG_AS(head,___FORW)+___BODY_OFS-1;
                int i2 = find_msection (the_msections, hd_ptr2);
                if (i2 >= 0 && i2 < the_msections->nb_sections)
                  {
                    ___PTRDIFF_T pos2 = hd_ptr2 -
                                        (the_msections->sections[i2]->base +
                                         tospace_offset);
                    if (pos2 < 0 || pos2 >= ___MSECTION_SIZE>>1)
                      bug (___PSP obj, 0, "was copied outside of tospace");
                    else if (___HD_TYP((*hd_ptr2)) != ___MOVABLE0)
                      bug (___PSP obj, 0, "was copied and copy is not ___MOVABLE0");
                  }
                else
                  bug (___PSP obj, 0, "was copied outside of tospace");
              }
            else if (___HD_TYP(head) != ___MOVABLE0)
              bug (___PSP obj, ___HTB, "should be ___MOVABLE0");
            else
              {
                pos -= tospace_offset;
                if (pos >= 0 && pos < ___MSECTION_SIZE>>1)
                  bug (___PSP obj, 0, "is in tospace");
              }
            return;
          }
      }
    head = *hd_ptr; /* this dereference will likely bomb if there is a bug */
    if (___HD_TYP(head) != ___PERM && ___HD_TYP(head) != ___STILL)
      bug (___PSP obj, 0, "is not ___PERM or ___STILL");
  }
  
  
  ___HIDDEN void zap_section
     ___P((___WORD *start,
           ___WORD *end),
          (start,
           end)
  ___WORD *start;
  ___WORD *end;)
  {
    while (start < end)
      {
  #ifdef ZAP_USING_INVALID_HEAD_TAG
        *start = (*start << ___HTB) | INVALID_HEAD_TAG;
  #else
        *start = ZAP_PATTERN;
  #endif
        start++;
      }
  }
  
  
  ___HIDDEN int unzapped_words
     ___P((___WORD *start,
           int words),
          (start,
           words)
  ___WORD *start;
  int words;)
  {
    ___WORD *ptr = start;
  
    while (words > 0 && *ptr++ == ZAP_PATTERN)
      words--;
  
    return words;
  }
  
  
  ___HIDDEN void check_fudge_used
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
    int s;
    int h;
  
    s = unzapped_words (___ps->stack_limit - ___MSECTION_FUDGE,
                        ___MSECTION_FUDGE);
  
    if (s > stack_fudge_used)
      stack_fudge_used = s;
  
    h = ___ps->hp - ___ps->heap_limit;
  
    if (h > heap_fudge_used)
      heap_fudge_used = h;
  
  #ifdef ___DEBUG_GARBAGE_COLLECT
    ___printf ("********* used fudge: stack = %d  heap = %d\n", s, h);
  #endif
  }
  
  #endif
  
  
  /*---------------------------------------------------------------------------*/
  
  #ifdef ___DEBUG_GARBAGE_COLLECT
  
  #define fatal_heap_overflow() fatal_heap_overflow_debug (__LINE__)
  
  ___HIDDEN void fatal_heap_overflow_debug
     ___P((int line),
          (line)
  int line;)
  
  #else
  
  ___HIDDEN void fatal_heap_overflow ___PVOID
  
  #endif
  {
    char *msgs[2];
  
  #ifdef ___DEBUG_GARBAGE_COLLECT
    ___printf ("fatal_heap_overflow called at mem.c:%d\n", line);
  #endif
  
    msgs[0] = "Heap overflow";
    msgs[1] = 0;
  
    ___fatal_error (msgs);
  }
  
  
  ___HIDDEN ___msection *next_msection_without_locking
     ___P((___processor_state ___ps,
           ___msection *ms),
          (___ps,
           ms)
  ___processor_state ___ps;
  ___msection *ms;)
  {
    ___msection *result;
  
    /*
     * This function allocates an msection from the list of free
     * msections.  This is done when a processor has used up all of the
     * space in its current reserved msection (either heap_msection for
     * a heap allocation or stack_msection for a stack allocation).
     * This operation must be done in a critical section because
     * multiple processors may exhaust their space concurrently, either
     * when doing a GC or when ___stack_limit or ___heap_limit are
     * called.  However, this mutual exclusion is the responsibility of
     * the caller of next_msection_without_locking.
     *
     * A spinlock is appropriate for this critical section because the
     * critical section takes very little time and the requests for new
     * msections happen relatively much less frequently.  An experiment
     * on a 2.6 GHz Intel Core i7 using a tight allocation loop of pairs
     * and ___MSECTION_SIZE=131072, indicates that the critical section
     * lasts 0.2 microseconds and next_msection_without_locking
     * is called every 300 microseconds.
     */
  
    if (nb_msections_assigned == 0)
      result = the_msections->head; /* start at head of free msections */
    else
      result = alloc_msection->next; /* move to next free msection */
  
    if (result == 0)
      {
        /*
         * If there are no free msections to allocate the next heap or
         * stack msection, it is possible to use ms for both the heap
         * allocations and stack allocations.  But if it is currently
         * the case that both use the same msection, then it is an error
         * because the garbage collector should have been called to free
         * some space.
         */
  
        if (stack_msection == heap_msection)
          fatal_heap_overflow ();
  
        result = ms;
      }
    else
      {
        alloc_msection = result;
        nb_msections_assigned++;
      }
  
    return result;
  }
  
  
  ___HIDDEN void set_stack_msection
     ___P((___processor_state ___ps,
           ___msection *ms),
          (___ps,
           ms)
  ___processor_state ___ps;
  ___msection *ms;)
  {
    stack_msection = ms;
  
    alloc_stack_limit = start_of_tospace(ms);
    alloc_stack_start = alloc_stack_limit + (___MSECTION_SIZE>>1);
    alloc_stack_ptr = alloc_stack_start;
  }
  
  
  ___HIDDEN void set_stack_msection_possibly_sharing_with_heap
     ___P((___processor_state ___ps,
           ___msection *ms),
          (___ps,
           ms)
  ___processor_state ___ps;
  ___msection *ms;)
  {
    set_stack_msection (___ps, ms);
  
    if (ms == heap_msection)
      {
        /*
         * The same msection will be used for the stack and the heap, so
         * adjust the heap and stack limits accordingly.  3/4 of the
         * remaining usable space is assigned to the stack.
         */
  
        ___SIZE_TS space = alloc_heap_limit - alloc_heap_ptr;
  
        if (space < 2*___MSECTION_FUDGE)
          fatal_heap_overflow ();
  
        space = (space - 2*___MSECTION_FUDGE) >> 2; /* 1/4 of usable space */
  
        alloc_heap_limit = alloc_heap_ptr + (space + ___MSECTION_FUDGE);
        alloc_stack_limit = alloc_stack_ptr - (3*space + ___MSECTION_FUDGE);
      }
  
  #ifdef ENABLE_CONSISTENCY_CHECKS
    if (___DEBUG_SETTINGS_LEVEL(___GSTATE->setup_params.debug_settings) >= 1)
      zap_section (alloc_stack_limit, alloc_stack_ptr);
  #endif
  }
  
  
  ___HIDDEN void stack_msection_stop_using
     ___P((___processor_state ___ps,
           ___WORD *stack_start,
           ___WORD *stack_ptr),
          (___ps,
           stack_start,
           stack_ptr)
  ___processor_state ___ps;
  ___WORD *stack_start;
  ___WORD *stack_ptr;)
  {
    words_prev_msections += stack_start - stack_ptr;
  }
  
  
  ___HIDDEN void stack_msection_resume_using
     ___P((___processor_state ___ps,
           ___WORD *stack_start,
           ___WORD *stack_ptr),
          (___ps,
           stack_start,
           stack_ptr)
  ___processor_state ___ps;
  ___WORD *stack_start;
  ___WORD *stack_ptr;)
  {
    words_prev_msections -= stack_start - stack_ptr;
  }
  
  
  ___HIDDEN void next_stack_msection_without_locking
     ___P((___processor_state ___ps),
          (___ps)
  ___processor_state ___ps;)
  {
    ___msection *ms;
    ms = next_msection_without_locking (___ps, heap_msection);
    set_stack_msection_possibly_sharing_with_heap (___ps, ms);
  }
  
  
  ___HIDDEN void next_stack_msection
     ___P((___processor_state ___ps),
          (___ps)
  ___processor_state ___ps;)
  {
    ___msection *ms;
    ALLOC_MEM_LOCK();
    ms = next_msection_without_locking (___ps, heap_msection);
    ALLOC_MEM_UNLOCK();
    set_stack_msection_possibly_sharing_with_heap (___ps, ms);
  }
  
  
  ___HIDDEN void start_heap_chunk
     ___P((___processor_state ___ps),
          (___ps)
  ___processor_state ___ps;)
  {
    alloc_heap_chunk_start = alloc_heap_ptr;
    alloc_heap_chunk_limit = alloc_heap_ptr + ___MSECTION_CHUNK;
  }
  
  
  #define NULL_CHUNK_LINK ___TAG(0, ___FORW)
  
  
  ___HIDDEN void end_heap_chunk
     ___P((___processor_state ___ps),
          (___ps)
  ___processor_state ___ps;)
  {
    /*
     * Add the end of chunk marker.
     *
     * This is done even when the chunk is empty, in case the chunk is
     * currently being scanned.
     */
  
    *alloc_heap_ptr++ = NULL_CHUNK_LINK; /* leave space for next chunk's link */
  
    if (alloc_heap_ptr != alloc_heap_chunk_start &&
        !(scan_ptr >= alloc_heap_chunk_start && scan_ptr < alloc_heap_ptr))
      {
        /*
         * The chunk being ended is not empty and it isn't currently
         * being scanned, so add it to the heap chunk FIFO and wake any
         * idle processor.
         */
  
        ___WORD *new_tail = alloc_heap_chunk_start-1;
  
  #ifndef ___SINGLE_THREADED_VMS
        ___SPINLOCK_LOCK(heap_chunks_to_scan_lock);
  #endif
  
        *heap_chunks_to_scan_tail = ___TAG(new_tail, ___FORW);
  
        /*
         * A memory barrier is needed to ensure that the content of the
         * chunk, including the end of chunk and the link to the chunk,
         * is visible to other processors.
         */
  
        ___SHARED_MEMORY_BARRIER();
  
        heap_chunks_to_scan_tail = new_tail;
  
        /*
         * A memory barrier is needed to ensure that the new tail of the
         * heap chunk FIFO are visible to other processors.  This can't
         * be combined with the previous memory barrier because the
         * ordering is important (as soon as the modification of
         * heap_chunks_to_scan_tail is observed by another processor, it
         * may attempt to read the content of the chunk).
         */
  
        ___SHARED_MEMORY_BARRIER();
  
  #ifndef ___SINGLE_THREADED_VMS
        ___SPINLOCK_UNLOCK(heap_chunks_to_scan_lock);
        ___CONDVAR_SIGNAL(scan_termination_condvar);
  #endif
      }
  }
  
  
  ___HIDDEN void set_heap_msection
     ___P((___processor_state ___ps,
           ___msection *ms),
          (___ps,
           ms)
  ___processor_state ___ps;
  ___msection *ms;)
  {
    heap_msection = ms;
  
    alloc_heap_start = start_of_tospace(ms);
    alloc_heap_limit = alloc_heap_start + (___MSECTION_SIZE>>1);
    alloc_heap_ptr = alloc_heap_start;
  }
  
  
  ___HIDDEN void set_heap_msection_possibly_sharing_with_stack
     ___P((___processor_state ___ps,
           ___msection *ms),
          (___ps,
           ms)
  ___processor_state ___ps;
  ___msection *ms;)
  {
    set_heap_msection (___ps, ms);
  
    if (ms == stack_msection)
      {
        /*
         * The same msection will be used for the stack and the heap, so
         * adjust the heap and stack limits accordingly.  3/4 of the
         * remaining usable space is assigned to the heap.
         */
  
        ___SIZE_TS space = alloc_stack_ptr - alloc_stack_limit;
  
        if (space < 2*___MSECTION_FUDGE)
          fatal_heap_overflow ();
  
        space = (space - 2*___MSECTION_FUDGE) >> 2; /* 1/4 of usable space */
  
        alloc_stack_limit = alloc_stack_ptr - (space + ___MSECTION_FUDGE);
        alloc_heap_limit = alloc_heap_ptr + (3*space + ___MSECTION_FUDGE);
      }
  
  #ifdef ENABLE_CONSISTENCY_CHECKS
    //  if (___DEBUG_SETTINGS_LEVEL(___GSTATE->setup_params.debug_settings) >= 1)
    //    zap_section (alloc_heap_ptr, alloc_heap_limit);
  #endif
  }
  
  
  ___HIDDEN void next_heap_msection_without_locking
     ___P((___processor_state ___ps),
          (___ps)
  ___processor_state ___ps;)
  {
    ___msection *ms;
    words_prev_msections += alloc_heap_ptr - alloc_heap_start;
    ms = next_msection_without_locking (___ps, stack_msection);
    set_heap_msection_possibly_sharing_with_stack (___ps, ms);
  }
  
  
  ___HIDDEN void next_heap_msection
     ___P((___processor_state ___ps),
          (___ps)
  ___processor_state ___ps;)
  {
    ___msection *ms;
    words_prev_msections += alloc_heap_ptr - alloc_heap_start;
    ALLOC_MEM_LOCK();
    ms = next_msection_without_locking (___ps, stack_msection);
    ALLOC_MEM_UNLOCK();
    set_heap_msection_possibly_sharing_with_stack (___ps, ms);
  }
  
  
  ___HIDDEN void prepare_heap_msection
     ___P((___processor_state ___ps),
          (___ps)
  ___processor_state ___ps;)
  {
    /*
     * Heap chunks are non-empty, except possibly for the last chunk in
     * the msection.  Consequently, an msection may end with 2
     * consecutive end of chunk markers.  One for the last non-empty
     * chunk and one for an empty chunk.  The heap allocation limit must
     * be adjusted to handle this case.
     */
  
    alloc_heap_limit -= 2; /* leave space for 2 end of chunk markers */
  
    *alloc_heap_ptr++ = NULL_CHUNK_LINK; /* link of msection's first chunk */
  
    start_heap_chunk (___ps);
  }
  
  
  ___HIDDEN void setup_stack_heap_vmstate
     ___P((___virtual_machine_state ___vms),
          (___vms)
  ___virtual_machine_state ___vms;)
  {
  #undef ___VMSTATE_MEM
  #define ___VMSTATE_MEM(var) ___vms->mem.var
  
    ___msection *alloc = the_msections->head;
    int np = ___vms->processor_count;
    int i;
  
    for (i=0; i<np; i++)
      {
        ___processor_state ___ps = &___vms->pstate[i];
  
        tospace_offset = fromspace_offset;  /* Flip fromspace and tospace */
  
        msection_free_list = 0;
  
        words_prev_msections = 0;
  
        stack_msection = 0;
        heap_msection = 0;
  
        set_stack_msection (___ps, alloc);
        alloc = alloc->next;
  
        alloc_msection = alloc;
  
        set_heap_msection (___ps, alloc);
        alloc = alloc->next;
  
        prepare_heap_msection (___ps);
        scan_ptr = alloc_heap_chunk_start;
  
        heap_chunks_to_scan = NULL_CHUNK_LINK;
        heap_chunks_to_scan_head = &heap_chunks_to_scan;
        heap_chunks_to_scan_tail = &heap_chunks_to_scan;
      }
  
    nb_msections_assigned = np*2;
  
  #ifndef ___SINGLE_THREADED_VMS
  
    /* Initialize the active scanning workers count */
  
    scan_workers_count[0] = np;
    scan_workers_count[1] = np;
  
  #endif
  
  #undef ___VMSTATE_MEM
  #define ___VMSTATE_MEM(var) ___VMSTATE_FROM_PSTATE(___ps)->mem.var
  }
  
  
  /*---------------------------------------------------------------------------*/
  
  #ifdef ENABLE_CONSISTENCY_CHECKS
  
  #define mark_array(start,n) mark_array_debug (start,n,__LINE__)
  
  ___HIDDEN void mark_array_debug
     ___P((___PSD
           ___WORD *start,
           ___WORD n,
           int line),
          (___PSV
           start,
           n,
           line)
  ___PSDKR
  ___WORD *start;
  ___WORD n;
  int line;)
  
  #else
  
  ___HIDDEN void mark_array
     ___P((___PSD
           ___WORD *start,
           ___WORD n),
          (___PSV
           start,
           n)
  ___PSDKR
  ___WORD *start;
  ___WORD n;)
  
  #endif
  {
    ___PSGET
    ___WORD *alloc = alloc_heap_ptr;
    ___WORD *limit = alloc_heap_limit;
  
  #ifdef ENABLE_CONSISTENCY_CHECKS
    mark_array_call_line = line;
  #endif
  
    while (n-- > 0)
      {
        ___WORD *cell = start++;
  
      again: /* looping back here is possible when tail marking */
        {
          ___WORD obj = *cell;
  
          if (___MEM_ALLOCATED(obj))
            {
              ___WORD *body;
              ___WORD head;
              int head_typ;
              int subtype;
  
  #ifdef ENABLE_CONSISTENCY_CHECKS
              if (___DEBUG_SETTINGS_LEVEL(___GSTATE->setup_params.debug_settings) >= 1)
                validate_old_obj (___PSP obj);
  #endif
  
              body = ___UNTAG(obj) + ___BODY_OFS;
              head = body[-1];
              subtype = ___HD_SUBTYPE(head);
              head_typ = ___HD_TYP(head);
  
              if (head_typ == ___MOVABLE0)
                {
                  ___SIZE_TS words = ___HD_WORDS(head);
  #if ___WS == 4
                  ___BOOL pad = 0;
                  while (alloc + words + (subtype >= ___sS64VECTOR ? 2 : 1) >
                         limit)
  #else
                  while (alloc + words + 1 > limit)
  #endif
                    {
                      alloc_heap_ptr = alloc;
                      end_heap_chunk (___ps);
                      next_heap_msection (___ps);
                      prepare_heap_msection (___ps);
                      alloc = alloc_heap_ptr;
                      limit = alloc_heap_limit;
                    }
  #if ___WS != 8
                  /*
                   * ___sS64VECTOR, ___sU64VECTOR, ___sF64VECTOR,
                   * ___sFLONUM and ___sBIGNUM need to be aligned on a
                   * multiple of 8.
                   */
                  if (subtype >= ___sS64VECTOR)
                    {
                      if ((___CAST(___WORD,alloc) & (8-1)) == 0)
                        *alloc++ = ___MAKE_HD_WORDS(0, ___sVECTOR);
                      else
                        pad = 1;
                    }
  #endif
                  *alloc++ = head;
  
  #ifdef ___SINGLE_THREADED_VMS
  
                  body[-1] = ___TAG((alloc - ___BODY_OFS), ___FORW);
  
  #else
  
                  {
                    ___WORD head_now =
                      ___COMPARE_AND_SWAP_WORD(&body[-1],
                                               head,
                                               ___TAG((alloc - ___BODY_OFS), ___FORW));
  
                    if (head_now != head)
                      {
                        /*
                         * Other processor forwarded the object first so
                         * the allocation must be undone and head_now is
                         * the correct forwarding pointer.
                         */
  
                        alloc--;
                        *cell = ___TAG(___UNTAG_AS(head_now, ___FORW), ___TYP(obj));
                        continue;
                      }
                  }
  
  #endif
  
                  *cell = ___TAG((alloc - ___BODY_OFS), ___TYP(obj));
  
                  if (words > 0 && subtype <= ___sBOXVALUES)
                    cell = alloc;
                  else
                    cell = 0;
  
                  while (words > 0)
                    {
                      *alloc++ = *body++;
                      words--;
                    }
  #if ___WS == 4
                  if (pad)
                    *alloc++ = ___MAKE_HD_WORDS(0, ___sVECTOR);
  #endif
                  if (alloc >= alloc_heap_chunk_limit)
                    {
                      alloc_heap_ptr = alloc;
                      end_heap_chunk (___ps);
                      start_heap_chunk (___ps);
                      alloc = alloc_heap_ptr;
                    }
  
                  if (cell != 0) goto again;
                }
              else if (head_typ == ___STILL)
                {
  #ifdef ___SINGLE_THREADED_VMS
  
                  if (body[___STILL_MARK_OFS - ___STILL_BODY_OFS] == -1)
                    {
                      body[___STILL_MARK_OFS - ___STILL_BODY_OFS]
                        = ___CAST(___WORD,still_objs_to_scan);
                      still_objs_to_scan
                        = ___CAST(___WORD,body - ___STILL_BODY_OFS);
                    }
  
  #else
  
                  if (___COMPARE_AND_SWAP_WORD(&body[___STILL_MARK_OFS - ___STILL_BODY_OFS],
                                               -1,
                                               ___CAST(___WORD,still_objs_to_scan))
                      == -1)
                    {
                      still_objs_to_scan
                        = ___CAST(___WORD,body - ___STILL_BODY_OFS);
                    }
  #endif
                }
              else if (___TYP(head_typ) == ___FORW)
                {
                  *cell = ___TAG(___UNTAG_AS(head, ___FORW), ___TYP(obj));
                }
  #ifdef ENABLE_CONSISTENCY_CHECKS
              else if (___DEBUG_SETTINGS_LEVEL(___GSTATE->setup_params.debug_settings) >= 1 &&
                       head_typ != ___PERM)
                bug (___PSP obj, 0, "was not ___PERM, ___STILL, ___MOVABLE0 or ___FORW");
  #endif
            }
        }
      }
  
    alloc_heap_ptr = alloc;
  }
  
  
  ___HIDDEN void mark_captured_continuation
     ___P((___PSD
           ___WORD *orig_ptr),
          (___PSV
           orig_ptr)
  ___PSDKR
  ___WORD *orig_ptr;)
  {
    ___PSGET
    ___WORD *ptr = orig_ptr;
    int fs, link, i;
    ___WORD *fp;
    ___WORD ra1;
    ___WORD ra2;
    ___WORD cf;
  
    cf = *ptr;
  
  #ifdef SHOW_FRAMES
    ___printf ("mark_captured_continuation cf=%p\n", ___CAST(void*,cf));
  #endif
  
    if (___TYP(cf) == ___tFIXNUM && cf != ___END_OF_CONT_MARKER)
      {
        /* continuation frame is in the stack */
  
        ___WORD *alloc = alloc_heap_ptr;
        ___WORD *limit = alloc_heap_limit;
  
        MISC_MEM_LOCK();
  
        next_frame:
  
        fp = ___CAST(___WORD*,cf);
  
        ra1 = ___FP_STK(fp,-___FRAME_STACK_RA);
  
  #ifdef SHOW_FRAMES
          ___printf ("  frame [ra=%p] ", ___CAST(void*,ra1));
  #endif
  
        if (ra1 == ___GSTATE->internal_return)
          {
            ___WORD actual_ra = ___FP_STK(fp,___RETI_RA);
            ___RETI_GET_FS_LINK(actual_ra,fs,link)
            ___COVER_MARK_CAPTURED_CONTINUATION_RETI;
          }
        else
          {
            ___RETN_GET_FS_LINK(ra1,fs,link)
            ___COVER_MARK_CAPTURED_CONTINUATION_RETN;
          }
  
  #ifdef SHOW_FRAMES
          ___printf ("fs=%d link=%d fp=%p ra=", fs, link, fp);
          print_value (ra1);
          ___printf ("\n");
  #endif
  
        ___FP_ADJFP(fp,-___FRAME_SPACE(fs)) /* get base of frame */
  
        ra2 = ___FP_STK(fp,link+1);
  
        if (___TYP(ra2) == ___tFIXNUM)
          {
            ___COVER_MARK_CAPTURED_CONTINUATION_ALREADY_COPIED;
            *ptr = ra2; /* already copied, replace by forwarding pointer */
          }
        else
          {
            ___WORD forw;
            ___SIZE_TS words;
  
            ___COVER_MARK_CAPTURED_CONTINUATION_COPY;
  
            words = fs + ___FRAME_EXTRA_SLOTS;
  
            while (alloc + words + ___SUBTYPED_OVERHEAD > limit)
              {
                alloc_heap_ptr = alloc;
                end_heap_chunk (___ps);
                next_heap_msection (___ps);
                prepare_heap_msection (___ps);
                alloc = alloc_heap_ptr;
                limit = alloc_heap_limit;
              }
  
            *alloc++ = ___MAKE_HD_WORDS(words, ___sFRAME);
  #if ___SUBTYPED_OVERHEAD != 1
            #error "___SUBTYPED_OVERHEAD != 1"
  #endif
            forw = ___TAG((alloc - ___BODY_OFS), ___tFIXNUM);
            *alloc++ = ra1;
  #if ___FRAME_EXTRA_SLOTS != 1
            #error "___FRAME_EXTRA_SLOTS != 1"
  #endif
  
            for (i=fs; i>0; i--)
              *alloc++ = ___FP_STK(fp,i);
  
            if (ra2 == ___GSTATE->handler_break)
              {
                /* first frame of that section */
  
                ___COVER_MARK_CAPTURED_CONTINUATION_FIRST_FRAME;
  
                cf = ___FP_STK(fp,-___BREAK_FRAME_NEXT);
              }
            else
              {
                /* not the first frame of that section */
  
                ___COVER_MARK_CAPTURED_CONTINUATION_NOT_FIRST_FRAME;
  
                ___FP_SET_STK(fp,-___FRAME_STACK_RA,ra2)
                cf = ___CAST(___WORD,fp);
              }
  
            ___FP_SET_STK(alloc,link+1,cf)
            ___FP_SET_STK(fp,link+1,forw) /* leave a forwarding pointer */
  
            *ptr = forw;
  
            ptr = &___FP_STK(alloc,link+1);
  
            if (alloc_heap_ptr >= alloc_heap_chunk_limit)
              {
                alloc_heap_ptr = alloc;
                end_heap_chunk (___ps);
                start_heap_chunk (___ps);
                alloc = alloc_heap_ptr;
              }
  
            if (___TYP(cf) == ___tFIXNUM && cf != ___END_OF_CONT_MARKER)
              goto next_frame;
          }
  
        *orig_ptr = ___TAG(___UNTAG_AS(*orig_ptr, ___tFIXNUM), ___tSUBTYPED);
  
        alloc_heap_ptr = alloc;
  
        MISC_MEM_UNLOCK();
      }
    else
      mark_array (___PSP orig_ptr, 1);
  }
  
  
  ___HIDDEN void mark_frame
     ___P((___PSD
           ___WORD *fp,
           int fs,
           ___WORD gcmap,
           ___WORD *nextgcmap),
          (___PSV
           fp,
           fs,
           gcmap,
           nextgcmap)
  ___PSDKR
  ___WORD *fp;
  int fs;
  ___WORD gcmap;
  ___WORD *nextgcmap;)
  {
    int i = 1;
  
  #ifdef SHOW_FRAMESzzz
  
    {
      int k = 1;
      while (k <= fs)
        {
          ___WORD obj = ___FP_STK(fp,k);
          ___printf ("  %2d: ", k);
          print_value (obj);
          ___printf ("\n");
          k++;
        }
    }
  
  #endif
  
    for (;;)
      {
        if (gcmap & 1)
          {
            int j = i;
            do
              {
                if (i == fs)
                  {
  #ifdef SHOW_FRAMES
                    {
                      int k = j;
                      while (k <= i)
                        {
                          ___WORD obj = ___FP_STK(fp,k);
                          ___printf ("  %2d: ", k);
                          print_value (obj);
                          ___printf ("\n");
                          k++;
                        }
                    }
  #endif
                    mark_array (___PSP &___FP_STK(fp,i), i-j+1);
                    return;
                  }
                if ((i & (___WORD_WIDTH-1)) == 0)
                  gcmap = *nextgcmap++;
                else
                  gcmap >>= 1;
                i++;
              } while (gcmap & 1);
  #ifdef SHOW_FRAMES
            {
              int k = j;
              while (k < i)
                {
                  ___WORD obj = ___FP_STK(fp,k);
                  ___printf ("  %2d: ", k);
                  print_value (obj);
                  ___printf ("\n");
                  k++;
                }
            }
  #endif
            mark_array (___PSP &___FP_STK(fp,i-1), i-j);
          }
        if (i == fs)
          return;
        if ((i & (___WORD_WIDTH-1)) == 0)
        {
          gcmap = *nextgcmap++;
  #ifdef SHOW_FRAMES
    ___printf ("gcmap = 0x%016x\n", gcmap);
  #endif
        }
        else
          gcmap >>= 1;
        i++;
      }
  }
  
  
  ___HIDDEN void mark_continuation
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
    int fs, link;
    ___WORD *fp;
    ___WORD ra1;
    ___WORD ra2;
    ___WORD gcmap;
    ___WORD *nextgcmap = 0;
  
  #ifdef ENABLE_CONSISTENCY_CHECKS
    reference_location = IN_CONTINUATION;
  #endif
  
    fp = ___ps->fp;
  
  #ifdef SHOW_FRAMES
    ___printf ("mark_continuation fp=%p\n", fp);
  #endif
  
    if (fp != ___ps->stack_break)
      for (;;)
        {
          ra1 = ___FP_STK(fp,-___FRAME_STACK_RA);
  
  #ifdef SHOW_FRAMES
          ___printf ("  frame [ra=%p] ", ___CAST(void*,ra1));
  #endif
  
          if (ra1 == ___GSTATE->internal_return)
            {
              ___WORD actual_ra = ___FP_STK(fp,___RETI_RA);
              ___RETI_GET_FS_LINK_GCMAP(actual_ra,fs,link,gcmap,nextgcmap)
              ___COVER_MARK_CONTINUATION_RETI;
            }
          else
            {
              ___RETN_GET_FS_LINK_GCMAP(ra1,fs,link,gcmap,nextgcmap)
              ___COVER_MARK_CONTINUATION_RETN;
            }
  
  #ifdef SHOW_FRAMES
          ___printf ("fs=%d link=%d fp=%p ra=", fs, link, fp);
          print_value (ra1);
  #endif
  
          ___FP_ADJFP(fp,-___FRAME_SPACE(fs)) /* get base of frame */
  
          ra2 = ___FP_STK(fp,link+1);
  
  #ifdef SHOW_FRAMES
          if (fp == ___ps->stack_break)
            ___printf ("  (first frame above break frame)\n");
  #endif
  
          mark_frame (___PSP fp, fs, gcmap, nextgcmap);
  
          if (fp == ___ps->stack_break)
            break;
  
          ___FP_SET_STK(fp,-___FRAME_STACK_RA,ra2)
        }
  
    mark_captured_continuation (___PSP &___FP_STK(fp,-___BREAK_FRAME_NEXT));
  }
  
  
  ___HIDDEN void mark_rc
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
    ___rc_header *h = rc_head.next;
  
  #ifdef ENABLE_CONSISTENCY_CHECKS
    reference_location = IN_RC;
  #endif
  
    while (h != &rc_head)
      {
        ___rc_header *next = h->next;
        mark_array (___PSP &h->data, 1);
        h = next;
      }
  }
  
  
  #define UNMARKED_MOVABLE(obj) \
  ((unmarked_typ = ___HD_TYP((unmarked_body=___BODY(obj))[-1])) == ___MOVABLE0)
  
  #define UNMARKED_STILL(obj) \
  (unmarked_typ == ___STILL && \
   unmarked_body[___STILL_MARK_OFS - ___STILL_BODY_OFS] == -1)
  
  #define UNMARKED(obj) \
  (UNMARKED_MOVABLE(obj) || UNMARKED_STILL(obj))
  
  
  ___HIDDEN ___SIZE_TS scan
     ___P((___PSD
           ___WORD *body),
          (___PSV
           body)
  ___PSDKR
  ___WORD *body;)
  {
    ___PSGET
    ___WORD head = body[-1];
    ___SIZE_TS words = ___HD_WORDS(head);
    int subtype = ___HD_SUBTYPE(head);
  
  #ifdef ENABLE_CONSISTENCY_CHECKS
    reference_location = IN_OBJECT;
    container_body = body;
  #endif
  
    switch (subtype)
      {
      case ___sFOREIGN:
      case ___sSTRING:
      case ___sS8VECTOR:
      case ___sU8VECTOR:
      case ___sS16VECTOR:
      case ___sU16VECTOR:
      case ___sS32VECTOR:
      case ___sU32VECTOR:
      case ___sS64VECTOR:
      case ___sU64VECTOR:
      case ___sF32VECTOR:
      case ___sF64VECTOR:
      case ___sFLONUM:
      case ___sBIGNUM:
        break;
  
      case ___sWEAK:
        if (words == ___WILL_SIZE)
          {
            /* Object is a will */
  
            /*
             * The will contains a weak reference to its testator object
             * and a strong reference to the action procedure.
             * Consequently, the action procedure must be marked and,
             * only if traverse_weak_refs is true, the testator object
             * is also marked.  The link field is never scanned.
             */
  
            if (traverse_weak_refs)
              mark_array (___PSP body+1, 2); /* scan action and testator */
            else
              {
                mark_array (___PSP body+2, 1); /* scan action only */
  
                /*
                 * Remember that this will's testator object remains to
                 * be marked by the process_wills function.
                 */
  
                body[0] = body[0] | ___UNMARKED_TESTATOR_WILL;
              }
          }
        else
          {
            /* Object is a GC hash table */
  
            int flags = ___INT(body[___GCHASHTABLE_FLAGS]);
            int i;
  
            if ((flags & ___GCHASHTABLE_FLAG_WEAK_KEYS) == 0 &&
                (flags & ___GCHASHTABLE_FLAG_MEM_ALLOC_KEYS))
              {
                for (i=words-2; i>=___GCHASHTABLE_KEY0; i-=2)
                  mark_array (___PSP body+i, 1); /* mark objects in key fields */
              }
  
            if ((flags & ___GCHASHTABLE_FLAG_WEAK_VALS) == 0)
              {
                for (i=words-1; i>=___GCHASHTABLE_VAL0; i-=2)
                  mark_array (___PSP body+i, 1); /* mark objects in value fields */
              }
  
            body[0] = reached_gc_hash_tables;
            reached_gc_hash_tables = ___TAG((body-1),0);
          }
        break;
  
      case ___sSYMBOL:
      case ___sKEYWORD:
        mark_array (___PSP body, 1); /* only scan name of symbols & keywords */
        break;
  
      case ___sCONTINUATION:
        mark_captured_continuation (___PSP &body[___CONTINUATION_FRAME]);
        mark_array (___PSP body+1, words-1); /* skip the frame pointer */
        break;
  
      case ___sFRAME:
        {
          int fs, link;
          ___WORD *fp = body + ___FRAME_EXTRA_SLOTS;
          ___WORD ra = body[0];
          ___WORD gcmap;
          ___WORD *nextgcmap = 0;
          ___WORD frame;
  
  #ifdef SHOW_FRAMES
          ___printf ("___sFRAME object\n");
          ___printf ("  frame [ra=%p] ", ___CAST(void*,ra));
  #endif
  
          if (ra == ___GSTATE->internal_return)
            {
              ___WORD actual_ra = body[___FRAME_RETI_RA];
              ___RETI_GET_FS_LINK_GCMAP(actual_ra,fs,link,gcmap,nextgcmap)
              ___COVER_SCAN_FRAME_RETI;
            }
          else
            {
              ___RETN_GET_FS_LINK_GCMAP(ra,fs,link,gcmap,nextgcmap)
              ___COVER_SCAN_FRAME_RETN;
            }
  
  #ifdef SHOW_FRAMES
          ___printf ("fs=%d link=%d fp=%p ra=", fs, link, fp);
          print_value (ra);
          ___printf ("\n");
  #endif
  
          fp += fs;
  
          frame = ___FP_STK(fp,link+1);
  
          if (___TYP(frame) == ___tFIXNUM && frame != ___END_OF_CONT_MARKER)
            ___FP_SET_STK(fp,link+1,___FAL)
  
          mark_frame (___PSP fp, fs, gcmap, nextgcmap);
  
          if (___TYP(frame) == ___tFIXNUM && frame != ___END_OF_CONT_MARKER)
            ___FP_SET_STK(fp,link+1,___TAG(___UNTAG_AS(frame, ___tFIXNUM), ___tSUBTYPED))
  
          mark_array (___PSP &body[0], 1);
        }
        break;
  
      case ___sPROCEDURE:
  
        /*
         * The object can only be a closure (nonclosures are permanent objects).
         */
  
        mark_array (___PSP body+1, words-1); /* only scan free variables */
  
        break;
  
      default:
  
        if (___HD_TYP(head) == ___MOVABLE0 && subtype <= ___sBOXVALUES)
          mark_array (___PSP body+1, words-1);
        else
          mark_array (___PSP body, words);
  
        break;
      }
  
    return words;
  }
  
  
  ___HIDDEN void setup_still_objs_to_scan
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
    ___WORD *base = ___CAST(___WORD*,still_objs);
    ___WORD *to_scan = 0;
  
    while (base != 0)
      {
        if (base[___STILL_REFCOUNT_OFS] == 0)
          base[___STILL_MARK_OFS] = -1;
        else
          {
            base[___STILL_MARK_OFS] = ___CAST(___WORD,to_scan);
            to_scan = base;
          }
        base = ___CAST(___WORD*,base[___STILL_LINK_OFS]);
      }
  
    still_objs_to_scan = ___CAST(___WORD,to_scan);
  }
  
  
  ___HIDDEN void scan_still_objs_to_scan
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
    ___WORD *base;
  
    while ((base = ___CAST(___WORD*,still_objs_to_scan)) != 0)
      {
        still_objs_to_scan = base[___STILL_MARK_OFS];
        scan (___PSP base + ___STILL_BODY_OFS);
      }
  }
  
  
  ___HIDDEN void scan_complete_heap_chunk
     ___P((___PSD
           ___WORD *start),
          (___PSV
           start)
  ___PSDKR
  ___WORD *start;)
  {
    ___PSGET
    ___WORD *ptr = start;
  
  #ifdef ENABLE_GC_ACTLOG_SCAN_COMPLETE_HEAP_CHUNK
    ___ACTLOG_BEGIN_PS(scan_complete_heap_chunk,_);
  #endif
  
    while (___TYP(*ptr) != ___FORW) /* not end of complete chunk? */
      {
        ptr++;
        ptr += scan (___PSP ptr);
      }
  
  #ifdef ENABLE_GC_ACTLOG_SCAN_COMPLETE_HEAP_CHUNK
    ___ACTLOG_END_PS();
  #endif
  }
  
  
  ___HIDDEN void scan_movable_objs_to_scan
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
  
    /*
  
      SITUATION #1: scanning a complete chunk
  
       chunk 1  chunk 2   chunk 3   incomplete chunk
      +-------+---------+---------+------------------+-----
      |L      |L        |L        |L                 |
      +-------+---------+---------+------------------+-----
                   ^                                  ^
            scan_ptr                                  alloc_heap_ptr
  
  
      SITUATION #2: scanning the incomplete chunk
  
       chunk 1  chunk 2   chunk 3   incomplete chunk
      +-------+---------+---------+------------------+-----
      |L      |L        |L        |L                 |
      +-------+---------+---------+------------------+-----
                                           ^          ^
                                    scan_ptr          alloc_heap_ptr
  
  
      SITUATION #3: done scanning all movable objects
  
       chunk 1  chunk 2   chunk 3   incomplete chunk
      +-------+---------+---------+------------------+-----
      |L      |L        |L        |L                 |
      +-------+---------+---------+------------------+-----
                                                      ^
                                              scan_ptr alloc_heap_ptr
  
       L = link to next chunk tagged with ___FORW
  
     */
  
    ___WORD *ptr = scan_ptr;
    ___VOLATILE ___WORD *hcsh;
  
    while (ptr != alloc_heap_ptr) /* SITUATION #1 or #2 ? */
      {
        while (___TYP(*ptr) != ___FORW) /* not end of complete chunk? */
          {
            ptr++;
            ptr += scan (___PSP ptr);
            if (ptr == alloc_heap_ptr) /* end of incomplete chunk? */
              {
                /* SITUATION #3, done scanning all movable objects */
                scan_ptr = ptr;
                return;
              }
          }
  
        scan_ptr = ptr; /* remember where scan ended */
  
        /*
         * SITUATION #1, at end of complete chunk.
         */
  
        ___SPINLOCK_LOCK(heap_chunks_to_scan_lock);
  
        while ((hcsh=heap_chunks_to_scan_head) != heap_chunks_to_scan_tail)
          {
            /*
             * Get the next complete heap chunk from heap chunk FIFO and
             * scan it.
             */
  
            ptr = ___UNTAG_AS(*hcsh, ___FORW);
  
            heap_chunks_to_scan_head = ptr;
  
            ___SHARED_MEMORY_BARRIER(); /* share heap_chunks_to_scan_head */
  
            ___SPINLOCK_UNLOCK(heap_chunks_to_scan_lock);
  
            scan_complete_heap_chunk (___PSP ptr+1);
  
            ___SPINLOCK_LOCK(heap_chunks_to_scan_lock);
          }
  
        ___SPINLOCK_UNLOCK(heap_chunks_to_scan_lock);
  
        /*
         * Scan the incomplete heap chunk currently being created.
         */
  
        ptr = alloc_heap_chunk_start;
  
        scan_ptr = ptr;
      }
  }
  
  
  ___HIDDEN void free_unmarked_still_objs
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
    ___WORD *last = &still_objs;
    ___WORD *base = ___CAST(___WORD*,*last);
    ___SIZE_TS live_words_still = 0;
  
    while (base != 0)
      {
        ___WORD link = base[___STILL_LINK_OFS];
        if (base[___STILL_MARK_OFS] == -1)
          {
            ___WORD head = base[___STILL_BODY_OFS-1];
            if (___HD_SUBTYPE(head) == ___sFOREIGN)
              ___release_foreign
                (___TAG((base + ___STILL_BODY_OFS - ___BODY_OFS), ___tSUBTYPED));
            free_mem_aligned (base);
          }
        else
          {
            live_words_still += base[___STILL_LENGTH_OFS];
            *last = ___CAST(___WORD,base);
            last = base + ___STILL_LINK_OFS;
          }
        base = ___CAST(___WORD*,link);
      }
  
    *last = 0;
  
    words_still_objs = live_words_still;
    words_still_objs_deferred = 0;
  
    /*
     * In principle the occupied_words_still could be updated here but
     * this would require acquiring a lock, so instead the
     * occupied_words_still will be recomputed from all of the
     * processor's words_still_objs when computing the space occupied by
     * live objects prior to resizing the heap.
     */
  }
  
  
  ___HIDDEN void free_still_objs
     ___P((___processor_state ___ps),
          (___ps)
  ___processor_state ___ps;)
  {
    ___WORD *base = ___CAST(___WORD*,still_objs);
  
    still_objs = 0;
  
    while (base != 0)
      {
        ___WORD link = base[___STILL_LINK_OFS];
        ___WORD head = base[___STILL_BODY_OFS-1];
        if (___HD_SUBTYPE(head) == ___sFOREIGN)
          ___release_foreign
            (___TAG((base + ___STILL_BODY_OFS - ___BODY_OFS), ___tSUBTYPED));
        free_mem_aligned (base);
        base = ___CAST(___WORD*,link);
      }
  }
  
  
  #define SET_MAX(var,val) do { if ((var) < (val)) var = val; } while (0)
  #define SET_MIN(var,val) do { if ((var) > (val)) var = val; } while (0)
  
  
  ___HIDDEN ___SIZE_TS adjust_heap
     ___P((___SIZE_TS live),
          (live)
  ___SIZE_TS live;)
  {
    ___SIZE_TS target;
  
    if (___GSTATE->setup_params.adjust_heap_hook != 0)
      return ___GSTATE->setup_params.adjust_heap_hook (live);
  
    if (___GSTATE->setup_params.live_percent < 100)
      target = live / ___GSTATE->setup_params.live_percent * 100;
    else
      target = live + ___MSECTION_BIGGEST;
  
    SET_MAX(target,
            ___CAST(___SIZE_TS,(___GSTATE->setup_params.min_heap >> ___LWS)));
  
    if (___GSTATE->setup_params.max_heap > 0)
      SET_MIN(target,
              ___CAST(___SIZE_TS,(___GSTATE->setup_params.max_heap >> ___LWS)));
  
    return target;
  }
  
  
  ___HIDDEN void prepare_mem_pstate
     ___P((___processor_state ___ps),
          (___ps)
  ___processor_state ___ps;)
  {
    ___SIZE_TS avail;
    ___SIZE_TS stack_avail;
    ___SIZE_TS stack_left_before_fudge;
    ___SIZE_TS heap_avail;
    ___SIZE_TS heap_left_before_fudge;
  
  #ifdef ___CALL_GC_FREQUENTLY
    avail = 0;
    ___ps->mem.gc_calls_to_punt_ = 2000;
  #else
    avail = compute_free_heap_space()/2;
    SET_MAX(avail,0);
  #endif
  
    stack_avail = avail/2;
    stack_left_before_fudge = (alloc_stack_ptr - alloc_stack_limit)
                              - ___MSECTION_FUDGE;
  
    ___ps->fp = alloc_stack_ptr;
    ___ps->stack_limit = alloc_stack_ptr
                         - ((stack_avail < stack_left_before_fudge)
                            ? stack_avail
                            : stack_left_before_fudge);
  
    heap_avail = avail - stack_avail;
    heap_left_before_fudge = (alloc_heap_limit - alloc_heap_ptr)
                             - ___MSECTION_FUDGE;
  
    ___ps->hp = alloc_heap_ptr;
    ___ps->heap_limit = alloc_heap_ptr
                        + ((heap_avail < heap_left_before_fudge)
                           ? heap_avail
                           : heap_left_before_fudge);
  
    /* set stack overflow and interrupt detection limit */
  
    ___begin_interrupt_service_pstate (___ps);
    ___end_interrupt_service_pstate (___ps, 0);
  
  #ifdef ENABLE_CONSISTENCY_CHECKS
    if (___DEBUG_SETTINGS_LEVEL(___GSTATE->setup_params.debug_settings) >= 1)
      {
        ___WORD *end = ___ps->stack_limit;
        ___WORD *start = end - ___MSECTION_FUDGE;
        if (end > alloc_stack_ptr)
          end = alloc_stack_ptr;
        zap_section (start, end);
        if (___DEBUG_SETTINGS_LEVEL(___GSTATE->setup_params.debug_settings) == 3)
          {
            ___printf ("heap_size          = %d\n", heap_size);
            ___printf ("avail              = %d\n", avail);
            ___printf ("stack_avail        = %d\n", stack_avail);
            ___printf ("heap_avail         = %d\n", heap_avail);
            ___printf ("stack_msection     = %p\n", stack_msection);
            ___printf ("heap_msection      = %p\n", heap_msection);
            ___printf ("___ps->stack_start = %p\n", ___ps->stack_start);
            ___printf ("___ps->stack_break = %p\n", ___ps->stack_break);
            ___printf ("___ps->fp          = %p\n", ___ps->fp);
            ___printf ("alloc_stack_ptr    = %p\n", alloc_stack_ptr);
            ___printf ("___ps->stack_limit = %p\n", ___ps->stack_limit);
            ___printf ("alloc_stack_limit  = %p\n", alloc_stack_limit);
            ___printf ("alloc_heap_limit   = %p\n", alloc_heap_limit);
            ___printf ("___ps->heap_limit  = %p\n", ___ps->heap_limit);
            ___printf ("___ps->hp          = %p\n", ___ps->hp);
            ___printf ("alloc_heap_ptr     = %p\n", alloc_heap_ptr);
            ___printf ("alloc_heap_start   = %p\n", alloc_heap_start);
          }
      }
  #endif
  }
  
  
  ___SCMOBJ ___setup_mem_pstate
     ___P((___processor_state ___ps),
          (___ps)
  ___processor_state ___ps;)
  {
    ___virtual_machine_state ___vms = ___VMSTATE_FROM_PSTATE(___ps);
    ___SCMOBJ err;
  
    /*
     * Setup processor's activity log.
     */
  
    if ((err = ___setup_actlog_pstate (___ps)) != ___FIX(___NO_ERR))
      return err;
  
    /*
     * Setup location of tospace.
     */
  
    tospace_offset = ___vms->pstate[0].mem.tospace_offset_;
  
    ___SPINLOCK_INIT(heap_chunks_to_scan_lock);
  
    /*
     * Allocate processor's stack and heap.
     */
  
    msection_free_list = 0;
  
    words_prev_msections = 0;
  
    stack_msection = 0;
    alloc_stack_start = 0;
    alloc_stack_ptr = 0;
  
    heap_msection = 0;
    alloc_heap_start = 0;
    alloc_heap_ptr = 0;
  
    next_stack_msection (___ps); /* allocate one msection for stack */
    next_heap_msection (___ps);  /* allocate one msection for local heap */
  
    /* Setup list of still objects. */
  
    still_objs = 0;
    words_still_objs = 0;
    words_still_objs_deferred = 0;
  
    /* Keep track of bytes allocated */
  
    bytes_allocated_minus_occupied = 0.0;
  
    /*
     * Setup reference counted memory management.
     */
  
    setup_rc (___ps);
  
    /*
     * Create "break frame" of initial top section.
     */
  
    ___ps->stack_start = alloc_stack_start;
    alloc_stack_ptr = alloc_stack_start;
  
    ___FP_ADJFP(alloc_stack_ptr,___FIRST_BREAK_FRAME_SPACE)
    ___FP_SET_STK(alloc_stack_ptr,-___BREAK_FRAME_NEXT,___END_OF_CONT_MARKER)
  
    ___ps->stack_break = alloc_stack_ptr;
  
    /*
     * Setup will lists.
     */
  
    nonexecutable_wills = ___TAG(0,0); /* tagged empty list */
    executable_wills = ___TAG(0,___EXECUTABLE_WILL); /* tagged empty list */
  
  #ifdef ___DEBUG_CTRL_FLOW_HISTORY
  
    {
      int i;
      ___ps->ctrl_flow_history_index = 0;
      for (i=___CTRL_FLOW_HISTORY_LENGTH-1; i>=0; i--)
        ___ps->ctrl_flow_history[i].line = 0;
    }
  
  #endif
  
  #ifdef ___DEBUG_STACK_LIMIT
    ___ps->poll_location.line = 0;
    ___ps->stack_limit_location.line = 0;
  #endif
  
  #ifdef ___DEBUG_HEAP_LIMIT
    ___ps->check_heap_location.line = 0;
    ___ps->heap_limit_location.line = 0;
  #endif
  
  #ifdef ___HEARTBEAT_USING_POLL_COUNTDOWN
    ___ps->heartbeat_interval = ___HEARTBEAT_USING_POLL_COUNTDOWN;
    ___ps->heartbeat_countdown = ___ps->heartbeat_interval;
  #endif
  
    prepare_mem_pstate (___ps);
  
    return err;
  }
  
  
  ___SCMOBJ ___setup_mem_vmstate
     ___P((___virtual_machine_state ___vms),
          (___vms)
  ___virtual_machine_state ___vms;)
  {
  #undef ___VMSTATE_MEM
  #define ___VMSTATE_MEM(var) ___vms->mem.var
  
    int init_nb_sections;
  
  #ifndef ___SINGLE_THREADED_VMS
  
    /*
     * Initialize spinlock for VM level memory allocation.
     */
  
    ___SPINLOCK_INIT(misc_mem_lock);
    ___SPINLOCK_INIT(alloc_mem_lock);
  
    /*
     * Initialize condition variable to determine end of scan at VM level.
     */
  
    ___MUTEX_INIT(scan_termination_mutex);
    ___CONDVAR_INIT(scan_termination_condvar);
  
  #endif
  
  #ifndef ___SINGLE_VM
  
    /*
     * Add to tail of virtual machine circular list.
     */
  
    ___MUTEX_LOCK(___GSTATE->vm_list_mut);
  
    {
      ___virtual_machine_state head = &___GSTATE->vmstate0;
      ___virtual_machine_state tail = head->prev;
  
      ___vms->prev = tail;
      ___vms->next = head;
      head->prev = ___vms;
      tail->next = ___vms;
    }
  
    ___MUTEX_UNLOCK(___GSTATE->vm_list_mut);
  
    /* TODO: implement expansion of glos array when number of globals grows beyond 20000 */
  
    { int n = 20000;
      ___vms->glos = ___CAST(___SCMOBJ*,___ALLOC_MEM(n * sizeof (___SCMOBJ)));
      while (--n>=0) { ___vms->glos[n] = ___UNB1; }
    }
  
  #endif
  
    /*
     * It is important to initialize the_msections first so
     * that if the program terminates early the procedure
     * ___cleanup_mem_vmstate will not access dangling pointers.
     */
  
    the_msections = 0;
  
    /*
     * Setup location of tospace.
     */
  
    ___vms->pstate[0].mem.tospace_offset_ = 0;
  
    /*
     * Set the overflow reserve so that the rest parameter handler can
     * construct the rest parameter list without having to call the
     * garbage collector.
     */
  
    normal_overflow_reserve = 2*((___MAX_NB_PARMS+___SUBTYPED_OVERHEAD) +
                                 ___MAX_NB_ARGS*(___PAIR_SIZE+___PAIR_OVERHEAD));
    overflow_reserve = normal_overflow_reserve;
  
    /* Setup GC statistics */
  
    nb_gcs = 0.0;
    gc_user_time = 0.0;
    gc_sys_time = 0.0;
    gc_real_time = 0.0;
  
    latest_gc_real_time = 0.0;
    latest_gc_heap_size = ___CAST(___F64,heap_size) * ___WS;
    latest_gc_live = 0.0;
    latest_gc_movable = 0.0;
    latest_gc_still = 0.0;
  
    /* Allocate msections of VM */
  
    init_nb_sections =
      ___MIN_NB_MSECTIONS_PER_PROCESSOR * ___vms->processor_count +
      ___CEILING_DIV((___GSTATE->setup_params.min_heap >> ___LWS) +
                     normal_overflow_reserve,
                     ___MSECTION_SIZE - 2*___MSECTION_FUDGE);
  
    adjust_msections (&the_msections, init_nb_sections);
  
    if (the_msections == 0 ||
        the_msections->nb_sections != init_nb_sections)
      return ___FIX(___HEAP_OVERFLOW_ERR);
  
    occupied_words_movable = 0;
    occupied_words_still = 0;
  
    nb_msections_assigned = 0;
  
    heap_size = compute_heap_space();
  
    return ___FIX(___NO_ERR);
  
  #undef ___VMSTATE_MEM
  #define ___VMSTATE_MEM(var) ___VMSTATE_FROM_PSTATE(___ps)->mem.var
  }
  
  
  ___SCMOBJ ___setup_mem ___PVOID
  {
    if (___GSTATE->setup_params.min_heap == 0)
      {
        /*
         * Choose a reasonable minimum heap size.
         */
  
        ___GSTATE->setup_params.min_heap = ___cpu_cache_size (0, 0) / 2;
  
        SET_MAX(___GSTATE->setup_params.min_heap, ___DEFAULT_MIN_HEAP);
      }
  
    if (___GSTATE->setup_params.live_percent <= 0 ||
        ___GSTATE->setup_params.live_percent > 100)
      {
        /*
         * Choose a reasonable minimum live percent.
         */
  
        ___GSTATE->setup_params.live_percent = ___DEFAULT_LIVE_PERCENT;
      }
  
    /*
     * Setup psections.
     */
  
    ___GSTATE->mem.psections = 0;
    ___GSTATE->mem.palloc_ptr = 0;
  
    /*
     * Create empty global variable list, symbol table and keyword
     * table.
     */
  
    ___glo_list_setup ();
  
    {
      ___SCMOBJ t = alloc_symkey_table (___sSYMBOL, INIT_SYMBOL_TABLE_LENGTH);
  
      if (___FIXNUMP(t))
        return t;
  
      ___GSTATE->symbol_table = t;
    }
  
    {
      ___SCMOBJ t = alloc_symkey_table (___sKEYWORD, INIT_KEYWORD_TABLE_LENGTH);
  
      if (___FIXNUMP(t))
        return t;
  
      ___GSTATE->keyword_table = t;
    }
  
    return ___FIX(___NO_ERR);
  }
  
  
  void ___cleanup_mem_pstate
     ___P((___processor_state ___ps),
          (___ps)
  ___processor_state ___ps;)
  {
    free_still_objs (___ps);
    cleanup_rc (___ps);
  }
  
  
  void ___cleanup_mem_vmstate
     ___P((___virtual_machine_state ___vms),
          (___vms)
  ___virtual_machine_state ___vms;)
  {
  #undef ___VMSTATE_MEM
  #define ___VMSTATE_MEM(var) ___vms->mem.var
  
  #ifndef ___SINGLE_THREADED_VMS
  
    /*
     * Destroy spinlock for VM level memory allocation.
     */
  
    ___SPINLOCK_DESTROY(misc_mem_lock);
    ___SPINLOCK_DESTROY(alloc_mem_lock);
  
    /*
     * Destroy condition variable to determine end of scan at VM level.
     */
  
    ___CONDVAR_DESTROY(scan_termination_condvar);
    ___MUTEX_DESTROY(scan_termination_mutex);
  
  #endif
  
    ___cleanup_mem_pstate (&___vms->pstate[0]);/*TODO: other processors?*/
  
    free_msections (&the_msections);
  
  #ifndef ___SINGLE_VM
  
    /*
     * Remove from virtual machine circular list.
     */
  
    /* It is assumed that ___GSTATE->vm_list_mut is currently locked */
  
    {
      ___virtual_machine_state prev = ___vms->prev;
      ___virtual_machine_state next = ___vms->next;
  
      next->prev = prev;
      prev->next = next;
    }
  
  #endif
  
  #undef ___VMSTATE_MEM
  #define ___VMSTATE_MEM(var) ___VMSTATE_FROM_PSTATE(___ps)->mem.var
  }
  
  
  void ___cleanup_mem ___PVOID
  {
    free_psections ();
  }
  
  
  ___HIDDEN void determine_will_executability
     ___P((___WORD list),
          (list)
  ___WORD list;)
  {
    while (___UNTAG(list) != 0)
      {
        ___WORD* will_body = ___BODY(list);
        ___WORD will_head = will_body[-1];
        ___WORD testator;
  
        ___WORD *unmarked_body; /* used by the UNMARKED macro */
        int unmarked_typ;
  
        if (___TYP(will_head) == ___FORW) /* was will forwarded? */
          will_body = ___BODY_AS(will_head,___FORW);
  
        list = will_body[0];
  
        testator = will_body[1];
  
        if (___MEM_ALLOCATED(testator) &&
            UNMARKED(testator)) /* testator was not marked? */
          {
            /*
             * All paths to testator object from roots pass through
             * weak references, so mark will as executable.
             */
  
            will_body[0] = list | ___EXECUTABLE_WILL;
          }
      }
  }
  
  
  ___HIDDEN void process_wills
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
    ___WORD* tail_exec;
    ___WORD* tail_nonexec;
    ___WORD curr;
  
  #ifdef ENABLE_CONSISTENCY_CHECKS
    reference_location = IN_WILL_LIST;
  #endif
  
    determine_will_executability (nonexecutable_wills);
  
    /*
     * Finish scanning the wills whose testator object remains to be
     * marked.
     *
     * The wills that have become executable are also transferred from
     * the nonexecutable wills list to the executable wills list.
     */
  
    tail_exec = &executable_wills;
    curr = *tail_exec;
  
    while (___UNTAG(curr) != 0)
      {
        ___WORD will = ___TAG(___UNTAG(curr),___tSUBTYPED);
  
        mark_array (___PSP &will, 1);
  
        *tail_exec = ___TAG(___UNTAG(will),___EXECUTABLE_WILL);
        tail_exec = &___BODY_AS(will,___tSUBTYPED)[0];
        curr = *tail_exec;
        if (curr & ___UNMARKED_TESTATOR_WILL)
          mark_array (___PSP tail_exec+1, 1); /* mark testator object */
      }
  
    tail_nonexec = &nonexecutable_wills;
    curr = *tail_nonexec;
  
    while (___UNTAG(curr) != 0)
      {
        ___WORD will = ___TAG(___UNTAG(curr),___tSUBTYPED);
  
        mark_array (___PSP &will, 1);
  
        if (___BODY_AS(will,___tSUBTYPED)[0] & ___EXECUTABLE_WILL)
          {
            /* move will to executable will list */
  
            *tail_exec = ___TAG(___UNTAG(will),___EXECUTABLE_WILL);
            tail_exec = &___BODY_AS(will,___tSUBTYPED)[0];
            curr = *tail_exec;
            if (curr & ___UNMARKED_TESTATOR_WILL)
              mark_array (___PSP tail_exec+1, 1); /* mark testator object */
          }
        else
          {
            /* leave will in nonexecutable will list */
  
            *tail_nonexec = ___TAG(___UNTAG(will),0);
            tail_nonexec = &___BODY_AS(will,___tSUBTYPED)[0];
            curr = *tail_nonexec;
            if (curr & ___UNMARKED_TESTATOR_WILL)
              mark_array (___PSP tail_nonexec+1, 1); /* mark testator object */
          }
      }
  
    *tail_exec = ___TAG(0,___EXECUTABLE_WILL);
    *tail_nonexec = ___TAG(0,0);
  }
  
  
  ___HIDDEN void process_gc_hash_tables
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
    ___WORD curr = reached_gc_hash_tables;
  
    while (curr != ___TAG(0,0))
      {
        ___WORD* body = ___BODY(curr);
        ___SIZE_TS words = ___HD_WORDS(body[-1]);
        int flags = ___INT(body[___GCHASHTABLE_FLAGS]);
        int i;
  
        curr = body[0];
  
        body[0] = ___FIX(0);
  
        if (((___GCHASHTABLE_FLAG_WEAK_KEYS | ___GCHASHTABLE_FLAG_MEM_ALLOC_KEYS)
             & flags) ==
            (___GCHASHTABLE_FLAG_WEAK_KEYS | ___GCHASHTABLE_FLAG_MEM_ALLOC_KEYS))
          {
            if (flags & ___GCHASHTABLE_FLAG_WEAK_VALS)
              {
                /*
                 * GC hash table is weak on keys and on values.
                 */
  
                /*
                 * Eliminate GC hash table entries with an unmarked key
                 * or an unmarked value.
                 */
  
                for (i=words-2; i>=___GCHASHTABLE_KEY0; i-=2)
                  {
                    ___WORD *unmarked_body; /* used by the UNMARKED macro */
                    int unmarked_typ;
  
                    ___WORD key = body[i];
                    ___WORD val = body[i+1];
  
                    if (___MEM_ALLOCATED(key))
                      {
                        ___WORD key_head = ___BODY(key)[-1];
  
                        if (___TYP(key_head) == ___FORW)
                          {
                            /*
                             * The key is movable and has been
                             * forwarded.
                             */
  
                            if (___MEM_ALLOCATED(val))
                              {
                                ___WORD val_head = ___BODY(val)[-1];
  
                                if (___TYP(val_head) == ___FORW)
                                  {
                                    /*
                                     * The key is movable and has been
                                     * forwarded and the value is
                                     * movable and has been forwarded,
                                     * so update key field and value
                                     * field and remember to rehash next
                                     * time the GC hash table is
                                     * accessed.
                                     */
  
                                    body[i] =
                                      ___TAG(___UNTAG_AS(key_head, ___FORW),
                                             ___TYP(key));
                                    body[i+1] =
                                      ___TAG(___UNTAG_AS(val_head, ___FORW),
                                             ___TYP(val));
                                    flags |= ___GCHASHTABLE_FLAG_KEY_MOVED;
                                  }
                                else if (UNMARKED(val))
                                  {
                                    /*
                                     * Change the entry to indicate it
                                     * has been deleted.
                                     */
  
                                    body[i] = ___DELETED;
                                    body[i+1] = ___UNUSED;
                                    body[___GCHASHTABLE_COUNT] =
                                      ___FIXSUB(body[___GCHASHTABLE_COUNT],
                                                ___FIX(1));
                                    flags |= ___GCHASHTABLE_FLAG_ENTRY_DELETED;
                                  }
                                else
                                  {
                                    /*
                                     * The key is movable and has been
                                     * forwarded and the value is not
                                     * movable and is reachable, so
                                     * update key field and remember to
                                     * rehash next time the GC hash
                                     * table is accessed.
                                     */
  
                                    body[i] =
                                      ___TAG(___UNTAG_AS(key_head, ___FORW),
                                             ___TYP(key));
                                    flags |= ___GCHASHTABLE_FLAG_KEY_MOVED;
                                  }
                              }
                            else
                              {
                                /*
                                 * The key is movable and has been
                                 * forwarded, and the value is not
                                 * memory allocated, so update key field
                                 * and remember to rehash next time the
                                 * GC hash table is accessed.
                                 */
  
                                body[i] =
                                  ___TAG(___UNTAG_AS(key_head, ___FORW),
                                         ___TYP(key));
                                flags |= ___GCHASHTABLE_FLAG_KEY_MOVED;
                              }
                          }
                        else if (UNMARKED(key))
                          {
                            /*
                             * Change the entry to indicate it has been
                             * deleted.
                             */
  
                            body[i] = ___DELETED;
                            body[i+1] = ___UNUSED;
                            body[___GCHASHTABLE_COUNT] =
                              ___FIXSUB(body[___GCHASHTABLE_COUNT],___FIX(1));
                            flags |= ___GCHASHTABLE_FLAG_ENTRY_DELETED;
                          }
                        else
                          {
                            /*
                             * The key is not movable and is reachable.
                             */
  
                            if (___MEM_ALLOCATED(val))
                              {
                                ___WORD val_head = ___BODY(val)[-1];
  
                                if (___TYP(val_head) == ___FORW)
                                  {
                                    /*
                                     * The key is not movable and is
                                     * reachable and the value is
                                     * movable and has been forwarded,
                                     * so update value field.
                                     */
  
                                    body[i+1] =
                                      ___TAG(___UNTAG_AS(val_head, ___FORW),
                                             ___TYP(val));
                                  }
                                else if (UNMARKED(val))
                                  {
                                    /*
                                     * Change the entry to indicate it
                                     * has been deleted.
                                     */
  
                                    body[i] = ___DELETED;
                                    body[i+1] = ___UNUSED;
                                    body[___GCHASHTABLE_COUNT] =
                                      ___FIXSUB(body[___GCHASHTABLE_COUNT],
                                                ___FIX(1));
                                    flags |= ___GCHASHTABLE_FLAG_ENTRY_DELETED;
                                  }
                                else
                                  {
                                    /*
                                     * The key is not movable and is
                                     * reachable and the value is not
                                     * movable and is reachable, so
                                     * leave fields untouched.
                                     */
                                  }
                              }
                            else
                              {
                                /*
                                 * The key is not movable and is
                                 * reachable and the value is not memory
                                 * allocated, so leave fields untouched.
                                 */
                              }
                          }
                      }
                    else
                      {
                        /*
                         * The key is not memory allocated.
                         */
  
                        if (___MEM_ALLOCATED(val))
                          {
                            ___WORD val_head = ___BODY(val)[-1];
  
                            if (___TYP(val_head) == ___FORW)
                              {
                                /*
                                 * The key is not memory allocated and
                                 * the value is movable and has been
                                 * forwarded, so update value field.
                                 */
  
                                body[i+1] =
                                  ___TAG(___UNTAG_AS(val_head, ___FORW),
                                         ___TYP(val));
                              }
                            else if (UNMARKED(val))
                              {
                                /*
                                 * Change the entry to indicate it
                                 * has been deleted.
                                 */
  
                                body[i] = ___DELETED;
                                body[i+1] = ___UNUSED;
                                body[___GCHASHTABLE_COUNT] =
                                  ___FIXSUB(body[___GCHASHTABLE_COUNT],
                                            ___FIX(1));
                                flags |= ___GCHASHTABLE_FLAG_ENTRY_DELETED;
                              }
                            else
                              {
                                /*
                                 * The key is not memory allocated and
                                 * the value is not movable and is
                                 * reachable, so leave fields untouched.
                                 */
                              }
                          }
                        else
                          {
                            /*
                             * The key is not memory allocated and the
                             * value is not memory allocated, so leave
                             * fields untouched.
                             */
                          }
                      }
                  }
              }
            else
              {
                /*
                 * GC hash table is weak on keys only.
                 */
  
                /*
                 * Eliminate GC hash table entries with an unmarked key.
                 */
  
                for (i=words-2; i>=___GCHASHTABLE_KEY0; i-=2)
                  {
                    ___WORD *unmarked_body; /* used by the UNMARKED macro */
                    int unmarked_typ;
  
                    ___WORD key = body[i];
  
                    if (___MEM_ALLOCATED(key))
                      {
                        ___WORD head = ___BODY(key)[-1];
  
                        if (___TYP(head) == ___FORW)
                          {
                            /*
                             * The key is movable and has been
                             * forwarded, so update key field and
                             * remember to rehash next time the
                             * GC hash table is accessed.
                             */
  
                            body[i] = ___TAG(___UNTAG_AS(head, ___FORW),
                                             ___TYP(key));
                            flags |= ___GCHASHTABLE_FLAG_KEY_MOVED;
                          }
                        else if (UNMARKED(key))
                          {
                            /*
                             * Change the entry to indicate it has been
                             * deleted.
                             */
  
                            body[i] = ___DELETED;
                            body[i+1] = ___UNUSED;
                            body[___GCHASHTABLE_COUNT] =
                              ___FIXSUB(body[___GCHASHTABLE_COUNT],___FIX(1));
                            flags |= ___GCHASHTABLE_FLAG_ENTRY_DELETED;
                          }
                      }
                  }
              }
          }
        else
          {
            if (flags & ___GCHASHTABLE_FLAG_WEAK_VALS)
              {
                /*
                 * GC hash table is weak on values only.
                 */
  
                /*
                 * Eliminate GC hash table entries with an unmarked value.
                 */
  
                for (i=words-2; i>=___GCHASHTABLE_KEY0; i-=2)
                  {
                    ___WORD *unmarked_body; /* used by the UNMARKED macro */
                    int unmarked_typ;
  
                    ___WORD val = body[i+1];
  
                    if (___MEM_ALLOCATED(val))
                      {
                        ___WORD head = ___BODY(val)[-1];
  
                        if (___TYP(head) == ___FORW)
                          {
                            /*
                             * The value is movable and has been
                             * forwarded, so update value field.
                             */
  
                            body[i+1] = ___TAG(___UNTAG_AS(head, ___FORW),
                                               ___TYP(val));
                          }
                        else if (UNMARKED(val))
                          {
                            /*
                             * Change the entry to indicate it has been
                             * deleted.
                             */
  
                            body[i] = ___DELETED;
                            body[i+1] = ___UNUSED;
                            body[___GCHASHTABLE_COUNT] =
                              ___FIXSUB(body[___GCHASHTABLE_COUNT],___FIX(1));
                            flags |= ___GCHASHTABLE_FLAG_ENTRY_DELETED;
                          }
                      }
                  }
              }
  
            if (flags & ___GCHASHTABLE_FLAG_MEM_ALLOC_KEYS)
              flags |= ___GCHASHTABLE_FLAG_KEY_MOVED; /* assume worst case */
          }
  
        body[___GCHASHTABLE_FLAGS] = ___FIX(flags);
      }
  }
  
  
  ___HIDDEN void gc_hash_table_rehash_in_situ
     ___P((___SCMOBJ ht),
          (ht)
  ___SCMOBJ ht;)
  {
    ___WORD* body = ___BODY_AS(ht,___tSUBTYPED);
    ___SIZE_TS words = ___HD_WORDS(body[-1]);
    int size2 = ___INT(___VECTORLENGTH(ht)) - ___GCHASHTABLE_KEY0;
    int i;
  
    ___FIELD(ht, ___GCHASHTABLE_FLAGS) =
      ___FIXAND(___FIELD(ht, ___GCHASHTABLE_FLAGS),
                ___FIXNOT(___FIX(___GCHASHTABLE_FLAG_KEY_MOVED)));
  
    if (___FIXZEROP(___FIXAND(body[___GCHASHTABLE_FLAGS],
                              ___FIX(___GCHASHTABLE_FLAG_MEM_ALLOC_KEYS))))
      {
        /*
         * Free deleted entries and mark key field of all active
         * entries.
         */
  
        for (i=___GCHASHTABLE_KEY0; i<words; i+=2)
          {
            ___WORD key = body[i];
            if (key == ___DELETED)
              {
                body[i] = ___UNUSED;
                body[___GCHASHTABLE_FREE] =
                  ___FIXADD(body[___GCHASHTABLE_FREE], ___FIX(1));
              }
            else if (key != ___UNUSED)
              body[i] = ___MEM_ALLOCATED_SET(key);
          }
  
        /*
         * Move the active entries.
         */
  
        for (i=___GCHASHTABLE_KEY0; i<words; i+=2)
          {
            ___WORD key = body[i];
  
            if (___MEM_ALLOCATED(key))
              {
                /* this is an active entry that has not been moved yet */
  
                ___SCMOBJ val = body[i+1];
                ___SCMOBJ obj;
                int probe2;
                int step2;
  
                body[i] = ___UNUSED;
                body[i+1] = ___UNUSED;
  
              chain_non_mem_alloc:
                key = ___MEM_ALLOCATED_CLEAR(key); /* recover true encoding */
                probe2 = ___GCHASHTABLE_HASH1(key,size2>>1) << 1;
                step2 = ___GCHASHTABLE_HASH2(key,size2>>1) << 1;
  
              next_non_mem_alloc:
                obj = body[probe2+___GCHASHTABLE_KEY0];
  
                if (obj == ___UNUSED)
                  {
                    /* storing into an unused entry */
  
                    body[probe2+___GCHASHTABLE_KEY0] = key;
                    body[probe2+___GCHASHTABLE_VAL0] = val;
                  }
                else if (___MEM_ALLOCATED(obj))
                  {
                    /* storing into an active entry */
  
                    body[probe2+___GCHASHTABLE_KEY0] = key;
                    key = obj;
                    obj = body[probe2+___GCHASHTABLE_VAL0];
                    body[probe2+___GCHASHTABLE_VAL0] = val;
                    val = obj;
                    goto chain_non_mem_alloc; /* now move overwritten entry */
                  }
                else
                  {
                    /* an entry has been moved here, so keep looking */
  
                    probe2 -= step2;
                    if (probe2 < 0)
                      probe2 += size2;
                    goto next_non_mem_alloc;
                  }
              }
          }
      }
    else
      {
        /*
         * Free deleted entries and mark key field of all active
         * entries.
         */
  
        for (i=___GCHASHTABLE_KEY0; i<words; i+=2)
          {
            ___WORD key = body[i];
            if (key == ___DELETED)
              {
                body[i] = ___UNUSED;
                body[___GCHASHTABLE_FREE] =
                  ___FIXADD(body[___GCHASHTABLE_FREE], ___FIX(1));
              }
            else
              body[i] = ___MEM_ALLOCATED_CLEAR(key);
          }
  
        /*
         * Move the active entries.
         */
  
        for (i=___GCHASHTABLE_KEY0; i<words; i+=2)
          {
            ___WORD key = body[i];
  
            if (key != ___UNUSED && !___MEM_ALLOCATED(key))
              {
                /* this is an active entry that has not been moved yet */
  
                ___SCMOBJ val = body[i+1];
                ___SCMOBJ obj;
                int probe2;
                int step2;
  
                body[i] = ___UNUSED;
                body[i+1] = ___UNUSED;
  
              chain_mem_alloc:
                key = ___MEM_ALLOCATED_SET(key); /* recover true encoding */
                probe2 = ___GCHASHTABLE_HASH1(key,size2>>1) << 1;
                step2 = ___GCHASHTABLE_HASH2(key,size2>>1) << 1;
  
              next_mem_alloc:
                obj = body[probe2+___GCHASHTABLE_KEY0];
  
                if (obj == ___UNUSED)
                  {
                    /* storing into an unused entry */
  
                    body[probe2+___GCHASHTABLE_KEY0] = key;
                    body[probe2+___GCHASHTABLE_VAL0] = val;
                  }
                else if (!___MEM_ALLOCATED(obj))
                  {
                    /* storing into an active entry */
  
                    body[probe2+___GCHASHTABLE_KEY0] = key;
                    key = obj;
                    obj = body[probe2+___GCHASHTABLE_VAL0];
                    body[probe2+___GCHASHTABLE_VAL0] = val;
                    val = obj;
                    goto chain_mem_alloc; /* now move overwritten entry */
                  }
                else
                  {
                    /* an entry has been moved here, so keep looking */
  
                    probe2 -= step2;
                    if (probe2 < 0)
                      probe2 += size2;
                    goto next_mem_alloc;
                  }
              }
          }
      }
  }
  
  ___SCMOBJ ___gc_hash_table_ref
     ___P((___SCMOBJ ht,
           ___SCMOBJ key),
          (ht,
           key)
  ___SCMOBJ ht;
  ___SCMOBJ key;)
  {
    int size2;
    int probe2;
    ___SCMOBJ obj;
  
    if (!___FIXZEROP(___FIXAND(___FIELD(ht, ___GCHASHTABLE_FLAGS),
                               ___FIX(___GCHASHTABLE_FLAG_KEY_MOVED))))
      gc_hash_table_rehash_in_situ (ht);
  
    size2 = ___INT(___VECTORLENGTH(ht)) - ___GCHASHTABLE_KEY0;
    probe2 = ___GCHASHTABLE_HASH1(key,size2>>1) << 1;
    obj = ___FIELD(ht, probe2+___GCHASHTABLE_KEY0);
  
    if (___EQP(obj,key))
      return ___FIELD(ht, probe2+___GCHASHTABLE_VAL0);
    else if (!___EQP(obj,___UNUSED))
      {
        int step2 = ___GCHASHTABLE_HASH2(key,size2>>1) << 1;
  
        for (;;)
          {
            probe2 -= step2;
            if (probe2 < 0)
              probe2 += size2;
            obj = ___FIELD(ht, probe2+___GCHASHTABLE_KEY0);
  
            if (___EQP(obj,key))
              return ___FIELD(ht, probe2+___GCHASHTABLE_VAL0);
            else if (___EQP(obj,___UNUSED))
              break;
          }
      }
  
    return ___UNUSED; /* key was not found */
  }
  
  ___SCMOBJ ___gc_hash_table_set
     ___P((___SCMOBJ ht,
           ___SCMOBJ key,
           ___SCMOBJ val),
          (ht,
           key,
           val)
  ___SCMOBJ ht;
  ___SCMOBJ key;
  ___SCMOBJ val;)
  {
    int size2;
    int probe2;
    ___SCMOBJ obj;
  
    if (!___FIXZEROP(___FIXAND(___FIELD(ht, ___GCHASHTABLE_FLAGS),
                               ___FIX(___GCHASHTABLE_FLAG_KEY_MOVED))))
      gc_hash_table_rehash_in_situ (ht);
  
    size2 = ___INT(___VECTORLENGTH(ht)) - ___GCHASHTABLE_KEY0;
    probe2 = ___GCHASHTABLE_HASH1(key,size2>>1) << 1;
    obj = ___FIELD(ht, probe2+___GCHASHTABLE_KEY0);
  
    if (!___EQP(val,___ABSENT))
      {
        /* trying to add or replace an entry */
  
        if (___EQP(obj,key))
          {
          replace_entry:
            ___FIELD(ht, probe2+___GCHASHTABLE_VAL0) = val;
          }
        else if (___EQP(obj,___UNUSED))
          {
          add_entry:
            ___FIELD(ht, probe2+___GCHASHTABLE_KEY0) = key;
            ___FIELD(ht, probe2+___GCHASHTABLE_VAL0) = val;
            ___FIELD(ht, ___GCHASHTABLE_COUNT) =
              ___FIXADD(___FIELD(ht, ___GCHASHTABLE_COUNT), ___FIX(1));
            if (___FIXNEGATIVEP(___FIELD(ht, ___GCHASHTABLE_FREE) =
                                  ___FIXSUB(___FIELD(ht, ___GCHASHTABLE_FREE),
                                            ___FIX(1))))
              return ___TRU;
          }
        else
          {
            int step2 = ___GCHASHTABLE_HASH2(key,size2>>1) << 1;
            int deleted2 = -1;
  
            for (;;)
              {
                if (deleted2 < 0 && ___EQP(obj,___DELETED))
                  deleted2 = probe2;
  
                probe2 -= step2;
                if (probe2 < 0)
                  probe2 += size2;
                obj = ___FIELD(ht, probe2+___GCHASHTABLE_KEY0);
  
                if (___EQP(obj,key))
                  goto replace_entry;
  
                if (___EQP(obj,___UNUSED))
                  {
                    if (deleted2 < 0)
                      goto add_entry;
  
                    ___FIELD(ht, deleted2+___GCHASHTABLE_KEY0) = key;
                    ___FIELD(ht, deleted2+___GCHASHTABLE_VAL0) = val;
                    ___FIELD(ht, ___GCHASHTABLE_COUNT) =
                      ___FIXADD(___FIELD(ht, ___GCHASHTABLE_COUNT), ___FIX(1));
  
                    break;
                  }
              }
          }
      }
    else
      {
        /* trying to delete an entry */
  
        if (___EQP(obj,key))
          {
          delete_entry:
            ___FIELD(ht, probe2+___GCHASHTABLE_KEY0) = ___DELETED;
            ___FIELD(ht, probe2+___GCHASHTABLE_VAL0) = ___UNUSED;
            ___FIELD(ht, ___GCHASHTABLE_COUNT) =
              ___FIXSUB(___FIELD(ht, ___GCHASHTABLE_COUNT),
                        ___FIX(1));
            if (___FIXLT(___FIELD(ht, ___GCHASHTABLE_COUNT),
                         ___FIELD(ht, ___GCHASHTABLE_MIN_COUNT)))
              return ___TRU;
          }
        else if (!___EQP(obj,___UNUSED))
          {
            int step2 = ___GCHASHTABLE_HASH2(key,size2>>1) << 1;
  
            for (;;)
              {
                probe2 -= step2;
                if (probe2 < 0)
                  probe2 += size2;
                obj = ___FIELD(ht, probe2+___GCHASHTABLE_KEY0);
  
                if (___EQP(obj,key))
                  goto delete_entry;
  
                if (___EQP(obj,___UNUSED))
                  break;
              }
          }
      }
  
   /*
    * Hash table does not need to be resized.
    */
  
    return ___FAL;
  }
  
  ___SCMOBJ ___gc_hash_table_rehash
     ___P((___SCMOBJ ht_src,
           ___SCMOBJ ht_dst),
          (ht_src,
           ht_dst)
  ___SCMOBJ ht_src;
  ___SCMOBJ ht_dst;)
  {
    ___WORD* body_src = ___BODY_AS(ht_src,___tSUBTYPED);
    ___SIZE_TS words = ___HD_WORDS(body_src[-1]);
    int i;
  
    for (i=___GCHASHTABLE_KEY0; i<words; i+=2)
      {
        ___WORD key = body_src[i];
  
        if (key != ___UNUSED &&
            key != ___DELETED)
          ___gc_hash_table_set (ht_dst, key, body_src[i+1]);
      }
  
    return ht_dst;
  }
  
  
  ___HIDDEN void move_continuation
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
  
    ___WORD *start;
    ___SIZE_TS length;
    ___WORD *p1;
    ___WORD *p2;
  
    start = ___ps->fp;
    length = (___ps->stack_break + ___FIRST_BREAK_FRAME_SPACE) - start;
  
    p1 = start + length;
    p2 = alloc_stack_ptr;
  
    ___ps->stack_start = alloc_stack_start;
    ___ps->stack_break = p2 - ___FIRST_BREAK_FRAME_SPACE;
  
    while (p1 != start)
      *--p2 = *--p1;
  
    alloc_stack_ptr = p2;
  }
  
  
  ___HIDDEN void determine_occupied_words
     ___P((___virtual_machine_state ___vms),
          (___vms)
  ___virtual_machine_state ___vms;)
  {
  #undef ___VMSTATE_MEM
  #define ___VMSTATE_MEM(var) ___vms->mem.var
  
    /*
     * Compute space occupied by live objects.
     */
  
    int p;
    int np = ___vms->processor_count;
    ___SIZE_TS movable = 0;
    ___SIZE_TS still = 0;
    ___F64 bytes_allocated = 0.0;
  
    for (p=0; p<np; p++)
      {
        ___processor_state ps = &___vms->pstate[p];
  
        movable += words_movable_objs(ps);
  
        still += ps->mem.words_still_objs_;
  
        /*
         * Note that at this point bytes_allocated_minus_occupied is
         * actually the number of bytes allocated by the processor.
         */
  
        bytes_allocated += ps->mem.bytes_allocated_minus_occupied_;
      }
  
    occupied_words_movable = movable;
    occupied_words_still = still;
  
    latest_gc_alloc = bytes_allocated;
  
  #undef ___VMSTATE_MEM
  #define ___VMSTATE_MEM(var) ___VMSTATE_FROM_PSTATE(___ps)->mem.var
  }
  
  
  ___HIDDEN ___BOOL resize_heap
     ___P((___virtual_machine_state ___vms,
           ___SIZE_TS requested_words_still),
          (___vms,
           requested_words_still)
  ___virtual_machine_state ___vms;
  ___SIZE_TS requested_words_still;)
  {
  #undef ___VMSTATE_MEM
  #define ___VMSTATE_MEM(var) ___vms->mem.var
  
    ___BOOL overflow = 0;
    ___SIZE_TS target_heap_space;
    ___SIZE_TS target_movable_space;
    int target_nb_sections;
    ___SIZE_TS live;
  
    determine_occupied_words (___vms);
  
    occupied_words_still += requested_words_still; /* pretend requested space is live */
  
    live = occupied_words_movable + occupied_words_still;
  
    /*
     * Determine the target size of the heap in msections given the
     * space requested for the still object.
     */
  
    target_heap_space = adjust_heap (live);
  
    if (live > target_heap_space)
      {
        /*
         * Trigger a recoverable heap overflow.
         */
  
        overflow = 1;
  
        /*
         * Take some space from the overflow reserve.
         */
  
        overflow_reserve >>= 5; /* make 96.875% of reserve usable */
  
        if (overflow_reserve == 0)
          fatal_heap_overflow ();
  
        /*
         * Cancel allocation of still object.
         */
  
        occupied_words_still -= requested_words_still;
        live -= requested_words_still;
  
        target_heap_space = adjust_heap (live);
      }
  
    if (live + normal_overflow_reserve <= target_heap_space)
      {
        /*
         * Now that there is enough free space, reset the overflow
         * reserve to its normal value.
         */
  
        overflow_reserve = normal_overflow_reserve;
      }
  
    target_movable_space = target_heap_space - occupied_words_still;
  
    SET_MAX(target_movable_space, 0);
  
    /*
     * Compute the number of msections required after the GC.  The code
     * reserves ___MIN_NB_MSECTIONS_PER_PROCESSOR per processor taking
     * the target number of processors into account in case the GC was
     * called as part of the resizing of the VM.
     */
  
    target_nb_sections =
      ___MIN_NB_MSECTIONS_PER_PROCESSOR * target_processor_count +
      ___CEILING_DIV(target_movable_space + normal_overflow_reserve,
                     ___MSECTION_SIZE - 2*___MSECTION_FUDGE);
  
    SET_MAX(target_nb_sections,
            nb_msections_assigned);
  
    adjust_msections (&the_msections, target_nb_sections);
  
    heap_size = compute_heap_space();
  
    /*
     * Maintain GC statistics.
     */
  
    latest_gc_heap_size = ___CAST(___F64,heap_size) * ___WS;
  
    latest_gc_live = ___CAST(___F64,live) * ___WS;
    latest_gc_movable = ___CAST(___F64,occupied_words_movable) * ___WS;
    latest_gc_still = ___CAST(___F64,occupied_words_still) * ___WS;
  
    return overflow;
  
  #undef ___VMSTATE_MEM
  #define ___VMSTATE_MEM(var) ___VMSTATE_FROM_PSTATE(___ps)->mem.var
  }
  
  
  ___HIDDEN void mark_registers
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
  
  #ifdef ENABLE_CONSISTENCY_CHECKS
    reference_location = IN_REGISTER;
  #endif
  
    mark_array (___PSP ___ps->r, ___NB_GVM_REGS);
  }
  
  
  ___HIDDEN void mark_processor_scmobj
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
  
  #ifdef ENABLE_CONSISTENCY_CHECKS
    reference_location = IN_PROCESSOR_SCMOBJ;
  #endif
  
    mark_array (___PSP
                ___BODY_AS(___PROCESSOR_SCMOBJ(___ps),___tSUBTYPED),
                ___PROCESSOR_SIZE);
  }
  
  
  ___HIDDEN void mark_vm_scmobj
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
    ___virtual_machine_state ___vms = ___VMSTATE_FROM_PSTATE(___ps);
  
  #ifdef ENABLE_CONSISTENCY_CHECKS
    reference_location = IN_VM_SCMOBJ;
  #endif
  
    mark_array (___PSP
                ___BODY_AS(___VM_SCMOBJ(___vms),___tSUBTYPED),
                ___VM_SIZE);
  }
  
  
  ___HIDDEN void mark_global_variables
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
    ___virtual_machine_state ___vms = ___VMSTATE_FROM_PSTATE(___ps);
    int id = ___PROCESSOR_ID(___ps,___vms); /* id of this processor */
  
  #ifdef ENABLE_CONSISTENCY_CHECKS
    reference_location = IN_GLOBAL_VAR;
  #endif
  
    /*
     * Mark a portion of the global variables.
     */
  
  #ifdef ___SINGLE_VM
  
    {
      int np = ___vms->processor_count;
      int lo = (id * ___GLO_SUBLIST_COUNT) / np;
      int hi = ((id+1) * ___GLO_SUBLIST_COUNT) / np;
  
      while (lo < hi)
        {
          ___glo_sublist_struct *sl = &___GSTATE->mem.glo_list.sublist[lo];
          ___glo_struct *glo = sl->head;
  
          while (glo != 0)
            {
  #ifdef ___DEBUG_GARBAGE_COLLECT_globals
              print_global_var_name (glo);
              ___printf ("\n");
  #endif
              mark_array (___PSP &___GLOCELL(glo->val), 1);
              glo = glo->next;
            }
  
          lo++;
        }
    }
  
  #else
  
    {
      int n = ___GSTATE->mem.glo_list.count;
      int np = ___vms->processor_count;
      int lo = (id * n) / np;
      int hi = ((id+1) * n) / np;
  
      mark_array (___PSP
                  ___VMSTATE_FROM_PSTATE(___ps)->glos+lo,
                  hi-lo);
    }
  
  #endif
  }
  
  
  ___HIDDEN void mark_symkey_tables
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
  
  #ifdef ENABLE_CONSISTENCY_CHECKS
    reference_location = IN_SYMKEY_TABLE;
  #endif
  
    mark_array (___PSP &___GSTATE->symbol_table, 1);
    mark_array (___PSP &___GSTATE->keyword_table, 1);
  }
  
  
  ___HIDDEN void mark_reachable_from_marked
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
  
  #ifndef ___SINGLE_THREADED_VMS
  
    ___virtual_machine_state ___vms = ___VMSTATE_FROM_PSTATE(___ps);
    ___VOLATILE ___WORD *workers_count = &scan_workers_count[traverse_weak_refs];
    int np = ___vms->processor_count;
    int id = ___PROCESSOR_ID(___ps,___vms); /* id of this processor */
    int i;
  
   continue_local_scan:
  
  #endif
  
    do
      {
        scan_still_objs_to_scan (___PSPNC);
        scan_movable_objs_to_scan (___PSPNC);
      } while (___CAST(___WORD*,still_objs_to_scan) != 0);
  
  #ifndef ___SINGLE_THREADED_VMS
  
  #define ___GC_SCAN_STEAL_WORK_CYCLES 1000
  
    for (;;)
      {
        /* Try stealing a queued chunk from another processor */
  
        for (i = (np-1) * ___GC_SCAN_STEAL_WORK_CYCLES - 1; i>=0; i--)
          {
            ___processor_state ps = &___vms->pstate[(i + i%(np-1) + 1) % np];
            ___VOLATILE ___WORD *hcsh;
  
            if (ps->mem.heap_chunks_to_scan_head_ !=
                ps->mem.heap_chunks_to_scan_tail_)
              {
                /* only try stealing when chunk FIFO is non-empty */
  
                ___SPINLOCK_LOCK(ps->mem.heap_chunks_to_scan_lock_);
  
                if ((hcsh=ps->mem.heap_chunks_to_scan_head_) !=
                    ps->mem.heap_chunks_to_scan_tail_)
                  {
                    /* chunk FIFO is really non-empty */
  
                    ___WORD *ptr = ___UNTAG_AS(*hcsh, ___FORW);
  
                    ps->mem.heap_chunks_to_scan_head_ = ptr;
  
                    ___SHARED_MEMORY_BARRIER(); /* share heap_chunks_to_scan_head */
  
                    ___SPINLOCK_UNLOCK(ps->mem.heap_chunks_to_scan_lock_);
  
                    scan_complete_heap_chunk (___PSP ptr+1);
  
                    goto continue_local_scan;
                  }
                else
                  {
                    ___SPINLOCK_UNLOCK(ps->mem.heap_chunks_to_scan_lock_);
                  }
              }
          }
  
        /* Signal being idle and wait for more work or termination */
  
        ___MUTEX_LOCK(scan_termination_mutex);
  
        if (--(*workers_count) == 0)
          {
            /* Scan has terminated */
  
            for (i=np-1; i>=0; i--)
              ___CONDVAR_SIGNAL(scan_termination_condvar);
  
            ___MUTEX_UNLOCK(scan_termination_mutex);
  
            break;
          }
        else
          {
            /* Other processors are still actively scanning chunks */
  
            ___ACTLOG_BEGIN_PS(gc_wait,lightgray);
            ___CONDVAR_WAIT(scan_termination_condvar,scan_termination_mutex);
            ___ACTLOG_END_PS();
  
            if (*workers_count == 0)
              {
                ___MUTEX_UNLOCK(scan_termination_mutex);
                break;
              }
  
            (*workers_count)++;
  
            ___MUTEX_UNLOCK(scan_termination_mutex);
          }
      }
  
  #endif
  }
  
  
  ___HIDDEN void garbage_collect_setup_phase
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
    ___virtual_machine_state ___vms = ___VMSTATE_FROM_PSTATE(___ps);
  
  #ifdef ENABLE_GC_ACTLOG_PHASES
    ___ACTLOG_BEGIN_PS(setup_phase,_);
  #endif
  
  #ifdef ENABLE_GC_TRACE_PHASES
    if (___PROCESSOR_ID(___ps,___vms) == 0)
      ___printf ("garbage_collect_setup_phase\n");
    BARRIER();
  #endif
  
    /* Assign initial stack and heap msections to each processor */
  
    if (___PROCESSOR_ID(___ps,___vms) == 0)
      setup_stack_heap_vmstate (___vms);
  
    /* Create list of externally referenced still objects to trace */
  
    setup_still_objs_to_scan (___PSPNC);
  
    /* Account for deferred accounting of still object allocation */
  
    words_still_objs += words_still_objs_deferred;
    words_still_objs_deferred = 0;
  
  #ifdef ENABLE_GC_ACTLOG_PHASES
    ___ACTLOG_END_PS();
  #endif
  }
  
  
  ___HIDDEN void garbage_collect_mark_strong_phase
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
    ___virtual_machine_state ___vms = ___VMSTATE_FROM_PSTATE(___ps);
  
  #ifdef ENABLE_GC_ACTLOG_PHASES
    ___ACTLOG_BEGIN_PS(mark_strong_phase,_);
  #endif
  
  #ifdef ENABLE_GC_TRACE_PHASES
    if (___PROCESSOR_ID(___ps,___vms) == 0)
      ___printf ("garbage_collect_mark_strong_phase\n");
    BARRIER();
  #endif
  
  #ifdef ENABLE_CONSISTENCY_CHECKS
    if (___DEBUG_SETTINGS_LEVEL(___GSTATE->setup_params.debug_settings) >= 1)
      {
        stack_fudge_used = 0;
        heap_fudge_used = 0;
      }
  #endif
  
    /* maintain list of GC hash tables reached by GC */
  
    reached_gc_hash_tables = ___TAG(0,0);
  
    traverse_weak_refs = 0; /* don't traverse weak references in this phase */
  
    if (___PROCESSOR_ID(___ps,___vms) == 0)
      {
        mark_vm_scmobj (___PSPNC);
        mark_symkey_tables (___PSPNC);
        mark_rc (___PSPNC);
      }
  
    mark_global_variables (___PSPNC);
  
    mark_continuation (___PSPNC);
  
    mark_registers (___PSPNC);
  
    mark_processor_scmobj (___PSPNC);
  
    mark_reachable_from_marked (___PSPNC);
  
  #ifdef ENABLE_GC_ACTLOG_PHASES
    ___ACTLOG_END_PS();
  #endif
  }
  
  ___HIDDEN void nan_mark_array
     ___P((___PSD
           ___WORD *start,
           ___WORD n),
          (___PSV
           start,
           n)
  ___PSDKR
  ___WORD *start;
  ___WORD n;)
  
  {
    ___PSGET
    ___WORD *alloc = alloc_heap_ptr;
    ___WORD *limit = alloc_heap_limit;
  
    while (n-- > 0)
      {
        ___WORD *cell = start++;
  
      again: /* looping back here is possible when tail marking */
        {
          ___WORD obj = *cell;
          ___WORD tag = (obj & 0xFFFF000000000000);
  
          // Memory object
          if (tag == 0xFFFF000000000000)
            {
              ___WORD addr;
              ___WORD *body;
              ___WORD head;
              int head_typ;
              int subtype;
  
              addr = (obj & 0xFFFFFFFFFFFF);
              head = *((___WORD*)addr);
              body = ((___WORD*)addr)+1;
              subtype = ___HD_SUBTYPE(head);
              head_typ = ___HD_TYP(head);
  
              if (head_typ == ___MOVABLE0)
                {
                  ___SIZE_TS words = ___HD_WORDS(head);
  
                  while (alloc + words + 1 > limit)
                    {
                      alloc_heap_ptr = alloc;
                      end_heap_chunk (___ps);
                      next_heap_msection (___ps);
                      prepare_heap_msection (___ps);
                      alloc = alloc_heap_ptr;
                      limit = alloc_heap_limit;
                    }
  
                  *alloc++ = head;
  
                  // Write forwarding pointer
                  body[-1] = ___TAG((alloc - ___BODY_OFS), ___FORW);
  
                  // Write new tagged pointer in cell
                  ___WORD newaddr = alloc - ___BODY_OFS;
                  ___WORD tagged = 0xFFFF000000000000 | newaddr;
                  *cell = tagged;
  
                  if (words > 0 && subtype <= ___sBOXVALUES)
                    cell = alloc;
                  else
                    cell = 0;
  
                  while (words > 0)
                    {
                      *alloc++ = *body++;
                      words--;
                    }
  
                  if (alloc >= alloc_heap_chunk_limit)
                    {
                      alloc_heap_ptr = alloc;
                      end_heap_chunk (___ps);
                      start_heap_chunk (___ps);
                      alloc = alloc_heap_ptr;
                    }
  
                  if (cell != 0) goto again;
                }
              else if (head_typ == ___STILL)
                {
                  if (body[___STILL_MARK_OFS - ___STILL_BODY_OFS] == -1)
                    {
                      body[___STILL_MARK_OFS - ___STILL_BODY_OFS]
                        = ___CAST(___WORD,still_objs_to_scan);
                      still_objs_to_scan
                        = ___CAST(___WORD,body - ___STILL_BODY_OFS);
                    }
                }
              else if (___TYP(head_typ) == ___FORW)
                {
                  // Write new tagged pointer in cell
                  ___WORD newaddr = ___UNTAG_AS(head, ___FORW);
                  ___WORD tagged = 0xFFFF000000000000 | newaddr;
                  *cell = tagged;
                }
  
            }
        }
      }
  
    alloc_heap_ptr = alloc;
  }
  
  ___HIDDEN ___SIZE_TS nan_scan
     ___P((___PSD
           ___WORD *body),
          (___PSV
           body)
  ___PSDKR
  ___WORD *body;)
  {
    ___PSGET
    ___WORD head = body[-1];
  
    ___SIZE_TS words = ___HD_WORDS(head);
    int subtype = ___HD_SUBTYPE(head);
  
    switch (subtype)
      {
      case ___sFOREIGN:
      case ___sSTRING:
      case ___sS8VECTOR:
      case ___sU8VECTOR:
      case ___sS16VECTOR:
      case ___sU16VECTOR:
      case ___sS32VECTOR:
      case ___sU32VECTOR:
      case ___sS64VECTOR:
      case ___sU64VECTOR:
      case ___sF32VECTOR:
      case ___sF64VECTOR:
      case ___sFLONUM:
      case ___sBIGNUM:
        break;
  
      case ___sWEAK:
        printf("Unexpected case.\n"); // ___sWEAK is not used by lc
        exit(0);
        break;
  
      case ___sSYMBOL:
      case ___sKEYWORD:
        printf("NYI case scan 1.\n");
        exit(0);
        //mark_array (___PSP body, 1); /* only scan name of symbols & keywords */
        break;
  
      case ___sCONTINUATION:
        printf("Unexpected case.\n"); // ___sCONTINUATION is not used by lc
        exit(0);
        break;
  
      case ___sFRAME:
        printf("Unexpected case.\n"); // ___sWEAKFRAME is not used by lc
        exit(0);
        break;
  
      case ___sPROCEDURE:
        nan_mark_array (___PSP body+1, words-1); /* only scan free variables */
        break;
  
      default:
        if (___HD_TYP(head) == ___MOVABLE0 && subtype <= ___sBOXVALUES) {
            nan_mark_array (___PSP body+1, words-1);
        }
        else {
            nan_mark_array (___PSP body, words);
        }
        break;
      }
  
    return words;
  }
  
  ___HIDDEN void nan_scan_still_objs_to_scan
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
    ___WORD *base;
  
    while ((base = ___CAST(___WORD*,still_objs_to_scan)) != 0)
      {
        still_objs_to_scan = base[___STILL_MARK_OFS];
        nan_scan (___PSP base + ___STILL_BODY_OFS);
      }
  }
  
  ___HIDDEN void nan_scan_complete_heap_chunk
     ___P((___PSD
           ___WORD *start),
          (___PSV
           start)
  ___PSDKR
  ___WORD *start;)
  {
    ___PSGET
    ___WORD *ptr = start;
  
    while (___TYP(*ptr) != ___FORW) /* not end of complete chunk? */
      {
        ptr++;
        ptr += nan_scan (___PSP ptr);
      }
  
  }
  
  
  ___HIDDEN void nan_scan_movable_objs_to_scan
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
  
    ___WORD *ptr = scan_ptr;
    ___VOLATILE ___WORD *hcsh;
  
    while (ptr != alloc_heap_ptr) /* SITUATION #1 or #2 ? */
      {
        while (___TYP(*ptr) != ___FORW) /* not end of complete chunk? */
          {
            ptr++;
            ptr += nan_scan (___PSP ptr);
            if (ptr == alloc_heap_ptr) /* end of incomplete chunk? */
              {
                /* SITUATION #3, done scanning all movable objects */
                scan_ptr = ptr;
                return;
              }
          }
  
        scan_ptr = ptr; /* remember where scan ended */
  
        /*
         * SITUATION #1, at end of complete chunk.
         */
  
        ___SPINLOCK_LOCK(heap_chunks_to_scan_lock);
  
        while ((hcsh=heap_chunks_to_scan_head) != heap_chunks_to_scan_tail)
          {
            /*
             * Get the next complete heap chunk from heap chunk FIFO and
             * scan it.
             */
  
  
            ptr = ___UNTAG_AS(*hcsh, ___FORW);
  
            heap_chunks_to_scan_head = ptr;
  
            ___SHARED_MEMORY_BARRIER(); /* share heap_chunks_to_scan_head */
  
            ___SPINLOCK_UNLOCK(heap_chunks_to_scan_lock);
  
            nan_scan_complete_heap_chunk (___PSP ptr+1);
  
            ___SPINLOCK_LOCK(heap_chunks_to_scan_lock);
          }
  
        ___SPINLOCK_UNLOCK(heap_chunks_to_scan_lock);
  
        /*
         * Scan the incomplete heap chunk currently being created.
         */
  
        ptr = alloc_heap_chunk_start;
  
        scan_ptr = ptr;
      }
  }
  
  ___HIDDEN void nan_mark_reachable_from_marked
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
  
    do
      {
        nan_scan_still_objs_to_scan (___PSPNC);
        nan_scan_movable_objs_to_scan (___PSPNC);
      } while (___CAST(___WORD*,still_objs_to_scan) != 0);
  }
  
  
  #ifdef LC_DEBUG
  
      #define lc_log(...) printf(__VA_ARGS__)
  
      void print_lc_descriptor(___U64 descriptor)
      {
          lc_log("# descriptor %llu (fs == %llu, mask == %llu)\n", descriptor, descriptor & 255, descriptor >>  8);
      }
  
      void print_lc_stack(___WORD* stack_ptr, ___WORD* stack_lim)
      {
          lc_log("** stack:\n");
          lc_log("+--------------------------------------\n");
          lc_log("| rdx -> %p == %llu\n", stack_ptr+0, stack_ptr[0]);
          lc_log("+--------------------------------------\n");
          lc_log("| r14 -> %p == %llu\n", stack_ptr+1, stack_ptr[1]);
          lc_log("+--------------------------------------\n");
          lc_log("| r13 -> %p == %llu\n", stack_ptr+2, stack_ptr[2]);
          lc_log("+--------------------------------------\n");
          lc_log("| r12 -> %p == %llu\n", stack_ptr+3, stack_ptr[3]);
          lc_log("+--------------------------------------\n");
          lc_log("| r11 -> %p == %llu\n", stack_ptr+4, stack_ptr[4]);
          lc_log("+--------------------------------------\n");
          lc_log("| r10 -> %p == %llu\n", stack_ptr+5, stack_ptr[5]);
          lc_log("+--------------------------------------\n");
          lc_log("| rdi -> %p == %llu\n", stack_ptr+6, stack_ptr[6]);
          lc_log("+--------------------------------------\n");
          lc_log("| rsi -> %p == %llu\n", stack_ptr+7, stack_ptr[7]);
          lc_log("+--------------------------------------\n");
          lc_log("| r15 -> %p == %llu\n", stack_ptr+8, stack_ptr[8]);
          lc_log("+--------------------------------------\n");
          lc_log("| rbx -> %p == %llu\n", stack_ptr+9, stack_ptr[9]);
          lc_log("+--------------------------------------\n");
          lc_log("| rcx -> %p == %llu\n", stack_ptr+10, stack_ptr[10]);
          lc_log("+--------------------------------------\n");
          lc_log("+--------------------------------------\n");
          for (int i=0; i<200; i++)
          {
              if (stack_ptr+11+i >= stack_lim)
                break;
              lc_log("| %p == %llu\n", stack_ptr+11+i, stack_ptr[11+i]);
              lc_log("+--------------------------------------\n");
          }
      }
  #else
      #define lc_log(...)
      #define print_lc_descriptor(...)
      #define print_lc_stack(...)
  #endif
  
  void mark_lc_frame(___WORD* ptr, ___U64 descriptor, ___U64 len)
  {
      lc_log("# Marking frame %llx for %llx elements \n", ptr, len);
      for (___U64 i=0; i<len; i++)
      {
          if ((descriptor & 1) == 0)
          {
              lc_log("    Marking %llx\n", ptr-i);
              mark_array(___PSP ptr-i,1);
          }
          descriptor = descriptor >> 1;
      }
  }
  
  ___HIDDEN void garbage_collect_lc_phase
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
    ___virtual_machine_state ___vms = ___VMSTATE_FROM_PSTATE(___ps);
  
    //reached_gc_hash_tables = ___TAG(0,0);
    traverse_weak_refs = 0; /* don't traverse weak references in this phase */
  
    // Get stack info from global lc ctx
    ___WORD* body = (lc_global_ctx.lc_stack+1);
    ___WORD  head = *lc_global_ctx.lc_stack;
    ___WORD* stack_ptr = (lc_global_ctx.lc_stack_ptr);
    ___WORD  vlen = (head >> 11);
    ___WORD len = body + vlen - stack_ptr;
    ___WORD* stack_lim = body + vlen;
  
    lc_log("-- GC \n");
    lc_log("USE LC DESC: %lld\n", lc_global_ctx.lc_stack_usedesc);
    print_lc_stack(stack_ptr,stack_lim);
  
    // Mark saved registers
    mark_array(___PSP stack_ptr, 11);
    stack_ptr += 11;
  
    // Mark first frame
    ___U64 desc;
    switch (lc_global_ctx.lc_stack_usedesc)
    {
        case LC_CALLBACK_FN:
        {
            // GC called from lc fn callback, use registered frame descriptor
            desc = lc_global_ctx.lc_stack_desc;
            stack_ptr += (desc & 255) - 1;
            break;
        }
        case LC_CALLBACK_CONT:
        {
            // GC called from lc cont callback, extract cr table from rdx
            ___WORD* table = stack_ptr[-11];
            desc = table[1];
            stack_ptr += (desc & 255)-1;
            break;
        }
        case LC_CALLBACK_STUB:
        {
            // GC called from stub callback, use registered frame descriptor
            desc = lc_global_ctx.lc_stack_desc;
            stack_ptr += (desc & 255)-1;
            break;
        }
        case LC_GENERIC_REST:
        {
            // GC called from generic rest param allocation, use pushed encoded fs as descriptor
            desc = (stack_ptr[1] >> 2)+1;
            stack_ptr += (desc & 255)+1;
            break;
        }
        case LC_GAMBIT_CALL:
        {
            ___U64 nbargs =  stack_ptr[0];
            desc = stack_ptr[1];
            stack_ptr += (desc & 255) + 4 + nbargs - 1;
            break;
        }
        default:
        {
            // GC called from runtime lc allocation, extract descriptor from top of stack
            desc = stack_ptr[0];
            stack_ptr += (desc & 255);
        }
    }
    ___U64 desc_fs = desc & 255;
    ___U64 desc_mask = desc >> 8;
    print_lc_descriptor(desc);
    // First frame is empty then skip stack scanning
    mark_lc_frame(stack_ptr, desc_mask, desc_fs);
  
    if (desc_fs == 0)
      stack_ptr += 1;
  
    // ___WORD* body = (lc_global_ctx.lc_stack+1);
    // ___WORD  head = *lc_global_ctx.lc_stack;
    // ___WORD* stack_ptr = (lc_global_ctx.lc_stack_ptr);
    // ___WORD  vlen = (head >> 11);
    // ___WORD len = body + vlen - stack_ptr;
    lc_log("lc_stack_ptr %p\n", (lc_global_ctx.lc_stack_ptr));
    lc_log("lc_stack_bod %p\n", (lc_global_ctx.lc_stack+1));
    lc_log("lc_stack_lim %p\n", body + vlen);
  
    lc_log("lc_stubs_begin %p\n", lc_global_ctx.lc_stubs_begin);
    lc_log("lc_stubs_end %p\n", lc_global_ctx.lc_stubs_end);
  
    // Mark other frames
    while (stack_ptr < (stack_lim - 1))
    {
        ___WORD* table = stack_ptr[0];
  
        if (lc_global_ctx.lc_intraprocedural)
        {
            if (table >= lc_global_ctx.lc_stubs_begin && table < lc_global_ctx.lc_stubs_end)
            {
                lc_log("Read descriptor from continuation stub (%p).\n", table);
                ___U64 stub_addr = (___U64)table;
                ___U64 vec_addr = *((___U64*)(stub_addr+5));
                ___U64 desc_addr = vec_addr - 1 + 16;
                desc = *((___U64*)desc_addr);
                desc = desc >> 2; // Because descriptor is tagged in stubs, we need to untag it
            }
            else
            {
                lc_log("Read descriptor from continuation version (%p).\n", table);
                desc = table[-1];
            }
        }
        else
          desc = table[1];
        lc_log("reading descriptor at %p\n", (stack_ptr));
        print_lc_descriptor(desc);
  
        desc_fs = desc & 255;
        desc_mask = desc >> 8;
        stack_ptr += desc_fs;
        mark_lc_frame(stack_ptr, desc_mask, desc_fs);
    }
  
    // NOTE: Globals are handled by gambit default gc
  
    // Mark reachable
    mark_reachable_from_marked(___PSPNC);
  
    // Reset usedesc variable to LC_CALLBACK_NONE for next GCs
    lc_global_ctx.lc_stack_usedesc = LC_CALLBACK_NONE;
  }
  
  ___HIDDEN void garbage_collect_nan_phase
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
    ___virtual_machine_state ___vms = ___VMSTATE_FROM_PSTATE(___ps);
  
    //reached_gc_hash_tables = ___TAG(0,0);
    traverse_weak_refs = 0; /* don't traverse weak references in this phase */
  
    // Mark lc stack
    ___WORD* body = (lc_global_ctx.lc_stack+1);
    ___WORD  head = *lc_global_ctx.lc_stack;
    ___WORD* stack_ptr = (lc_global_ctx.lc_stack_ptr);
    ___WORD  vlen = (head >> 11);
    ___WORD len = body + vlen - stack_ptr;
    nan_mark_array(___PSP stack_ptr, len);
  
    // Mark lc global
    body = (lc_global_ctx.lc_global+1);
    head = *lc_global_ctx.lc_global;
    len = (head >> 11);
    nan_mark_array(___PSP body, len);
  
    // Mark reachable
    nan_mark_reachable_from_marked(___PSPNC);
  }
  
  ___HIDDEN void garbage_collect_mark_weak_phase
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
    ___virtual_machine_state ___vms = ___VMSTATE_FROM_PSTATE(___ps);
  
    /*
     * At this point all of the objects accessible from the roots
     * without having to traverse a weak reference have been scanned
     * by the GC.
     */
  
  #ifdef ENABLE_GC_ACTLOG_PHASES
    ___ACTLOG_BEGIN_PS(mark_weak_phase,_);
  #endif
  
  #ifdef ENABLE_GC_TRACE_PHASES
    if (___PROCESSOR_ID(___ps,___vms) == 0)
      ___printf ("garbage_collect_mark_weak_phase\n");
    BARRIER();
  #endif
  
    traverse_weak_refs = 1; /* traverse weak references in this phase */
  
    process_wills (___PSPNC);
  
    mark_reachable_from_marked (___PSPNC);
  
    move_continuation (___PSPNC);
  
  #ifdef ENABLE_GC_ACTLOG_PHASES
    ___ACTLOG_END_PS();
  #endif
  }
  
  
  ___HIDDEN void garbage_collect_cleanup_phase
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
    ___virtual_machine_state ___vms = ___VMSTATE_FROM_PSTATE(___ps);
  
  #ifdef ENABLE_GC_ACTLOG_PHASES
    ___ACTLOG_BEGIN_PS(cleanup_phase,_);
  #endif
  
  #ifdef ENABLE_GC_TRACE_PHASES
    if (___PROCESSOR_ID(___ps,___vms) == 0)
      ___printf ("garbage_collect_cleanup_phase\n");
    BARRIER();
  #endif
  
    process_gc_hash_tables (___PSPNC);
  
    free_unmarked_still_objs (___PSPNC);
  
  #ifdef ENABLE_GC_ACTLOG_PHASES
    ___ACTLOG_END_PS();
  #endif
  }
  
  
  ___BOOL ___garbage_collect_pstate
     ___P((___processor_state ___ps,
           ___SIZE_TS requested_words_still),
          (___ps,
           requested_words_still)
  ___processor_state ___ps;
  ___SIZE_TS requested_words_still;)
  {
    ___virtual_machine_state ___vms = ___VMSTATE_FROM_PSTATE(___ps);
    ___BOOL overflow = 0;
    ___F64 user_time_start, sys_time_start, real_time_start;
    ___F64 user_time_end, sys_time_end, real_time_end;
    ___F64 user_time, sys_time, real_time;
  
    ___ACTLOG_BEGIN_PS(gc,red);
  
    /* Start measuring GC statistics */
  
    if (___PROCESSOR_ID(___ps,___vms) == 0)
      {
  #ifdef ENABLE_GC_TRACE_PHASES
        ___printf ("----------------------------------------- GC START #%d\n", ___CAST(int,nb_gcs)+1);
  #endif
        ___process_times (&user_time_start, &sys_time_start, &real_time_start);
      }
  
    /* Print debugging info */
  
  #ifdef ___DEBUG_GARBAGE_COLLECT
  
    {
      int p;
      int np = ___vms->processor_count;
      for (p=0; p<np; p++)
        {
          if (___PROCESSOR_ID(___ps,___vms) == p)
            {
              ___printf ("processor #%d\n", p);
              ___printf ("heap_size          = %d\n", heap_size);
              ___printf ("tospace_offset     = %d\n", ___ps->mem.tospace_offset_);
              ___printf ("___ps->stack_start = %p\n", ___ps->stack_start);
              ___printf ("___ps->stack_break = %p\n", ___ps->stack_break);
              ___printf ("___ps->fp          = %p\n", ___ps->fp);
              ___printf ("___ps->stack_limit = %p\n", ___ps->stack_limit);
              ___printf ("___ps->heap_limit  = %p\n", ___ps->heap_limit);
              ___printf ("___ps->hp          = %p\n", ___ps->hp);
            }
          BARRIER();
        }
    }
  
  #endif
  
    /* Recover processor's stack and heap pointers */
  
    alloc_stack_ptr = ___ps->fp;
    alloc_heap_ptr  = ___ps->hp;
  
  
    /* Keep track of bytes allocated by this processor */
  
    bytes_allocated_minus_occupied += bytes_occupied(___ps);
  
    BARRIER();
  
  
    /* Setup the stacks and heaps of all the processors */
  
    garbage_collect_setup_phase (___PSPNC);
  
    BARRIER();
  
  
    /* Mark the objects that are reachable strongly */
  
    garbage_collect_mark_strong_phase (___PSPNC);
  
    BARRIER();
  
    #ifdef LC_DEBUG
        if (lc_global_ctx.gc_lock != 0)
        {
            printf("ERROR: GC blocked by LC but called during callback init phase.\n");
            printf("       Locked by %llu\n", lc_global_ctx.gc_lock);
            exit(0);
        }
    #endif
  
    /* Process LC objects (nan boxed objects) */
    if (lc_global_ctx.lc_stack != NULL && lc_global_ctx.lc_stack_ptr != NULL)
    {
        if (lc_global_ctx.lc_global != NULL)
          garbage_collect_nan_phase(___PSPNC);
        else
          garbage_collect_lc_phase(___PSPNC);
    }
  
    BARRIER();
  
    /* Mark the objects that are reachable weakly */
  
    garbage_collect_mark_weak_phase (___PSPNC);
  
    BARRIER();
  
    /* Process gc hash tables and free unreachable still objects */
  
    garbage_collect_cleanup_phase (___PSPNC);
  
    BARRIER();
  
  
    /* Resize heap */
  
    if (___PROCESSOR_ID(___ps,___vms) == 0)
      overflow = resize_heap (___vms, requested_words_still);
  
    BARRIER();
  
  
    /* Guarantee heap fudge */
  
    if (alloc_heap_ptr > alloc_heap_limit - ___MSECTION_FUDGE)
      next_heap_msection (___ps);
  
  
    /* Keep track of bytes allocated by this processor */
  
    bytes_allocated_minus_occupied -= bytes_occupied(___ps);
  
  
    /* Finalize measuring GC statistics */
  
    if (___PROCESSOR_ID(___ps,___vms) == 0)
      {
        ___process_times (&user_time_end, &sys_time_end, &real_time_end);
  
        user_time = user_time_end - user_time_start;
        sys_time = sys_time_end - sys_time_start;
        real_time = real_time_end - real_time_start;
  
        nb_gcs = nb_gcs + 1.0;
        gc_user_time += user_time;
        gc_sys_time += sys_time;
        gc_real_time += real_time;
  
        latest_gc_user_time = user_time;
        latest_gc_sys_time = sys_time;
        latest_gc_real_time = real_time;
  
        ___raise_interrupt_pstate (___ps, ___INTR_GC); /* raise gc interrupt */
  
  #ifdef ENABLE_GC_TRACE_PHASES
        ___printf ("----------------------------------------- GC END #%d\n", ___CAST(int,nb_gcs));
  #endif
      }
  
    /* Prepare to continue executing program */
  
    prepare_mem_pstate (___ps);
  
  
    ___ACTLOG_END_PS();
  
    return overflow;
  }
  
  
  #ifdef ___DEBUG_STACK_LIMIT
  
  ___BOOL ___stack_limit_debug
     ___P((___PSD
           int line,
           char *file),
          (___PSV
           line,
           file)
  ___PSDKR
  int line;
  char *file;)
  
  #else
  
  ___BOOL ___stack_limit
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  
  #endif
  {
    ___PSGET
  
    /*
     * In a multithreaded VM, the function ___stack_limit can be called
     * concurrently by multiple processors. The VM level memory allocation
     * lock is used to implement a critical section.
     */
  
    /* Recover processor's stack and heap pointers */
  
    alloc_stack_ptr = ___ps->fp;
    alloc_heap_ptr  = ___ps->hp;
  
  #ifdef ___DEBUG_STACK_LIMIT
    ___ps->stack_limit_line = line;
    ___ps->stack_limit_file = file;
    ___printf ("___POLL caused ___stack_limit call at %s:%d\n",
               ___ps->poll_file,
               ___ps->poll_line);
  #endif
  
  #ifdef ENABLE_CONSISTENCY_CHECKS
    if (___DEBUG_SETTINGS_LEVEL(___GSTATE->setup_params.debug_settings) >= 1)
      check_fudge_used (___PSPNC);
  #endif
  
    if (alloc_stack_ptr < alloc_stack_limit + ___MSECTION_FUDGE)
      {
        /*
         * There isn't enough free space in the current stack msection.
         */
  
        ___msection *prev_stack_msection = stack_msection;
        ___WORD *prev_alloc_stack_start = alloc_stack_start;
        ___WORD *prev_alloc_stack_ptr = alloc_stack_ptr;
        ___WORD *prev_stack_break = ___ps->stack_break;
        ___WORD *fp;
        int frame_count;
        int words;
  
        /*
         * Get a new stack msection.
         */
  
        ___msection *ms = msection_free_list;
  
        if (stack_msection != heap_msection &&
            ms != NULL)
          {
            /* we can reuse an existing one */
  
            msection_free_list = ___CAST(___msection*,ms->base[0]);
  
            set_stack_msection (___ps, ms);
          }
        else
          {
            /* we need to allocate a new msection */
  
            ALLOC_MEM_LOCK();
  
            if (
  #ifdef CALL_GC_FREQUENTLY
                --___gc_calls_to_punt < 0 ||
  #endif
                compute_free_heap_space() < ___MSECTION_SIZE)
              {
                ALLOC_MEM_UNLOCK();
  
                /*
                 * Because the GC preserves the topmost contiguous
                 * frames in the stack msection (the frames between the
                 * stack pointer and the latest break frame), the
                 * occupation of the stack msection would increase
                 * gradually with subsequent calls to ___stack_limit and
                 * this would eventually cause an uncontrolled overflow
                 * of the stack msection.
                 *
                 * To avoid this, a break frame is added at the top of
                 * the stack when the topmost contiguous frames in the
                 * stack msection take too much space.  This will cause
                 * the GC to move all the frames to the heap.
                 */
  
                if ((___ps->stack_break - alloc_stack_ptr) >
                    (___ps->stack_start - ___ps->stack_limit)*2/3)
                  {
                    /*
                     * At the top of the current stack msection there are
                     * contiguous frames that occupy more than 2/3 of the
                     * available space.
                     */
  
                    /*
                     * Add a break frame.
                     */
  
                    ___FP_ADJFP(alloc_stack_ptr,___BREAK_FRAME_SPACE)
                    ___FP_SET_STK(alloc_stack_ptr,
                                  -___BREAK_FRAME_NEXT,
                                  ___CAST(___WORD,prev_alloc_stack_ptr))
                    ___ps->stack_break = alloc_stack_ptr;
                  }
  
                prepare_mem_pstate (___ps);
  
                return 1; /* trigger GC */
              }
  
            next_stack_msection_without_locking (___ps);
  
            ALLOC_MEM_UNLOCK();
          }
  
        /*
         * Move to the new stack msection.
         */
  
        ___ps->stack_start = alloc_stack_start;
        alloc_stack_ptr = alloc_stack_start;
  
        /*
         * Create a "break frame" in the new stack msection.  The break
         * frame is used by the break handler (see _kernel.scm).
         */
  
        ___FP_ADJFP(alloc_stack_ptr,___FIRST_BREAK_FRAME_SPACE)
  
        /*
         * Because ___stack_limit is only called by the stack-limit
         * handler in _kernel.scm and it has pushed an internal
         * return frame to the top of the stack, the frame pointer
         * can't be pointing to a break frame,
         * i.e. prev_alloc_stack_ptr != prev_stack_break.
         *
         * If the topmost frame were to be left on the
         * stack, when ___stack_overflow_undo would return to it, an
         * uncontrolled overflow of the stack would be possible
         * (because the generated code assumes that after returning
         * from a call to ___stack_limit it is OK to perform a
         * function call without checking the stack limit).
         *
         * For this reason, is is necessary for correctness to
         * transfer the topmost frame to the new stack msection.
         * However, only transferring the topmost frame may cause
         * the stack limit handler to be called frequently if there
         * are many shallow function calls in a row (calls to
         * ___stack_limit followed by ___stack_overflow_undo in a
         * tight loop).  To avoid this performance issue, it is best
         * to transfer a certain number of frames, but no more than
         * up to the break frame.
         */
  
        fp = prev_alloc_stack_ptr;
        frame_count = 0; /* count of frames to transfer */
  
        for (;;)
          {
            int fs, link;
            ___WORD ra1 = ___FP_STK(fp,-___FRAME_STACK_RA);
            ___WORD ra2;
  
            frame_count++;
  
            if (ra1 == ___GSTATE->internal_return)
              {
                ___WORD actual_ra = ___FP_STK(fp,___RETI_RA);
                ___RETI_GET_FS_LINK(actual_ra,fs,link)
              }
            else
              {
                ___RETN_GET_FS_LINK(ra1,fs,link)
              }
  
            ___FP_ADJFP(fp,-___FRAME_SPACE(fs)) /* get base of frame */
  
            ra2 = ___FP_STK(fp,link+1);
  
            words = fp - prev_alloc_stack_ptr;
  
            if (fp == prev_stack_break)
              {
                /* reached the break frame */
  
                /* best to not transfer any frames to new stack msection */
  
                /*
                 * Add a break frame.
                 */
  
                ___FP_ADJFP(alloc_stack_ptr,___BREAK_FRAME_SPACE)
                ___FP_SET_STK(alloc_stack_ptr,
                              -___BREAK_FRAME_NEXT,
                              ___CAST(___WORD,prev_alloc_stack_ptr))
                ___ps->stack_break = alloc_stack_ptr;
  
                fp = alloc_stack_ptr;
  
                break;
              }
  
            ___FP_SET_STK(fp,-___FRAME_STACK_RA,ra2)
  
            words = fp - prev_alloc_stack_ptr;
  
            if (frame_count >= 5 || words >= 100)
              {
                /* reached max frame count or max volume */
  
                /*
                 * Save state of previous stack msection in the
                 * first break frame of new stack msection to allow
                 * returning to the previous stack msection when
                 * ___stack_overflow_undo is called.
                 */
  
                ___FP_SET_STK(alloc_stack_ptr,
                              -___FIRST_BREAK_FRAME_STACK_MSECTION,
                              ___CAST(___WORD,prev_stack_msection))
  
                ___FP_SET_STK(alloc_stack_ptr,
                              -___FIRST_BREAK_FRAME_STACK_BREAK,
                              ___CAST(___WORD,prev_stack_break))
  
                ___FP_SET_STK(alloc_stack_ptr,
                              -___BREAK_FRAME_NEXT,
                              ___CAST(___WORD,fp))
  
                ___ps->stack_break = alloc_stack_ptr;
  
                memmove (alloc_stack_ptr - words,
                         prev_alloc_stack_ptr,
                         words << ___LWS);
  
                ___FP_SET_STK(alloc_stack_ptr,
                              link+1,
                              ___GSTATE->handler_break)
  
                ___FP_ADJFP(alloc_stack_ptr, words)
  
                break;
              }
          }
  
        stack_msection_stop_using (___ps, prev_alloc_stack_start, fp);
      }
  
    prepare_mem_pstate (___ps);
  
    return 0;
  }
  
  
  ___WORD ___stack_overflow_undo_if_possible
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
    ___D_FP
    ___R_FP
  
    if (stack_msection != heap_msection &&
        ___ps->stack_start == &___STK(-___FIRST_BREAK_FRAME_SPACE))
      {
        /*
         * The current stack msection is not shared with the heap and
         * the break frame is at the start of the stack msection, so
         * the stack can be moved to the previous stack msection.
         */
  
        ___msection *ms = ___CAST(___msection*,
                                  ___STK(-___FIRST_BREAK_FRAME_STACK_MSECTION));
  
        stack_msection->base[0] = ___CAST(___WORD,msection_free_list);
        msection_free_list = stack_msection;
  
        set_stack_msection (___ps, ms);
  
        ___ps->stack_break =
          ___CAST(___WORD*,___STK(-___FIRST_BREAK_FRAME_STACK_BREAK));
  
        alloc_stack_ptr =
          ___CAST(___WORD*,___STK(-___BREAK_FRAME_NEXT));
  
        ___ps->stack_start = alloc_stack_start;
  
        stack_msection_resume_using (___ps, alloc_stack_start, alloc_stack_ptr);
  
        prepare_mem_pstate (___ps);
  
        ___SET_FP(alloc_stack_ptr)
  
        return ___FRAME_FETCH_RA;
      }
  
    return ___FAL;
  }
  
  
  #ifdef ___DEBUG_HEAP_LIMIT
  
  ___BOOL ___heap_limit_debug
     ___P((___PSD
           int line,
           char *file),
          (___PSV
           line,
           file)
  ___PSDKR
  int line;
  char *file;)
  
  #else
  
  ___BOOL ___heap_limit
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  
  #endif
  {
    ___PSGET
  
    /*
     * In a multithreaded VM, the function ___heap_limit can be called
     * concurrently by multiple processors. The VM level memory allocation
     * lock is used to implement a critical section.
     */
  
    /* Recover processor's stack and heap pointers */
  
    alloc_stack_ptr = ___ps->fp;
    alloc_heap_ptr  = ___ps->hp;
  
  #ifdef ___DEBUG_HEAP_LIMIT
    ___ps->heap_limit_line = line;
    ___ps->heap_limit_file = file;
  #endif
  
  #ifdef ENABLE_CONSISTENCY_CHECKS
    if (___DEBUG_SETTINGS_LEVEL(___GSTATE->setup_params.debug_settings) >= 1)
      check_fudge_used (___PSPNC);
  #endif
  
    {
      /*
       * Get a new heap msection.
       */
  
      ___msection *ms = msection_free_list;
  
      if (stack_msection != heap_msection &&
          ms != NULL)
        {
          /* we can reuse an existing one */
  
          msection_free_list = ___CAST(___msection*,ms->base[0]);
  
          set_heap_msection (___ps, ms);
        }
      else
        {
          /* we need to allocate a new msection */
  
          ALLOC_MEM_LOCK();
  
          if (
  #ifdef CALL_GC_FREQUENTLY
              --___gc_calls_to_punt >= 0 &&
  #endif
              compute_free_heap_space() >= ___MSECTION_SIZE)
            {
              if (alloc_heap_ptr > alloc_heap_limit - ___MSECTION_FUDGE)
                next_heap_msection_without_locking (___ps);
  
              ALLOC_MEM_UNLOCK();
            }
          else
            {
              ALLOC_MEM_UNLOCK();
  
              return 1; /* trigger GC */
            }
        }
    }
  
    prepare_mem_pstate (___ps);
  
    return 0;
  }
  
  
  /*---------------------------------------------------------------------------*/
  
  
  ___F64 ___bytes_allocated
     ___P((___PSDNC),
          (___PSVNC)
  ___PSDKR)
  {
    ___PSGET
  
    /* Recover processor's stack and heap pointers */
  
    alloc_stack_ptr = ___ps->fp;
    alloc_heap_ptr  = ___ps->hp;
  
    return bytes_allocated_minus_occupied + bytes_occupied(___ps);
  }
  
  
  /*---------------------------------------------------------------------------*/
  