⟦cf7822b4b⟧

TextFile

/*          Hey EMACS, this is -*- C -*- code!                 */

/****************************************************************
*                                                               *
*                         Copyright (c) 1985                    *
*               Massachusetts Institute of Technology           *
*                                                               *
* This material was developed by the Scheme project at the      *
* Massachusetts Institute of Technology, Department of          *
* Electrical Engineering and Computer Science.  Permission to   *
* copy this software, to redistribute it, and to use it for any *
* purpose is granted, subject to the following restrictions and *
* understandings.                                               *
*                                                               *
* 1. Any copy made of this software must include this copyright *
* notice in full.                                               *
*                                                               *
* 2. Users of this software agree to make their best efforts (a)*
* to return to the MIT Scheme project any improvements or       *
* extensions that they make, so that these may be included in   *
* future releases; and (b) to inform MIT of noteworthy uses of  *
* this software.                                                *
*                                                               *
* 3.  All materials developed as a consequence of the use of    *
* this software shall duly acknowledge such use, in accordance  *
* with the usual standards of acknowledging credit in academic  *
* research.                                                     *
*                                                               *
* 4. MIT has made no warrantee or representation that the       *
* operation of this software will be error-free, and MIT is     *
* under no obligation to provide any services, by way of        *
* maintenance, update, or otherwise.                            *
*                                                               *
* 5.  In conjunction with products arising from the use of this *
* material, there shall be no use of the name of the            *
* Massachusetts Institute of Technology nor of any adaptation   *
* thereof in any advertising, promotional, or sales literature  *
* without prior written consent from MIT in each case.          *
*                                                               *
****************************************************************/

/* File: FASDUMP.C
   This file contains code for FASDUMP, BAND_DUMP, and BAND_LOAD.
*/

#include "scheme.h"
#include "primitive.h"
#include "dump.c"
\f


/* Some statics used freely in this file */
Pointer *NewFree, *NewMemTop, *Fixup, *Orig_New_Free;

/* (BAND_DUMP PROCEDURE FILE-NAME)
      [Primitive number 0xB7]
      Saves all of the heap and pure space on FILE-NAME.  When the
      file is loaded back using BAND_LOAD, PROCEDURE is called with an
      argument of NIL.
*/
Built_In_Primitive(Prim_Band_Dump, 2, "BAND-DUMP")
{ Pointer Combination, Ext_Prims;
  long Arg1Type;
  Primitive_2_Args();

  Band_Dump_Permitted();
  Arg1Type = Type_Code(Arg1);
  if ((Arg1Type != TC_CONTROL_POINT) &&
      (Arg1Type != TC_PRIMITIVE) &&
      (Arg1Type != TC_PRIMITIVE_EXTERNAL) &&
      (Arg1Type != TC_EXTENDED_PROCEDURE)) Arg_1_Type(TC_PROCEDURE);
  Arg_2_Type(TC_CHARACTER_STRING);
  if (!Open_Dump_File(Arg2, WRITE_FLAG))
    Primitive_Error(ERR_ARG_2_BAD_RANGE);
  /* Free cannot be saved around this code since Make_Prim_Exts will
     intern the undefined externals and potentially allocate space.
   */
  Ext_Prims = Make_Prim_Exts();
  Combination = Make_Pointer(TC_COMBINATION_1, Free);
  Free[COMB_1_FN] = Arg1;
  Free[COMB_1_ARG_1] = NIL;
  Free += 2;
  *Free++ = Combination;
  *Free++ = Ext_Prims;
  Write_File(Free-Heap_Bottom, Heap_Bottom, Free-2,
             Free_Constant-Constant_Space, Constant_Space, Free-1);
  fclose(File_Handle);
  return NIL;
}
\f


/* FASDUMP:
  
   Hideous and ugly ... in order to dump an object it must be traced
   (as in a garbage collection), but with some awful differences.
   First, the copy must have (a) the global value cell of symbols set
   to UNBOUND; (b) the danger bits cleared in all objects; and (c)
   variables uncompiled.  Second, and worse, all the broken hearts
   created during the process must be restored to their original
   values.  This last is done by growing the copy of the object in the
   bottom of spare heap, keeping track of the locations of broken
   hearts and original contents at the top of the spare heap.

   FASDUMP is called with three arguments:
   Argument 1: Base of spare heap
   Argument 2: Top of spare heap
   Argument 3: Hunk 3, #<Object to dump | File name | Flag>
               where the flag is #!true for a dump into constant
               space at reload time, () for a dump into heap.

   As with Purify, dumping an object for reloading into constant space
   requires dividing it into pure and constant parts and building a
   standard Pure/Constant block.
*/
\f


/* Copy of GCLoop, except (a) copies out of constant space into the
   object to be dumped; (b) changes symbols and variables as
   described; (c) clears danger bits as described; (d) keeps track of
   broken hearts and their original contents (e) End_Pointer and
   To_Pointer are now NewFree.
*/

#define	NORMAL_DUMP	0
#define PURE_COPY	1
#define CONSTANT_COPY	2

Boolean DumpLoop(Scan, Dump_Mode)
fast Pointer *Scan;
int Dump_Mode;
{ fast Pointer *Old;
  fast int Type_For_GC;
  Pointer New_Address, *Starting_Address;

  Starting_Address = Scan;
  if (Dump_Debug) printf( "Starting scan at %x\n", Scan);

/* DumpLoop continues on next page */
\f


/* DumpLoop, continued */

  for ( ; Scan < NewFree; Scan++)
  { *Scan &= ~DANGER_BIT;
    Type_For_GC = GC_Type(*Scan);
    if (Dump_Debug && *Scan != NIL)
      printf( "0x%x: %x|%x ... ",
              Scan, Type_Code(*Scan), Get_Integer(*Scan));
    if ((Type_For_GC == GC_Non_Pointer) ||
        ((Dump_Mode == PURE_COPY) &&
         ((Type_Code(*Scan) == TC_ENVIRONMENT) ||
          (Type_Code(*Scan) == TC_INTERNED_SYMBOL) ||
          (Type_Code(*Scan) == TC_UNINTERNED_SYMBOL) ||
          (Type_Code(*Scan) == TC_VARIABLE))))
    { Type_For_GC = Safe_Type_Code(*Scan);
      if (Consistency_Check)
	if ((Type_For_GC == TC_BROKEN_HEART) &&
            Address(*Scan) != 0)
        { printf("Broken heart in scan.\n");
          Microcode_Termination(TERM_EXIT);
        }
      if ((Type_For_GC == TC_MANIFEST_NM_VECTOR) ||
	  (Type_For_GC == TC_MANIFEST_SPECIAL_NM_VECTOR))
		/* Special headers meaning following block
		   contains no relocatable pointers */
      { if (Dump_Debug)
          printf( "skipping %d cells.",
                  Get_Integer(*Scan));
        Scan += Get_Integer(*Scan);
      }
      else if (Dump_Debug && *Scan != NIL)
             printf( "not a pointer.");
    }

/* DumpLoop continues on the next page */
\f


/* DumpLoop, continued */

    else /* A pointer object */
    { Old = Get_Pointer(*Scan);
      if ((Dump_Mode == CONSTANT_COPY) &&
          (Old > Starting_Address) && (Old < NewFree))
      { if (Dump_Debug) printf( "Skipping 0x%x", *Scan);
        continue;		/* Loop on ... */
      }
      if (Dump_Debug) printf( "From 0x%x", Old);
      if (Safe_Type_Code(*Old) == TC_BROKEN_HEART)
      { Store_Address(*Scan, Address(*Old));
        if (Dump_Debug) printf( ", To (BH) 0x%x",
                                Address(*Old));
      }
      else		/* Otherwise, it must be copied */
      { if (Dump_Debug) printf( ", To 0x%x", NewFree);
	New_Address = BROKEN_HEART_0 + C_To_Scheme(NewFree);
        { fast long i, Length;
          switch (Type_For_GC)
          { case GC_Non_Pointer:
              printf( "Non_Pointer copy?\n");
              Microcode_Termination(TERM_EXIT);

            case GC_Vector: Length = Vector_Length(*Scan)+1; break;

/* DumpLoop continues on the next page */
\f


/* DumpLoop, continued */

            case GC_Triple:  
              if (Safe_Type_Code(*Scan)==TC_VARIABLE)
              { *NewFree++ = *Old;
                *NewFree++ = UNCOMPILED_VARIABLE;
                *NewFree++ = NIL;
                Length = 0;
              }
              else Length = 3;
              break;

            default:        
              if (Safe_Type_Code(*Scan)==TC_UNINTERNED_SYMBOL)
	      { *NewFree++ = *Old;
                *NewFree++ = UNBOUND_OBJECT;
                Length = 0;
              }
              else if (Safe_Type_Code(*Scan)==TC_INTERNED_SYMBOL)
              { *NewFree++ = *Old;
		*NewFree++ = Make_Non_Pointer(TC_BROKEN_HEART, 0);
                Length = 0;
              }
	      else Length = 2;
              break;
          }
          if ((NewFree+Length+5) >= Fixup) return false;
          for (i=0; i < Length; i++) *NewFree++ = *Old++;
          if (Dump_Debug) printf( " copied %d words", Length);
        }
        *--Fixup = * Get_Pointer(*Scan);                   /* What it was.*/
        *--Fixup = Make_New_Pointer(TC_ADDRESS, *Scan);    /* Where it goes.*/
        *Get_Pointer(*Scan) = New_Address;
        Store_Address(*Scan, Address(New_Address));
      } /* End of else for ... == TC_BROKEN_HEART */
    } /* End of else for ... == GC_Type_Code */
    if (Dump_Debug && *Scan != NIL) printf( "\n");
  } /* End of FOR loop */
  return true;
} /* End of DumpLoop */
\f


/* (PRIMITIVE_FASDUMP Object-to-Dump File-Name Flag)
      [Primitive number 0x56]
      Dump an object into a file so that it can be loaded using
      PRIMITIVE_BINARY_FASLOAD.  A spare heap is required for this
      operation.  The first argument is the object to be dumped.  The
      second is the filename and the third a flag.  The flag, if
      #!TRUE, means that the object is to be dumped for reloading into
      constant space.  This is currently disabled. If the flag is NIL,
      it means that it will be reloaded into the heap.  The primitive
      returns #!TRUE or NIL indicating whether it successfully dumped
      the object (it can fail on an object that is too large).
*/
Built_In_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP")
{ Pointer Object, File_Name, Flag, *New_Object,
          *Addr_Of_New_Object, Prim_Exts;
  long Pure_Length, Length;
  Boolean To_Constant_Space;
  Primitive_3_Args();

  Object = Arg1;
  File_Name = Arg2;
  Flag = Arg3;
  if (Type_Code(File_Name) != TC_CHARACTER_STRING)
    Primitive_Error(ERR_ARG_2_WRONG_TYPE);
  if (!Open_Dump_File(File_Name, WRITE_FLAG))
    Primitive_Error(ERR_ARG_2_BAD_RANGE);
#ifdef CAN_DUMP_PURE
  if ((Flag != NIL) && (Flag != TRUTH))
#else
  if (Flag != NIL)
#endif
    Primitive_Error(ERR_ARG_3_WRONG_TYPE);

  Fasdump_Free_Calc(NewFree, NewMemTop, Orig_New_Free);
  Fixup = NewMemTop;
  Prim_Exts = Make_Prim_Exts();
  New_Object = NewFree;
  *NewFree++ = Object;
  *NewFree++ = Prim_Exts;

/* Prim_Primitive_Fasdump continues on next page */
\f


/* Prim_Primitive_Fasdump, continued */

#ifdef CAN_DUMP_PURE
  if (Flag==TRUTH)
  { if (!DumpLoop(New_Object, PURE_COPY))
    { fclose(File_Handle);
      Fasdump_Exit_Hook();
      return NIL;
    }
    Pure_Length = (NewFree-New_Object) + 1;
    *NewFree++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
    *NewFree++ = Make_Non_Pointer(CONSTANT_PART, Pure_Length);
    if (!DumpLoop(New_Object, CONSTANT_COPY))
    { fclose(File_Handle);
      Fasdump_Exit_Hook();
      return NIL;
    }
    Length =  NewFree-New_Object+2;
    *NewFree++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
    *NewFree++ = Make_Non_Pointer(END_OF_BLOCK, Length-1);
    Addr_Of_New_Object = Get_Pointer(New_Object[0]);
    Prim_Exts = New_Object[1];
    New_Object[0] = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR,
                                     Pure_Length);
    New_Object[1] = Make_Non_Pointer(PURE_PART, Length-1);
    Write_File(0, 0x000000, Addr_Of_New_Object,
               Length, New_Object, Prim_Exts);
    fclose(File_Handle);
  }

/* Fasdump continues on the next page */
\f


/* Fasdump, continued */

  else		/* Dumping for reload into heap */
#endif
  { if (!DumpLoop(New_Object, NORMAL_DUMP))
    { fclose(File_Handle);
      Fasdump_Exit_Hook();
      return NIL;
    }
    Length = NewFree-New_Object;
    Write_File(Length, New_Object, New_Object,
               0, ADDRESS_MASK, New_Object+1);
    fclose(File_Handle);
  }
  while (Fixup != NewMemTop)
  { Pointer *Fix_Address;
    Fix_Address = Get_Pointer(*Fixup++); /* Where it goes. */
    *Fix_Address = *Fixup++;             /* Put it there. */
  }
  Fasdump_Exit_Hook();
  return TRUTH;
}
\f


/* (BAND_LOAD FILE-NAME)
      [Primitive number 0xB9]
      Restores the heap and pure space from the contents of FILE-NAME,
      which is typically a file created by BAND_DUMP.  The file can,
      however, be any file which can be loaded with BINARY_FASLOAD.
*/
Built_In_Primitive(Prim_Band_Load, 1, "BAND-LOAD")
{ Pointer Save_FO, *Save_Free, *Save_Free_Constant, Save_Undefined,
          *Save_Stack_Pointer, *Save_Stack_Guard, Result;
  long Jump_Value;
  jmp_buf  Swapped_Buf, *Saved_Buf;
  Primitive_1_Arg();

  Save_Fixed_Obj(Save_FO);
  Save_Undefined = Undefined_Externals;
  Undefined_Externals = NIL;
  Save_Free = Free;
  Free = Heap_Bottom;
  Save_Free_Constant = Free_Constant;
  Free_Constant = Constant_Space;
  Save_Stack_Pointer = Stack_Pointer;
  Stack_Pointer = Stack_Top;
  Save_Stack_Guard = Stack_Guard;
  Set_Stack_Guard(Stack_Pointer - STACK_GUARD_SIZE);

/* Prim_Band_Load continues on next page */
\f


/* Prim_Band_Load, continued */

  /* There is some jiggery-pokery going on here to make sure
     that all returns from Fasload (including error exits) return to
     the clean-up code before returning on up the C call stack.
  */
  Saved_Buf = Back_To_Eval;
  Jump_Value = setjmp(Swapped_Buf);
  if (Jump_Value == 0)
  { Back_To_Eval = (jmp_buf *) Swapped_Buf;
    Result = Fasload(Arg1, false);
    Back_To_Eval = Saved_Buf;
    History = Make_Dummy_History();
    Store_Return(RC_END_OF_COMPUTATION);
    Store_Expression(NIL);
    Save_Cont();
    Store_Expression(Result);
    Store_Env(Make_Non_Pointer(GLOBAL_ENV, GO_TO_GLOBAL));
    Band_Load_Hook();
    longjmp(*Back_To_Eval, PRIM_DO_EXPRESSION);
  }
  else
  { Back_To_Eval = Saved_Buf;
    Free = Save_Free;
    Free_Constant = Save_Free_Constant;
    Stack_Pointer = Save_Stack_Pointer;
    Set_Stack_Guard(Save_Stack_Guard);
    Undefined_Externals = Save_Undefined;
    Restore_Fixed_Obj(Save_FO);
    if (Jump_Value == PRIM_INTERRUPT)
    { printf("\nFile too large for memory.\n");
      Jump_Value = ERR_FASL_FILE_BAD_DATA;
    }
    Primitive_Error(Jump_Value);
  }
}
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦cf7822b4b⟧ TextFile

Derivation

TextFile
