--- gforth/engine/engine.c	2001/02/24 13:44:39	1.27
+++ gforth/engine/engine.c	2002/08/09 09:42:36	1.42
@@ -19,7 +19,10 @@
   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 */
 
+undefine(`symbols')
+
 #include "config.h"
+#include "forth.h"
 #include <ctype.h>
 #include <stdio.h>
 #include <string.h>
@@ -27,7 +30,6 @@
 #include <assert.h>
 #include <stdlib.h>
 #include <errno.h>
-#include "forth.h"
 #include "io.h"
 #include "threaded.h"
 #ifndef STANDALONE
@@ -196,6 +198,7 @@ DCell timeval2us(struct timeval *tvp)
 
 #ifdef HAS_FILE
 static char* fileattr[6]={"rb","rb","r+b","r+b","wb","wb"};
+static char* pfileattr[6]={"r","r","r+","r+","w","w"};
 
 #ifndef O_BINARY
 #define O_BINARY 0
@@ -212,37 +215,39 @@ static int ufileattr[6]= {
 
 /* conversion on fetch */
 
-#define vm_Cell2f(x)		((Bool)(x))
-#define vm_Cell2c(x)		((Char)(x))
-#define vm_Cell2n(x)		((Cell)x)
-#define vm_Cell2w(x)		((Cell)x)
-#define vm_Cell2u(x)		((UCell)(x))
-#define vm_Cell2a_(x)		((Cell *)(x))
-#define vm_Cell2c_(x)		((Char *)(x))
-#define vm_Cell2f_(x)		((Float *)(x))
-#define vm_Cell2df_(x)		((DFloat *)(x))
-#define vm_Cell2sf_(x)		((SFloat *)(x))
-#define vm_Cell2xt(x)		((Xt)(x))
-#define vm_Cell2f83name(x)	((struct F83Name *)(x))
-#define vm_Cell2longname(x)	((struct Longname *)(x))
-#define vm_Float2r(x)	(x)
+#define vm_Cell2f(_cell,_x)		((_x)=(Bool)(_cell))
+#define vm_Cell2c(_cell,_x)		((_x)=(Char)(_cell))
+#define vm_Cell2n(_cell,_x)		((_x)=(Cell)(_cell))
+#define vm_Cell2w(_cell,_x)		((_x)=(Cell)(_cell))
+#define vm_Cell2u(_cell,_x)		((_x)=(UCell)(_cell))
+#define vm_Cell2a_(_cell,_x)		((_x)=(Cell *)(_cell))
+#define vm_Cell2c_(_cell,_x)		((_x)=(Char *)(_cell))
+#define vm_Cell2f_(_cell,_x)		((_x)=(Float *)(_cell))
+#define vm_Cell2df_(_cell,_x)		((_x)=(DFloat *)(_cell))
+#define vm_Cell2sf_(_cell,_x)		((_x)=(SFloat *)(_cell))
+#define vm_Cell2xt(_cell,_x)		((_x)=(Xt)(_cell))
+#define vm_Cell2f83name(_cell,_x)	((_x)=(struct F83Name *)(_cell))
+#define vm_Cell2longname(_cell,_x)	((_x)=(struct Longname *)(_cell))
+#define vm_Float2r(_float,_x)		(_x=_float)
 
 /* conversion on store */
 
-#define vm_f2Cell(x)		((Cell)(x))
-#define vm_c2Cell(x)		((Cell)(x))
-#define vm_n2Cell(x)		((Cell)(x))
-#define vm_w2Cell(x)		((Cell)(x))
-#define vm_u2Cell(x)		((Cell)(x))
-#define vm_a_2Cell(x)		((Cell)(x))
-#define vm_c_2Cell(x)		((Cell)(x))
-#define vm_f_2Cell(x)		((Cell)(x))
-#define vm_df_2Cell(x)		((Cell)(x))
-#define vm_sf_2Cell(x)		((Cell)(x))
-#define vm_xt2Cell(x)		((Cell)(x))
-#define vm_f83name2Cell(x)	((Cell)(x))
-#define vm_longname2Cell(x)	((Cell)(x))
-#define vm_r2Float(x)	(x)
+#define vm_f2Cell(_x,_cell)		((_cell)=(Cell)(_x))
+#define vm_c2Cell(_x,_cell)		((_cell)=(Cell)(_x))
+#define vm_n2Cell(_x,_cell)		((_cell)=(Cell)(_x))
+#define vm_w2Cell(_x,_cell)		((_cell)=(Cell)(_x))
+#define vm_u2Cell(_x,_cell)		((_cell)=(Cell)(_x))
+#define vm_a_2Cell(_x,_cell)		((_cell)=(Cell)(_x))
+#define vm_c_2Cell(_x,_cell)		((_cell)=(Cell)(_x))
+#define vm_f_2Cell(_x,_cell)		((_cell)=(Cell)(_x))
+#define vm_df_2Cell(_x,_cell)		((_cell)=(Cell)(_x))
+#define vm_sf_2Cell(_x,_cell)		((_cell)=(Cell)(_x))
+#define vm_xt2Cell(_x,_cell)		((_cell)=(Cell)(_x))
+#define vm_f83name2Cell(_x,_cell)	((_cell)=(Cell)(_x))
+#define vm_longname2Cell(_x,_cell)	((_cell)=(Cell)(_x))
+#define vm_r2Float(_x,_float)		(_float=_x)
+
+#define vm_Cell2Cell(_x,_y)		(_y=_x)
 
 /* if machine.h has not defined explicit registers, define them as implicit */
 #ifndef IPREG
@@ -277,13 +282,19 @@ static int ufileattr[6]= {
 # define CPU_DEP1 0
 #endif
 
-/* declare and compute cfa for certain threading variants */
-/* warning: this is nonsyntactical; it will not work in place of a statement */
-#ifndef GETCFA
-#define DOCFA
+/* instructions containing these must be the last instruction of a
+   super-instruction (e.g., branches, EXECUTE, and other instructions
+   ending the basic block). Instructions containing SET_IP get this
+   automatically, so you usually don't have to write it.  If you have
+   to write it, write it after IP points to the next instruction.
+   Used for profiling.  Don't write it in a word containing SET_IP, or
+   the following block will be counted twice. */
+#ifdef VM_PROFILING
+#define SUPER_END  vm_count_block(IP)
 #else
-#define DOCFA	Xt cfa; GETCFA(cfa)
+#define SUPER_END
 #endif
+#define SUPER_CONTINUE
 
 #ifdef GFORTH_DEBUGGING
 /* define some VM registers as global variables, so they survive exceptions;
@@ -293,7 +304,34 @@ Xt *ip;
 Cell *rp;
 #endif
 
-Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
+#ifdef DEBUG
+#define CFA_TO_NAME(__cfa) \
+      Cell len, i; \
+      char * name = __cfa; \
+      for(i=0; i<32; i+=sizeof(Cell)) { \
+        len = ((Cell*)name)[-1]; \
+        if(len < 0) { \
+	  len &= 0x1F; \
+          if((len+sizeof(Cell)) > i) break; \
+	} len = 0; \
+	name -= sizeof(Cell); \
+      }
+#endif
+
+Xt *primtable(Label symbols[], Cell size)
+     /* used in primitive primtable for peephole optimization */
+{
+  Xt *xts = (Xt *)malloc(size*sizeof(Xt));
+  Cell i;
+
+  for (i=0; i<size; i++)
+    xts[i] = &symbols[i];
+  return xts;
+}
+
+
+define(enginerest,
+`(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
 */
@@ -305,9 +343,7 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
   register Cell *sp SPREG = sp0;
   register Float *fp FPREG = fp0;
   register Address lp LPREG = lp0;
-#ifdef CFA_NEXT
   register Xt cfa CFAREG;
-#endif
 #ifdef MORE_VARS
   MORE_VARS
 #endif
@@ -330,10 +366,18 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
     (Label)&&dofield,
     (Label)&&dodoes,
     /* the following entry is normally unused;
-       it's there because its index indicates a does-handler */
+       it is there because its index indicates a does-handler */
     CPU_DEP1,
+#define INST_ADDR(name) (Label)&&I_##name
+#include "prim_lab.i"
+#undef INST_ADDR
+    (Label)&&after_last,
+    (Label)0,
+#ifdef IN_ENGINE2
+#define INST_ADDR(name) (Label)&&J_##name
 #include "prim_lab.i"
-    (Label)0
+#undef INST_ADDR
+#endif
   };
 #ifdef CPU_DEP2
   CPU_DEP2
@@ -349,19 +393,22 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
 
   if (ip == NULL) {
 #if defined(DOUBLY_INDIRECT)
-#define CODE_OFFSET (22*sizeof(Cell))
+#define CODE_OFFSET (26*sizeof(Cell))
+#define XT_OFFSET (22*sizeof(Cell))
     int i;
     Cell code_offset = offset_image? CODE_OFFSET : 0;
+    Cell xt_offset = offset_image? XT_OFFSET : 0;
 
     symbols = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+CODE_OFFSET)+code_offset);
+    xts = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+XT_OFFSET)+xt_offset);
     for (i=0; i<DOESJUMP+1; i++)
-      symbols[i] = (Label)routines[i];
+      xts[i] = symbols[i] = (Label)routines[i];
     for (; routines[i]!=0; i++) {
       if (i>=MAX_SYMBOLS) {
 	fprintf(stderr,"gforth-ditc: more than %d primitives\n",MAX_SYMBOLS);
 	exit(1);
       }
-      symbols[i] = &routines[i];
+      xts[i] = symbols[i] = &routines[i];
     }
 #endif /* defined(DOUBLY_INDIRECT) */
     return symbols;
@@ -371,6 +418,7 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
   IF_fpTOS(fpTOS = fp[0]);
 /*  prep_terminal(); */
   SET_IP(ip);
+  SUPER_END; /* count the first block, too */
   NEXT;
 
 
@@ -380,14 +428,18 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
   
  docol:
   {
-    DOCFA;
 #ifdef DEBUG
-    fprintf(stderr,"%08lx: col: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
+    {
+      CFA_TO_NAME(cfa);
+      fprintf(stderr,"%08lx: col: %08lx %.*s\n",(Cell)ip,(Cell)PFA1(cfa),
+	      len,name);
+    }
 #endif
 #ifdef CISC_NEXT
     /* this is the simple version */
     *--rp = (Cell)ip;
     SET_IP((Xt *)PFA1(cfa));
+    SUPER_END;
     NEXT;
 #else
     /* this one is important, so we help the compiler optimizing */
@@ -395,6 +447,7 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
       DEF_CA
       rp[-1] = (Cell)ip;
       SET_IP((Xt *)PFA1(cfa));
+      SUPER_END;
       NEXT_P1;
       rp--;
       NEXT_P2;
@@ -404,7 +457,6 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
 
  docon:
   {
-    DOCFA;
 #ifdef DEBUG
     fprintf(stderr,"%08lx: con: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
 #endif
@@ -420,7 +472,6 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
   
  dovar:
   {
-    DOCFA;
 #ifdef DEBUG
     fprintf(stderr,"%08lx: var: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
 #endif
@@ -436,7 +487,6 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
   
  douser:
   {
-    DOCFA;
 #ifdef DEBUG
     fprintf(stderr,"%08lx: user: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
 #endif
@@ -452,16 +502,15 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
   
  dodefer:
   {
-    DOCFA;
 #ifdef DEBUG
     fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
 #endif
+    SUPER_END;
     EXEC(*(Xt *)PFA1(cfa));
   }
 
  dofield:
   {
-    DOCFA;
 #ifdef DEBUG
     fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
 #endif
@@ -489,8 +538,6 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
      
      */
   {
-    DOCFA;
-
     /*    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));
@@ -505,9 +552,26 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
     *--sp = (Cell)PFA(cfa);
 #endif
     SET_IP(DOES_CODE1(cfa));
+    SUPER_END;
     /*    fprintf(stderr,"TOS = %08lx, IP=%08lx\n", spTOS, IP);*/
   }
   NEXT;
 
+#ifndef IN_ENGINE2
+#define LABEL(name) I_##name
+#else
+#define LABEL(name) J_##name: asm(".skip 16"); I_##name
+#endif
+#define LABEL2(name)
 #include "prim.i"
-}
+#undef LABEL
+  after_last: return (Label *)0;
+  /*needed only to get the length of the last primitive */
+}'
+)
+
+Label *engine enginerest
+
+#define IN_ENGINE2
+Label *engine2 enginerest
+