Skip to content
Snippets Groups Projects
Commit 62957726 authored by wlott's avatar wlott
Browse files

Initial revision

parent 0bbd4f0e
No related branches found
No related tags found
No related merge requests found
CPPFLAGS = -I. -I/usr/misc/.X11/include
CC = gcc # -Wall -Wstrict-prototypes -Wmissing-prototypes
CPP = /usr/cs/lib/cpp
CFLAGS = -g
ASFLAGS = -g
NM = nm -gp
UNDEFSYMPATTERN = &
ASSEM_SRC = mips-assem.S
ARCH_SRC = mips-arch.c
OS_SRC = mach-os.c
OS_LINK_FLAGS=
OS_LIBS=-lmach
# $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/GNUmakefile,v 1.1 1992/07/28 20:13:58 wlott Exp $
all: lisp.nm
CC = gcc
include Config
SRCS = lisp.c coreparse.c alloc.c monitor.c print.c interr.c os-common.c \
vars.c parse.c interrupt.c search.c validate.c gc.c globals.c \
dynbind.c breakpoint.c regnames.c backtrace.c save.c purify.c \
socket.c ${ARCH_SRC} ${ASSEM_SRC} ${OS_SRC}
OBJS = $(patsubst %.c,%.o,$(patsubst %.S,%.o,$(SRCS)))
### Don't look in RCS for the files, because we might not want the latest.
%: RCS/%,v
lisp.nm: lisp
echo -n 'Map file for lisp version ' > ,lisp.nm
cat version >> ,lisp.nm
$(NM) lisp >> ,lisp.nm
mv ,lisp.nm lisp.nm
lisp: ${OBJS} version undefineds
echo -n '1 + ' | cat - version | bc > ,version
mv ,version version
$(CC) ${CFLAGS} -DVERSION=`cat version` -c version.c
$(CC) $(CFLAGS) ${OS_LINK_FLAGS} `cat undefineds` -o ,lisp \
${OBJS} version.o \
${OS_LIBS} -lm
mv -f ,lisp lisp
version:
echo 0 > version
undefineds: undefineds.src
${CPP} undefineds.src | \
sed -e '/^#/d' -e '/^[ ]*$$/d' -e 's/.*/-Xlinker -u -Xlinker ${UNDEFSYMPATTERN}/' | \
sort -u > ,undefineds
mv ,undefineds undefineds
### Socket.c needs to be compiled with UNIXCONN defined.
socket.o: socket.c
$(COMPILE.c) -DUNIXCONN socket.c
internals.h:
@echo "You must run genesis to create internals.h!"
@false
clean:
rm -f Depends lisp.h undefineds *.o lisp lisp.nm
depend:
$(CC) -MM ${CFLAGS} ${CPPFLAGS} ${SRCS} > ,depends
mv ,depends Depends
include Depends
/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/alloc.c,v 1.1 1992/07/28 20:14:02 wlott Exp $ */
#include "lisp.h"
#include "internals.h"
#include "alloc.h"
#include "globals.h"
#include "gc.h"
#ifdef ibmrt
#define GET_FREE_POINTER() ((lispobj *)SymbolValue(ALLOCATION_POINTER))
#define SET_FREE_POINTER(new_value) \
(SetSymbolValue(ALLOCATION_POINTER,(lispobj)(new_value)))
#define GET_GC_TRIGGER() ((lispobj *)SymbolValue(INTERNAL_GC_TRIGGER))
#define SET_GC_TRIGGER(new_value) \
(SetSymbolValue(INTERNAL_GC_TRIGGER,(lispobj)(new_value)))
#else
#define GET_FREE_POINTER() current_dynamic_space_free_pointer
#define SET_FREE_POINTER(new_value) \
(current_dynamic_space_free_pointer = (new_value))
#define GET_GC_TRIGGER() current_auto_gc_trigger
#define SET_GC_TRIGGER(new_value) \
clear_auto_gc_trigger(); set_auto_gc_trigger(new_value);
#endif
/****************************************************************
Allocation Routines.
****************************************************************/
static lispobj *alloc(int bytes)
{
lispobj *result;
/* Round to dual word boundry. */
bytes = (bytes + lowtag_Mask) & ~lowtag_Mask;
result = GET_FREE_POINTER();
SET_FREE_POINTER(result + (bytes / sizeof(lispobj)));
if (GET_GC_TRIGGER() && GET_FREE_POINTER() > GET_GC_TRIGGER()) {
SET_GC_TRIGGER((char *)GET_FREE_POINTER()
- (char *)current_dynamic_space);
}
return result;
}
static lispobj *alloc_unboxed(int type, int words)
{
lispobj *result;
result = alloc((1 + words) * sizeof(lispobj));
*result = (lispobj) (words << type_Bits) | type;
return result;
}
static lispobj alloc_vector(int type, int length, int size)
{
struct vector *result;
result = (struct vector *)alloc((2 + (length*size + 31) / 32) * sizeof(lispobj));
result->header = type;
result->length = make_fixnum(length);
return ((lispobj)result)|type_OtherPointer;
}
lispobj alloc_cons(lispobj car, lispobj cdr)
{
struct cons *ptr = (struct cons *)alloc(sizeof(struct cons));
ptr->car = car;
ptr->cdr = cdr;
return (lispobj)ptr | type_ListPointer;
}
lispobj alloc_number(long n)
{
struct bignum *ptr;
if (-0x20000000 < n && n < 0x20000000)
return make_fixnum(n);
else {
ptr = (struct bignum *)alloc_unboxed(type_Bignum, 1);
ptr->digits[0] = n;
return (lispobj) ptr | type_OtherPointer;
}
}
lispobj alloc_string(char *str)
{
int len = strlen(str);
lispobj result = alloc_vector(type_SimpleString, len+1, 8);
struct vector *vec = (struct vector *)PTR(result);
vec->length = make_fixnum(len);
strcpy((char *)vec->data, str);
return result;
}
lispobj alloc_sap(void *ptr)
{
struct sap *sap = (struct sap *)alloc_unboxed(type_Sap, 1);
sap->pointer = ptr;
return (lispobj) sap | type_OtherPointer;
}
/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/alloc.h,v 1.1 1992/07/28 20:14:04 wlott Exp $ */
#ifndef _ALLOC_H_
#define _ALLOC_H_
#include "lisp.h"
extern lispobj alloc_cons(lispobj car, lispobj cdr);
extern lispobj alloc_number(long n);
extern lispobj alloc_string(char *str);
extern lispobj alloc_sap(void *ptr);
#endif _ALLOC_H_
#ifndef __ARCH_H__
#define __ARCH_H__
#include "os.h"
#include "signal.h"
extern char *arch_init(void);
extern void arch_skip_instruction(struct sigcontext *scp);
extern boolean arch_pseudo_atomic_atomic(struct sigcontext *scp);
extern void arch_set_pseudo_atomic_interrupted(struct sigcontext *scp);
extern os_vm_address_t arch_get_bad_addr(struct sigcontext *scp);
extern unsigned char *arch_internal_error_arguments(struct sigcontext *scp);
extern unsigned long arch_install_breakpoint(void *pc);
extern void arch_remove_breakpoint(void *pc, unsigned long orig_inst);
extern void arch_install_interrupt_handlers(void);
extern void arch_do_displaced_inst(struct sigcontext *scp,
unsigned long orig_inst);
extern lispobj funcall0(lispobj function);
extern lispobj funcall1(lispobj function, lispobj arg0);
extern lispobj funcall2(lispobj function, lispobj arg0, lispobj arg1);
extern lispobj funcall3(lispobj function, lispobj arg0, lispobj arg1,
lispobj arg2);
#endif /* __ARCH_H__ */
/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/backtrace.c,v 1.1 1992/07/28 20:14:10 wlott Exp $
*
* Simple backtrace facility. More or less from Rob's lisp version.
*/
#include <stdio.h>
#include <signal.h>
#include "lisp.h"
#include "internals.h"
#include "globals.h"
#include "interrupt.h"
#include "lispregs.h"
#ifndef i386
/* Sigh ... I know what the call frame looks like and it had
better not change. */
struct call_frame {
struct call_frame *old_cont;
lispobj saved_lra;
lispobj code;
lispobj other_state[5];
};
struct call_info {
struct call_frame *frame;
int interrupted;
struct code *code;
lispobj lra;
int pc; /* Note: this is the trace file offset, not the actual pc. */
};
#define HEADER_LENGTH(header) ((header)>>8)
static int previous_info(struct call_info *info);
static struct code *
code_pointer(lispobj object)
{
lispobj *headerp, header;
int type, len;
headerp = (lispobj *) PTR(object);
header = *headerp;
type = TypeOf(header);
switch (type) {
case type_CodeHeader:
break;
case type_ReturnPcHeader:
case type_FunctionHeader:
case type_ClosureFunctionHeader:
len = HEADER_LENGTH(header);
if (len == 0)
headerp = NULL;
else
headerp -= len;
break;
default:
headerp = NULL;
}
return (struct code *) headerp;
}
static boolean
cs_valid_pointer_p(struct call_frame *pointer)
{
return (((char *) control_stack <= (char *) pointer) &&
((char *) pointer < (char *) current_control_stack_pointer));
}
static void
info_from_lisp_state(struct call_info *info)
{
info->frame = (struct call_frame *)current_control_frame_pointer;
info->interrupted = 0;
info->code = NULL;
info->lra = 0;
info->pc = 0;
previous_info(info);
}
static void
info_from_sigcontext(struct call_info *info, struct sigcontext *csp)
{
unsigned long pc;
info->interrupted = 1;
if (LowtagOf(SC_REG(csp, reg_CODE)) == type_FunctionPointer) {
/* We tried to call a function, but crapped out before $CODE could be fixed up. Probably an undefined function. */
info->frame = (struct call_frame *)SC_REG(csp, reg_OCFP);
info->lra = (lispobj)SC_REG(csp, reg_LRA);
info->code = code_pointer(info->lra);
pc = (unsigned long)PTR(info->lra);
}
else {
info->frame = (struct call_frame *)SC_REG(csp, reg_CFP);
info->code = code_pointer(SC_REG(csp, reg_CODE));
info->lra = NIL;
pc = SC_PC(csp);
}
if (info->code != NULL)
info->pc = pc - (unsigned long) info->code -
(HEADER_LENGTH(info->code->header) * sizeof(lispobj));
else
info->pc = 0;
}
static int
previous_info(struct call_info *info)
{
struct call_frame *this_frame;
int free;
struct sigcontext *csp;
if (!cs_valid_pointer_p(info->frame)) {
printf("Bogus callee value (0x%08x).\n", (unsigned long)info->frame);
return 0;
}
this_frame = info->frame;
info->lra = this_frame->saved_lra;
info->frame = this_frame->old_cont;
info->interrupted = 0;
if (info->frame == NULL || info->frame == this_frame)
return 0;
if (info->lra == NIL) {
/* We were interrupted. Find the correct sigcontext. */
free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2;
while (free-- > 0) {
csp = lisp_interrupt_contexts[free];
if ((struct call_frame *)(SC_REG(csp, reg_CFP)) == info->frame) {
info_from_sigcontext(info, csp);
break;
}
}
}
else {
info->code = code_pointer(info->lra);
if (info->code != NULL)
info->pc = (unsigned long)PTR(info->lra) -
(unsigned long)info->code -
(HEADER_LENGTH(info->code->header) * sizeof(lispobj));
else
info->pc = 0;
}
return 1;
}
void
backtrace(int nframes)
{
struct call_info info;
info_from_lisp_state(&info);
do {
printf("<Frame 0x%08x%s, ", (unsigned long) info.frame,
info.interrupted ? " [interrupted]" : "");
if (info.code != (struct code *) 0) {
lispobj function;
printf("CODE: 0x%08X, ", (unsigned long) info.code | type_OtherPointer);
function = info.code->entry_points;
while (function != NIL) {
struct function_header *header;
lispobj name;
header = (struct function_header *) PTR(function);
name = header->name;
if (LowtagOf(name) == type_OtherPointer) {
lispobj *object;
object = (lispobj *) PTR(name);
if (TypeOf(*object) == type_SymbolHeader) {
struct symbol *symbol;
symbol = (struct symbol *) object;
object = (lispobj *) PTR(symbol->name);
}
if (TypeOf(*object) == type_SimpleString) {
struct vector *string;
string = (struct vector *) object;
printf("%s, ", (char *) string->data);
} else
printf("(Not simple string???), ");
} else
printf("(Not other pointer???), ");
function = header->next;
}
}
else
printf("CODE: ???, ");
if (info.lra != NIL)
printf("LRA: 0x%08x, ", (unsigned long)info.lra);
else
printf("<no LRA>, ");
if (info.pc)
printf("PC: 0x%x>\n", info.pc);
else
printf("PC: ???>\n");
} while (--nframes > 0 && previous_info(&info));
}
#else
void
backtrace(nframes)
int nframes;
{
printf("Can't backtrace on the x86.\n");
}
#endif
#include <stdio.h>
#include <signal.h>
#include "lisp.h"
#include "os.h"
#include "internals.h"
#include "arch.h"
#include "lispregs.h"
#include "globals.h"
#include "alloc.h"
#include "breakpoint.h"
#define REAL_LRA_SLOT 0
#define KNOWN_RETURN_P_SLOT 1
#define BOGUS_LRA_CONSTANTS 2
static void *compute_pc(lispobj code_obj, int pc_offset)
{
struct code *code;
code = (struct code *)PTR(code_obj);
return (void *)((char *)code + HeaderValue(code->header)*sizeof(lispobj)
+ pc_offset);
}
unsigned long breakpoint_install(lispobj code_obj, int pc_offset)
{
return arch_install_breakpoint(compute_pc(code_obj, pc_offset));
}
void breakpoint_remove(lispobj code_obj, int pc_offset,
unsigned long orig_inst)
{
arch_remove_breakpoint(compute_pc(code_obj, pc_offset), orig_inst);
}
void breakpoint_do_displaced_inst(struct sigcontext *scp,
unsigned long orig_inst)
{
arch_do_displaced_inst(scp, orig_inst);
}
static lispobj find_code(struct sigcontext *scp)
{
#ifdef CODE
lispobj code = SC_REG(scp, CODE), header;
if (LowtagOf(code) != type_OtherPointer)
return NIL;
header = *(lispobj *)PTR(code);
if (TypeOf(header) == type_CodeHeader)
return code;
else
return code - HeaderValue(code)*sizeof(lispobj);
#else
return NIL;
#endif
}
static void internal_handle_breakpoint(struct sigcontext *scp, lispobj code)
{
int offset;
if (code == NIL)
offset = 0;
else {
unsigned long code_start;
struct code *codeptr = (struct code *)PTR(code);
code_start = (unsigned long)codeptr
+ HeaderValue(codeptr->header)*sizeof(lispobj);
if (SC_PC(scp) < code_start)
offset = 0;
else {
offset = SC_PC(scp) - code_start;
if (offset >= codeptr->code_size)
offset = 0;
}
}
funcall3(SymbolFunction(HANDLE_BREAKPOINT),
make_fixnum(offset),
code,
alloc_sap(scp));
scp->sc_mask = sigblock(0);
}
void handle_breakpoint(int signal, int subcode, struct sigcontext *scp)
{
internal_handle_breakpoint(scp, find_code(scp));
}
void *handle_function_end_breakpoint(int signal, int subcode,
struct sigcontext *scp)
{
lispobj code = find_code(scp);
struct code *codeptr = (struct code *)PTR(code);
lispobj lra;
internal_handle_breakpoint(scp, code);
lra = codeptr->constants[REAL_LRA_SLOT];
#ifdef CODE
if (codeptr->constants[KNOWN_RETURN_P_SLOT] == NIL)
SC_REG(scp, CODE) = lra;
#endif
return (void *)(lra - type_OtherPointer+sizeof(lispobj));
}
/*
* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/breakpoint.h,v 1.1 1992/07/28 20:14:15 wlott Exp $
*/
#ifndef _BREAKPOINT_H_
#define _BREAKPOINT_H_
extern unsigned long breakpoint_install(lispobj code_obj, int pc_offset);
extern void breakpoint_remove(lispobj code_obj, int pc_offset,
unsigned long orig_inst);
extern void breakpoint_do_displaced_inst(struct sigcontext *scp,
unsigned long orig_inst);
extern void handle_breakpoint(int signal, int subcode, struct sigcontext *scp);
extern void *handle_function_end_breakpoint(int signal, int subcode,
struct sigcontext *scp);
#endif
/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/core.h,v 1.1 1992/07/28 20:14:19 wlott Exp $ */
#ifndef _CORE_H_
#define _CORE_H_
#include "lisp.h"
#include "lispregs.h"
#define CORE_PAGESIZE OS_VM_DEFAULT_PAGESIZE
#define CORE_MAGIC (('C' << 24) | ('O' << 16) | ('R' << 8) | 'E')
#define CORE_END 3840
#define CORE_NDIRECTORY 3861
#define CORE_VALIDATE 3845
#define CORE_VERSION 3860
#define CORE_MACHINE_STATE 3862
#define DYNAMIC_SPACE_ID (1)
#define STATIC_SPACE_ID (2)
#define READ_ONLY_SPACE_ID (3)
struct ndir_entry {
long identifier;
long nwords;
long data_page;
long address;
long page_count;
};
struct machine_state {
lispobj *csp;
lispobj *cfp;
long control_stack_page;
#ifdef reg_BSP
lispobj *bsp;
#endif
long binding_stack_page;
char *nsp;
long number_stack_page;
};
extern boolean load_core_file(char *file);
#endif
/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/coreparse.c,v 1.1 1992/07/28 20:14:21 wlott Exp $ */
#include <stdio.h>
#include <sys/types.h>
#include <sys/file.h>
#include "os.h"
#include "lisp.h"
#include "globals.h"
#include "core.h"
#include "save.h"
extern int version;
static void process_directory(int fd, long *ptr, int count)
{
long id, offset, len;
lispobj *free_pointer;
os_vm_address_t addr;
struct ndir_entry *entry;
entry = (struct ndir_entry *) ptr;
while (count-- > 0) {
id = entry->identifier;
offset = CORE_PAGESIZE * (1 + entry->data_page);
addr = (os_vm_address_t) (CORE_PAGESIZE * entry->address);
free_pointer = (lispobj *) addr + entry->nwords;
len = CORE_PAGESIZE * entry->page_count;
if (len != 0) {
os_vm_address_t real_addr;
#ifdef PRINTNOISE
printf("Mapping %d bytes at 0x%x.\n", len, addr);
#endif
real_addr=os_map(fd, offset, addr, len);
if(real_addr!=addr)
fprintf(stderr,
"process_directory: file mapped in wrong place! (0x%08x != 0x%08x)\n",
real_addr,
addr);
}
#if 0
printf("Space ID = %d, free pointer = 0x%08x.\n", id, free_pointer);
#endif
switch (id) {
case DYNAMIC_SPACE_ID:
if (addr != (os_vm_address_t)dynamic_0_space && addr != (os_vm_address_t)dynamic_1_space)
printf("Strange ... dynamic space lossage.\n");
current_dynamic_space = (lispobj *)addr;
#ifdef ibmrt
SetSymbolValue(ALLOCATION_POINTER, (lispobj)free_pointer);
#else
current_dynamic_space_free_pointer = free_pointer;
#endif
break;
case STATIC_SPACE_ID:
static_space = (lispobj *) addr;
break;
case READ_ONLY_SPACE_ID:
/* Don't care about read only space */
break;
default:
printf("Strange space ID: %d; ignored.\n", id);
break;
}
entry++;
}
}
boolean load_core_file(char *file)
{
int fd = open(file, O_RDONLY), count;
long header[CORE_PAGESIZE / sizeof(long)], val, len, *ptr;
boolean restore_state = FALSE;
if (fd < 0) {
fprintf(stderr, "Could not open file \"%s\".\n", file);
perror("open");
exit(1);
}
count = read(fd, header, CORE_PAGESIZE);
if (count < 0) {
perror("read");
exit(1);
}
if (count < CORE_PAGESIZE) {
fprintf(stderr, "Premature EOF.\n");
exit(1);
}
ptr = header;
val = *ptr++;
if (val != CORE_MAGIC) {
fprintf(stderr, "Invalid magic number: 0x%x should have been 0x%x.\n",
val, CORE_MAGIC);
exit(1);
}
while (val != CORE_END) {
val = *ptr++;
len = *ptr++;
switch (val) {
case CORE_END:
break;
case CORE_VERSION:
if (*ptr != version) {
fprintf(stderr, "WARNING: ldb version (%d) different from core version (%d).\nYou may lose big.\n", version, *ptr);
}
break;
case CORE_VALIDATE:
fprintf(stderr, "Validation no longer supported; ignored.\n");
break;
case CORE_NDIRECTORY:
process_directory(fd, ptr,
(len-2) / (sizeof(struct ndir_entry) / sizeof(long)));
break;
case CORE_MACHINE_STATE:
restore_state = TRUE;
load(fd, (struct machine_state *)ptr);
break;
default:
printf("Unknown core file entry: %d; skipping.\n", val);
break;
}
ptr += len - 2;
}
return restore_state;
}
/*
* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/dynbind.c,v 1.1 1992/07/28 20:14:22 wlott Exp $
*
* Support for dynamic binding from C.
*/
#include "lisp.h"
#include "internals.h"
#include "globals.h"
#include "dynbind.h"
#ifdef ibmrt
#define GetBSP() ((struct binding *)SymbolValue(BINDING_STACK_POINTER))
#define SetBSP(value) SetSymbolValue(BINDING_STACK_POINTER, (lispobj)(value))
#else
#define GetBSP() ((struct binding *)current_binding_stack_pointer)
#define SetBSP(value) (current_binding_stack_pointer=(lispobj *)(value))
#endif
void bind_variable(lispobj symbol, lispobj value)
{
lispobj old_value;
struct binding *binding;
old_value = SymbolValue(symbol);
binding = GetBSP();
SetBSP(binding+1);
binding->value = old_value;
binding->symbol = symbol;
SetSymbolValue(symbol, value);
}
void unbind(void)
{
struct binding *binding;
lispobj symbol;
binding = GetBSP() - 1;
symbol = binding->symbol;
SetSymbolValue(symbol, binding->value);
binding->symbol = 0;
SetBSP(binding);
}
void unbind_to_here(lispobj *bsp)
{
struct binding *target = (struct binding *)bsp;
struct binding *binding = GetBSP();
lispobj symbol;
while (target < binding) {
binding--;
symbol = binding->symbol;
if (symbol) {
SetSymbolValue(symbol, binding->value);
binding->symbol = 0;
}
}
SetBSP(binding);
}
/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/dynbind.h,v 1.1 1992/07/28 20:14:24 wlott Exp $ */
#ifndef _DYNBIND_H_
#define _DYNBIND_H_
extern void bind_variable(lispobj symbol, lispobj value);
extern void unbind(void);
extern void unbind_to_here(lispobj *bsp);
#endif
lisp/gc.c 0 → 100644
This diff is collapsed.
/*
* Header file for GC
*
* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gc.h,v 1.1 1992/07/28 20:14:28 wlott Exp $
*/
#ifndef _GC_H_
#define _GC_H_
extern void gc_init(void);
extern void collect_garbage(void);
#ifndef ibmrt
#include "os.h"
extern void set_auto_gc_trigger(os_vm_size_t usage);
extern void clear_auto_gc_trigger(void);
#endif ibmrt
#endif _GC_H_
/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/globals.c,v 1.1 1992/07/28 20:14:29 wlott Exp $ */
/* Variables everybody needs to look at or frob on. */
#include <stdio.h>
#include "lisp.h"
#include "internals.h"
#include "globals.h"
int foreign_function_call_active;
lispobj *current_control_stack_pointer;
lispobj *current_control_frame_pointer;
#ifndef BINDING_STACK_POINTER
lispobj *current_binding_stack_pointer;
#endif
lispobj *read_only_space;
lispobj *static_space;
lispobj *dynamic_0_space;
lispobj *dynamic_1_space;
lispobj *control_stack;
lispobj *binding_stack;
lispobj *current_dynamic_space;
#ifndef ALLOCATION_POINTER
lispobj *current_dynamic_space_free_pointer;
#endif
#ifndef INTERNAL_GC_TRIGGER
lispobj *current_auto_gc_trigger;
#endif
void globals_init(void)
{
/* Space, stack, and free pointer vars are initialized by
validate() and coreparse(). */
#ifndef INTERNAL_GC_TRIGGER
/* No GC trigger yet */
current_auto_gc_trigger = NULL;
#endif
/* Set foreign function call active. */
foreign_function_call_active = 1;
/* Initialize the current lisp state. */
current_control_stack_pointer = control_stack;
current_control_frame_pointer = (lispobj *)0;
#ifndef BINDING_STACK_POINTER
current_binding_stack_pointer = binding_stack;
#endif
}
/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/globals.h,v 1.1 1992/07/28 20:14:31 wlott Exp $ */
#if !defined(_INCLUDE_GLOBALS_H_)
#define _INCLUDED_GLOBALS_H_
#ifndef LANGUAGE_ASSEMBLY
#include "lisp.h"
extern int foreign_function_call_active;
extern lispobj *current_control_stack_pointer;
extern lispobj *current_control_frame_pointer;
#ifndef ibmrt
extern lispobj *current_binding_stack_pointer;
#endif
extern lispobj *read_only_space;
extern lispobj *static_space;
extern lispobj *dynamic_0_space;
extern lispobj *dynamic_1_space;
extern lispobj *control_stack;
extern lispobj *binding_stack;
extern lispobj *current_dynamic_space;
#ifndef ibmrt
extern lispobj *current_dynamic_space_free_pointer;
extern lispobj *current_auto_gc_trigger;
#endif
extern void globals_init(void);
#else LANGUAGE_ASSEMBLY
/* These are needed by ./assem.s */
#ifdef mips
#define EXTERN(name,bytes) .extern name bytes
#endif
#ifdef sparc
#define EXTERN(name,bytes) .global _/**/name
#endif
#ifdef ibmrt
#define EXTERN(name,bytes) .globl _/**/name
#endif
EXTERN(foreign_function_call_active, 4)
EXTERN(current_control_stack_pointer, 4)
EXTERN(current_control_frame_pointer, 4)
#ifndef ibmrt
EXTERN(current_binding_stack_pointer, 4)
EXTERN(current_dynamic_space_free_pointer, 4)
#endif
#ifdef mips
EXTERN(current_flags_register, 4)
#endif
#endif LANGUAGE_ASSEMBLY
#endif _INCLUDED_GLOBALS_H_
/*
* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/interr.c,v 1.1 1992/07/28 20:14:32 wlott Exp $
*
* Stuff to handle internal errors.
*
*/
#include <stdio.h>
#include <stdarg.h>
#include "signal.h"
#include "lisp.h"
#include "internals.h"
#include "interr.h"
#include "print.h"
#include "lispregs.h"
#include "arch.h"
/* Lossage handler. */
static void default_lossage_handler(void)
{
exit(1);
}
static void (*lossage_handler)(void) = default_lossage_handler;
void set_lossage_handler(void handler(void))
{
lossage_handler = handler;
}
void lose(char *fmt, ...)
{
va_list ap;
if (fmt != NULL) {
va_start(ap, fmt);
vfprintf(stderr, fmt, ap);
fflush(stderr);
va_end(ap);
}
lossage_handler();
}
/* Internal error handler for when the Lisp error system doesn't exist. */
static char *errors[] = ERRORS;
void internal_error(struct sigcontext *context)
{
unsigned char *ptr = arch_internal_error_arguments(context);
int len, scoffset, sc, offset, ch;
len = *ptr++;
printf("Error: %s\n", errors[*ptr++]);
len--;
while (len > 0) {
scoffset = *ptr++;
len--;
if (scoffset == 253) {
scoffset = *ptr++;
len--;
}
else if (scoffset == 254) {
scoffset = ptr[0] + ptr[1]*256;
ptr += 2;
len -= 2;
}
else if (scoffset == 255) {
scoffset = ptr[0] + (ptr[1]<<8) + (ptr[2]<<16) + (ptr[3]<<24);
ptr += 4;
len -= 4;
}
sc = scoffset & 0x1f;
offset = scoffset >> 5;
printf(" SC: %d, Offset: %d", sc, offset);
switch (sc) {
case sc_AnyReg:
case sc_DescriptorReg:
putchar('\t');
brief_print(SC_REG(context, offset));
break;
case sc_BaseCharReg:
ch = SC_REG(context, offset);
#ifdef i386
if (offset&1)
ch = ch>>8;
ch = ch & 0xff;
#endif
switch (ch) {
case '\n': printf("\t'\\n'\n"); break;
case '\b': printf("\t'\\b'\n"); break;
case '\t': printf("\t'\\t'\n"); break;
case '\r': printf("\t'\\r'\n"); break;
default:
if (ch < 32 || ch > 127)
printf("\\%03o", ch);
else
printf("\t'%c'\n", ch);
break;
}
break;
case sc_SapReg:
#ifdef sc_WordPointerReg
case sc_WordPointerReg:
#endif
printf("\t0x%08x\n", SC_REG(context, offset));
break;
case sc_SignedReg:
printf("\t%ld\n", SC_REG(context, offset));
break;
case sc_UnsignedReg:
printf("\t%lu\n", SC_REG(context, offset));
break;
#ifdef sc_SingleFloatReg
case sc_SingleFloatReg:
printf("\t%g\n", *(float *)&context->sc_fpregs[offset]);
break;
#endif
#ifdef sc_DoubleFloatReg
case sc_DoubleFloatReg:
printf("\t%g\n", *(double *)&context->sc_fpregs[offset]);
break;
#endif
default:
printf("\t???\n");
break;
}
}
lose(NULL);
}
/* Utility routines used by random pieces of code. */
lispobj debug_print(lispobj string)
{
printf("%s\n", (char *)(((struct vector *)PTR(string))->data));
return NIL;
}
/*
* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/interr.h,v 1.1 1992/07/28 20:14:34 wlott Exp $
*/
#ifndef _INTERR_H_
#define _INTERR_H_
#define crap_out(msg) do { write(2, msg, sizeof(msg)); lose(); } while (0)
extern void lose(char *fmt, ...);
extern void set_lossage_handler(void fun(void));
extern void internal_error(struct sigcontext *context);
extern lispobj debug_print(lispobj string);
#endif
/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/interrupt.c,v 1.1 1992/07/28 20:14:35 wlott Exp $ */
/* Interrupt handing magic. */
#include <stdio.h>
#include <signal.h>
#ifdef mips
#include <mips/cpu.h>
#endif
#include "lisp.h"
#include "internals.h"
#include "os.h"
#include "arch.h"
#include "globals.h"
#include "lispregs.h"
#include "interrupt.h"
#include "validate.h"
#include "monitor.h"
#include "gc.h"
#include "alloc.h"
#include "dynbind.h"
#include "interr.h"
boolean internal_errors_enabled = 0;
struct sigcontext *lisp_interrupt_contexts[MAX_INTERRUPTS];
union interrupt_handler interrupt_handlers[NSIG];
void (*interrupt_low_level_handlers[NSIG])(int signal, int code,
struct sigcontext *scp) = {0};
static int pending_signal = 0, pending_code = 0, pending_mask = 0;
static boolean maybe_gc_pending = FALSE;
/****************************************************************\
* Utility routines used by various signal handlers. *
\****************************************************************/
void fake_foreign_function_call(struct sigcontext *context)
{
int context_index;
lispobj oldcont;
/* Get current LISP state from context */
#ifdef reg_ALLOC
current_dynamic_space_free_pointer = (lispobj *)SC_REG(context, reg_ALLOC);
#endif
#ifdef reg_BSP
current_binding_stack_pointer = (lispobj *)SC_REG(context, reg_BSP);
#endif
#ifndef i386
/* Build a fake stack frame */
current_control_frame_pointer = (lispobj *)SC_REG(context, reg_CSP);
if ((lispobj *)SC_REG(context, reg_CFP)==current_control_frame_pointer) {
/* There is a small window during call where the callee's frame */
/* isn't built yet. */
if (LowtagOf(SC_REG(context, reg_CODE)) == type_FunctionPointer) {
/* We have called, but not built the new frame, so
build it for them. */
current_control_frame_pointer[0] = SC_REG(context, reg_OCFP);
current_control_frame_pointer[1] = SC_REG(context, reg_LRA);
current_control_frame_pointer += 8;
/* Build our frame on top of it. */
oldcont = (lispobj)SC_REG(context, reg_CFP);
}
else {
/* We haven't yet called, build our frame as if the
partial frame wasn't there. */
oldcont = (lispobj)SC_REG(context, reg_OCFP);
}
}
/* ### We can't tell if we are still in the caller if it had to
reg_ALLOCate the stack frame due to stack arguments. */
/* ### Can anything strange happen during return? */
else
/* Normal case. */
oldcont = (lispobj)SC_REG(context, reg_CFP);
current_control_stack_pointer = current_control_frame_pointer + 8;
current_control_frame_pointer[0] = oldcont;
current_control_frame_pointer[1] = NIL;
current_control_frame_pointer[2] = (lispobj)SC_REG(context, reg_CODE);
#endif
/* Do dynamic binding of the active interrupt context index
and save the context in the context array. */
context_index = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2;
if (context_index >= MAX_INTERRUPTS) {
fprintf(stderr,
"Maximum number (%d) of interrupts exceeded. Exiting.\n",
MAX_INTERRUPTS);
exit(1);
}
bind_variable(FREE_INTERRUPT_CONTEXT_INDEX,
make_fixnum(context_index + 1));
lisp_interrupt_contexts[context_index] = context;
/* No longer in Lisp now. */
foreign_function_call_active = 1;
}
void undo_fake_foreign_function_call(struct sigcontext *context)
{
/* Block all blockable signals */
sigblock(BLOCKABLE);
/* Going back into lisp. */
foreign_function_call_active = 0;
/* Undo dynamic binding. */
/* ### Do I really need to unbind_to_here()? */
unbind();
#ifdef reg_ALLOC
/* Put the dynamic space free pointer back into the context. */
SC_REG(context, reg_ALLOC) =
(unsigned long) current_dynamic_space_free_pointer;
#endif
}
void interrupt_internal_error(int signal, int code, struct sigcontext *context,
boolean continuable)
{
sigsetmask(context->sc_mask);
fake_foreign_function_call(context);
if (internal_errors_enabled)
funcall2(SymbolFunction(INTERNAL_ERROR), alloc_sap(context),
continuable ? T : NIL);
else
internal_error(context);
undo_fake_foreign_function_call(context);
if (continuable)
arch_skip_instruction(context);
}
void interrupt_handle_pending(struct sigcontext *context)
{
boolean were_in_lisp = !foreign_function_call_active;
SetSymbolValue(INTERRUPT_PENDING, NIL);
if (maybe_gc_pending) {
maybe_gc_pending = FALSE;
if (were_in_lisp)
fake_foreign_function_call(context);
funcall0(SymbolFunction(MAYBE_GC));
if (were_in_lisp)
undo_fake_foreign_function_call(context);
}
if (pending_signal) {
int signal, code;
signal = pending_signal;
code = pending_code;
pending_signal = 0;
pending_code = 0;
interrupt_handle_now(signal, code, context);
}
context->sc_mask = pending_mask;
pending_mask = 0;
}
/****************************************************************\
* interrupt_handle_now, maybe_now_maybe_later *
* the two main signal handlers. *
\****************************************************************/
void interrupt_handle_now(int signal, int code, struct sigcontext *context)
{
int were_in_lisp;
union interrupt_handler handler;
handler = interrupt_handlers[signal];
if(handler.c==SIG_IGN)
return;
were_in_lisp = !foreign_function_call_active;
if (were_in_lisp)
fake_foreign_function_call(context);
/* Allow signals again. */
sigsetmask(context->sc_mask);
if (handler.c==SIG_DFL)
/* This can happen if someone tries to ignore or default on of the */
/* signals we need for runtime support, and the runtime support */
/* decides to pass on it. */
lose("interrupt_handle_now: No handler for signal %d?\n", signal);
else if (LowtagOf(handler.lisp) == type_FunctionPointer)
funcall3(handler.lisp, make_fixnum(signal), make_fixnum(code),
alloc_sap(context));
else
(*handler.c)(signal, code, context);
if (were_in_lisp)
undo_fake_foreign_function_call(context);
}
static void maybe_now_maybe_later(int signal, int code,
struct sigcontext *context)
{
if (SymbolValue(INTERRUPTS_ENABLED) == NIL) {
pending_signal = signal;
pending_code = code;
pending_mask = context->sc_mask;
context->sc_mask |= BLOCKABLE;
SetSymbolValue(INTERRUPT_PENDING, T);
} else if ((!foreign_function_call_active)
&& arch_pseudo_atomic_atomic(context)) {
pending_signal = signal;
pending_code = code;
pending_mask = context->sc_mask;
context->sc_mask |= BLOCKABLE;
arch_set_pseudo_atomic_interrupted(context);
} else
interrupt_handle_now(signal, code, context);
}
/****************************************************************\
* Stuff to detect and handle hitting the gc trigger. *
\****************************************************************/
#ifndef INTERNAL_GC_TRIGGER
static boolean gc_trigger_hit(struct sigcontext *context)
{
if (current_auto_gc_trigger == NULL)
return FALSE;
else{
lispobj *badaddr=(lispobj *)arch_get_bad_addr(context);
return (badaddr >= current_auto_gc_trigger &&
badaddr < current_dynamic_space + DYNAMIC_SPACE_SIZE);
}
}
#endif
boolean interrupt_maybe_gc(struct sigcontext *context)
{
if (!foreign_function_call_active
#ifndef INTERNAL_GC_TRIGGER
&& gc_trigger_hit(context)
#endif
) {
#ifndef INTERNAL_GC_TRIGGER
clear_auto_gc_trigger();
#endif
if (arch_pseudo_atomic_atomic(context)) {
maybe_gc_pending = TRUE;
if (pending_signal == 0) {
pending_mask = context->sc_mask;
context->sc_mask |= BLOCKABLE;
}
arch_set_pseudo_atomic_interrupted(context);
}
else {
fake_foreign_function_call(context);
funcall0(SymbolFunction(MAYBE_GC));
undo_fake_foreign_function_call(context);
}
return TRUE;
}else
return FALSE;
}
/****************************************************************\
* Noise to install handlers. *
\****************************************************************/
void interrupt_install_low_level_handler
(int signal,
void handler(int signal, int code, struct sigcontext *handler))
{
struct sigvec sv;
sv.sv_handler=handler;
sv.sv_mask=BLOCKABLE;
sv.sv_flags=0;
sigvec(signal,&sv,NULL);
interrupt_low_level_handlers[signal]=(handler==SIG_DFL ? 0 : handler);
}
unsigned long install_handler(int signal,
void handler(int signal, int code,
struct sigcontext *handler))
{
struct sigvec sv;
int oldmask;
union interrupt_handler oldhandler;
oldmask = sigblock(sigmask(signal));
if(interrupt_low_level_handlers[signal]==0){
if(handler==SIG_DFL || handler==SIG_IGN)
sv.sv_handler = handler;
else if (sigmask(signal)&BLOCKABLE)
sv.sv_handler = maybe_now_maybe_later;
else
sv.sv_handler = interrupt_handle_now;
sv.sv_mask = BLOCKABLE;
sv.sv_flags = 0;
sigvec(signal, &sv, NULL);
}
oldhandler = interrupt_handlers[signal];
interrupt_handlers[signal].c = handler;
sigsetmask(oldmask);
return (unsigned long)oldhandler.lisp;
}
void interrupt_init(void)
{
int i;
for (i = 0; i < NSIG; i++)
interrupt_handlers[i].c = SIG_DFL;
}
/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/interrupt.h,v 1.1 1992/07/28 20:14:37 wlott Exp $ */
#if !defined(_INCLUDE_INTERRUPT_H_)
#define _INCLUDE_INTERRUPT_H_
#include <signal.h>
#define MAX_INTERRUPTS (4096)
extern struct sigcontext *lisp_interrupt_contexts[MAX_INTERRUPTS];
union interrupt_handler {
lispobj lisp;
void (*c)(int signal, int code, struct sigcontext *scp);
};
extern void interrupt_init(void);
extern void fake_foreign_function_call(struct sigcontext *context);
extern void undo_fake_foreign_function_call(struct sigcontext *context);
extern void interrupt_handle_now(int signal, int code, struct sigcontext *scp);
extern void interrupt_handle_pending(struct sigcontext *scp);
extern void interrupt_internal_error(int signal, int code,
struct sigcontext *scp,
boolean continuable);
extern boolean interrupt_maybe_gc(struct sigcontext *context);
extern void interrupt_install_low_level_handler
(int signal,
void handler(int signal, int code, struct sigcontext *handler));
extern unsigned long install_handler(int signal,
void handler(int signal, int code,
struct sigcontext *handler));
extern union interrupt_handler interrupt_handlers[NSIG];
#define BLOCKABLE (sigmask(SIGHUP) | sigmask(SIGINT) | \
sigmask(SIGQUIT) | sigmask(SIGPIPE) | \
sigmask(SIGALRM) | sigmask(SIGURG) | \
sigmask(SIGTSTP) | sigmask(SIGCHLD) | \
sigmask(SIGIO) | sigmask(SIGXCPU) | \
sigmask(SIGXFSZ) | sigmask(SIGVTALRM) | \
sigmask(SIGPROF) | sigmask(SIGWINCH) | \
sigmask(SIGUSR1) | sigmask(SIGUSR2))
#endif
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment