github.com/Interlisp.maiko
1
0
Fork 0
mirror of https://github.com/Interlisp/maiko.git synced 2026-01-31 05:42:25 +00:00
Code Issues Projects Releases Wiki Activity

Maiko sources matching state as of 020102 prior to initial patching for Mac OSX

Browse Source
This commit is contained in:
Nick Briggs
2015-04-20 18:53:52 -07:00
commit de170a64d9
427 changed files with 129342 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

390
src/gcrcell.c Executable file
View File

@@ -0,0 +1,390 @@
/* $Id: gcrcell.c,v 1.3 1999/05/31 23:35:32 sybalsky Exp $ (C) Copyright Venue, All Rights Reserved */
static char *id = "$Id: gcrcell.c,v 1.3 1999/05/31 23:35:32 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 : gcrcell.c */
/* */
/*************************************************************************/
/* */
/* Creation Date : July-7-1987 */
/* Written by Tomoru Teruuchi */
/* */
/*************************************************************************/
/* */
/* Functions : */
/* gcreccell(cell); */
/* freelistcell(cell); */
/* */
/* */
/*************************************************************************/
/* Descreption : */
/* */
/* The functions "gcreccell" and "freelistcell" are the translated */
/* functions from the Lisp functions "\GCRECLAIMCELL" that is the UFN */
/* function of the opcode "RECLAIMCELL", and "\FREELISTCELL". */
/* These functions may have the following characteristics : */
/* */
/* gcreccell(cell) LispPTR cell */
/* This function may always return NIL(= 0), as the Lisp */
/* macro .RECLAIMCELLLP. in more upper level may use this */
/* return value as the further Garbage's pointer.(The Opcode*/
/* "RECLAIMCELL"'s function is specified as this, but its */
/* UFN function is not. The gcreccell function's */
/* behavior is same as the UFN function for speed and */
/* simplicity,this is, this function is closed in this level*/
/* ) */
/* This function may reclaim the data of all types that is */
/* Garbage.Especially, the data whose types are ARRAYBLOCK */
/* (= 0), STACKP(= 8),VMEMPAGEP(= 10) and CODEBLOCK(= 54,55,*/
/* 56,57,58,59,60,61,62,63) may be reclaimed by each special*/
/* processes that are specified and invoked by this function*/
/* .The data whose type is LISTP is the main data type */
/* processed in this function actually and only then the */
/* function "freelistcell" may be called for making linkage */
/* of free list. */
/* */
/* freelistcell(cell) LispPTR cell */
/* This function may make the linkage of free list of the */
/* cons cell.The header of this linkage is DTD->NEXTPAGE of */
/* LISTP and each cons page has its internal linkage of free*/
/* cells.This return value is not considered as not used. */
/* */
/*************************************************************************/
/* \Tomtom */
/*************************************************************************/
#include <stdio.h>
#include "lispemul.h"
#include "lsptypes.h"
#include "address.h"
#include "adr68k.h"
#include "lspglob.h"
#include "stack.h"
#include "cell.h"
#include "ifpage.h"
#include "gc.h"
#include "dbprint.h"
#ifdef NEWCDRCODING
#undef CONSPAGE_LAST
#define CONSPAGE_LAST 0x0ffffffff
#else
#undef CONSPAGE_LAST
#define CONSPAGE_LAST 0x0ffff
#endif /* NEWCDRCODING */
#define TODO_LIMIT 1000
#define ADD_TO_DO(ptr,offset) \
if (do_count < TODO_LIMIT) \
{ \
if (ptr & 0xF0000000) error("illegal ptr in addtodo"); \
to_do[do_count] = (ptr); \
to_do_offset[do_count] = offset; \
todo_uses++; \
/*REC_GCLOOKUP((ptr), ADDREF);*/ \
do_count++; \
} else { /* error("GC missing some to-do's"); */ todo_misses++; }
unsigned todo_uses = 0;
unsigned todo_misses = 0;
unsigned todo_reads = 0;
/************************************************************************/
/* */
/* g c r e c c e l l */
/* */
/* Reclaim a cell, doing necessary finalization &c. */
/* */
/************************************************************************/
gcreccell(LispPTR cell)
{
register ConsCell *ptr;
struct dtd *typdtd;
DLword typ;
register LispPTR tmpptr, donext, tmpcell, val;
LispPTR ptrfield, carfield;
int index, code;
LispPTR *field;
int freecnt;
LispPTR freeptr;
#ifdef NEWCDRCODING
LispPTR to_do[TODO_LIMIT]; /* table of pointers to follow, since Cdr coding lost */
short to_do_offset[TODO_LIMIT]; /* offset in datatype */
unsigned do_count = 0; /* counter of entries in to_do table */
#endif /* NEWCDRCODING */
val = NIL;
tmpptr = cell;
index = -1;
donext = NIL;
lp:
ptr = (ConsCell *)Addr68k_from_LADDR(tmpptr&-2);
/* # ifdef CHECK
if (refcnt(tmpptr) != 1) error("reclaiming cell w/refcnt not 1");
# endif
*/
#ifdef DEBUG
if (tmpptr & 1) error("Reclaiming cell pointer with low bit 1.");
#else
tmpptr &= -2; /* turn off low bit of pointer, so we never reclaim odd'ns */
#endif
if ((tmpptr & 0x0FFF0000) == 0x60000) error("freeing an old atom??");
typ = GetTypeNumber(tmpptr);
#ifdef DEBUG
if (typ==6) printf("Reclaiming array ptr 0x%x.\n", tmpptr);
#endif
switch(typ)
{
case TYPE_LISTP:
{
if ((code = ptr->cdr_code) == CDR_INDIRECT) /* indirect */
{ tmpcell = ptr->car_field; /* Monitor */
freelistcell(tmpptr);
ptr = (ConsCell *) Addr68k_from_LADDR(tmpcell);
tmpptr = tmpcell;
code = ptr->cdr_code;
};
if (index != -1) /* car part */
index = -1;
else
{
REC_GCLOOKUPV(car(tmpptr), DELREF, val);
if (val != NIL)
{
ptr->car_field = donext;
ptr->cdr_code = code;
donext = tmpptr;
goto doval;
};
}
REC_GCLOOKUPV(cdr(tmpptr), DELREF, val);
if (code <= CDR_MAXINDIRECT)
{
#ifdef NEWCDRCODING
tmpcell = tmpptr + ((code - CDR_INDIRECT) << 1);
#else
tmpcell = POINTER_PAGEBASE(tmpptr)
+ ((code - CDR_INDIRECT) << 1);
#endif /* NEWCDRCODING */
freelistcell(tmpcell);
};
freelistcell(tmpptr);
goto doval;
};
case TYPE_ARRAYBLOCK:
if ((index == -1) && reclaimarrayblock(tmpptr))
goto trynext;
else break;
case TYPE_STACKP:
if ((index == -1) && reclaimstackp(tmpptr)) goto trynext;
break;
case TYPE_VMEMPAGEP:
if ((index == -1) && releasingvmempage(tmpptr))
{
goto trynext;
}
else break;
case TYPE_CODEHUNK1:
case TYPE_CODEHUNK2:
case TYPE_CODEHUNK3:
case TYPE_CODEHUNK4:
case TYPE_CODEHUNK5:
case TYPE_CODEHUNK6:
case TYPE_CODEHUNK7:
case TYPE_CODEHUNK8:
case TYPE_CODEHUNK9:
case TYPE_CODEHUNK10:
if ((index == -1) && reclaimcodeblock(tmpptr)) goto trynext;
else break;
default: ;
};
normal:
typdtd = (struct dtd *)GetDTD(typ);
ptrfield = typdtd->dtd_ptrs;
if (index != -1)
{
index = (index << 1);
ptrfield = cdr(ptrfield);
while ((car(ptrfield) & 0x0ffff) != index) ptrfield = cdr(ptrfield);
index = -1;
};
while(ptrfield != NIL)
{
carfield = car(ptrfield);
ptrfield = cdr(ptrfield);
carfield &= 0x0ffff;
REC_GCLOOKUPV((POINTERMASK &
*(LispPTR *)Addr68k_from_LADDR(tmpptr+carfield)),
DELREF, val);
#ifndef NEWCDRCODING
if (val != NIL)
{
if (ptrfield != NIL)
{
ptr = (ConsCell *)Addr68k_from_LADDR(tmpptr);
ptr->car_field = donext;
ptr->cdr_code = ((car(ptrfield) & 0x0ffff) >> 1);
donext = tmpptr;
goto doval;
}
else goto addtofreelist;
};
#else
if (val != NIL)
{
if (ptrfield != NIL)
{
if ((carfield = car(ptrfield) & 0x0ffff) >> 1 < 15)
{
ptr = (ConsCell *)Addr68k_from_LADDR(tmpptr);
ptr->car_field = donext;
ptr->cdr_code = ((car(ptrfield) & 0x0ffff) >> 1);
donext = tmpptr;
goto doval;
}
else
{ ADD_TO_DO(tmpptr, (car(ptrfield) & 0xffff)>>1); goto doval; }
}
else goto addtofreelist;
};
#endif /* NEWCDRCODING */
};
addtofreelist:
field = (LispPTR *)Addr68k_from_LADDR(tmpptr);
*field = typdtd->dtd_free;
typdtd->dtd_free = tmpptr & POINTERMASK;
#ifdef DTDDEBUG
check_dtd_chain(GetTypeNumber(tmpptr & POINTERMASK));
#endif
/******************************/
/* */
/* Freeing one cell made another cell's refcnt = 0. */
/* ADDREF the second cell (to remove it from the GC table) */
/* and reclaim it. */
/************************************************************/
doval:
if (val != NIL)
{
tmpptr = val;
REC_GCLOOKUP(tmpptr, ADDREF);
/* GCLOOKUP(0x8000, ADDREF,tmpptr); */
val = NIL;
goto lp;
};
/***************************************************************/
/* */
/* Finished freeing the main cell, but we may have saved other */
/* cells whose refcnt's went to 0 along the way. This is */
/* where we work down the list of saved items to free. */
/* */
/****************************************************************/
trynext:
if (donext != NIL)
{
tmpptr = donext;
ptr = (ConsCell *)Addr68k_from_LADDR(tmpptr);
donext = (LispPTR)ptr->car_field;
index = ptr->cdr_code;
goto lp;
};
#ifdef NEWCDRCODING
if (do_count) /* If there are other cells to collect */
{
do_count--;
tmpptr = to_do[do_count];
index = to_do_offset[do_count];
todo_reads++;
/*REC_GCLOOKUP(tmpptr, ADDREF); */
goto lp;
}
#endif /*NEWCDRCODING */
return(NIL);
}
/************************************************************************/
/* */
/* f r e e l i s t c e l l */
/* */
/* */
/* */
/************************************************************************/
freelistcell(LispPTR cell)
{
struct conspage *pbase;
register ConsCell *cell68k;
unsigned int offset, prior, celloffset;
cell68k = (ConsCell *)Addr68k_from_LADDR(cell);
pbase = (struct conspage *)Addr68k_from_LPAGE(POINTER_PAGE(cell));
celloffset = (LispPTR)cell & 0xFF;
#ifdef NEWCDRCODING
if (celloffset < 8)
error("freeing CONS cell that's really freelist ptr");
#endif /* NEWCDRCODING */
if (pbase->count) /* There are free cells on the page already */
{
prior = 0;
for (offset = pbase->next_cell; offset;
offset = FREECONS(pbase,offset) -> next_free)
{
#ifdef NEWCDRCODING
if ((6^offset) < (6^celloffset))
#else
if (offset < celloffset)
#endif /* NEWCDRCODING */
{
break;
}
prior = offset;
}
if (prior) FREECONS(pbase, prior)->next_free = celloffset;
else pbase->next_cell = celloffset;
((freecons *)cell68k) -> next_free = offset;
}
else /* NO FREE CELLS. Just replace next_free. */
{
pbase->next_cell = celloffset;
FREECONS(pbase,celloffset)->next_free = 0; /* And this is end of the chain */
}
if ((++pbase->count > 32) && (pbase->next_page == CONSPAGE_LAST))
{
pbase->next_page = ListpDTD->dtd_nextpage;
ListpDTD->dtd_nextpage = POINTER_PAGE(cell);
};
}