home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / bchdmp.c < prev    next >
C/C++ Source or Header  |  2001-02-12  |  31KB  |  1,109 lines
  1. /* -*-C-*-
  2.  
  3. $Id: bchdmp.c,v 9.88 2001/02/12 22:32:32 cph Exp $
  4.  
  5. Copyright (c) 1987-2001 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag,
  23.    purify, and fasdump, respectively, to provide garbage collection
  24.    and related utilities to disk. */
  25.  
  26. #include "scheme.h"
  27. #include "prims.h"
  28. #include "osfile.h"
  29. #include "osfs.h"
  30. #include "trap.h"
  31. #include "lookup.h"        /* UNCOMPILED_VARIABLE */
  32. #define In_Fasdump
  33. #include "fasl.h"
  34. #include "bchgcc.h"
  35.  
  36. extern int EXFUN (OS_channel_copy, (off_t, Tchannel, Tchannel));
  37.  
  38. extern SCHEME_OBJECT EXFUN
  39.   (dump_renumber_primitive, (SCHEME_OBJECT));
  40. extern SCHEME_OBJECT * EXFUN
  41.   (initialize_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *));
  42. extern SCHEME_OBJECT * EXFUN
  43.   (cons_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *));
  44. extern SCHEME_OBJECT * EXFUN
  45.   (cons_whole_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *));
  46.  
  47. extern SCHEME_OBJECT compiler_utilities;
  48. extern SCHEME_OBJECT * EXFUN
  49.   (cons_c_code_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *));
  50.  
  51. #ifdef __unix__
  52. #  include "ux.h"
  53. #  include "uxio.h"
  54.    static char FASDUMP_FILENAME[] = "fasdumpXXXXXX";
  55. #endif
  56.  
  57. #ifdef __WIN32__
  58. #  include "nt.h"
  59. #  include "ntio.h"
  60.    static char FASDUMP_FILENAME[] = "faXXXXXX";
  61. #endif
  62.  
  63. #ifdef __OS2__
  64. #  include "os2.h"
  65.    static char FASDUMP_FILENAME[] = "faXXXXXX";
  66. #  ifdef __EMX__
  67. #    include <io.h>
  68. #  endif
  69. #  if defined(__IBMC__) || defined(__WATCOMC__)
  70. #    include <io.h>
  71. #    include <sys\stat.h>
  72. #    include <fcntl.h>
  73. #    ifndef F_OK
  74. #      define F_OK 0
  75. #      define X_OK 1
  76. #      define W_OK 2
  77. #      define R_OK 4
  78. #    endif
  79. #  endif
  80. #endif
  81.  
  82. static Tchannel dump_channel;
  83. static CONST char * dump_file_name;
  84. static int real_gc_file;
  85. static int dump_file;
  86. static SCHEME_OBJECT * saved_free;
  87. static SCHEME_OBJECT * fixup_buffer = 0;
  88. static SCHEME_OBJECT * fixup_buffer_end;
  89. static SCHEME_OBJECT * fixup;
  90. static int fixup_count = 0;
  91. static Boolean compiled_code_present_p;
  92.  
  93. #define Write_Data(size, buffer)                    \
  94.   ((OS_channel_write_dump_file                        \
  95.     (dump_channel,                            \
  96.      ((char *) (buffer)),                        \
  97.      ((size) * (sizeof (SCHEME_OBJECT)))))                \
  98.    / (sizeof (SCHEME_OBJECT)))
  99.  
  100. #include "dump.c"
  101.  
  102. static SCHEME_OBJECT EXFUN (dump_to_file, (SCHEME_OBJECT, CONST char *));
  103. static int EXFUN (fasdump_exit, (long length));
  104. static int EXFUN (reset_fixes, (void));
  105. static ssize_t EXFUN (eta_read, (int, char *, int));
  106. static ssize_t EXFUN (eta_write, (int, char *, int));
  107. static long EXFUN
  108.   (dump_loop, (SCHEME_OBJECT *, SCHEME_OBJECT **, SCHEME_OBJECT **));
  109.  
  110. /* (PRIMITIVE-FASDUMP object-to-dump filename-or-channel flag)
  111.  
  112.    Dump an object into a file so that it can be loaded using
  113.    BINARY-FASLOAD.  A spare heap is required for this operation.  The
  114.    first argument is the object to be dumped.  The second is the
  115.    filename or channel.  The third argument, FLAG, is currently
  116.    ignored.  The primitive returns #T or #F indicating whether it
  117.    successfully dumped the object (it can fail on an object that is
  118.    too large).  It should signal an error rather than return false,
  119.    but ... some other time.
  120.  
  121.    This version of fasdump can only handle files (actually lseek-able
  122.    streams), since the header is written at the beginning of the
  123.    output but its contents are only know after the rest of the output
  124.    has been written.
  125.  
  126.    Thus, for arbitrary channels, a temporary file is allocated, and on
  127.    completion, the file is copied to the channel.  */
  128.  
  129. DEFINE_PRIMITIVE ("PRIMITIVE-FASDUMP", Prim_prim_fasdump, 3, 3, 0)
  130. {
  131.   PRIMITIVE_HEADER (3);
  132.   {
  133.     SCHEME_OBJECT root = (ARG_REF (1));
  134.     if (STRING_P (ARG_REF (2)))
  135.       PRIMITIVE_RETURN (dump_to_file (root, (STRING_ARG (2))));
  136.     {
  137.       Tchannel channel = (arg_channel (2));
  138.       char * temp_name = (make_gc_file_name (FASDUMP_FILENAME));
  139.       transaction_begin ();
  140.       protect_gc_file_name (temp_name);
  141.       if (!allocate_gc_file (temp_name))
  142.     signal_error_from_primitive (ERR_EXTERNAL_RETURN);
  143.       {
  144.     SCHEME_OBJECT fasdump_result = (dump_to_file (root, temp_name));
  145.     if (fasdump_result == SHARP_T)
  146.       {
  147.         Tchannel temp_channel = (OS_open_input_file (temp_name));
  148.         int copy_result
  149.           = (OS_channel_copy ((OS_file_length (temp_channel)),
  150.                   temp_channel,
  151.                   channel));
  152.         OS_channel_close (temp_channel);
  153.         OS_file_remove (temp_name);
  154.         transaction_commit ();
  155.         if (copy_result < 0)
  156.           signal_error_from_primitive (ERR_IO_ERROR);
  157.       }
  158.     PRIMITIVE_RETURN (fasdump_result);
  159.       }
  160.     }
  161.   }
  162. }
  163.  
  164. /* (DUMP-BAND PROCEDURE FILE-NAME)
  165.    Saves all of the heap and pure space on FILE-NAME.  When the
  166.    file is loaded back using BAND_LOAD, PROCEDURE is called with an
  167.    argument of #F.  */
  168.  
  169. DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2, 0)
  170. {
  171.   SCHEME_OBJECT * saved_free;
  172.   SCHEME_OBJECT * prim_table_start;
  173.   SCHEME_OBJECT * prim_table_end;
  174.   SCHEME_OBJECT * c_table_start;
  175.   SCHEME_OBJECT * c_table_end;
  176.   long prim_table_length;
  177.   long c_table_length;
  178.   int result = 0;
  179.   PRIMITIVE_HEADER (2);
  180.  
  181.   Band_Dump_Permitted ();
  182.   CHECK_ARG (1, INTERPRETER_APPLICABLE_P);
  183.   CHECK_ARG (2, STRING_P);
  184.   if (Unused_Heap_Bottom < Heap_Bottom)
  185.     /* Cause the image to be in the low heap, to increase
  186.        the probability that no relocation is needed on reload. */
  187.     Primitive_GC (0);
  188.   Primitive_GC_If_Needed (5);
  189.  
  190.   saved_free = Free;
  191.  
  192.   {
  193.     SCHEME_OBJECT Combination;
  194.     Combination = (MAKE_POINTER_OBJECT (TC_COMBINATION_1, Free));
  195.     (Free[COMB_1_FN]) = (ARG_REF (1));
  196.     (Free[COMB_1_ARG_1]) = SHARP_F;
  197.     Free += 2;
  198.     {
  199.       SCHEME_OBJECT p = (MAKE_POINTER_OBJECT (TC_LIST, Free));
  200.       (*Free++) = Combination;
  201.       (*Free++) = compiler_utilities;
  202.       (*Free++) = p;
  203.     }
  204.   }
  205.  
  206.   prim_table_start = Free;
  207.   prim_table_end
  208.     = (cons_whole_primitive_table (prim_table_start, Heap_Top,
  209.                    (&prim_table_length)));
  210.   if (prim_table_end >= Heap_Top)
  211.     goto done;
  212.  
  213.   c_table_start = prim_table_end;
  214.   c_table_end
  215.     = (cons_c_code_table (c_table_start, Heap_Top,
  216.               (&c_table_length)));
  217.   if (c_table_end >= Heap_Top)
  218.     goto done;
  219.  
  220.   {
  221.     CONST char * filename = ((CONST char *) (STRING_LOC ((ARG_REF (2)), 0)));
  222.     SCHEME_OBJECT * faligned_heap = Heap_Bottom;
  223.     SCHEME_OBJECT * faligned_constant = Constant_Space;
  224.  
  225.     BCH_ALIGN_FLOAT_ADDRESS (faligned_heap);
  226.     BCH_ALIGN_FLOAT_ADDRESS (faligned_constant);
  227.  
  228.     OS_file_remove_link (filename);
  229.     dump_channel = (OS_open_dump_file (filename));
  230.     if (dump_channel == NO_CHANNEL)
  231.       error_bad_range_arg (2);
  232.  
  233.     result
  234.       = (Write_File ((Free - 1),
  235.              ((long) (Free - faligned_heap)),
  236.              faligned_heap,
  237.              ((long) (Free_Constant - faligned_constant)),
  238.              faligned_constant,
  239.              prim_table_start,
  240.              prim_table_length,
  241.              ((long) (prim_table_end - prim_table_start)),
  242.              c_table_start,
  243.              c_table_length,
  244.              ((long) (c_table_end - c_table_start)),
  245.              (compiler_utilities != SHARP_F),
  246.              1));
  247.  
  248.     OS_channel_close_noerror (dump_channel);
  249.     if (!result)
  250.       OS_file_remove (filename);
  251.   }
  252.  
  253.  done:
  254.   Band_Dump_Exit_Hook ();
  255.   Free = saved_free;
  256.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (result));
  257. }
  258.  
  259. static SCHEME_OBJECT
  260. DEFUN (dump_to_file, (root, fname),
  261.        SCHEME_OBJECT root AND
  262.        CONST char * fname)
  263. {
  264.   Boolean success = 1;
  265.   long value;
  266.   long length;
  267.   long hlength;
  268.   long tlength;
  269.   long tsize;
  270.   SCHEME_OBJECT * dumped_object;
  271.   SCHEME_OBJECT * free_buffer;
  272.   SCHEME_OBJECT * dummy;
  273.   SCHEME_OBJECT * table_start;
  274.   SCHEME_OBJECT * table_end;
  275.   SCHEME_OBJECT * table_top;
  276.   SCHEME_OBJECT header [FASL_HEADER_LENGTH];
  277.  
  278.   if (fixup_buffer == 0)
  279.     {
  280.       fixup_buffer = ((SCHEME_OBJECT *) (malloc (gc_buffer_bytes)));
  281.       if (fixup_buffer == 0)
  282.     error_system_call (errno, syscall_malloc);
  283.       fixup_buffer_end = (fixup_buffer + gc_buffer_size);
  284.     }
  285.  
  286.   dump_file_name = fname;
  287.   dump_file = (open (dump_file_name, GC_FILE_FLAGS, 0666));
  288.   if (dump_file < 0)
  289.     error_bad_range_arg (2);
  290.  
  291.   compiled_code_present_p = 0;
  292.   real_gc_file = (swap_gc_file (dump_file));
  293.   saved_free = Free;
  294.   fixup = fixup_buffer_end;
  295.   fixup_count = -1;
  296.  
  297.   table_top = (& (saved_free [Space_Before_GC ()]));
  298.   table_start = (initialize_primitive_table (saved_free, table_top));
  299.   if (table_start >= table_top)
  300.     {
  301.       fasdump_exit (0);
  302.       Primitive_GC (table_start - saved_free);
  303.     }
  304.  
  305.   free_buffer = (initialize_free_buffer ());
  306.   Free = 0;
  307.   free_buffer += FASL_HEADER_LENGTH;
  308.  
  309.   dummy = free_buffer;
  310.   BCH_ALIGN_FLOAT (Free, dummy);
  311.  
  312.   (*free_buffer++) = root;
  313.   dumped_object = (Free++);
  314.  
  315.   value
  316.     = dump_loop (((initialize_scan_buffer (0)) + FASL_HEADER_LENGTH),
  317.          (&free_buffer), (&Free));
  318.   if (value != PRIM_DONE)
  319.     {
  320.       fasdump_exit (0);
  321.       if (value == PRIM_INTERRUPT)
  322.     return (SHARP_F);
  323.       else
  324.     signal_error_from_primitive (value);
  325.     }
  326.   end_transport (&success);
  327.   if (!success)
  328.     {
  329.       fasdump_exit (0);
  330.       return (SHARP_F);
  331.     }
  332.  
  333.   length = (Free - dumped_object);
  334.  
  335.   table_end = (cons_primitive_table (table_start, table_top, &tlength));
  336.   if (table_end >= table_top)
  337.     {
  338.       fasdump_exit (0);
  339.       Primitive_GC (table_end - saved_free);
  340.     }
  341.  
  342. #ifdef NATIVE_CODE_IS_C
  343.   /* Cannot dump C compiled code. */
  344.   if (compiled_code_present_p)
  345.     {
  346.       fasdump_exit (0);
  347.       signal_error_from_primitive (ERR_COMPILED_CODE_ERROR);
  348.     }
  349. #endif
  350.  
  351.   tsize = (table_end - table_start);
  352.   hlength = ((sizeof (SCHEME_OBJECT)) * tsize);
  353.   if (((lseek (dump_file,
  354.            ((sizeof (SCHEME_OBJECT)) * (length + FASL_HEADER_LENGTH)),
  355.            0))
  356.        == -1)
  357.       || ((write (dump_file, ((char *) (&table_start[0])), hlength))
  358.       != hlength))
  359.     {
  360.       fasdump_exit (0);
  361.       return (SHARP_F);
  362.     }
  363.  
  364.   hlength = ((sizeof (SCHEME_OBJECT)) * FASL_HEADER_LENGTH);
  365.   prepare_dump_header
  366.     (header, dumped_object, length, dumped_object,
  367.      0, Constant_Space, tlength, tsize, 0, 0,
  368.      compiled_code_present_p, 0);
  369.   if (((lseek (dump_file, 0, 0)) == -1)
  370.       || ((write (dump_file, ((char *) &header[0]), hlength)) != hlength))
  371.     {
  372.       fasdump_exit (0);
  373.       return (SHARP_F);
  374.     }
  375.   return
  376.     (BOOLEAN_TO_OBJECT
  377.      (fasdump_exit (((sizeof (SCHEME_OBJECT)) * (length + tsize)) + hlength)));
  378. }
  379.  
  380. static int
  381. DEFUN (fasdump_exit, (length), long length)
  382. {
  383.   SCHEME_OBJECT * fixes, * fix_address;
  384.   int result;
  385.  
  386.   Free = saved_free;
  387.   restore_gc_file ();
  388.  
  389. #ifdef HAVE_FTRUNCATE
  390.   ftruncate (dump_file, length);
  391. #endif
  392.   result = ((close (dump_file)) == 0);
  393. #if defined(HAVE_TRUNCATE) && !defined(HAVE_FTRUNCATE)
  394.   truncate (dump_file_name, length);
  395. #endif
  396.  
  397.   if (length == 0)
  398.     unlink (dump_file_name);
  399.   dump_file_name = 0;
  400.  
  401.   fixes = fixup;
  402.  
  403.  next_buffer:
  404.  
  405.   while (fixes != fixup_buffer_end)
  406.     {
  407.       fix_address = ((SCHEME_OBJECT *) (*fixes++));
  408.       (*fix_address) = (*fixes++);
  409.     }
  410.  
  411.   if (fixup_count >= 0)
  412.     {
  413.       if ((retrying_file_operation
  414.        (eta_read,
  415.         real_gc_file,
  416.         ((char *) fixup_buffer),
  417.         (gc_file_start_position + (fixup_count << gc_buffer_byte_shift)),
  418.         gc_buffer_bytes,
  419.         "read",
  420.         "the fixup buffer",
  421.         (&gc_file_current_position),
  422.         io_error_retry_p))
  423.       != ((long) gc_buffer_bytes))
  424.     {
  425.       gc_death
  426.         (TERM_EXIT,
  427.          "fasdump: Could not read back the fasdump fixup information",
  428.          0, 0);
  429.       /*NOTREACHED*/
  430.     }
  431.       fixup_count -= 1;
  432.       fixes = fixup_buffer;
  433.       goto next_buffer;
  434.     }
  435.  
  436.   fixup = fixes;
  437.   Fasdump_Exit_Hook ();
  438.   return (result);
  439. }
  440.  
  441. static int
  442. DEFUN_VOID (reset_fixes)
  443. {
  444.   long start;
  445.  
  446.   fixup_count += 1;
  447.   start = (gc_file_start_position + (fixup_count << gc_buffer_byte_shift));
  448.  
  449.   if (((start + ((long) gc_buffer_bytes)) > gc_file_end_position)
  450.       || ((retrying_file_operation
  451.        (eta_write,
  452.         real_gc_file,
  453.         ((char *) fixup_buffer),
  454.         start,
  455.         gc_buffer_bytes,
  456.         "write",
  457.         "the fixup buffer",
  458.         (&gc_file_current_position),
  459.         io_error_always_abort))
  460.       != ((long) gc_buffer_bytes)))
  461.     return (0);
  462.   fixup = fixup_buffer_end;
  463.   return (1);
  464. }
  465.  
  466. static ssize_t
  467. DEFUN (eta_read, (fid, buffer, size),
  468.        int fid AND
  469.        char * buffer AND
  470.        int size)
  471. {
  472.   return (read (fid, buffer, size));
  473. }
  474.  
  475. static ssize_t
  476. DEFUN (eta_write, (fid, buffer, size),
  477.        int fid AND
  478.        char * buffer AND
  479.        int size)
  480. {
  481.   return (write (fid, buffer, size));
  482. }
  483.  
  484. #define MAYBE_DUMP_FREE(free)                        \
  485. {                                    \
  486.   if (free >= free_buffer_top)                        \
  487.     DUMP_FREE (free);                            \
  488. }
  489.  
  490. #define DUMP_FREE(free) do                        \
  491. {                                    \
  492.   Boolean _s = 1;                            \
  493.   free = (dump_and_reset_free_buffer (free, (&_s)));            \
  494.   if (!_s)                                \
  495.     return (PRIM_INTERRUPT);                        \
  496. } while (0)
  497.  
  498. #define MAYBE_DUMP_SCAN(scan)                        \
  499. {                                    \
  500.   if (scan >= scan_buffer_top)                        \
  501.     DUMP_SCAN (scan);                            \
  502. }
  503.  
  504. #define DUMP_SCAN(scan) do                        \
  505. {                                    \
  506.   Boolean _s = 1;                            \
  507.   scan = (dump_and_reload_scan_buffer (scan, (&_s)));            \
  508.   if (!_s)                                \
  509.     return (PRIM_INTERRUPT);                        \
  510. } while (0)
  511.  
  512. #define PUSH_FIXUP_DATA(ptr)                        \
  513. {                                    \
  514.   if ((fixup == fixup_buffer) && (!reset_fixes ()))            \
  515.     return (PRIM_INTERRUPT);                        \
  516.   (*--fixup) = (* (ptr));                        \
  517.   (*--fixup) = ((SCHEME_OBJECT) ptr);                    \
  518. }
  519.  
  520. #define TRANSPORT_VECTOR(new_address, free, old_start, n_words)        \
  521. {                                    \
  522.   SCHEME_OBJECT * old_ptr = old_start;                    \
  523.   SCHEME_OBJECT * free_end = (free + n_words);                \
  524.   if (free_end < free_buffer_top)                    \
  525.     while (free < free_end)                        \
  526.       (*free++) = (*old_ptr++);                        \
  527.   else                                    \
  528.     {                                    \
  529.       while (free < free_buffer_top)                    \
  530.     (*free++) = (*old_ptr++);                    \
  531.       free = (transport_vector_tail (free, free_end, old_ptr));        \
  532.       if (free == 0)                            \
  533.     return (PRIM_INTERRUPT);                    \
  534.     }                                    \
  535. }
  536.  
  537. static SCHEME_OBJECT *
  538. DEFUN (transport_vector_tail, (free, free_end, tail),
  539.        SCHEME_OBJECT * free AND
  540.        SCHEME_OBJECT * free_end AND
  541.        SCHEME_OBJECT * tail)
  542. {
  543.   unsigned long n_words = (free_end - free);
  544.   {
  545.     Boolean success = 1;
  546.     free = (dump_and_reset_free_buffer (free, (&success)));
  547.     if (!success)
  548.       return (0);
  549.   }
  550.   {
  551.     unsigned long n_blocks = (n_words >> gc_buffer_shift);
  552.     if (n_blocks > 0)
  553.       {
  554.     Boolean success = 1;
  555.     free = (dump_free_directly (tail, n_blocks, (&success)));
  556.     if (!success)
  557.       return (0);
  558.     tail += (n_blocks << gc_buffer_shift);
  559.       }
  560.   }
  561.   {
  562.     SCHEME_OBJECT * free_end = (free + (n_words & gc_buffer_mask));
  563.     while (free < free_end)
  564.       (*free++) = (*tail++);
  565.   }
  566.   return (free);
  567. }
  568.  
  569. /* A copy of gc_loop, with minor modifications. */
  570.  
  571. static long
  572. DEFUN (dump_loop, (scan, free_ptr, new_address_ptr),
  573.        SCHEME_OBJECT * scan AND
  574.        SCHEME_OBJECT ** free_ptr AND
  575.        SCHEME_OBJECT ** new_address_ptr)
  576. {
  577.   SCHEME_OBJECT * free = (*free_ptr);
  578.   SCHEME_OBJECT * new_address = (*new_address_ptr);
  579.   while (scan != free)
  580.     {
  581.       SCHEME_OBJECT object;
  582.       if (scan >= scan_buffer_top)
  583.     {
  584.       if (scan == scan_buffer_top)
  585.         DUMP_SCAN (scan);
  586.       else
  587.         {
  588.           sprintf
  589.         (gc_death_message_buffer,
  590.          "dump_loop: scan (0x%lx) > scan_buffer_top (0x%lx)",
  591.          ((unsigned long) scan),
  592.          ((unsigned long) scan_buffer_top));
  593.           gc_death (TERM_EXIT, gc_death_message_buffer, scan, free);
  594.           /*NOTREACHED*/
  595.         }
  596.     }
  597.       object = (*scan);
  598.       switch (OBJECT_TYPE (object))
  599.     {
  600.     case TC_BROKEN_HEART:
  601.       if ((OBJECT_DATUM (object)) == 0)
  602.         {
  603.           scan += 1;
  604.           break;
  605.         }
  606.       if (object == (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan)))
  607.         /* Does this ever happen?  */
  608.         goto end_dump_loop;
  609.       sprintf (gc_death_message_buffer,
  610.            "dump_loop: broken heart (0x%lx) in scan",
  611.            object);
  612.       gc_death (TERM_BROKEN_HEART, gc_death_message_buffer, scan, free);
  613.       /*NOTREACHED*/
  614.       break;
  615.  
  616.     case TC_CHARACTER:
  617.     case TC_CONSTANT:
  618.     case TC_FIXNUM:
  619.     case TC_NULL:
  620.     case TC_RETURN_CODE:
  621.     case TC_STACK_ENVIRONMENT:
  622.     case TC_THE_ENVIRONMENT:
  623.       scan += 1;
  624.       break;
  625.  
  626.     case TC_PCOMB0:
  627.     case TC_PRIMITIVE:
  628.       (*scan++) = (dump_renumber_primitive (object));
  629.       break;
  630.  
  631.     case TC_CELL:
  632.       {
  633.         SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
  634.         if (BROKEN_HEART_P (*old_start))
  635.           (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
  636.         else
  637.           {
  638.         PUSH_FIXUP_DATA (old_start);
  639.         (*free++) = (old_start[0]);
  640.         MAYBE_DUMP_FREE (free);
  641.         (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
  642.         (*old_start) = (MAKE_BROKEN_HEART (new_address));
  643.         new_address += 1;
  644.           }
  645.       }
  646.       break;
  647.  
  648.     case TC_ACCESS:
  649.     case TC_ASSIGNMENT:
  650.     case TC_COMBINATION_1:
  651.     case TC_COMMENT:
  652.     case TC_COMPLEX:
  653.     case TC_DEFINITION:
  654.     case TC_DELAY:
  655.     case TC_DELAYED:
  656.     case TC_DISJUNCTION:
  657.     case TC_ENTITY:
  658.     case TC_EXTENDED_PROCEDURE:
  659.     case TC_INTERNED_SYMBOL:
  660.     case TC_IN_PACKAGE:
  661.     case TC_LAMBDA:
  662.     case TC_LEXPR:
  663.     case TC_LIST:
  664.     case TC_PCOMB1:
  665.     case TC_PROCEDURE:
  666.     case TC_RATNUM:
  667.     case TC_SCODE_QUOTE:
  668.     case TC_SEQUENCE_2:
  669.     case TC_UNINTERNED_SYMBOL:
  670.     case TC_WEAK_CONS:
  671.     transport_pair:
  672.       {
  673.         SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
  674.         if (BROKEN_HEART_P (*old_start))
  675.           (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
  676.         else
  677.           {
  678.         PUSH_FIXUP_DATA (old_start);
  679.         (*free++) = (old_start[0]);
  680.         switch (OBJECT_TYPE (object))
  681.           {
  682.           case TC_INTERNED_SYMBOL:
  683.             (*free++) = BROKEN_HEART_ZERO;
  684.             break;
  685.           case TC_UNINTERNED_SYMBOL:
  686.             (*free++) = UNBOUND_OBJECT;
  687.             break;
  688.           default:
  689.             (*free++) = (old_start[1]);
  690.             break;
  691.           }
  692.         MAYBE_DUMP_FREE (free);
  693.         (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
  694.         (*old_start) = (MAKE_BROKEN_HEART (new_address));
  695.         new_address += 2;
  696.           }
  697.       }
  698.       break;
  699.  
  700.     case TC_COMBINATION_2:
  701.     case TC_CONDITIONAL:
  702.     case TC_EXTENDED_LAMBDA:
  703.     case TC_HUNK3_A:
  704.     case TC_HUNK3_B:
  705.     case TC_PCOMB2:
  706.     case TC_SEQUENCE_3:
  707.     case TC_VARIABLE:
  708.       {
  709.         SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
  710.         if (BROKEN_HEART_P (*old_start))
  711.           (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
  712.         else
  713.           {
  714.         PUSH_FIXUP_DATA (old_start);
  715.         (*free++) = (old_start[0]);
  716.         switch (OBJECT_TYPE (object))
  717.           {
  718.           case TC_VARIABLE:
  719.             (*free++) = UNCOMPILED_VARIABLE;
  720.             (*free++) = SHARP_F;
  721.             break;
  722.           default:
  723.             (*free++) = (old_start[1]);
  724.             (*free++) = (old_start[2]);
  725.             break;
  726.           }
  727.         MAYBE_DUMP_FREE (free);
  728.         (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
  729.         (*old_start) = (MAKE_BROKEN_HEART (new_address));
  730.         new_address += 3;
  731.           }
  732.       }
  733.       break;
  734.  
  735.     case TC_QUAD:
  736.       {
  737.         SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
  738.         if (BROKEN_HEART_P (*old_start))
  739.           (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
  740.         else
  741.           {
  742.         PUSH_FIXUP_DATA (old_start);
  743.         (*free++) = (old_start[0]);
  744.         (*free++) = (old_start[1]);
  745.         (*free++) = (old_start[2]);
  746.         (*free++) = (old_start[3]);
  747.         MAYBE_DUMP_FREE (free);
  748.         (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
  749.         (*old_start) = (MAKE_BROKEN_HEART (new_address));
  750.         new_address += 4;
  751.           }
  752.       }
  753.       break;
  754.  
  755.     case TC_BIG_FIXNUM:
  756.     case TC_CHARACTER_STRING:
  757.     case TC_COMBINATION:
  758.     case TC_CONTROL_POINT:
  759.     case TC_NON_MARKED_VECTOR:
  760.     case TC_PCOMB3:
  761.     case TC_RECORD:
  762.     case TC_VECTOR:
  763.     case TC_VECTOR_16B:
  764.     case TC_VECTOR_1B:
  765.       {
  766.         SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
  767.         if (BROKEN_HEART_P (*old_start))
  768.           (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
  769.         else
  770.           {
  771.         unsigned long n_words = (1 + (OBJECT_DATUM (*old_start)));
  772.         PUSH_FIXUP_DATA (old_start);
  773.         TRANSPORT_VECTOR (new_address, free, old_start, n_words);
  774.         (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
  775.         (*old_start) = (MAKE_BROKEN_HEART (new_address));
  776.         new_address += n_words;
  777.           }
  778.       }
  779.       break;
  780.  
  781.     case TC_BIG_FLONUM:
  782.     case TC_COMPILED_CODE_BLOCK:
  783.       {
  784.         SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
  785.         if (BROKEN_HEART_P (*old_start))
  786.           (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
  787.         else
  788.           {
  789.         unsigned long n_words = (1 + (OBJECT_DATUM (*old_start)));
  790.         PUSH_FIXUP_DATA (old_start);
  791.         BCH_ALIGN_FLOAT (new_address, free);
  792.         TRANSPORT_VECTOR (new_address, free, old_start, n_words);
  793.         (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
  794.         (*old_start) = (MAKE_BROKEN_HEART (new_address));
  795.         new_address += n_words;
  796.           }
  797.       }
  798.       break;
  799.  
  800.     case TC_MANIFEST_NM_VECTOR:
  801.     case TC_MANIFEST_SPECIAL_NM_VECTOR:
  802.       scan += (1 + (OBJECT_DATUM (object)));
  803.       MAYBE_DUMP_SCAN (scan);
  804.       break;
  805.  
  806.     case TC_REFERENCE_TRAP:
  807.       if ((OBJECT_DATUM (object)) > TRAP_MAX_IMMEDIATE)
  808.         goto transport_pair;
  809.       /* Otherwise it's a non-pointer.  */
  810.       scan += 1;
  811.       break;
  812.  
  813.     case TC_COMPILED_ENTRY:
  814.       compiled_code_present_p = true;
  815.       {
  816.         SCHEME_OBJECT * old_start;
  817.         Get_Compiled_Block (old_start, (OBJECT_ADDRESS (object)));
  818.         if (BROKEN_HEART_P (*old_start))
  819.           (*scan++)
  820.         = (RELOCATE_COMPILED (object,
  821.                       (OBJECT_ADDRESS (*old_start)),
  822.                       old_start));
  823.         else
  824.           {
  825.         unsigned long n_words = (1 + (OBJECT_DATUM (*old_start)));
  826.         PUSH_FIXUP_DATA (old_start);
  827.         BCH_ALIGN_FLOAT (new_address, free);
  828.         TRANSPORT_VECTOR (new_address, free, old_start, n_words);
  829.         (*scan++)
  830.           = (RELOCATE_COMPILED (object, new_address, old_start));
  831.         (*old_start) = (MAKE_BROKEN_HEART (new_address));
  832.         new_address += n_words;
  833.           }
  834.       }
  835.       break;
  836.  
  837.     case TC_LINKAGE_SECTION:
  838.       switch (READ_LINKAGE_KIND (object))
  839.         {
  840.         case REFERENCE_LINKAGE_KIND:
  841.         case ASSIGNMENT_LINKAGE_KIND:
  842.           {
  843.         /* `count' typeless pointers to quads follow. */
  844.         unsigned long count = (READ_CACHE_LINKAGE_COUNT (object));
  845.         scan += 1;
  846.         while (count > 0)
  847.           {
  848.             SCHEME_OBJECT * old_start;
  849.             MAYBE_DUMP_SCAN (scan);
  850.             old_start = (SCHEME_ADDR_TO_ADDR (*scan));
  851.             if (BROKEN_HEART_P (*old_start))
  852.               (*scan++)
  853.             = (ADDR_TO_SCHEME_ADDR (OBJECT_ADDRESS (*old_start)));
  854.             else
  855.               {
  856.             PUSH_FIXUP_DATA (old_start);
  857.             (*free++) = (old_start[0]);
  858.             (*free++) = (old_start[1]);
  859.             (*free++) = (old_start[2]);
  860.             (*free++) = (old_start[3]);
  861.             MAYBE_DUMP_FREE (free);
  862.             (*scan++) = (ADDR_TO_SCHEME_ADDR (new_address));
  863.             (*old_start) = (MAKE_BROKEN_HEART (new_address));
  864.             new_address += 4;
  865.               }
  866.             count -= 1;
  867.           }
  868.           }
  869.           break;
  870.  
  871.         case OPERATOR_LINKAGE_KIND:
  872.         case GLOBAL_OPERATOR_LINKAGE_KIND:
  873.           {
  874.         unsigned long count = (READ_OPERATOR_LINKAGE_COUNT (object));
  875.         char * entry = (FIRST_OPERATOR_LINKAGE_ENTRY (scan));
  876.         long delta;
  877.  
  878.         if (count > 0)
  879.           compiled_code_present_p = true;
  880.  
  881.         {
  882.           int extend_p = (entry >= ((char *) scan_buffer_top));
  883.           long delta1 = (((char *) scan) - entry);
  884.           if (extend_p)
  885.             extend_scan_buffer (entry, free);
  886.           BCH_START_OPERATOR_RELOCATION (scan);
  887.           if (extend_p)
  888.             {
  889.               entry = (end_scan_buffer_extension (entry));
  890.               scan = ((SCHEME_OBJECT *) (entry + delta1));
  891.             }
  892.         }
  893.  
  894.         /* END_OPERATOR_LINKAGE_AREA assumes that we will add
  895.            one to the result, so do that now.  */
  896.         delta
  897.           = (((END_OPERATOR_LINKAGE_AREA (scan, count)) + 1)
  898.              - scan_buffer_top);
  899.  
  900.         /* The operator entries are copied sequentially, but
  901.            extra hair is required because the entry addresses
  902.            are encoded.  */
  903.         while (count > 0)
  904.           {
  905.             char * next_entry = (NEXT_LINKAGE_OPERATOR_ENTRY (entry));
  906.             int extend_p = (next_entry >= ((char *) scan_buffer_top));
  907.             SCHEME_OBJECT esaddr;
  908.             SCHEME_OBJECT * old_start;
  909.  
  910.             /* Guarantee that the scan buffer is large enough
  911.                to hold the entry.  */
  912.             if (extend_p)
  913.               extend_scan_buffer (next_entry, free);
  914.  
  915.             /* Get the entry address.  */
  916.             BCH_EXTRACT_OPERATOR_LINKAGE_ADDRESS (esaddr, entry);
  917.  
  918.             /* Get the code-block pointer for this entry.  */
  919.             Get_Compiled_Block
  920.               (old_start, (SCHEME_ADDR_TO_ADDR (esaddr)));
  921.  
  922.             /* Copy the block.  */
  923.             if (BROKEN_HEART_P (*old_start))
  924.               {
  925.             BCH_STORE_OPERATOR_LINKAGE_ADDRESS
  926.               ((RELOCATE_COMPILED_RAW_ADDRESS
  927.                 (esaddr,
  928.                  (OBJECT_ADDRESS (*old_start)),
  929.                  old_start)),
  930.                entry);
  931.               }
  932.             else
  933.               {
  934.             unsigned long n_words
  935.               = (1 + (OBJECT_DATUM (*old_start)));
  936.             PUSH_FIXUP_DATA (old_start);
  937.             BCH_ALIGN_FLOAT (new_address, free);
  938.             TRANSPORT_VECTOR
  939.               (new_address, free, old_start, n_words);
  940.             BCH_STORE_OPERATOR_LINKAGE_ADDRESS
  941.               ((RELOCATE_COMPILED_RAW_ADDRESS
  942.                 (esaddr, new_address, old_start)),
  943.                entry);
  944.             (*old_start) = (MAKE_BROKEN_HEART (new_address));
  945.             new_address += n_words;
  946.               }
  947.  
  948.             if (extend_p)
  949.               {
  950.             entry = (end_scan_buffer_extension (next_entry));
  951.             delta -= gc_buffer_size;
  952.               }
  953.             else
  954.               entry = next_entry;
  955.  
  956.             count -= 1;
  957.           }
  958.         scan = (scan_buffer_top + delta);
  959.         MAYBE_DUMP_SCAN (scan);
  960.         BCH_END_OPERATOR_RELOCATION (scan);
  961.           }
  962.           break;
  963.  
  964.         case CLOSURE_PATTERN_LINKAGE_KIND:
  965.           scan += (1 + (READ_CACHE_LINKAGE_COUNT (object)));
  966.           MAYBE_DUMP_SCAN (scan);
  967.           break;
  968.  
  969.         default:
  970.           gc_death (TERM_EXIT, "dump_loop: Unknown compiler linkage kind.",
  971.             scan, free);
  972.           /*NOTREACHED*/
  973.           scan += 1;
  974.           break;
  975.         }
  976.       break;
  977.  
  978.     case TC_MANIFEST_CLOSURE:
  979.       {
  980.         unsigned long count;
  981.         char * entry;
  982.         char * closure_end;
  983.  
  984.         {
  985.           unsigned long delta = (2 * (sizeof (format_word)));
  986.           char * count_end = (((char *) (scan + 1)) + delta);
  987.           int extend_p = (count_end >= ((char *) scan_buffer_top));
  988.  
  989.           /* Guarantee that the scan buffer is large enough to
  990.          hold the count field.  */
  991.           if (extend_p)
  992.         extend_scan_buffer (count_end, free);
  993.  
  994.           BCH_START_CLOSURE_RELOCATION (scan);
  995.           count = (MANIFEST_CLOSURE_COUNT (scan + 1));
  996.           entry = (FIRST_MANIFEST_CLOSURE_ENTRY (scan + 1));
  997.  
  998.           if (extend_p)
  999.         {
  1000.           long dw = (entry - count_end);
  1001.           count_end = (end_scan_buffer_extension (count_end));
  1002.           entry = (count_end + dw);
  1003.         }
  1004.           scan = ((SCHEME_OBJECT *) (count_end - delta));
  1005.         }
  1006.  
  1007.         if (count > 0)
  1008.           compiled_code_present_p = true;
  1009.  
  1010.         /* MANIFEST_CLOSURE_END assumes that one will be added to
  1011.            result, so do that now.  */
  1012.         closure_end
  1013.           = ((char *) ((MANIFEST_CLOSURE_END (scan, count)) + 1));
  1014.  
  1015.         /* The closures are copied sequentially, but extra hair is
  1016.            required because the code-entry pointers are encoded as
  1017.            machine instructions.  */
  1018.         while (count > 0)
  1019.           {
  1020.         char * entry_end = (CLOSURE_ENTRY_END (entry));
  1021.         int extend_p = (entry_end >= ((char *) scan_buffer_top));
  1022.         SCHEME_OBJECT esaddr;
  1023.         SCHEME_OBJECT * old_start;
  1024.         long delta1 = (entry - entry_end);
  1025.         long delta2 = (closure_end - entry_end);
  1026.  
  1027.         /* If the closure overflows the scan buffer, extend
  1028.            the buffer to the end of the closure.  */
  1029.         if (extend_p)
  1030.           extend_scan_buffer (entry_end, free);
  1031.  
  1032.         /* Extract the code-entry pointer and convert it to a
  1033.            C pointer.  */
  1034.         BCH_EXTRACT_CLOSURE_ENTRY_ADDRESS (esaddr, entry);
  1035.         Get_Compiled_Block (old_start, (SCHEME_ADDR_TO_ADDR (esaddr)));
  1036.  
  1037.         /* Copy the code entry.  Use machine-specific macro to
  1038.            update the pointer. */
  1039.         if (BROKEN_HEART_P (*old_start))
  1040.           BCH_STORE_CLOSURE_ENTRY_ADDRESS
  1041.             ((RELOCATE_COMPILED_RAW_ADDRESS
  1042.               (esaddr, (OBJECT_ADDRESS (*old_start)), old_start)),
  1043.              entry);
  1044.         else
  1045.           {
  1046.             unsigned long n_words = (1 + (OBJECT_DATUM (*old_start)));
  1047.             PUSH_FIXUP_DATA (old_start);
  1048.             BCH_ALIGN_FLOAT (new_address, free);
  1049.             TRANSPORT_VECTOR (new_address, free, old_start, n_words);
  1050.             BCH_STORE_CLOSURE_ENTRY_ADDRESS
  1051.               ((RELOCATE_COMPILED_RAW_ADDRESS
  1052.             (esaddr, new_address, old_start)),
  1053.                entry);
  1054.             (*old_start) = (MAKE_BROKEN_HEART (new_address));
  1055.             new_address += n_words;
  1056.           }
  1057.  
  1058.         if (extend_p)
  1059.           {
  1060.             entry_end = (end_scan_buffer_extension (entry_end));
  1061.             entry = (entry_end + delta1);
  1062.             closure_end = (entry_end + delta2);
  1063.           }
  1064.  
  1065.         entry = (NEXT_MANIFEST_CLOSURE_ENTRY (entry));
  1066.         count -= 1;
  1067.           }
  1068.         scan = ((SCHEME_OBJECT *) closure_end);
  1069.         MAYBE_DUMP_SCAN (scan);
  1070.         BCH_END_CLOSURE_RELOCATION (scan);
  1071.       }
  1072.       break;
  1073.  
  1074.     case TC_ENVIRONMENT:
  1075.       /* Make fasdump fail */
  1076.       return (ERR_FASDUMP_ENVIRONMENT);
  1077.  
  1078.     case TC_FUTURE:
  1079.       {
  1080.         SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
  1081.         if (BROKEN_HEART_P (*old_start))
  1082.           (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
  1083.         else if (Future_Spliceable (object))
  1084.           (*scan) = (Future_Value (object));
  1085.         else
  1086.           {
  1087.         unsigned long n_words = (1 + (OBJECT_DATUM (*old_start)));
  1088.         PUSH_FIXUP_DATA (old_start);
  1089.         TRANSPORT_VECTOR (new_address, free, old_start, n_words);
  1090.         (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
  1091.         (*old_start) = (MAKE_BROKEN_HEART (new_address));
  1092.         new_address += n_words;
  1093.           }
  1094.       }
  1095.       break;
  1096.  
  1097.     default:
  1098.       GC_BAD_TYPE ("dump_loop", object);
  1099.       scan += 1;
  1100.       break;
  1101.     }
  1102.     }
  1103.  
  1104.  end_dump_loop:
  1105.   (*free_ptr) = free;
  1106.   (*new_address_ptr) = new_address;
  1107.   return (PRIM_DONE);
  1108. }
  1109.