promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.42 1988/08/15 20:36:24 cph Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.43 1989/03/27 23:13:56 jinx Exp $ */
\f
/* Memory management top level. Garbage collection to disk.
Microcode_Termination(TERM_GC_OUT_OF_SPACE);
/*NOTREACHED*/
}
+ ENTER_CRITICAL_SECTION ("garbage collector");
gc_counter += 1;
GC_Reserve = Get_Integer(Arg1);
GC(EMPTY_LIST);
CLEAR_INTERRUPT(INT_GC);
Pop_Primitive_Frame(1);
GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
+ RENAME_CRITICAL_SECTION ("garbage collector daemon");
if (GC_Daemon_Proc == SHARP_F)
{
Will_Push(CONTINUATION_SIZE);
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchpur.c,v 9.41 1988/08/15 20:36:35 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchpur.c,v 9.42 1989/03/27 23:14:03 jinx Exp $
Copyright (c) 1987, 1988 Massachusetts Institute of Technology
Arg_3_Type(TC_FIXNUM);
Touch_In_Primitive(Arg1, object);
GC_Reserve = (Get_Integer (Arg3));
+ ENTER_CRITICAL_SECTION ("purify");
{
Pointer purify_result;
Pointer words_free;
if (daemon == SHARP_F)
{
Val = result;
+ EXIT_CRITICAL_SECTION ({});
PRIMITIVE_ABORT(PRIM_POP_RETURN);
/*NOTREACHED*/
}
+ RENAME_CRITICAL_SECTION ("purify daemon");
Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1));
Store_Expression(result);
- Store_Return(RC_RESTORE_VALUE);
+ Store_Return(RC_NORMAL_GC_DONE);
Save_Cont();
Push(daemon);
Push(STACK_FRAME_HEADER);
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bkpt.h,v 9.25 1988/08/15 20:37:43 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bkpt.h,v 9.26 1989/03/27 23:14:08 jinx Rel $
*
* This file contains breakpoint utilities.
* Disabled when not debugging the interpreter.
long Start_Time;
Start_Time = Sys_Clock();
- Loc = Apply_Primitive(prim);
+ APPLY_PRIMITIVE(Loc, prim);
perfinfo_data.primtime[PRIMITIVE_NUMBER(prim)] +=
(Sys_Clock() - Start_Time);
Set_Time_Zone(Zone_Working);
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.53 1988/10/21 18:20:51 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.54 1989/03/27 23:14:13 jinx Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
{-stack stack-size}
{-constant constant-size}
{-utabmd utab-filename} or {-utab utab-filename}
- {-recover}
{other arguments ignored by the core microcode}
with filespec either {-band band-name} or {-fasl file-name} or
extern Boolean Was_Scheme_Dumped;
Boolean Was_Scheme_Dumped = false;
-extern Boolean Recover_Automatically;
-Boolean Recover_Automatically = false;
Boolean inhibit_termination_messages;
int Saved_Heap_Size;
int Saved_Stack_Size;
*cold_load_p = false;
*file_name = DEFAULT_BAND_NAME;
- Recover_Automatically =
- (Parse_Option("-recover", Saved_argc, Saved_argv, true) != NOT_THERE);
-
if (!Was_Scheme_Dumped)
{
Heap_Size = HEAP_SIZE;
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/config.h,v 9.41 1989/02/19 17:51:33 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/config.h,v 9.42 1989/03/27 23:14:36 jinx Exp $
*
* This file contains the configuration information and the information
* given on the command line on Unix.
*/
#ifdef pdp10
+#define MACHINE_TYPE "pdp10"
#define Heap_In_Low_Memory
#define CHAR_SIZE 36 / * Ugh! Supposedly fixed in newer Cs * /
#define BELL '\007'
#endif
#ifdef nu
+#define MACHINE_TYPE "nu"
#define Heap_In_Low_Memory
#define CHAR_SIZE 8
#define USHORT_SIZE 16
/* Amazingly unix and vms agree on all these */
+#define MACHINE_TYPE "vax"
#define Heap_In_Low_Memory
#define UNSIGNED_SHIFT
#define VAX_BYTE_ORDER
#if (VMS_VERSION < 4)
/* Pre version 4 VMS has no void type. */
#define void
-#endif
+#endif /* VMS_VERSION */
/* This eliminates a spurious warning from the C compiler. */
#define main_type
exit(value); \
longjmp(Exit_Point, NORMAL_EXIT)
-#else /* not a vms, therefore unix */
+#else /* not VMS ie. unix */
/* Vax Unix C compiler bug */
target = Make_Non_Pointer(TC_FIXNUM, For_Vaxes_Sake); \
}
-#endif /* not vms */
+#endif /* VMS */
#endif /* vax */
\f
#ifdef hp9000s200 /* and s300, pretty indistinguishable */
+#define MACHINE_TYPE "hp9000s200"
#define Heap_In_Low_Memory
#define UNSIGNED_SHIFT
#define CHAR_SIZE 8
#endif
#ifdef hp9000s500
+#define MACHINE_TYPE "hp9000s500"
/* An unfortunate fact of life on this machine:
the C heap is in high memory thus Heap_In_Low_Memory is not
defined and the whole thing runs slowly. *Sigh*
#define MAX_FLONUM_EXPONENT 1023
#ifdef sun4
+#define MACHINE_TYPE "sun4"
#define FASL_INTERNAL_FORMAT FASL_SUN4
#define FLOATING_ALIGNMENT 0x7 /* Low 3 MBZ for float storage */
#endif
#ifdef sun3
+#define MACHINE_TYPE "sun3"
#define FASL_INTERNAL_FORMAT FASL_68020
#endif
#ifndef FASL_INTERNAL_FORMAT
+#define MACHINE_TYPE "sun2"
#define FASL_INTERNAL_FORMAT FASL_68000
#endif
#endif
#ifdef butterfly
+#define MACHINE_TYPE "butterfly"
#define Heap_In_Low_Memory
#define CHAR_SIZE 8
#define USHORT_SIZE 16
#endif
\f
#ifdef cyber180
+#define MACHINE_TYPE "cyber180"
/* Word size is 64 bits. */
#define Heap_In_Low_Memory
#define CHAR_SIZE 8
#endif
#ifdef celerity
+#define MACHINE_TYPE "celerity"
#define Heap_In_Low_Memory
#define UNSIGNED_SHIFT
#define CHAR_SIZE 8
in the second MSBit. This is taken care of in object.h, and is
still considered Heap_In_Low_Memory.
*/
+#define MACHINE_TYPE "hp9000s800"
#define Heap_In_Low_Memory
#define UNSIGNED_SHIFT
#define CHAR_SIZE 8
#endif
\f
#ifdef umax
+#define MACHINE_TYPE "umax"
#define Heap_In_Low_Memory
#define UNSIGNED_SHIFT
#define CHAR_SIZE 8
#endif
#ifdef pyr
+#define MACHINE_TYPE "pyramid"
#define Heap_In_Low_Memory
#define UNSIGNED_SHIFT
-#define CHAR_SIZE 8
-#define USHORT_SIZE 16
-#define ULONG_SIZE 32
-#define BELL '\007'
-#define FASL_INTERNAL_FORMAT FASL_PYR
-#define FLONUM_EXPT_SIZE 10
-#define FLONUM_MANTISSA_BITS 53
-#define MAX_FLONUM_EXPONENT 1023
+#define CHAR_SIZE 8
+#define USHORT_SIZE 16
+#define ULONG_SIZE 32
+#define BELL '\007'
+#define FASL_INTERNAL_FORMAT FASL_PYR
+#define FLONUM_EXPT_SIZE 10
+#define FLONUM_MANTISSA_BITS 53
+#define MAX_FLONUM_EXPONENT 1023
#endif
#ifdef alliant
+#define MACHINE_TYPE "alliant"
#define Heap_In_Low_Memory
#define UNSIGNED_SHIFT
#define CHAR_SIZE 8
#if (ULONG_SIZE == 32)
#define b32
#endif
+
+#ifndef MACHINE_TYPE
+#define MACHINE_TYPE "unknown"
+#endif
\f
/* Default "segment" sizes */
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/const.h,v 9.29 1988/08/15 20:44:34 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/const.h,v 9.30 1989/03/27 23:14:42 jinx Exp $
*
* Named constants used throughout the interpreter
*
#define REGBLOCK_RETURN 6
#define REGBLOCK_LEXPR_ACTUALS 7
#define REGBLOCK_MINIMUM_LENGTH 8
+#define REGBLOCK_PRIMITIVE 9
\f
/* Codes specifying how to start scheme at boot time. */
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/default.h,v 9.30 1988/08/09 19:27:45 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/default.h,v 9.31 1989/03/27 23:14:47 jinx Rel $
*
* This file contains default definitions for some hooks which
* various machines require. These machines define these hooks
/* Primitive calling code. */
#ifndef ENABLE_DEBUGGING_TOOLS
-#define Apply_Primitive(N) Internal_Apply_Primitive(N)
+#define APPLY_PRIMITIVE INTERNAL_APPLY_PRIMITIVE
#else
extern Pointer Apply_Primitive();
+#define APPLY_PRIMITIVE(Loc, N) \
+{ \
+ Loc = Apply_Primitive(N); \
+}
#endif
#ifndef Metering_Apply_Primitive
-#define Metering_Apply_Primitive(Loc, N) \
-Loc = Apply_Primitive(N)
+#define Metering_Apply_Primitive APPLY_PRIMITIVE
#endif
#ifndef Eval_Ucode_Hook
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/errors.h,v 9.31 1988/08/15 20:45:29 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/errors.h,v 9.32 1989/03/27 23:14:52 jinx Exp $
*
* Error and termination code declarations.
*
/* 0x37 */ "IO-ERROR", \
/* 0x38 */ "FASDUMP-ENVIRONMENT", \
/* 0x39 */ "FASLOAD-BAND", \
-/* 0x40 */ "FASLOAD-COMPILED-MISMATCH" \
+/* 0x3A */ "FASLOAD-COMPILED-MISMATCH" \
}
\f
/* Termination codes: the interpreter halts on these */
#define TERM_TOUCH 0x17
#define TERM_SAVE_AND_EXIT 0x18
#define TERM_TRAP 0x19
+#define TERM_BAD_BACK_OUT 0x20
/*
If you add any termination codes here, add them to
the tables below as well!
*/
-#define MAX_TERMINATION 0x19
+#define MAX_TERMINATION 0x20
\f
#define TERM_NAME_TABLE \
{ \
/* 0x16 */ "SIGNAL", \
/* 0x17 */ "TOUCH", \
/* 0x18 */ "SAVE-AND-EXIT", \
-/* 0x19 */ "TERM_TRAP" \
+/* 0x19 */ "TERM_TRAP", \
+/* 0x20 */ "BAD_BACK_OUT" \
}
\f
#define TERM_MESSAGE_TABLE \
/* 0x16 */ "Unhandled signal received", \
/* 0x17 */ "Touch without futures support", \
/* 0x18 */ "Halt requested by external source", \
-/* 0x19 */ "User requested termination after trap" \
+/* 0x19 */ "User requested termination after trap", \
+/* 0x20 */ "Backing out of non-primitive" \
}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.38 1988/09/29 04:57:52 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.39 1989/03/27 23:14:58 jinx Exp $
The "fast loader" which reads in and relocates binary files and then
interns symbols. It is called with one argument: the (character
*/
#ifndef start_band_load
-#define start_band_load()
+#define start_band_load() \
+{ \
+ ENTER_CRITICAL_SECTION ("band load"); \
+}
#endif
#ifndef end_band_load
} \
} \
} \
+ EXIT_CRITICAL_SECTION ({}); \
}
#endif
-
+\f
DEFINE_PRIMITIVE ("LOAD-BAND", Prim_band_load, 1, 1, 0)
{
extern char *malloc();
extern strcpy(), free();
extern void compiler_reset();
extern Pointer compiler_utilities;
+ static void terminate_band_load();
jmp_buf
swapped_buf,
long temp, length;
Pointer result, cutl;
char *band_name;
+ Boolean load_file_failed;
Primitive_1_Arg();
-\f
+
saved_free = Free;
Free = Heap_Bottom;
saved_memtop = MemTop;
strcpy(band_name, Scheme_String_To_C_String(Arg1));
}
- /* 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;
- temp = setjmp(swapped_buf);
- if (temp != 0)
- {
- extern char
- *Error_Names[],
- *Abort_Names[];
-
- if (temp > 0)
- {
- fprintf(stderr,
- "\nload-band: Error %d (%s) past the point of no return.\n",
- temp, Error_Names[temp]);
- }
- else
- {
- fprintf(stderr,
- "\nload-band: Abort %d (%s) past the point of no return.\n",
- temp, Abort_Names[(-temp)-1]);
- }
+ load_file_failed = true;
- if (band_name != ((char *) NULL))
- {
- fprintf(stderr, "band-name = \"%s\".\n", band_name);
- free(band_name);
- }
- end_band_load(false, true);
- Back_To_Eval = saved_buf;
- Microcode_Termination(TERM_DISK_RESTORE);
- /*NOTREACHED*/
- }
+ UNWIND_PROTECT({
+ result = load_file(true);
+ load_file_failed = false;
+ },
+ {
+ if (load_file_failed)
+ {
+ terminate_band_load(UNWIND_PROTECT_value,
+ band_name);
+ /*NOTREACHED*/
+ }
+ });
- Back_To_Eval = ((jmp_buf *) swapped_buf);
- result = load_file(true);
- Back_To_Eval = saved_buf;
-\f
if (reload_band_name != ((char *) NULL))
{
free(reload_band_name);
Store_Return(RC_END_OF_COMPUTATION);
Store_Expression(NIL);
Save_Cont();
-
+\f
Store_Expression(Vector_Ref(result, 0));
Store_Env(Make_Non_Pointer(GLOBAL_ENV, GO_TO_GLOBAL));
PRIMITIVE_ABORT(PRIM_DO_EXPRESSION);
/*NOTREACHED*/
}
+
+static void
+terminate_band_load(abort_value, band_name)
+ int abort_value;
+ char *band_name;
+{
+ extern char
+ * Error_Names[],
+ * Abort_Names[];
+
+ if (abort_value > 0)
+ {
+ fprintf(stderr,
+ "\nload-band: Error %d (%s) past the point of no return.\n",
+ abort_value, Error_Names[abort_value]);
+ }
+ else
+ {
+ fprintf(stderr,
+ "\nload-band: Abort %d (%s) past the point of no return.\n",
+ abort_value, Abort_Names[(-abort_value)-1]);
+ }
+
+ if (band_name != ((char *) NULL))
+ {
+ fprintf(stderr, "band-name = \"%s\".\n", band_name);
+ free(band_name);
+ }
+ end_band_load(false, true);
+ Microcode_Termination(TERM_DISK_RESTORE);
+ /*NOTREACHED*/
+}
\f
#ifdef BYTE_INVERSION
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fixobj.h,v 9.26 1988/08/15 20:47:07 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fixobj.h,v 9.27 1989/03/27 23:15:06 jinx Rel $
*
* Declarations of user offsets into the Fixed Objects Vector.
* This should correspond to the file UTABMD.SCM
*/
\f
-#define Non_Object 0x00 /* Used for unassigned variables */
-#define System_Interrupt_Vector 0x01 /* Handlers for interrups */
-#define System_Error_Vector 0x02 /* Handlers for errors */
-#define OBArray 0x03 /* Array for interning symbols */
-#define Types_Vector 0x04 /* Type number -> Name map */
-#define Returns_Vector 0x05 /* Return code -> Name map */
-#define Primitives_Vector 0x06 /* Primitive code -> Name map */
-#define Errors_Vector 0x07 /* Error code -> Name map */
-#define Identification_Vector 0x08 /* ID Vector index -> name map */
-#define GC_Daemon 0x0B /* Procedure to run after GC */
-#define Trap_Handler 0x0C /* Continue after disaster */
-#define Stepper_State 0x0E /* NOT IMPLEMENTED YET */
-#define Fixed_Objects_Slots 0x0F /* Names of these slots */
-#define External_Primitives 0x10 /* Names of external prims */
-#define State_Space_Tag 0x11 /* Tag for state spaces */
-#define State_Point_Tag 0x12 /* Tag for state points */
-#define Dummy_History 0x13 /* Empty history structure */
-#define Bignum_One 0x14 /* Cache for bignum one */
-#define System_Scheduler 0x15 /* Scheduler for touched futures */
-#define Termination_Vector 0x16 /* Names for terminations */
-#define Termination_Proc_Vector 0x17 /* Handlers for terminations */
-#define Me_Myself 0x18 /* The actual shared vector */
-/* The next slot is used only in multiprocessor mode */
-#define The_Work_Queue 0x19 /* Where work is stored */
-/* These two slots are only used if logging futures */
-#define Future_Logger 0x1A /* Routine to log touched futures */
-#define Touched_Futures 0x1B /* Vector of touched futures */
+#define Non_Object 0x00 /* Used for unassigned variables. */
+#define System_Interrupt_Vector 0x01 /* Handlers for interrups. */
+#define System_Error_Vector 0x02 /* Handlers for errors. */
+#define OBArray 0x03 /* Array for interning symbols. */
+#define Types_Vector 0x04 /* Type number -> Name map. */
+#define Returns_Vector 0x05 /* Return code -> Name map. */
+#define Primitives_Vector 0x06 /* Primitive code -> Name map. */
+#define Errors_Vector 0x07 /* Error code -> Name map. */
+#define Identification_Vector 0x08 /* ID Vector index -> name map. */
+/* UNUSED slot 0x09 */
+/* UNUSED slot 0x0A */
+#define GC_Daemon 0x0B /* Procedure to run after GC. */
+#define Trap_Handler 0x0C /* Abort after disaster. */
+/* UNUSED slot 0x0D */
+#define Stepper_State 0x0E /* UNUSED in CScheme. */
+#define Fixed_Objects_Slots 0x0F /* Names of these slots. */
+/* UNUSED slot 0x10 used to be
+ External_Primitives Names of external prims. */
+#define State_Space_Tag 0x11 /* Tag for state spaces. */
+#define State_Point_Tag 0x12 /* Tag for state points. */
+#define Dummy_History 0x13 /* Empty history structure. */
+#define Bignum_One 0x14 /* Cache for bignum one. */
+#define System_Scheduler 0x15 /* MultiScheme:
+ Scheduler for touched futures. */
+#define Termination_Vector 0x16 /* Names for terminations. */
+#define Termination_Proc_Vector 0x17 /* Handlers for terminations. */
+#define Me_Myself 0x18 /* MultiScheme:
+ The shared fixed objects vector. */
+#define The_Work_Queue 0x19 /* MultiScheme:
+ Where work is stored. */
+#define Future_Logger 0x1A /* MultiScheme: When logging futures,
+ routine to log touched futures. */
+#define Touched_Futures 0x1B /* MultiScheme: When logging futures,
+ vector of touched futures. */
#define Precious_Objects 0x1C /* Objects that should not be lost! */
-#define Error_Procedure 0x1D /* User invoked error handler */
-#define Unsnapped_Link 0x1E /* Handler for call to compiled code */
-#define Utilities_Vector 0x1F /* ??? */
-#define Compiler_Err_Procedure 0x20 /* ??? */
+#define Error_Procedure 0x1D /* User invoked error handler. */
+#define Unsnapped_Link 0x1E /* UNUSED in CScheme. */
+#define Utilities_Vector 0x1F /* UNUSED in CScheme. */
+#define Compiler_Err_Procedure 0x20 /* User invoked error handler
+ from compiled code. */
#define Lost_Objects_Base 0x21 /* Free at the end of the "real" gc. */
-#define State_Space_Root 0x22 /* Root of state space */
-#define Primitive_Profiling_Table 0x23 /* Table of profile counts for primitives. */
+#define State_Space_Root 0x22 /* Root of state space. */
+#define Primitive_Profiling_Table 0x23 /* Table of profile counts for
+ primitives. */
#define NFixed_Objects 0x24
/* -*-C-*-
-Copyright (c) 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hooks.c,v 9.35 1989/03/27 23:15:12 jinx Exp $
+
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hooks.c,v 9.34 1988/12/08 10:48:14 cph Exp $
- *
+/*
* This file contains various hooks and handles which connect the
* primitives with the main interpreter.
*/
/*NOTREACHED*/
}
\f
+/* (DISABLE-INTERRUPTS! INTERRUPTS)
+ Disables the interrupts specified by INTERRUPTS. These interrupts
+ will trigger when the corresponding bits are enabled by ENABLE-INTERRUPTS!,
+ SET-INTERRUPT-ENABLES!, WITH-INTERRUPT-MASK, or a throw.
+ See intrpt.h for more information on interrupts.
+*/
+DEFINE_PRIMITIVE ("DISABLE-INTERRUPTS!", Prim_disable_interrupts, 1, 1, 0)
+{
+ long previous;
+ PRIMITIVE_HEADER (1);
+
+ previous = (FETCH_INTERRUPT_MASK ());
+ SET_INTERRUPT_MASK (previous & (~((arg_fixnum (1)) & INT_Mask)));
+ PRIMITIVE_RETURN (MAKE_SIGNED_FIXNUM (previous));
+}
+
/* (ENABLE-INTERRUPTS! INTERRUPTS)
- Changes the enabled interrupt bits to bitwise-or of INTERRUPTS
- and previous value of interrupts. Returns the previous value.
- See MASK_INTERRUPT_ENABLES for more information on interrupts.
+ Enables the interrupts specified by INTERRUPTS. At the next interrupt
+ point, any pending interrupts which were previously disabled will trigger.
+ See intrpt.h for more information on interrupts.
*/
DEFINE_PRIMITIVE ("ENABLE-INTERRUPTS!", Prim_enable_interrupts, 1, 1, 0)
{
long previous;
- Primitive_1_Arg ();
+ PRIMITIVE_HEADER (1);
- Arg_1_Type (TC_FIXNUM);
previous = (FETCH_INTERRUPT_MASK ());
- SET_INTERRUPT_MASK (((Get_Integer (Arg1)) & INT_Mask) | previous);
+ SET_INTERRUPT_MASK (previous | ((arg_fixnum (1)) & INT_Mask));
PRIMITIVE_RETURN (MAKE_SIGNED_FIXNUM (previous));
}
/* -*-C-*-
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.47 1988/11/10 06:14:18 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.48 1989/03/27 23:15:19 jinx Exp $
*
* This file contains the heart of the Scheme Scode
* interpreter
Import_Registers_Except_Val();
break;
#endif
-
+\f
case RC_HALT:
Export_Registers();
Microcode_Termination(TERM_TERM_HANDLER);
-\f
+ case RC_HARDWARE_TRAP:
+ {
+ /* This just reinvokes the handler */
+
+ Pointer info, handler;
+ info = (STACK_REF (0));
+
+ Save_Cont();
+ if ((! (Valid_Fixed_Obj_Vector())) ||
+ ((handler = (Get_Fixed_Obj_Slot(Trap_Handler))) == SHARP_F))
+ {
+ fprintf(stderr, "There is no trap handler for recovery!\n");
+ Microcode_Termination(TERM_TRAP);
+ /*NOTREACHED*/
+ }
+ Will_Push(STACK_ENV_EXTRA_SLOTS + 2);
+ Push(info);
+ Push(handler);
+ Push(STACK_FRAME_HEADER + 1);
+ Pushed();
+ goto Internal_Apply;
+ }
+\f
/* Internal_Apply, the core of the application mechanism.
+
Branch here to perform a function application.
At this point the top of the stack contains an application frame
Microcode_Termination(TERM_GC_OUT_OF_SPACE);
}
GC_Space_Needed = 0;
+ EXIT_CRITICAL_SECTION ({ Save_Cont(); Export_Registers(); });
End_GC_Hook();
break;
\f
{
Pointer GC_Daemon_Proc, Result;
+ RENAME_CRITICAL_SECTION ("purify pass 2");
Export_Registers();
Result = Purify_Pass_2(Fetch_Expression());
Import_Registers();
There is no need to run the daemons, and we should let
the runtime system know what happened. */
RESULT_OF_PURIFY (NIL);
+ EXIT_CRITICAL_SECTION ({ Export_Registers(); });
break;
}
GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
if (GC_Daemon_Proc == NIL)
{
RESULT_OF_PURIFY (SHARP_T);
+ EXIT_CRITICAL_SECTION ({ Export_Registers(); });
break;
}
+ RENAME_CRITICAL_SECTION( "purify daemon 2");
Store_Expression(NIL);
Store_Return(RC_PURIFY_GC_2);
Save_Cont();
case RC_PURIFY_GC_2:
RESULT_OF_PURIFY (SHARP_T);
+ EXIT_CRITICAL_SECTION ({ Export_Registers(); });
break;
case RC_REPEAT_DISPATCH:
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.h,v 9.30 1988/08/15 20:50:22 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.h,v 9.31 1989/03/27 23:15:28 jinx Rel $
*
* Macros used by the interpreter and some utilities.
*
not implemented.
*/
-#define Internal_Apply_Primitive(primitive) \
-((*(Primitive_Procedure_Table[PRIMITIVE_TABLE_INDEX(primitive)]))())
+#define INTERNAL_APPLY_PRIMITIVE(loc, primitive) \
+{ \
+ Regs[REGBLOCK_PRIMITIVE] = primitive; \
+ loc = ((*(Primitive_Procedure_Table[PRIMITIVE_TABLE_INDEX(primitive)]))()); \
+ Regs[REGBLOCK_PRIMITIVE] = NIL; \
+}
/* This is only valid for implemented primitives. */
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/intrpt.h,v 1.4 1988/08/15 20:50:33 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/intrpt.h,v 1.5 1989/03/27 23:15:34 jinx Exp $
*
* Interrupt manipulation utilities.
*/
/* Compatibility */
#define COMPILER_SET_MEMTOP() COMPILER_SETUP_INTERRUPT()
+\f
+/* Critical sections.
+
+ There should be a stack of critical sections, each with a
+ queue of hooks.
+ */
+
+extern char * critical_section_name;
+extern Boolean critical_section_hook_p;
+extern void (*critical_section_hook)();
+
+#define DECLARE_CRITICAL_SECTION() \
+ char * critical_section_name = ((char *) NULL); \
+ Boolean critical_section_hook_p; \
+ void (*critical_section_hook)()
+
+#define ENTER_CRITICAL_SECTION(name) \
+{ \
+ critical_section_name = (name); \
+}
+
+#define RENAME_CRITICAL_SECTION(name) \
+{ \
+ critical_section_name = (name); \
+}
+
+#define EXIT_CRITICAL_SECTION(code_if_hook) \
+{ \
+ if (critical_section_hook_p) \
+ { \
+ code_if_hook; \
+ { \
+ char * name; \
+ \
+ name = critical_section_name; \
+ critical_section_hook_p = false; \
+ critical_section_name = ((char *) NULL); \
+ critical_section_hook (name); \
+ /*NOTREACHED*/ \
+ } \
+ } \
+ else \
+ { \
+ critical_section_name = ((char *) NULL); \
+ } \
+}
+
+#define SET_CRITICAL_SECTION_HOOK(hook) \
+{ \
+ critical_section_hook = (hook); \
+ critical_section_hook_p = true; \
+}
+
+#define CLEAR_CRITICAL_SECTION_HOOK() \
+{ \
+ critical_section_hook_p = false; \
+}
+
+#define WITHIN_CRITICAL_SECTION_P() \
+ (critical_section_name != ((char *) NULL))
+
+#define CRITICAL_SECTION_NAME() \
+ (critical_section_name)
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/memmag.c,v 9.35 1988/08/15 20:51:50 cph Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/memmag.c,v 9.36 1989/03/27 23:15:41 jinx Exp $ */
/* Memory management top level.
Free, MemTop, Heap_Top);
Microcode_Termination(TERM_NO_SPACE);
}
+ ENTER_CRITICAL_SECTION ("garbage collector");
gc_counter += 1;
GC_Reserve = Get_Integer(Arg1);
GCFlip();
CLEAR_INTERRUPT(INT_GC);
Pop_Primitive_Frame(1);
GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
- if (GC_Daemon_Proc == NIL)
+ RENAME_CRITICAL_SECTION ("garbage collector daemon");
+ if (GC_Daemon_Proc == SHARP_F)
{
Will_Push(CONTINUATION_SIZE);
Store_Return(RC_NORMAL_GC_DONE);
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.36 1988/08/15 20:53:30 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.37 1989/03/27 23:15:46 jinx Exp $
*
* This file contains the code that copies objects into pure
* and constant space.
Touch_In_Primitive(Arg1, Object);
GC_Reserve = (Get_Integer (Arg3));
+ ENTER_CRITICAL_SECTION ("purify pass 1");
Purify_Result = Purify(Object, Arg2);
Pop_Primitive_Frame(3);
Daemon = Get_Fixed_Obj_Slot(GC_Daemon);
{
Pointer words_free;
+ RENAME_CRITICAL_SECTION ("purify pass 2");
Purify_Result = Purify_Pass_2(Purify_Result);
words_free = (Make_Unsigned_Fixnum (MemTop - Free));
Val = (Make_Pointer (TC_LIST, Free));
PRIMITIVE_ABORT(PRIM_POP_RETURN);
/*NOTREACHED*/
}
+ RENAME_CRITICAL_SECTION ("purify daemon 1");
Store_Expression(Purify_Result);
Store_Return(RC_PURIFY_GC_1);
Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purutl.c,v 9.34 1988/08/15 20:53:42 cph Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purutl.c,v 9.35 1989/03/27 23:15:52 jinx Exp $ */
/* Pure/Constant space utilities. */
#include "gccode.h"
#include "zones.h"
\f
-void
+static void
Update(From, To, Was, Will_Be)
fast Pointer *From, *To, *Was, *Will_Be;
{
From = END_OPERATOR_LINKAGE_AREA(From, count);
continue;
}
-
+\f
case TC_MANIFEST_CLOSURE:
- count = READ_OPERATOR_LINKAGE_COUNT(*From);
- From = END_OPERATOR_LINKAGE_AREA(From, count);
- continue;
+ {
+ machine_word *start_ptr;
+ fast machine_word *word_ptr;
+
+ From += 1;
+ word_ptr = FIRST_MANIFEST_CLOSURE_ENTRY(From);
+ start_ptr = word_ptr;
+
+ while (VALID_MANIFEST_CLOSURE_ENTRY(word_ptr))
+ {
+ word_ptr = NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr);
+ }
+ From = MANIFEST_CLOSURE_END(word_ptr, start_ptr);
+
+ continue;
+ }
default:
continue;
case_Cell:
Length = 1;
break;
-
+\f
case TC_LINKAGE_SECTION:
case TC_MANIFEST_CLOSURE:
case_compiled_entry_point:
OBJECT_TYPE(Object));
Invalid_Type_Code();
}
-\f
+
/* Add a copy of the object to the last constant block in memory.
*/
Obj_Address = Get_Pointer(Object);
if (!Test_Pure_Space_Top(Constant_Address + Length))
- return NIL;
+ {
+ return (NIL);
+ }
Block_Length = Get_Integer(*(Constant_Address-1));
Constant_Address -= 2;
New_Address = Constant_Address;
#ifdef FLOATING_ALIGNMENT
+
/* This should be done more cleanly, always align before doing a
block, or something like it. -- JINX
*/
Length = Constant_Address - Start;
}
else
+
#endif
+\f
+ {
for (i = Length; --i >= 0; )
{
*Constant_Address++ = *Obj_Address;
*Obj_Address++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, i);
}
+ }
*Constant_Address++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
*Constant_Address++ = Make_Non_Pointer(END_OF_BLOCK, Block_Length + Length);
*(New_Address + 2 - Block_Length) =
Set_Pure_Top();
Terminate_Old_Stacklet();
Terminate_Constant_Space(End_Of_Area);
+
+ ENTER_CRITICAL_SECTION ("impurify");
+
Update(Heap_Bottom, Free, Obj_Address, New_Address);
Update(Constant_Space, End_Of_Area, Obj_Address, New_Address);
- return Make_Pointer(OBJECT_TYPE(Object), New_Address);
+
+ EXIT_CRITICAL_SECTION ({});
+
+ return (Make_Pointer(OBJECT_TYPE(Object), New_Address));
}
\f
/* (PRIMITIVE-IMPURIFY OBJECT)
Touch_In_Primitive(Arg1, Arg1);
Result = Make_Impure(Arg1);
if (Result != NIL)
- return Result;
+ {
+ return (Result);
+ }
Primitive_Error(ERR_IMPURIFY_OUT_OF_SPACE);
/*NOTREACHED*/
}
\f
-Boolean
-Pure_Test(Obj_Address)
- fast Pointer *Obj_Address;
+extern Pointer * find_constant_space_block();
+
+Pointer *
+find_constant_space_block(obj_address)
+ fast Pointer *obj_address;
{
- fast Pointer *Where;
+ fast Pointer *where, *low_constant;
+
#ifdef FLOATING_ALIGNMENT
- fast Pointer Float_Align_Value;
+ fast Pointer float_align_value;
- Float_Align_Value = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0);
+ float_align_value = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0);
#endif
- Where = Free_Constant-1;
- while (Where >= Constant_Space)
+ low_constant = Constant_Space;
+ where = (Free_Constant - 1);
+
+ while (where >= low_constant)
{
+
#ifdef FLOATING_ALIGNMENT
- while (*Where == Float_Align_Value)
- Where -= 1;
+ while (*where == float_align_value)
+ where -= 1;
#endif
- Where -= 1 + Get_Integer(*Where);
- if (Where <= Obj_Address)
- return
- ((Boolean) (Obj_Address <= (Where + 1 + Get_Integer(*(Where + 1)))));
+
+ where -= (1 + Get_Integer(*where));
+ if (where <= obj_address)
+ return (where);
+ }
+ return ((Pointer *) NULL);
+}
+
+Boolean
+Pure_Test(obj_address)
+ Pointer *obj_address;
+{
+ Pointer *block;
+
+ block = find_constant_space_block (obj_address);
+ if (block == ((Pointer *) NULL))
+ {
+ return (false);
}
- return ((Boolean) false);
+ return
+ ((Boolean) (obj_address <= (block + 1 + (Get_Integer(*(block + 1))))));
}
\f
/* (PURE? OBJECT)
{
Pointer *Next_Address;
- Next_Address = Free_Constant + 1;
+ Next_Address = (Free_Constant + 1);
Primitive_0_Args();
return Make_Pointer(TC_ADDRESS, Next_Address);
}
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/returns.h,v 9.34 1988/10/26 20:01:08 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/returns.h,v 9.35 1989/03/27 23:16:00 jinx Rel $
*
* Return codes. These are placed in Return when an
* interpreter operation needs to operate in several
#define RC_COMP_UNASSIGNED_TRAP_RESTART 0x59
/* formerly RC_COMP_CACHE_ASSIGN_RESTART 0x5A */
#define RC_COMP_LINK_CACHES_RESTART 0x5B
+#define RC_HARDWARE_TRAP 0x5C
/* When adding return codes, add them to the table below as well! */
-#define MAX_RETURN_CODE 0x5B
+#define MAX_RETURN_CODE 0x5C
\f
#define RETURN_NAME_TABLE \
{ \
/* 0x58 */ "COMPILER_SAFE_REFERENCE_TRAP_RESTART", \
/* 0x59 */ "COMPILER_UNASSIGNED_P_TRAP_RESTART", \
/* 0x5A */ "", \
-/* 0x5B */ "COMPILER_LINK_CACHES_RESTART" \
+/* 0x5B */ "COMPILER_LINK_CACHES_RESTART", \
+/* 0x5C */ "HARDWARE_TRAP" \
}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sysprim.c,v 9.31 1988/10/21 00:12:44 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sysprim.c,v 9.32 1989/03/27 23:16:05 jinx Rel $
*
* Random system primitives. Most are implemented in terms of
* utilities in os.c
#endif /* USE_STACKLETS */
PRIMITIVE_RETURN (result);
}
+\f
+DEFINE_PRIMITIVE ("SET-TRAP-STATE!", Prim_set_trap_state, 1, 1, 0)
+{
+ long result;
+ extern long OS_set_trap_state();
+ PRIMITIVE_HEADER (1);
+
+ result = (OS_set_trap_state (arg_nonnegative_integer (1)));
+ if (result < 0)
+ {
+ error_bad_range_arg (1);
+ /*NOTREACHED*/
+ }
+ PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM (result));
+}
;;;; Machine Dependent Type Tables
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.46 1988/07/15 20:26:31 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.47 1989/03/27 23:17:15 jinx Rel $
(declare (usual-integrations))
TOUCHED-FUTURES-VECTOR ;1B
PRECIOUS-OBJECTS ;1C
ERROR-PROCEDURE ;1D
- UNSNAPPED-LINK ;1E
- MICROCODE-UTILITIES-VECTOR ;1F
+ #F #| UNSNAPPED-LINK |# ;1E
+ #F #| MICROCODE-UTILITIES-VECTOR |# ;1F
COMPILER-ERROR-PROCEDURE ;20
LOST-OBJECT-BASE ;21
STATE-SPACE-ROOT ;22
COMPILER-UNASSIGNED?-TRAP-RESTART ;59
#F ;5A
COMPILER-LINK-CACHES-RESTART ;5B
+ HARDWARE-TRAP ;5C
))
\f
;;; [] Errors
SIGNAL ;16
TOUCH ;17
SAVE-AND-EXIT ;18
+ TRAP ;19
+ BAD-BACK-OUT ;20
))
(vector-set! (get-fixed-objects-vector)
;;; This identification string is saved by the system.
-"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.46 1988/07/15 20:26:31 cph Exp $"
\ No newline at end of file
+"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.47 1989/03/27 23:17:15 jinx Rel $"
\ No newline at end of file
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utils.c,v 9.39 1988/09/29 05:03:12 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utils.c,v 9.40 1989/03/27 23:17:22 jinx Exp $ */
/* This file contains utilities for interrupts, errors, etc. */
* restarted and completes successfully.
*/
- primitive = Fetch_Expression();
+ primitive = Regs[REGBLOCK_PRIMITIVE];
+ if (OBJECT_TYPE(primitive) != TC_PRIMITIVE)
+ {
+ fprintf(stderr,
+ "\nBack_Out_Of_Primitive backing out when not in primitive!\n");
+ Microcode_Termination(TERM_BAD_BACK_OUT);
+ }
nargs = PRIMITIVE_N_ARGUMENTS(primitive);
if (OBJECT_TYPE(Stack_Ref(nargs)) == TC_COMPILED_ENTRY)
{
Val = NIL;
Store_Return(RC_INTERNAL_APPLY);
Store_Expression(NIL);
+ Regs[REGBLOCK_PRIMITIVE] = NIL;
return;
}
\f
Print_Primitive(primitive);
}
Saved_Stack = Stack_Pointer;
- Result = Internal_Apply_Primitive(primitive);
+ Result = INTERNAL_APPLY_PRIMITIVE(primitive);
if (Saved_Stack != Stack_Pointer)
{
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 10.69 1989/03/14 01:59:28 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 10.70 1989/03/27 23:17:29 jinx Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#define VERSION 10
#endif
#ifndef SUBVERSION
-#define SUBVERSION 69
+#define SUBVERSION 70
#endif
#ifndef UCODE_TABLES_FILENAME
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/const.h,v 9.29 1988/08/15 20:44:34 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/const.h,v 9.30 1989/03/27 23:14:42 jinx Exp $
*
* Named constants used throughout the interpreter
*
#define REGBLOCK_RETURN 6
#define REGBLOCK_LEXPR_ACTUALS 7
#define REGBLOCK_MINIMUM_LENGTH 8
+#define REGBLOCK_PRIMITIVE 9
\f
/* Codes specifying how to start scheme at boot time. */
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/fixobj.h,v 9.26 1988/08/15 20:47:07 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/fixobj.h,v 9.27 1989/03/27 23:15:06 jinx Rel $
*
* Declarations of user offsets into the Fixed Objects Vector.
* This should correspond to the file UTABMD.SCM
*/
\f
-#define Non_Object 0x00 /* Used for unassigned variables */
-#define System_Interrupt_Vector 0x01 /* Handlers for interrups */
-#define System_Error_Vector 0x02 /* Handlers for errors */
-#define OBArray 0x03 /* Array for interning symbols */
-#define Types_Vector 0x04 /* Type number -> Name map */
-#define Returns_Vector 0x05 /* Return code -> Name map */
-#define Primitives_Vector 0x06 /* Primitive code -> Name map */
-#define Errors_Vector 0x07 /* Error code -> Name map */
-#define Identification_Vector 0x08 /* ID Vector index -> name map */
-#define GC_Daemon 0x0B /* Procedure to run after GC */
-#define Trap_Handler 0x0C /* Continue after disaster */
-#define Stepper_State 0x0E /* NOT IMPLEMENTED YET */
-#define Fixed_Objects_Slots 0x0F /* Names of these slots */
-#define External_Primitives 0x10 /* Names of external prims */
-#define State_Space_Tag 0x11 /* Tag for state spaces */
-#define State_Point_Tag 0x12 /* Tag for state points */
-#define Dummy_History 0x13 /* Empty history structure */
-#define Bignum_One 0x14 /* Cache for bignum one */
-#define System_Scheduler 0x15 /* Scheduler for touched futures */
-#define Termination_Vector 0x16 /* Names for terminations */
-#define Termination_Proc_Vector 0x17 /* Handlers for terminations */
-#define Me_Myself 0x18 /* The actual shared vector */
-/* The next slot is used only in multiprocessor mode */
-#define The_Work_Queue 0x19 /* Where work is stored */
-/* These two slots are only used if logging futures */
-#define Future_Logger 0x1A /* Routine to log touched futures */
-#define Touched_Futures 0x1B /* Vector of touched futures */
+#define Non_Object 0x00 /* Used for unassigned variables. */
+#define System_Interrupt_Vector 0x01 /* Handlers for interrups. */
+#define System_Error_Vector 0x02 /* Handlers for errors. */
+#define OBArray 0x03 /* Array for interning symbols. */
+#define Types_Vector 0x04 /* Type number -> Name map. */
+#define Returns_Vector 0x05 /* Return code -> Name map. */
+#define Primitives_Vector 0x06 /* Primitive code -> Name map. */
+#define Errors_Vector 0x07 /* Error code -> Name map. */
+#define Identification_Vector 0x08 /* ID Vector index -> name map. */
+/* UNUSED slot 0x09 */
+/* UNUSED slot 0x0A */
+#define GC_Daemon 0x0B /* Procedure to run after GC. */
+#define Trap_Handler 0x0C /* Abort after disaster. */
+/* UNUSED slot 0x0D */
+#define Stepper_State 0x0E /* UNUSED in CScheme. */
+#define Fixed_Objects_Slots 0x0F /* Names of these slots. */
+/* UNUSED slot 0x10 used to be
+ External_Primitives Names of external prims. */
+#define State_Space_Tag 0x11 /* Tag for state spaces. */
+#define State_Point_Tag 0x12 /* Tag for state points. */
+#define Dummy_History 0x13 /* Empty history structure. */
+#define Bignum_One 0x14 /* Cache for bignum one. */
+#define System_Scheduler 0x15 /* MultiScheme:
+ Scheduler for touched futures. */
+#define Termination_Vector 0x16 /* Names for terminations. */
+#define Termination_Proc_Vector 0x17 /* Handlers for terminations. */
+#define Me_Myself 0x18 /* MultiScheme:
+ The shared fixed objects vector. */
+#define The_Work_Queue 0x19 /* MultiScheme:
+ Where work is stored. */
+#define Future_Logger 0x1A /* MultiScheme: When logging futures,
+ routine to log touched futures. */
+#define Touched_Futures 0x1B /* MultiScheme: When logging futures,
+ vector of touched futures. */
#define Precious_Objects 0x1C /* Objects that should not be lost! */
-#define Error_Procedure 0x1D /* User invoked error handler */
-#define Unsnapped_Link 0x1E /* Handler for call to compiled code */
-#define Utilities_Vector 0x1F /* ??? */
-#define Compiler_Err_Procedure 0x20 /* ??? */
+#define Error_Procedure 0x1D /* User invoked error handler. */
+#define Unsnapped_Link 0x1E /* UNUSED in CScheme. */
+#define Utilities_Vector 0x1F /* UNUSED in CScheme. */
+#define Compiler_Err_Procedure 0x20 /* User invoked error handler
+ from compiled code. */
#define Lost_Objects_Base 0x21 /* Free at the end of the "real" gc. */
-#define State_Space_Root 0x22 /* Root of state space */
-#define Primitive_Profiling_Table 0x23 /* Table of profile counts for primitives. */
+#define State_Space_Root 0x22 /* Root of state space. */
+#define Primitive_Profiling_Table 0x23 /* Table of profile counts for
+ primitives. */
#define NFixed_Objects 0x24
/* -*-C-*-
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.47 1988/11/10 06:14:18 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.48 1989/03/27 23:15:19 jinx Exp $
*
* This file contains the heart of the Scheme Scode
* interpreter
Import_Registers_Except_Val();
break;
#endif
-
+\f
case RC_HALT:
Export_Registers();
Microcode_Termination(TERM_TERM_HANDLER);
-\f
+ case RC_HARDWARE_TRAP:
+ {
+ /* This just reinvokes the handler */
+
+ Pointer info, handler;
+ info = (STACK_REF (0));
+
+ Save_Cont();
+ if ((! (Valid_Fixed_Obj_Vector())) ||
+ ((handler = (Get_Fixed_Obj_Slot(Trap_Handler))) == SHARP_F))
+ {
+ fprintf(stderr, "There is no trap handler for recovery!\n");
+ Microcode_Termination(TERM_TRAP);
+ /*NOTREACHED*/
+ }
+ Will_Push(STACK_ENV_EXTRA_SLOTS + 2);
+ Push(info);
+ Push(handler);
+ Push(STACK_FRAME_HEADER + 1);
+ Pushed();
+ goto Internal_Apply;
+ }
+\f
/* Internal_Apply, the core of the application mechanism.
+
Branch here to perform a function application.
At this point the top of the stack contains an application frame
Microcode_Termination(TERM_GC_OUT_OF_SPACE);
}
GC_Space_Needed = 0;
+ EXIT_CRITICAL_SECTION ({ Save_Cont(); Export_Registers(); });
End_GC_Hook();
break;
\f
{
Pointer GC_Daemon_Proc, Result;
+ RENAME_CRITICAL_SECTION ("purify pass 2");
Export_Registers();
Result = Purify_Pass_2(Fetch_Expression());
Import_Registers();
There is no need to run the daemons, and we should let
the runtime system know what happened. */
RESULT_OF_PURIFY (NIL);
+ EXIT_CRITICAL_SECTION ({ Export_Registers(); });
break;
}
GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
if (GC_Daemon_Proc == NIL)
{
RESULT_OF_PURIFY (SHARP_T);
+ EXIT_CRITICAL_SECTION ({ Export_Registers(); });
break;
}
+ RENAME_CRITICAL_SECTION( "purify daemon 2");
Store_Expression(NIL);
Store_Return(RC_PURIFY_GC_2);
Save_Cont();
case RC_PURIFY_GC_2:
RESULT_OF_PURIFY (SHARP_T);
+ EXIT_CRITICAL_SECTION ({ Export_Registers(); });
break;
case RC_REPEAT_DISPATCH:
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/returns.h,v 9.34 1988/10/26 20:01:08 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/returns.h,v 9.35 1989/03/27 23:16:00 jinx Rel $
*
* Return codes. These are placed in Return when an
* interpreter operation needs to operate in several
#define RC_COMP_UNASSIGNED_TRAP_RESTART 0x59
/* formerly RC_COMP_CACHE_ASSIGN_RESTART 0x5A */
#define RC_COMP_LINK_CACHES_RESTART 0x5B
+#define RC_HARDWARE_TRAP 0x5C
/* When adding return codes, add them to the table below as well! */
-#define MAX_RETURN_CODE 0x5B
+#define MAX_RETURN_CODE 0x5C
\f
#define RETURN_NAME_TABLE \
{ \
/* 0x58 */ "COMPILER_SAFE_REFERENCE_TRAP_RESTART", \
/* 0x59 */ "COMPILER_UNASSIGNED_P_TRAP_RESTART", \
/* 0x5A */ "", \
-/* 0x5B */ "COMPILER_LINK_CACHES_RESTART" \
+/* 0x5B */ "COMPILER_LINK_CACHES_RESTART", \
+/* 0x5C */ "HARDWARE_TRAP" \
}
;;;; Machine Dependent Type Tables
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.46 1988/07/15 20:26:31 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.47 1989/03/27 23:17:15 jinx Rel $
(declare (usual-integrations))
TOUCHED-FUTURES-VECTOR ;1B
PRECIOUS-OBJECTS ;1C
ERROR-PROCEDURE ;1D
- UNSNAPPED-LINK ;1E
- MICROCODE-UTILITIES-VECTOR ;1F
+ #F #| UNSNAPPED-LINK |# ;1E
+ #F #| MICROCODE-UTILITIES-VECTOR |# ;1F
COMPILER-ERROR-PROCEDURE ;20
LOST-OBJECT-BASE ;21
STATE-SPACE-ROOT ;22
COMPILER-UNASSIGNED?-TRAP-RESTART ;59
#F ;5A
COMPILER-LINK-CACHES-RESTART ;5B
+ HARDWARE-TRAP ;5C
))
\f
;;; [] Errors
SIGNAL ;16
TOUCH ;17
SAVE-AND-EXIT ;18
+ TRAP ;19
+ BAD-BACK-OUT ;20
))
(vector-set! (get-fixed-objects-vector)
;;; This identification string is saved by the system.
-"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.46 1988/07/15 20:26:31 cph Exp $"
\ No newline at end of file
+"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.47 1989/03/27 23:17:15 jinx Rel $"
\ No newline at end of file
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 10.69 1989/03/14 01:59:28 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 10.70 1989/03/27 23:17:29 jinx Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#define VERSION 10
#endif
#ifndef SUBVERSION
-#define SUBVERSION 69
+#define SUBVERSION 70
#endif
#ifndef UCODE_TABLES_FILENAME
projects / mit-scheme.git / commitdiff