Commit 62957726 authored by wlott's avatar wlott
Browse files

Initial revision

parent 0bbd4f0e
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;