--- gforth/Attic/engine.c 1995/10/26 22:48:39 1.30 +++ gforth/Attic/engine.c 1995/12/26 17:35:36 1.33 @@ -1,7 +1,25 @@ -/* - Copyright 1992 by the ANSI figForth Development Group +/* Gforth virtual machine (aka inner interpreter) + + Copyright (C) 1995 Free Software Foundation, Inc. + + This file is part of Gforth. + + Gforth is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ +#include "config.h" #include #include #include @@ -71,32 +89,35 @@ int emitcounter; #define NULLC '\0' char *cstr(Char *from, UCell size, int clear) -/* if clear is true, scratch can be reused, otherwise we want more of - the same */ +/* return a C-string corresponding to the Forth string ( FROM SIZE ). + the C-string lives until the next call of cstr with CLEAR being true */ { - static char *scratch=NULL; - static unsigned scratchsize=0; - static char *nextscratch; - char *oldnextscratch; + static struct cstr_buffer { + char *buffer; + size_t size; + } *buffers=NULL; + static int nbuffers=0; + static int used=0; + struct cstr_buffer *b; + if (buffers==NULL) + buffers=malloc(0); if (clear) - nextscratch=scratch; - if (scratch==NULL) { - scratch=malloc(size+1); - nextscratch=scratch; - scratchsize=size; - } - else if (nextscratch+size>scratch+scratchsize) { - char *oldscratch=scratch; - scratch = realloc(scratch, (nextscratch-scratch)+size+1); - nextscratch=scratch+(nextscratch-oldscratch); - scratchsize=size; - } - memcpy(nextscratch,from,size); - nextscratch[size]='\0'; - oldnextscratch = nextscratch; - nextscratch += size+1; - return oldnextscratch; + used=0; + if (used>=nbuffers) { + buffers=realloc(buffers,sizeof(struct cstr_buffer)*(used+1)); + buffers[used]=(struct cstr_buffer){malloc(0),0}; + nbuffers=used+1; + } + b=&buffers[used]; + if (size+1 > b->size) { + b->buffer = realloc(b->buffer,size+1); + b->size = size+1; + } + memcpy(b->buffer,from,size); + b->buffer[size]='\0'; + used++; + return b->buffer; } char *tilde_cstr(Char *from, UCell size, int clear) @@ -179,6 +200,14 @@ static Address up0=NULL; #define FTOSREG #endif +/* declare and compute cfa for certain threading variants */ +/* warning: this is nonsyntactical; it will not work in place of a statement */ +#ifdef CFA_NEXT +#define DOCFA +#else +#define DOCFA Xt cfa; GETCFA(cfa) +#endif + Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0) /* executes code at ip, if ip!=NULL returns array of machine code labels (for use in a loader), if ip==NULL @@ -203,11 +232,17 @@ Label *engine(Xt *ip0, Cell *sp0, Cell * &&dodefer, &&dofield, &&dodoes, - &&dodoes, /* dummy for does handler address */ + /* the following entry is normally unused; + it's there because its index indicates a does-handler */ +#ifdef CPU_DEP1 + CPU_DEP1, +#else + (Label)0, +#endif #include "prim_labels.i" }; -#ifdef CPU_DEP - CPU_DEP; +#ifdef CPU_DEP2 + CPU_DEP2 #endif #ifdef DEBUG @@ -224,125 +259,105 @@ Label *engine(Xt *ip0, Cell *sp0, Cell * /* prep_terminal(); */ NEXT_P0; NEXT; + +#ifdef CPU_DEP3 + CPU_DEP3 +#endif docol: -#ifndef CFA_NEXT { - Xt cfa; GETCFA(cfa); -#endif + DOCFA; #ifdef DEBUG - fprintf(stderr,"%08lx: col: %08lx\n",(Cell)ip,(Cell)PFA1(cfa)); + fprintf(stderr,"%08lx: col: %08lx\n",(Cell)ip,(Cell)PFA1(cfa)); #endif #ifdef CISC_NEXT - /* this is the simple version */ - *--rp = (Cell)ip; - ip = (Xt *)PFA1(cfa); - NEXT_P0; - NEXT; -#else - /* this one is important, so we help the compiler optimizing - The following version may be better (for scheduling), but probably has - problems with code fields employing calls and delay slots - */ - { - DEF_CA - Xt *current_ip = (Xt *)PFA1(cfa); - cfa = *current_ip; - NEXT1_P1; + /* this is the simple version */ *--rp = (Cell)ip; - ip = current_ip+1; - NEXT1_P2; - } + ip = (Xt *)PFA1(cfa); + NEXT_P0; + NEXT; +#else + /* this one is important, so we help the compiler optimizing + The following version may be better (for scheduling), but probably has + problems with code fields employing calls and delay slots + */ + { + DEF_CA + Xt *current_ip = (Xt *)PFA1(cfa); + cfa = *current_ip; + NEXT1_P1; + *--rp = (Cell)ip; + ip = current_ip+1; + NEXT1_P2; + } #endif -#ifndef CFA_NEXT } -#endif docon: -#ifndef CFA_NEXT { - Xt cfa; GETCFA(cfa); -#endif + DOCFA; #ifdef DEBUG - fprintf(stderr,"%08lx: con: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa)); + fprintf(stderr,"%08lx: con: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa)); #endif #ifdef USE_TOS - *sp-- = TOS; - TOS = *(Cell *)PFA1(cfa); + *sp-- = TOS; + TOS = *(Cell *)PFA1(cfa); #else - *--sp = *(Cell *)PFA1(cfa); + *--sp = *(Cell *)PFA1(cfa); #endif -#ifndef CFA_NEXT } -#endif NEXT_P0; NEXT; dovar: -#ifndef CFA_NEXT { - Xt cfa; GETCFA(cfa); -#endif + DOCFA; #ifdef DEBUG - fprintf(stderr,"%08lx: var: %08lx\n",(Cell)ip,(Cell)PFA1(cfa)); + fprintf(stderr,"%08lx: var: %08lx\n",(Cell)ip,(Cell)PFA1(cfa)); #endif #ifdef USE_TOS - *sp-- = TOS; - TOS = (Cell)PFA1(cfa); + *sp-- = TOS; + TOS = (Cell)PFA1(cfa); #else - *--sp = (Cell)PFA1(cfa); + *--sp = (Cell)PFA1(cfa); #endif -#ifndef CFA_NEXT } -#endif NEXT_P0; NEXT; douser: -#ifndef CFA_NEXT { - Xt cfa; GETCFA(cfa); -#endif + DOCFA; #ifdef DEBUG - fprintf(stderr,"%08lx: user: %08lx\n",(Cell)ip,(Cell)PFA1(cfa)); + fprintf(stderr,"%08lx: user: %08lx\n",(Cell)ip,(Cell)PFA1(cfa)); #endif #ifdef USE_TOS - *sp-- = TOS; - TOS = (Cell)(up+*(Cell*)PFA1(cfa)); + *sp-- = TOS; + TOS = (Cell)(up+*(Cell*)PFA1(cfa)); #else - *--sp = (Cell)(up+*(Cell*)PFA1(cfa)); + *--sp = (Cell)(up+*(Cell*)PFA1(cfa)); #endif -#ifndef CFA_NEXT } -#endif NEXT_P0; NEXT; dodefer: -#ifndef CFA_NEXT { - Xt cfa; GETCFA(cfa); -#endif + DOCFA; #ifdef DEBUG - fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa)); + fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa)); #endif - EXEC(*(Xt *)PFA1(cfa)); -#ifndef CFA_NEXT + EXEC(*(Xt *)PFA1(cfa)); } -#endif dofield: -#ifndef CFA_NEXT { - Xt cfa; GETCFA(cfa); -#endif + DOCFA; #ifdef DEBUG - fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa)); + fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa)); #endif - TOS += *(Cell*)PFA1(cfa); -#ifndef CFA_NEXT + TOS += *(Cell*)PFA1(cfa); } -#endif NEXT_P0; NEXT; @@ -364,29 +379,25 @@ Label *engine(Xt *ip0, Cell *sp0, Cell * pfa: */ -#ifndef CFA_NEXT { - Xt cfa; GETCFA(cfa); + DOCFA; -/* fprintf(stderr, "Got CFA %08lx at doescode %08lx/%08lx: does: %08lx\n",cfa,(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));*/ -#endif + /* fprintf(stderr, "Got CFA %08lx at doescode %08lx/%08lx: does: %08lx\n",cfa,(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));*/ #ifdef DEBUG - fprintf(stderr,"%08lx/%08lx: does: %08lx\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa)); - fflush(stderr); + fprintf(stderr,"%08lx/%08lx: does: %08lx\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa)); + fflush(stderr); #endif - *--rp = (Cell)ip; - /* PFA1 might collide with DOES_CODE1 here, so we use PFA */ - ip = DOES_CODE1(cfa); + *--rp = (Cell)ip; + /* PFA1 might collide with DOES_CODE1 here, so we use PFA */ + ip = DOES_CODE1(cfa); #ifdef USE_TOS - *sp-- = TOS; - TOS = (Cell)PFA(cfa); + *sp-- = TOS; + TOS = (Cell)PFA(cfa); #else - *--sp = (Cell)PFA(cfa); + *--sp = (Cell)PFA(cfa); #endif -#ifndef CFA_NEXT -/* fprintf(stderr,"TOS = %08lx, IP=%08lx\n", TOS, IP);*/ + /* fprintf(stderr,"TOS = %08lx, IP=%08lx\n", TOS, IP);*/ } -#endif NEXT_P0; NEXT;