mirror of
https://github.com/Interlisp/maiko.git
synced 2026-01-14 07:30:21 +00:00
286 lines
11 KiB
C
286 lines
11 KiB
C
/* $Id: gccode.c,v 1.3 1999/05/31 23:35:30 sybalsky Exp $ (C) Copyright Venue, All Rights Reserved
|
|
*/
|
|
static char *id = "$Id: gccode.c,v 1.3 1999/05/31 23:35:30 sybalsky Exp $ Copyright (C) Venue";
|
|
|
|
/************************************************************************/
|
|
/* */
|
|
/* (C) Copyright 1989-95 Venue. All Rights Reserved. */
|
|
/* Manufactured in the United States of America. */
|
|
/* */
|
|
/* The contents of this file are proprietary information */
|
|
/* belonging to Venue, and are provided to you under license. */
|
|
/* They may not be further distributed or disclosed to third */
|
|
/* parties without the specific permission of Venue. */
|
|
/* */
|
|
/************************************************************************/
|
|
|
|
#include "version.h"
|
|
|
|
/************************************************************************/
|
|
/* File Name : gccode.c */
|
|
/* */
|
|
/************************************************************************/
|
|
/* */
|
|
/* Creation Date : Sep-25-1987 */
|
|
/* Written by Tomoru Teruuchi */
|
|
/* Edit by Larry Masinter */
|
|
/************************************************************************/
|
|
/* */
|
|
/* Functions : */
|
|
/* reclaimcodeblock(); */
|
|
/* */
|
|
/* */
|
|
/* */
|
|
/************************************************************************/
|
|
/* \Tomtom */
|
|
/************************************************************************/
|
|
|
|
#include "lispemul.h"
|
|
#include "lsptypes.h"
|
|
#include "address.h"
|
|
#include "adr68k.h"
|
|
#include "lspglob.h"
|
|
#include "lispmap.h"
|
|
#include "stack.h"
|
|
#include "cell.h"
|
|
#include "ifpage.h"
|
|
#include "gc.h"
|
|
#include "array.h"
|
|
#include <stdio.h>
|
|
|
|
#define min(a, b) ((a > b) ? b : a)
|
|
|
|
#define ENDOFX 0
|
|
#define GCONST 111
|
|
|
|
#define Reprobefn(bits, index) (((bits ^ ((bits) >> 8)) & min(63, index)) | 1)
|
|
#define Fn16bits(a, b) ((a + b) & 0x0ffff)
|
|
#define Hashingbits(item) (HILOC(item) ^ (((LOLOC(item) & 0x1fff) << 3) ^ (LOLOC(item) >> 9)))
|
|
#define Getikvalue(base, index) (*(LispPTR *)Addr68k_from_LADDR(base + (index << 1)))
|
|
|
|
#ifndef BYTESWAP
|
|
typedef struct implicit_key_hash_table {
|
|
LispPTR base;
|
|
unsigned last_index : 16;
|
|
unsigned num_slots : 16;
|
|
unsigned num_keys : 16;
|
|
unsigned null_slots : 16;
|
|
LispPTR key_accessor;
|
|
} Ikhashtbl;
|
|
#else
|
|
typedef struct implicit_key_hash_table {
|
|
LispPTR base;
|
|
unsigned num_slots : 16;
|
|
unsigned last_index : 16;
|
|
unsigned null_slots : 16;
|
|
unsigned num_keys : 16;
|
|
LispPTR key_accessor;
|
|
} Ikhashtbl;
|
|
#endif
|
|
|
|
#ifdef BIGVM
|
|
/* Table of opcode lengths for 4-byte atom opcode cases */
|
|
#define LONGEST_OPCODE 5
|
|
unsigned int oplength[256] = {
|
|
0, 0, 0, 0, 0, 1, 4, 2, 4, 4, 4, 4, 4, 5, 0, 0, 0, 2, 0, 0, 1, 1, 0, 4, 0, 0, 0, 0, 0, 0, 1, 0,
|
|
0, 0, 0, 1, 2, 9, 0, 0, 9, 9, 9, 9, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1, 0, 0,
|
|
0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1,
|
|
4, 0, 1, 1, 0, 0, 0, 4, 0, 0, 0, 0, 1, 1, 2, 4, 9, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 2, 0, 4,
|
|
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
|
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 2, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
|
1, 1, 0, 4, 0, 1, 1, 0, 1, 1, 2, 9, 0, 1, 1, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0,
|
|
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 1, 0, 0, 0, 0};
|
|
#elif defined(BIGATOMS)
|
|
/* Table of opcode lengths for 3-byte atom opcode cases */
|
|
#define LONGEST_OPCODE 4
|
|
unsigned int oplength[256] = {
|
|
0, 0, 0, 0, 0, 1, 3, 2, 3, 3, 3, 3, 3, 4, 0, 0, 0, 2, 0, 0, 1, 1, 0, 3, 0, 0, 0, 0, 0, 0, 1, 0,
|
|
0, 0, 0, 1, 2, 9, 0, 0, 9, 9, 9, 9, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1, 0, 0,
|
|
0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1,
|
|
3, 0, 1, 1, 0, 0, 0, 3, 0, 0, 0, 0, 1, 1, 2, 3, 9, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 2, 0, 3,
|
|
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
|
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 2, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
|
1, 1, 0, 3, 0, 1, 1, 0, 1, 1, 2, 9, 0, 1, 1, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0,
|
|
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 1, 0, 0, 0, 0};
|
|
#else
|
|
/* Table of opcode lengths for old, 2-byte atom opcodes. */
|
|
#define LONGEST_OPCODE 3
|
|
unsigned int oplength[256] = {
|
|
0, 0, 0, 0, 0, 1, 2, 2, 2, 2, 2, 2, 2, 3, 0, 0, 0, 2, 0, 0, 1, 1, 0, 2, 0, 0, 0, 0, 0, 0, 1, 0,
|
|
0, 0, 0, 1, 2, 9, 0, 0, 9, 9, 9, 9, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1, 0, 0,
|
|
0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1,
|
|
2, 0, 1, 1, 0, 0, 0, 2, 0, 0, 0, 0, 1, 1, 2, 3, 9, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 2, 0, 3,
|
|
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
|
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 2, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
|
1, 1, 0, 2, 0, 1, 1, 0, 1, 1, 2, 9, 0, 1, 1, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0,
|
|
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 1, 0, 0, 0, 0};
|
|
#endif /* BIGATOMS */
|
|
|
|
typedef ByteCode *InstPtr;
|
|
|
|
/************************************************************************/
|
|
/* */
|
|
/* m a p _ c o d e _ p o i n t e r s */
|
|
/* */
|
|
/* Find all pointers in a block of compiled code (they're the */
|
|
/* the args to the GCONST opcode), and change the reference */
|
|
/* count according to "casep". Complains if it hits an unknown */
|
|
/* opcode. */
|
|
/* */
|
|
/************************************************************************/
|
|
|
|
LispPTR map_code_pointers(LispPTR codeblock, short int casep) {
|
|
InstPtr codeptr;
|
|
register unsigned int opnum;
|
|
register unsigned int len;
|
|
struct fnhead *fnbase;
|
|
fnbase = (struct fnhead *)Addr68k_from_LADDR(codeblock);
|
|
codeptr = ((InstPtr)fnbase) + fnbase->startpc;
|
|
|
|
#ifdef RESWAPPEDCODESTREAM
|
|
if (!fnbase->byteswapped) byte_swap_code_block(fnbase);
|
|
#endif
|
|
|
|
while (T) {
|
|
switch (opnum = Get_code_BYTE(codeptr)) {
|
|
case ENDOFX: /* -X- */ return (NIL);
|
|
case GCONST: /* GCONST */
|
|
#ifdef BIGVM
|
|
{
|
|
LispPTR reclaimed = (Get_code_BYTE(codeptr + 1) << 24) |
|
|
(Get_code_BYTE(codeptr + 2) << 16) | (Get_code_BYTE(codeptr + 3) << 8) |
|
|
Get_code_BYTE(codeptr + 4);
|
|
#else
|
|
{
|
|
LispPTR reclaimed = (Get_code_BYTE(codeptr + 1) << 16) | (Get_code_BYTE(codeptr + 2) << 8) |
|
|
Get_code_BYTE(codeptr + 3);
|
|
#endif /* BIGVM */
|
|
if (reclaimed != codeblock)
|
|
/* {htfind(reclaimed, casep);} */
|
|
{
|
|
REC_GCLOOKUP(reclaimed, casep);
|
|
}
|
|
};
|
|
};
|
|
if ((len = oplength[opnum]) >
|
|
LONGEST_OPCODE) { /* len > biggest possible marks an unknown opcode */
|
|
char errtext[200];
|
|
sprintf(errtext,
|
|
"Unrecognized bytecode (0%o) at offset 0%o in code block x%x,x%x; continue to use "
|
|
"UFN length",
|
|
opnum, codeptr - (InstPtr)fnbase, (codeblock >> 16) & 0xFF, codeblock & 0xFFFF);
|
|
error(errtext);
|
|
oplength[opnum] = len = (((UFN *)UFNTable) + (opnum))->byte_num;
|
|
}
|
|
codeptr += len + 1;
|
|
};
|
|
}
|
|
|
|
/************************************************************************/
|
|
/* */
|
|
/* r e m i m p l i c i t k e y h a s h */
|
|
/* */
|
|
/* Remove a fn defn from the implicit-key hash table of defns */
|
|
/* */
|
|
/************************************************************************/
|
|
|
|
/* JRB - These values are xpointers; their high bytes are not set and
|
|
shouldn't be looked at */
|
|
#define getikkey(value) ((*(LispPTR *)Addr68k_from_LADDR(value)) & POINTERMASK)
|
|
|
|
LispPTR remimplicitkeyhash(LispPTR item, LispPTR ik_hash_table) {
|
|
Ikhashtbl *ik_htable;
|
|
LispPTR reprobe, bits, limits, index, base, value, key_accessor;
|
|
ik_htable = (Ikhashtbl *)Addr68k_from_LADDR(ik_hash_table);
|
|
bits = Hashingbits(item);
|
|
limits = ik_htable->last_index;
|
|
index = (bits & limits);
|
|
base = ik_htable->base;
|
|
value = Getikvalue(base, index);
|
|
if (value != *Deleted_Implicit_Hash_Slot_word) {
|
|
if (value != NIL) {
|
|
if (item == getikkey(value)) { goto found; };
|
|
} else
|
|
return (NIL);
|
|
};
|
|
reprobe = Reprobefn(bits, limits);
|
|
lp:
|
|
index = Fn16bits(index, reprobe) & limits;
|
|
value = Getikvalue(base, index);
|
|
if (value != *Deleted_Implicit_Hash_Slot_word) {
|
|
if (value != NIL) {
|
|
if (item == getikkey(value)) { goto found; };
|
|
} else
|
|
return (NIL);
|
|
};
|
|
goto lp;
|
|
found:
|
|
/*
|
|
htfind(*Deleted_Implicit_Hash_Slot_word, ADDREF);
|
|
htfind(Getikvalue(base, index), DELREF);
|
|
*/
|
|
REC_GCLOOKUP(*Deleted_Implicit_Hash_Slot_word, ADDREF);
|
|
REC_GCLOOKUP(Getikvalue(base, index), DELREF);
|
|
Getikvalue(base, index) = *Deleted_Implicit_Hash_Slot_word;
|
|
(ik_htable->num_keys)--;
|
|
return (T);
|
|
}
|
|
|
|
/************************************************************************/
|
|
/* */
|
|
/* r e c l a i m c o d e b l o c k */
|
|
/* */
|
|
/* Reclaim an array block that contains compiled code. When */
|
|
/* this happens, we need to decrement the reference counts for */
|
|
/* */
|
|
/* * The frame name, which may be a string, list, etc. */
|
|
/* * Any GCONSTs in the code (constants, internal fns, */
|
|
/* etc.), since they're no longer needed. */
|
|
/* */
|
|
/************************************************************************/
|
|
|
|
LispPTR reclaimcodeblock(LispPTR codebase) {
|
|
struct fnhead *fnbase;
|
|
if ((*Closure_Cache_Enabled_word != NIL) &&
|
|
(remimplicitkeyhash(codebase, *Closure_Cache_word) != NIL)) {
|
|
return (T);
|
|
};
|
|
fnbase = (struct fnhead *)Addr68k_from_LADDR(codebase);
|
|
REC_GCLOOKUP((POINTERMASK & fnbase->framename), DELREF);
|
|
if (fnbase->startpc != 0) map_code_pointers(codebase, DELREF);
|
|
return (NIL);
|
|
}
|
|
|
|
/************************************************************************/
|
|
/* */
|
|
/* c o d e _ b l o c k _ s i z e */
|
|
/* */
|
|
/* Given a native pointer to a code block, return its size. */
|
|
/* */
|
|
/************************************************************************/
|
|
|
|
int code_block_size(long unsigned int codeblock68k) {
|
|
InstPtr codeptr, initcodeptr;
|
|
register unsigned int opnum;
|
|
register unsigned int len;
|
|
struct fnhead *fnbase;
|
|
fnbase = (struct fnhead *)codeblock68k;
|
|
initcodeptr = codeptr = ((InstPtr)fnbase) + fnbase->startpc;
|
|
while (T) {
|
|
switch (opnum = Get_BYTE(codeptr)) {
|
|
case ENDOFX: /* -X- */ return (codeptr - initcodeptr);
|
|
};
|
|
if ((len = oplength[opnum]) >
|
|
LONGEST_OPCODE) { /* len > biggest possible marks an unknown opcode */
|
|
char errtext[200];
|
|
sprintf(errtext,
|
|
"Unrecognized bytecode (0%o) at offset 0%o in code block x%x,x%x; continue to use "
|
|
"UFN length",
|
|
opnum, codeptr - (InstPtr)fnbase, (int)((codeblock68k >> 16) & 0xFF), (int)(codeblock68k & 0xFFFF));
|
|
error(errtext);
|
|
oplength[opnum] = len = (((UFN *)UFNTable) + (opnum))->byte_num;
|
|
}
|
|
codeptr += len + 1;
|
|
};
|
|
}
|