[gforth] / gforth / engine / main.c  

gforth: gforth/engine/main.c

Diff for /gforth/engine/main.c between version 1.209 and 1.261

version 1.209, Sat Aug 9 13:24:25 2008 UTC version 1.261, Mon Jul 23 15:07:23 2012 UTC
Line 1 
Line 1 
 /* command line interpretation, image loading etc. for Gforth  /* command line interpretation, image loading etc. for Gforth
   
   
   Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008 Free Software Foundation, Inc.    Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,2009,2010,2011 Free Software Foundation, Inc.
   
   This file is part of Gforth.    This file is part of Gforth.
   
Line 28 
Line 28 
 #include <string.h>  #include <string.h>
 #include <math.h>  #include <math.h>
 #include <sys/types.h>  #include <sys/types.h>
   #ifdef HAVE_ALLOCA_H
   #include <alloca.h>
   #endif
 #ifndef STANDALONE  #ifndef STANDALONE
 #include <sys/stat.h>  #include <sys/stat.h>
 #endif  #endif
 #include <fcntl.h>  #include <fcntl.h>
 #include <assert.h>  #include <assert.h>
 #include <stdlib.h>  #include <stdlib.h>
 #include <stdbool.h>  
 #include <signal.h>  #include <signal.h>
   
 #ifndef STANDALONE  #ifndef STANDALONE
 #if HAVE_SYS_MMAN_H  #if HAVE_SYS_MMAN_H
 #include <sys/mman.h>  #include <sys/mman.h>
Line 43 
Line 46 
 #endif  #endif
 #include "io.h"  #include "io.h"
 #include "getopt.h"  #include "getopt.h"
 #ifdef STANDALONE  #ifndef STANDALONE
 /* #include <systypes.h> */  #include <locale.h>
 #endif  #endif
   
 /* output rules etc. for burg with --debug and --print-sequences */  /* output rules etc. for burg with --debug and --print-sequences */
Line 59 
Line 62 
 /* global variables for engine.c  /* global variables for engine.c
    We put them here because engine.c is compiled several times in     We put them here because engine.c is compiled several times in
    different ways for the same engine. */     different ways for the same engine. */
 Cell *gforth_SP;  PER_THREAD Cell *gforth_SP;
 Float *gforth_FP;  PER_THREAD Float *gforth_FP;
 Address gforth_UP=NULL;  PER_THREAD user_area* gforth_UP=NULL;
 Cell *gforth_RP;  PER_THREAD Cell *gforth_RP;
 Address gforth_LP;  PER_THREAD Address gforth_LP;
   
 #ifdef HAS_FFCALL  #ifdef HAS_FFCALL
   
 #include <callback.h>  #include <callback.h>
   
 va_alist gforth_clist;  PER_THREAD va_alist gforth_clist;
   
 void gforth_callback(Xt* fcall, void * alist)  void gforth_callback(Xt* fcall, void * alist)
 {  {
Line 82 
Line 85 
   
   gforth_clist = (va_alist)alist;    gforth_clist = (va_alist)alist;
   
   gforth_engine(fcall, sp, rp, fp, lp sr_call);    gforth_engine(fcall sr_call);
   
   /* restore global variables */    /* restore global variables */
   gforth_RP = rp;    gforth_RP = rp;
Line 99 
Line 102 
    GNU C manual) */     GNU C manual) */
 #if defined(GLOBALS_NONRELOC)  #if defined(GLOBALS_NONRELOC)
 saved_regs saved_regs_v;  saved_regs saved_regs_v;
 saved_regs *saved_regs_p = &saved_regs_v;  PER_THREAD saved_regs *saved_regs_p = &saved_regs_v;
 #else /* !defined(GLOBALS_NONRELOC) */  #else /* !defined(GLOBALS_NONRELOC) */
 Xt *saved_ip;  PER_THREAD Xt *saved_ip;
 Cell *rp;  PER_THREAD Cell *rp;
 #endif /* !defined(GLOBALS_NONRELOC) */  #endif /* !defined(GLOBALS_NONRELOC) */
 #endif /* !defined(GFORTH_DEBUGGING) */  #endif /* !defined(GFORTH_DEBUGGING) */
   
Line 136 
Line 139 
 #endif  #endif
   
 #ifdef MSDOS  #ifdef MSDOS
 jmp_buf throw_jmp_buf;  jmp_buf throw_jmp_handler;
 #endif  #endif
   
 #if defined(DOUBLY_INDIRECT)  #if defined(DOUBLY_INDIRECT)
Line 176 
Line 179 
 #define CODE_BLOCK_SIZE (512*1024) /* !! overflow handling for -native */  #define CODE_BLOCK_SIZE (512*1024) /* !! overflow handling for -native */
 Address code_area=0;  Address code_area=0;
 Cell code_area_size = CODE_BLOCK_SIZE;  Cell code_area_size = CODE_BLOCK_SIZE;
 Address code_here=NULL+CODE_BLOCK_SIZE; /* does for code-area what HERE  Address code_here; /* does for code-area what HERE does for the dictionary */
                                            does for the dictionary */  
 Address start_flush=NULL; /* start of unflushed code */  Address start_flush=NULL; /* start of unflushed code */
 Cell last_jump=0; /* if the last prim was compiled without jump, this  Cell last_jump=0; /* if the last prim was compiled without jump, this
                      is it's number, otherwise this contains 0 */                       is it's number, otherwise this contains 0 */
Line 190 
Line 192 
 #define MAX_STATE 9 /* maximum number of states */  #define MAX_STATE 9 /* maximum number of states */
 static int maxstates = MAX_STATE; /* number of states for stack caching */  static int maxstates = MAX_STATE; /* number of states for stack caching */
 static int ss_greedy = 0; /* if true: use greedy, not optimal ss selection */  static int ss_greedy = 0; /* if true: use greedy, not optimal ss selection */
 static int diag = 0; /* if true: print diagnostic informations */  
 static int tpa_noequiv = 0;     /* if true: no state equivalence checking */  static int tpa_noequiv = 0;     /* if true: no state equivalence checking */
 static int tpa_noautomaton = 0; /* if true: no tree parsing automaton */  static int tpa_noautomaton = 0; /* if true: no tree parsing automaton */
 static int tpa_trace = 0; /* if true: data for line graph of new states etc. */  static int tpa_trace = 0; /* if true: data for line graph of new states etc. */
Line 258 
Line 259 
 {  {
   return memcmp(s1, s2, n);    return memcmp(s1, s2, n);
 }  }
   
   Char *gforth_memmove(Char * dest, const Char* src, Cell n)
   {
     return memmove(dest, src, n);
   }
   
   Char *gforth_memset(Char * s, Cell c, UCell n)
   {
     return memset(s, c, n);
   }
   
   Char *gforth_memcpy(Char * dest, const Char* src, Cell n)
   {
     return memcpy(dest, src, n);
   }
 #endif  #endif
   
 static Cell max(Cell a, Cell b)  static Cell max(Cell a, Cell b)
Line 274 
Line 290 
 /* image file format:  /* image file format:
  *  "#! binary-path -i\n" (e.g., "#! /usr/local/bin/gforth-0.4.0 -i\n")   *  "#! binary-path -i\n" (e.g., "#! /usr/local/bin/gforth-0.4.0 -i\n")
  *   padding to a multiple of 8   *   padding to a multiple of 8
  *   magic: "Gforth3x" means format 0.6,   *   magic: "Gforth4x" means format 0.8,
  *              where x is a byte with   *              where x is a byte with
  *              bit 7:   reserved = 0   *              bit 7:   reserved = 0
  *              bit 6:5: address unit size 2^n octets   *              bit 6:5: address unit size 2^n octets
Line 293 
Line 309 
  * If the word =-1 (CF_NIL), the address is NIL,   * If the word =-1 (CF_NIL), the address is NIL,
  * If the word is <CF_NIL and >CF(DODOES), it's a CFA (:, Create, ...)   * If the word is <CF_NIL and >CF(DODOES), it's a CFA (:, Create, ...)
  * If the word =CF(DODOES), it's a DOES> CFA   * If the word =CF(DODOES), it's a DOES> CFA
  * If the word =CF(DOESJUMP), it's a DOES JUMP (2 Cells after DOES>,   * !! ABI-CODE and ;ABI-CODE
  *                                      possibly containing a jump to dodoes)   * If the word is <CF(DOER_MAX) and bit 14 is set, it's the xt of a primitive
  * If the word is <CF(DOESJUMP) and bit 14 is set, it's the xt of a primitive   * If the word is <CF(DOER_MAX) and bit 14 is clear,
  * If the word is <CF(DOESJUMP) and bit 14 is clear,  
  *                                        it's the threaded code of a primitive   *                                        it's the threaded code of a primitive
  * bits 13..9 of a primitive token state which group the primitive belongs to,   * bits 13..9 of a primitive token state which group the primitive belongs to,
  * bits 8..0 of a primitive token index into the group   * bits 8..0 of a primitive token index into the group
Line 392 
Line 407 
             case CF(DOVAL)   :              case CF(DOVAL)   :
             case CF(DOUSER)  :              case CF(DOUSER)  :
             case CF(DODEFER) :              case CF(DODEFER) :
             case CF(DOFIELD) : MAKE_CF(image+i,symbols[CF(token)]); break;              case CF(DOFIELD) :
             case CF(DOESJUMP): image[i]=0; break;  
 #endif /* !defined(DOUBLY_INDIRECT) */  
             case CF(DODOES)  :              case CF(DODOES)  :
               MAKE_DOES_CF(image+i,(Xt *)(image[i+1]+((Cell)start)));              case CF(DOABICODE) :
               break;              case CF(DOSEMIABICODE):
                 MAKE_CF(image+i,symbols[CF(token)]); break;
   #endif /* !defined(DOUBLY_INDIRECT) */
             default          : /* backward compatibility */              default          : /* backward compatibility */
 /*            printf("Code field generation image[%x]:=CFA(%x)\n",  /*            printf("Code field generation image[%x]:=CFA(%x)\n",
                      i, CF(image[i])); */                       i, CF(image[i])); */
Line 411 
Line 426 
                 }                  }
 #endif  #endif
               } else                } else
                 fprintf(stderr,"Primitive %ld used in this image at $%lx (offset $%x) is not implemented by this\n engine (%s); executing this code will crash.\n",(long)CF(token),(long)&image[i], i, PACKAGE_VERSION);                  fprintf(stderr,"Primitive %ld used in this image at %p (offset $%x) is not implemented by this\n engine (%s); executing this code will crash.\n",(long)CF(token), &image[i], i, PACKAGE_VERSION);
             }              }
           } else {            } else {
             int tok = -token & 0x1FF;              int tok = -token & 0x1FF;
Line 429 
Line 444 
               }                }
 #endif  #endif
             } else              } else
               fprintf(stderr,"Primitive %lx, %d of group %d used in this image at $%lx (offset $%x) is not implemented by this\n engine (%s); executing this code will crash.\n", (long)-token, tok, group, (long)&image[i],i,PACKAGE_VERSION);                fprintf(stderr,"Primitive %lx, %d of group %d used in this image at %p (offset $%x) is not implemented by this\n engine (%s); executing this code will crash.\n", (long)-token, tok, group, &image[i],i,PACKAGE_VERSION);
           }            }
         } else {          } else {
           /* if base is > 0: 0 is a null reference so don't adjust*/            /* if base is > 0: 0 is a null reference so don't adjust*/
Line 451 
Line 466 
   UCell r=PRIM_VERSION;    UCell r=PRIM_VERSION;
   Cell i;    Cell i;
   
   for (i=DOCOL; i<=DOESJUMP; i++) {    for (i=DOCOL; i<=DOER_MAX; i++) {
     r ^= (UCell)(symbols[i]);      r ^= (UCell)(symbols[i]);
     r = (r << 5) | (r >> (8*sizeof(Cell)-5));      r = (r << 5) | (r >> (8*sizeof(Cell)-5));
   }    }
Line 480 
Line 495 
     exit(1);      exit(1);
   }    }
   r = (Address)((((Cell)r)+(sizeof(Float)-1))&(-sizeof(Float)));    r = (Address)((((Cell)r)+(sizeof(Float)-1))&(-sizeof(Float)));
   debugp(stderr, "malloc succeeds, address=$%lx\n", (long)r);    debugp(stderr, "malloc succeeds, address=%p\n", r);
   return r;    return r;
 }  }
   
 static Address next_address=0;  static void *next_address=0;
 static void after_alloc(Address r, Cell size)  static void after_alloc(Address r, Cell size)
 {  {
   if (r != (Address)-1) {    if (r != (Address)-1) {
     debugp(stderr, "success, address=$%lx\n", (long) r);      debugp(stderr, "success, address=%p\n", r);
 #if 0  #if 0
     /* not needed now that we protect the stacks with mprotect */      /* not needed now that we protect the stacks with mprotect */
     if (pagesize != 1)      if (pagesize != 1)
Line 508 
Line 523 
 #ifndef MAP_PRIVATE  #ifndef MAP_PRIVATE
 # define MAP_PRIVATE 0  # define MAP_PRIVATE 0
 #endif  #endif
   #ifndef PROT_NONE
   # define PROT_NONE 0
   #endif
 #if !defined(MAP_ANON) && defined(MAP_ANONYMOUS)  #if !defined(MAP_ANON) && defined(MAP_ANONYMOUS)
 # define MAP_ANON MAP_ANONYMOUS  # define MAP_ANON MAP_ANONYMOUS
 #endif  #endif
Line 515 
Line 533 
 #if defined(HAVE_MMAP)  #if defined(HAVE_MMAP)
 static Address alloc_mmap(Cell size)  static Address alloc_mmap(Cell size)
 {  {
   Address r;    void *r;
   
 #if defined(MAP_ANON)  #if defined(MAP_ANON)
   debugp(stderr,"try mmap($%lx, $%lx, ..., MAP_ANON, ...); ", (long)next_address, (long)size);    debugp(stderr,"try mmap(%p, $%lx, ..., MAP_ANON, ...); ", next_address, size);
   r = mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_ANON|MAP_PRIVATE|map_noreserve, -1, 0);    r = mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_ANON|MAP_PRIVATE|map_noreserve, -1, 0);
 #else /* !defined(MAP_ANON) */  #else /* !defined(MAP_ANON) */
   /* Ultrix (at least) does not define MAP_FILE and MAP_PRIVATE (both are    /* Ultrix (at least) does not define MAP_FILE and MAP_PRIVATE (both are
Line 532 
Line 550 
     debugp(stderr, "open(\"/dev/zero\"...) failed (%s), no mmap; ",      debugp(stderr, "open(\"/dev/zero\"...) failed (%s), no mmap; ",
               strerror(errno));                strerror(errno));
   } else {    } else {
     debugp(stderr,"try mmap($%lx, $%lx, ..., MAP_FILE, dev_zero, ...); ", (long)next_address, (long)size);      debugp(stderr,"try mmap(%p, $%lx, ..., MAP_FILE, dev_zero, ...); ", next_address, size);
     r=mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FILE|MAP_PRIVATE|map_noreserve, dev_zero, 0);      r=mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FILE|MAP_PRIVATE|map_noreserve, dev_zero, 0);
   }    }
 #endif /* !defined(MAP_ANON) */  #endif /* !defined(MAP_ANON) */
Line 540 
Line 558 
   return r;    return r;
 }  }
   
 static void page_noaccess(Address a)  static void page_noaccess(void *a)
 {  {
   /* try mprotect first; with munmap the page might be allocated later */    /* try mprotect first; with munmap the page might be allocated later */
   debugp(stderr, "try mprotect(%p,%ld,PROT_NONE); ", a, (long)pagesize);    debugp(stderr, "try mprotect(%p,$%lx,PROT_NONE); ", a, (long)pagesize);
   if (mprotect(a, pagesize, PROT_NONE)==0) {    if (mprotect(a, pagesize, PROT_NONE)==0) {
     debugp(stderr, "ok\n");      debugp(stderr, "ok\n");
     return;      return;
   }    }
   debugp(stderr, "failed: %s\n", strerror(errno));    debugp(stderr, "failed: %s\n", strerror(errno));
   debugp(stderr, "try munmap(%p,%ld); ", a, (long)pagesize);    debugp(stderr, "try munmap(%p,$%lx); ", a, (long)pagesize);
   if (munmap(a,pagesize)==0) {    if (munmap(a,pagesize)==0) {
     debugp(stderr, "ok\n");      debugp(stderr, "ok\n");
     return;      return;
Line 576 
Line 594 
   return verbose_malloc(size);    return verbose_malloc(size);
 }  }
   
 static Address dict_alloc_read(FILE *file, Cell imagesize, Cell dictsize, Cell offset)  static void *dict_alloc_read(FILE *file, Cell imagesize, Cell dictsize, Cell offset)
 {  {
   Address image = MAP_FAILED;    void *image = MAP_FAILED;
   
 #if defined(HAVE_MMAP)  #if defined(HAVE_MMAP)
   if (offset==0) {    if (offset==0) {
     image=alloc_mmap(dictsize);      image=alloc_mmap(dictsize);
     if (image != (Address)MAP_FAILED) {      if (image != (void *)MAP_FAILED) {
       Address image1;        void *image1;
       debugp(stderr,"try mmap($%lx, $%lx, ..., MAP_FIXED|MAP_FILE, imagefile, 0); ", (long)image, (long)imagesize);        debugp(stderr,"try mmap(%p, $%lx, ..., MAP_FIXED|MAP_FILE, imagefile, 0); ", image, imagesize);
       image1 = mmap(image, imagesize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FIXED|MAP_FILE|MAP_PRIVATE|map_noreserve, fileno(file), 0);        image1 = mmap(image, imagesize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FIXED|MAP_FILE|MAP_PRIVATE|map_noreserve, fileno(file), 0);
       after_alloc(image1,dictsize);        after_alloc(image1,dictsize);
       if (image1 == (Address)MAP_FAILED)        if (image1 == (void *)MAP_FAILED)
         goto read_image;          goto read_image;
     }      }
   }    }
 #endif /* defined(HAVE_MMAP) */  #endif /* defined(HAVE_MMAP) */
   if (image == (Address)MAP_FAILED) {    if (image == (void *)MAP_FAILED) {
     image = gforth_alloc(dictsize+offset)+offset;      image = gforth_alloc(dictsize+offset)+offset;
   read_image:    read_image:
     rewind(file);  /* fseek(imagefile,0L,SEEK_SET); */      rewind(file);  /* fseek(imagefile,0L,SEEK_SET); */
Line 620 
Line 638 
   rsize=maxaligned(rsize);    rsize=maxaligned(rsize);
   lsize=maxaligned(lsize);    lsize=maxaligned(lsize);
   fsize=maxaligned(fsize);    fsize=maxaligned(fsize);
 }  
   
 #ifdef STANDALONE    header->dict_size=dictsize;
 void alloc_stacks(ImageHeader * h)    header->data_stack_size=dsize;
 {    header->fp_stack_size=fsize;
 #define SSTACKSIZE 0x200    header->return_stack_size=rsize;
   static Cell dstack[SSTACKSIZE+1];    header->locals_stack_size=lsize;
   static Cell rstack[SSTACKSIZE+1];  
   
   h->dict_size=dictsize;  
   h->data_stack_size=dsize;  
   h->fp_stack_size=fsize;  
   h->return_stack_size=rsize;  
   h->locals_stack_size=lsize;  
   
   h->data_stack_base=dstack+SSTACKSIZE;  
   //  h->fp_stack_base=gforth_alloc(fsize);  
   h->return_stack_base=rstack+SSTACKSIZE;  
   //  h->locals_stack_base=gforth_alloc(lsize);  
 }  
 #else  
 void alloc_stacks(ImageHeader * h)  
 {  
   h->dict_size=dictsize;  
   h->data_stack_size=dsize;  
   h->fp_stack_size=fsize;  
   h->return_stack_size=rsize;  
   h->locals_stack_size=lsize;  
   
 #if defined(HAVE_MMAP) && !defined(STANDALONE)  
   if (pagesize > 1) {  
     size_t p = pagesize;  
     size_t totalsize =  
       wholepage(dsize)+wholepage(fsize)+wholepage(rsize)+wholepage(lsize)+5*p;  
     Address a = alloc_mmap(totalsize);  
     if (a != (Address)MAP_FAILED) {  
       page_noaccess(a); a+=p; h->  data_stack_base=a; a+=wholepage(dsize);  
       page_noaccess(a); a+=p; h->    fp_stack_base=a; a+=wholepage(fsize);  
       page_noaccess(a); a+=p; h->return_stack_base=a; a+=wholepage(rsize);  
       page_noaccess(a); a+=p; h->locals_stack_base=a; a+=wholepage(lsize);  
       page_noaccess(a);  
       debugp(stderr,"stack addresses: d=%p f=%p r=%p l=%p\n",  
              h->data_stack_base,  
              h->fp_stack_base,  
              h->return_stack_base,  
              h->locals_stack_base);  
       return;  
     }      }
   }  
 #endif  
   h->data_stack_base=gforth_alloc(dsize);  
   h->fp_stack_base=gforth_alloc(fsize);  
   h->return_stack_base=gforth_alloc(rsize);  
   h->locals_stack_base=gforth_alloc(lsize);  
 }  
 #endif  
   
 #warning You can ignore the warnings about clobbered variables in gforth_go  #warning You can ignore the warnings about clobbered variables in gforth_go
 int gforth_go(Address image, int stack, Cell *entries)  
   #define NEXTPAGE(addr) ((Address)((((UCell)(addr)-1)&-pagesize)+pagesize))
   #define NEXTPAGE2(addr) ((Address)((((UCell)(addr)-1)&-pagesize)+2*pagesize))
   
   Cell gforth_go(Xt* ip0)
 {  {
   volatile ImageHeader *image_header = (ImageHeader *)image;  
   Cell *sp0=(Cell*)(image_header->data_stack_base + dsize);  
   Cell *rp0=(Cell *)(image_header->return_stack_base + rsize);  
   Float *fp0=(Float *)(image_header->fp_stack_base + fsize);  
 #ifdef GFORTH_DEBUGGING  
   volatile Cell *orig_rp0=rp0;  
 #endif  
   Address lp0=image_header->locals_stack_base + lsize;  
   Xt *ip0=(Xt *)(image_header->boot_entry);  
 #ifdef SYSSIGNALS  #ifdef SYSSIGNALS
   int throw_code;    int throw_code;
     jmp_buf throw_jmp_buf;
 #endif  #endif
     Cell signal_data_stack[24];
   /* ensure that the cached elements (if any) are accessible */    Cell signal_return_stack[16];
 #if !(defined(GFORTH_DEBUGGING) || defined(INDIRECT_THREADED) || defined(DOUBLY_INDIRECT) || defined(VM_PROFILING))    Float signal_fp_stack[1];
   sp0 -= 8; /* make stuff below bottom accessible for stack caching */  
   fp0--;  
 #endif  
   
   for(;stack>0;stack--)  
     *--sp0=entries[stack-1];  
   
 #if defined(SYSSIGNALS) && !defined(STANDALONE)  #if defined(SYSSIGNALS) && !defined(STANDALONE)
   get_winsize();    throw_jmp_handler = &throw_jmp_buf;
   
   install_signal_handlers(); /* right place? */  
   
   if ((throw_code=setjmp(throw_jmp_buf))) {  
     static Cell signal_data_stack[24];  
     static Cell signal_return_stack[16];  
     static Float signal_fp_stack[1];  
   
     debugp(stderr, "setjmp(%p)\n", *throw_jmp_handler);
     while((throw_code=setjmp(*throw_jmp_handler))) {
     signal_data_stack[15]=throw_code;      signal_data_stack[15]=throw_code;
   
 #ifdef GFORTH_DEBUGGING  #ifdef GFORTH_DEBUGGING
     debugp(stderr,"\ncaught signal, throwing exception %d, ip=%p rp=%p\n",      debugp(stderr,"\ncaught signal, throwing exception %d, ip=%p rp=%p\n",
               throw_code, saved_ip, rp);                throw_code, saved_ip, rp);
     if (rp <= orig_rp0 && rp > (Cell *)(image_header->return_stack_base+5)) {      if ((rp > NEXTPAGE2(gforth_UP->sp0)) &&
           (rp < NEXTPAGE(gforth_UP->rp0))) {
       /* no rstack overflow or underflow */        /* no rstack overflow or underflow */
       rp0 = rp;        gforth_RP = rp;
       *--rp0 = (Cell)saved_ip;        *--gforth_RP = (Cell)saved_ip;
     }      }
     else /* I love non-syntactic ifdefs :-) */      else /* I love non-syntactic ifdefs :-) */
       rp0 = signal_return_stack+16;        gforth_RP = signal_return_stack+16;
 #else  /* !defined(GFORTH_DEBUGGING) */  #else  /* !defined(GFORTH_DEBUGGING) */
     debugp(stderr,"\ncaught signal, throwing exception %d\n", throw_code);      debugp(stderr,"\ncaught signal, throwing exception %d\n", throw_code);
       rp0 = signal_return_stack+16;      gforth_RP = signal_return_stack+16;
 #endif /* !defined(GFORTH_DEBUGGING) */  #endif /* !defined(GFORTH_DEBUGGING) */
     /* fprintf(stderr, "rp=$%x\n",rp0);*/      /* fprintf(stderr, "rp=$%x\n",rp0);*/
   
     return((int)(Cell)gforth_engine(image_header->throw_entry, signal_data_stack+15,      ip0=gforth_header->throw_entry;
                        rp0, signal_fp_stack, 0 sr_call));      gforth_SP=signal_data_stack+15;
       gforth_FP=signal_fp_stack;
   }    }
 #endif  #endif
   
   return((int)(Cell)gforth_engine(ip0,sp0,rp0,fp0,lp0 sr_call));    return((Cell)gforth_engine(ip0 sr_call));
 }  }
   
 #if !defined(INCLUDE_IMAGE) && !defined(STANDALONE)  #if !defined(INCLUDE_IMAGE) && !defined(STANDALONE)
Line 861 
Line 817 
        significant space so we only do it if the user explicitly         significant space so we only do it if the user explicitly
        disables state equivalence. */         disables state equivalence. */
     debugp(stderr, "Disabling tpa-automaton, because nsupers>0 and state equivalence is enabled.\n");      debugp(stderr, "Disabling tpa-automaton, because nsupers>0 and state equivalence is enabled.\n");
     tpa_noautomaton = true;      tpa_noautomaton = 1;
   }    }
 }  }
   
Line 942 
Line 898 
 #ifndef NO_DYNAMIC  #ifndef NO_DYNAMIC
   if (no_dynamic)    if (no_dynamic)
     return;      return;
   symbols2=gforth_engine2(0,0,0,0,0 sr_call);    symbols2=gforth_engine2(0 sr_call);
 #if NO_IP  #if NO_IP
   symbols3=gforth_engine3(0,0,0,0,0 sr_call);    symbols3=gforth_engine3(0 sr_call);
 #else  #else
   symbols3=symbols1;    symbols3=symbols1;
 #endif  #endif
Line 1029 
Line 985 
       nonrelocs++;        nonrelocs++;
       continue;        continue;
     }      }
       if (CHECK_PRIM(s1, prim_len)) {
   #ifndef BURG_FORMAT
         debugp(stderr,"\n   non_reloc: architecture specific check failed\n");
   #endif
         pi->start = NULL; /* not relocatable */
         relocs--;
         nonrelocs++;
         continue;
       }
     assert(pi->length>=0);      assert(pi->length>=0);
     assert(pi->restlength >=0);      assert(pi->restlength >=0);
     while (j<(pi->length+pi->restlength)) {      while (j<(pi->length+pi->restlength)) {
Line 1053 
Line 1018 
           ia->rel=0;            ia->rel=0;
           debugp(stderr,"\n   absolute immarg: offset %3d",j);            debugp(stderr,"\n   absolute immarg: offset %3d",j);
         } else if ((&(s1[j]))+(*(Cell *)&(s1[j]))+4 ==          } else if ((&(s1[j]))+(*(Cell *)&(s1[j]))+4 ==
                    symbols1[DOESJUMP+1]) {                     symbols1[DOER_MAX+1]) {
           ia->rel=1;            ia->rel=1;
           debugp(stderr,"\n   relative immarg: offset %3d",j);            debugp(stderr,"\n   relative immarg: offset %3d",j);
         } else {          } else {
Line 1072 
Line 1037 
     debugp(stderr,"\n");      debugp(stderr,"\n");
   }    }
   decomp_prims = calloc(i,sizeof(PrimInfo *));    decomp_prims = calloc(i,sizeof(PrimInfo *));
   for (i=DOESJUMP+1; i<npriminfos; i++)    for (i=DOER_MAX+1; i<npriminfos; i++)
     decomp_prims[i] = &(priminfos[i]);      decomp_prims[i] = &(priminfos[i]);
   qsort(decomp_prims+DOESJUMP+1, npriminfos-DOESJUMP-1, sizeof(PrimInfo *),    qsort(decomp_prims+DOER_MAX+1, npriminfos-DOER_MAX-1, sizeof(PrimInfo *),
         compare_priminfo_length);          compare_priminfo_length);
 #endif  #endif
 }  }
Line 1083 
Line 1048 
 {  {
 #ifndef NO_DYNAMIC  #ifndef NO_DYNAMIC
   if (start_flush)    if (start_flush)
     FLUSH_ICACHE(start_flush, code_here-start_flush);      FLUSH_ICACHE((caddr_t)start_flush, code_here-start_flush);
   start_flush=code_here;    start_flush=code_here;
 #endif  #endif
 }  }
Line 1134 
Line 1099 
   Cell size;    Cell size;
 } *code_block_list=NULL, **next_code_blockp=&code_block_list;  } *code_block_list=NULL, **next_code_blockp=&code_block_list;
   
 static Address append_prim(Cell p)  static void reserve_code_space(UCell size)
 {  {
   PrimInfo *pi = &priminfos[p];    if (code_area+code_area_size < code_here+size) {
   Address old_code_here = code_here;  
   
   if (code_area+code_area_size < code_here+pi->length+pi->restlength+goto_len+CODE_ALIGNMENT) {  
     struct code_block_list *p;      struct code_block_list *p;
     append_jump();      append_jump();
       debugp(stderr,"Did not use %ld bytes in code block\n",
              (long)(code_area+code_area_size-code_here));
     flush_to_here();      flush_to_here();
     if (*next_code_blockp == NULL) {      if (*next_code_blockp == NULL) {
       code_here = start_flush = code_area = gforth_alloc(code_area_size);        code_here = start_flush = code_area = gforth_alloc(code_area_size);
Line 1154 
Line 1118 
       p = *next_code_blockp;        p = *next_code_blockp;
       code_here = start_flush = code_area = p->block;        code_here = start_flush = code_area = p->block;
     }      }
     old_code_here = code_here;  
     next_code_blockp = &(p->next);      next_code_blockp = &(p->next);
   }    }
   }
   
   static Address append_prim(Cell p)
   {
     PrimInfo *pi = &priminfos[p];
     Address old_code_here;
     reserve_code_space(pi->length+pi->restlength+goto_len+CODE_ALIGNMENT-1);
   memcpy(code_here, pi->start, pi->length);    memcpy(code_here, pi->start, pi->length);
     old_code_here = code_here;
   code_here += pi->length;    code_here += pi->length;
   return old_code_here;    return old_code_here;
 }  }
   
   static void reserve_code_super(PrimNum origs[], int ninsts)
   {
     int i;
     UCell size = CODE_ALIGNMENT-1; /* alignment may happen first */
     if (no_dynamic)
       return;
     /* use size of the original primitives as an upper bound for the
        size of the superinstruction.  !! This is only safe if we
        optimize for code size (the default) */
     for (i=0; i<ninsts; i++) {
       PrimNum p = origs[i];
       PrimInfo *pi = &priminfos[p];
       if (is_relocatable(p))
         size += pi->length;
       else
         if (i>0)
           size += priminfos[origs[i-1]].restlength+goto_len+CODE_ALIGNMENT-1;
     }
     size += priminfos[origs[i-1]].restlength+goto_len;
     reserve_code_space(size);
   }
 #endif  #endif
   
 int forget_dyncode(Address code)  int forget_dyncode(Address code)
Line 1215 
Line 1208 
       break;        break;
   }    }
   /* reverse order because NOOP might match other prims */    /* reverse order because NOOP might match other prims */
   for (i=npriminfos-1; i>DOESJUMP; i--) {    for (i=npriminfos-1; i>DOER_MAX; i--) {
     PrimInfo *pi=decomp_prims[i];      PrimInfo *pi=decomp_prims[i];
     if (pi->start==code || (pi->start && memcmp(code,pi->start,pi->length)==0))      if (pi->start==code || (pi->start && memcmp(code,pi->start,pi->length)==0))
       return vm_prims[super2[super_costs[pi-priminfos].offset]];        return vm_prims[super2[super_costs[pi-priminfos].offset]];
Line 1567 
Line 1560 
 static void tpa_state_normalize(struct tpa_state *t)  static void tpa_state_normalize(struct tpa_state *t)
 {  {
   /* normalize so cost of canonical state=0; this may result in    /* normalize so cost of canonical state=0; this may result in
      negative states for some states */       negative costs for some states */
   int d = t->inst[CANONICAL_STATE].cost;    int d = t->inst[CANONICAL_STATE].cost;
   int i;    int i;
   
Line 1639 
Line 1632 
   int i,j;    int i,j;
   struct tpa_state *ts[ninsts+1];    struct tpa_state *ts[ninsts+1];
   int nextdyn, nextstate, no_transition;    int nextdyn, nextstate, no_transition;
     Address old_code_area;
   
   lb_basic_blocks++;    lb_basic_blocks++;
   ts[ninsts] = termstate;    ts[ninsts] = termstate;
Line 1701 
Line 1695 
     }      }
   }    }
   /* now rewrite the instructions */    /* now rewrite the instructions */
     reserve_code_super(origs,ninsts);
     old_code_area = code_area;
   nextdyn=0;    nextdyn=0;
   nextstate=CANONICAL_STATE;    nextstate=CANONICAL_STATE;
   no_transition = ((!ts[0]->trans[nextstate].relocatable)    no_transition = ((!ts[0]->trans[nextstate].relocatable)
Line 1754 
Line 1750 
     nextstate = c->state_out;      nextstate = c->state_out;
   }    }
   assert(nextstate==CANONICAL_STATE);    assert(nextstate==CANONICAL_STATE);
     assert(code_area==old_code_area); /* does reserve_code_super() work? */
 }  }
 #endif  #endif
   
Line 1767 
Line 1764 
   if (start==NULL)    if (start==NULL)
     return;      return;
   prim = (Label)*start;    prim = (Label)*start;
   if (prim<((Label)(xts+DOESJUMP)) || prim>((Label)(xts+npriminfos))) {    if (prim<((Label)(xts+DOER_MAX)) || prim>((Label)(xts+npriminfos))) {
     fprintf(stderr,"compile_prim encountered xt %p\n", prim);      fprintf(stderr,"compile_prim encountered xt %p\n", prim);
     *start=(Cell)prim;      *start=(Cell)prim;
     return;      return;
Line 1778 
Line 1775 
 #elif defined(INDIRECT_THREADED)  #elif defined(INDIRECT_THREADED)
   return;    return;
 #else /* !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED)) */  #else /* !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED)) */
   /* !! does not work, for unknown reasons; but something like this is  
      probably needed to ensure that we don't call compile_prim_dyn  
      before the inline arguments are there */  
   static Cell *instps[MAX_BB];    static Cell *instps[MAX_BB];
   static PrimNum origs[MAX_BB];    static PrimNum origs[MAX_BB];
   static int ninsts=0;    static int ninsts=0;
Line 1799 
Line 1793 
   }    }
   prim_num = ((Xt)*start)-vm_prims;    prim_num = ((Xt)*start)-vm_prims;
   if(prim_num >= npriminfos) {    if(prim_num >= npriminfos) {
       /* code word */
     optimize_rewrite(instps,origs,ninsts);      optimize_rewrite(instps,origs,ninsts);
     /* fprintf(stderr,"optimize_rewrite(...,%d)\n",ninsts);*/      /* fprintf(stderr,"optimize_rewrite(...,%d)\n",ninsts);*/
     ninsts=0;      ninsts=0;
       append_jump();
       *start = *(Cell *)*start;
     return;      return;
   }    }
   assert(ninsts<MAX_BB);    assert(ninsts<MAX_BB);
Line 1811 
Line 1808 
 #endif /* !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED)) */  #endif /* !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED)) */
 }  }
   
   void gforth_init()
   {
   #if 0 && defined(__i386)
     /* disabled because the drawbacks may be worse than the benefits */
     /* set 387 precision control to use 53-bit mantissae to avoid most
        cases of double rounding */
     short fpu_control = 0x027f ;
     asm("fldcw %0" : : "m"(fpu_control));
   #endif /* defined(__i386) */
   
   #ifdef MACOSX_DEPLOYMENT_TARGET
     setenv("MACOSX_DEPLOYMENT_TARGET", MACOSX_DEPLOYMENT_TARGET, 0);
   #endif
   #ifdef LTDL_LIBRARY_PATH
     setenv("LTDL_LIBRARY_PATH", LTDL_LIBRARY_PATH, 0);
   #endif
   #ifndef STANDALONE
     /* buffering of the user output device */
   #ifdef _IONBF
     if (isatty(fileno(stdout))) {
       fflush(stdout);
       setvbuf(stdout,NULL,_IONBF,0);
     }
   #endif
     setlocale(LC_ALL, "");
     setlocale(LC_NUMERIC, "C");
   #else
     prep_terminal();
   #endif
   
 #ifndef STANDALONE  #ifndef STANDALONE
 Address gforth_loader(FILE *imagefile, char* filename)  #ifdef HAVE_LIBLTDL
     if (lt_dlinit()!=0) {
       fprintf(stderr,"%s: lt_dlinit failed", progname);
       exit(1);
     }
   #endif
   #ifdef HAS_OS
   #ifndef NO_DYNAMIC
     init_ss_cost();
   #endif /* !defined(NO_DYNAMIC) */
   #endif /* defined(HAS_OS) */
   #endif
     code_here = ((void *)0)+code_area_size;
   
     get_winsize();
   
     install_signal_handlers(); /* right place? */
   }
   
   /* pointer to last '/' or '\' in file, 0 if there is none. */
   static char *onlypath(char *filename)
   {
     return strrchr(filename, DIRSEP);
   }
   
   static FILE *openimage(char *fullfilename)
   {
     FILE *image_file;
     char * expfilename = tilde_cstr((Char *)fullfilename, strlen(fullfilename));
   
     image_file=fopen(expfilename,"rb");
     if (image_file!=NULL && debug)
       fprintf(stderr, "Opened image file: %s\n", expfilename);
     free(expfilename);
     return image_file;
   }
   
   /* try to open image file concat(path[0:len],imagename) */
   static FILE *checkimage(char *path, int len, char *imagename)
   {
     int dirlen=len;
     char fullfilename[dirlen+strlen((char *)imagename)+2];
   
     memcpy(fullfilename, path, dirlen);
     if (fullfilename[dirlen-1]!=DIRSEP)
       fullfilename[dirlen++]=DIRSEP;
     strcpy(fullfilename+dirlen,imagename);
     return openimage(fullfilename);
   }
   
   static FILE * open_image_file(char * imagename, char * path)
   {
     FILE * image_file=NULL;
     char *origpath=path;
   
     if(strchr(imagename, DIRSEP)==NULL) {
       /* first check the directory where the exe file is in !! 01may97jaw */
       if (onlypath(progname))
         image_file=checkimage(progname, onlypath(progname)-progname, imagename);
       if (!image_file)
         do {
           char *pend=strchr(path, PATHSEP);
           if (pend==NULL)
             pend=path+strlen(path);
           if (strlen(path)==0) break;
           image_file=checkimage(path, pend-path, imagename);
           path=pend+(*pend==PATHSEP);
         } while (image_file==NULL);
     } else {
       image_file=openimage(imagename);
     }
   
     if (!image_file) {
       fprintf(stderr,"%s: cannot open image file %s in path %s for reading\n",
               progname, imagename, origpath);
       exit(1);
     }
   
     return image_file;
   }
   
   #ifdef STANDALONE
   Address gforth_loader(char* imagename, char* path)
   {
     gforth_init();
     return gforth_engine(0 sr_call);
   }
   #else
   Address gforth_loader(char* imagename, char* path)
 /* returns the address of the image proper (after the preamble) */  /* returns the address of the image proper (after the preamble) */
 {  {
   ImageHeader header;    ImageHeader header;
Line 1839 
Line 1954 
        1         1
 #endif  #endif
     ;      ;
     FILE* imagefile=open_image_file(imagename, path);
   
     gforth_init();
   
   vm_prims = gforth_engine(0,0,0,0,0 sr_call);    vm_prims = gforth_engine(0 sr_call);
   check_prims(vm_prims);    check_prims(vm_prims);
   prepare_super_table();    prepare_super_table();
 #ifndef DOUBLY_INDIRECT  #ifndef DOUBLY_INDIRECT
Line 1857 
Line 1975 
   
   do {    do {
     if(fread(magic,sizeof(Char),8,imagefile) < 8) {      if(fread(magic,sizeof(Char),8,imagefile) < 8) {
       fprintf(stderr,"%s: image %s doesn't seem to be a Gforth (>=0.6) image.\n",        fprintf(stderr,"%s: image %s doesn't seem to be a Gforth (>=0.8) image.\n",
               progname, filename);                progname, imagename);
       exit(1);        exit(1);
     }      }
     preamblesize+=8;      preamblesize+=8;
   } while(memcmp(magic,"Gforth3",7));    } while(memcmp(magic,"Gforth4",7));
   magic7 = magic[7];    magic7 = magic[7];
   if (debug) {    if (debug) {
     magic[7]='\0';      magic[7]='\0';
Line 1893 
Line 2011 
   debugp(stderr,"pagesize=%ld\n",(unsigned long) pagesize);    debugp(stderr,"pagesize=%ld\n",(unsigned long) pagesize);
   
   image = dict_alloc_read(imagefile, preamblesize+header.image_size,    image = dict_alloc_read(imagefile, preamblesize+header.image_size,
                           preamblesize+dictsize, data_offset);                            dictsize, data_offset);
   imp=image+preamblesize;    imp=image+preamblesize;
   
   alloc_stacks((ImageHeader *)imp);  
   if (clear_dictionary)    if (clear_dictionary)
     memset(imp+header.image_size, 0, dictsize-header.image_size);      memset(imp+header.image_size, 0, dictsize-header.image_size-preamblesize);
   if(header.base==0 || header.base  == (Address)0x100) {    if(header.base==0 || header.base  == (Address)0x100) {
     Cell reloc_size=((header.image_size-1)/sizeof(Cell))/8+1;      Cell reloc_size=((header.image_size-1)/sizeof(Cell))/8+1;
     Char reloc_bits[reloc_size];      Char reloc_bits[reloc_size];
Line 1914 
Line 2031 
 #endif  #endif
   }    }
   else if(header.base!=imp) {    else if(header.base!=imp) {
     fprintf(stderr,"%s: Cannot load nonrelocatable image (compiled for address $%lx) at address $%lx\n",      fprintf(stderr,"%s: Cannot load nonrelocatable image (compiled for address %p) at address %p\n",
             progname, (unsigned long)header.base, (unsigned long)imp);              progname, header.base, imp);
     exit(1);      exit(1);
   }    }
   if (header.checksum==0)    if (header.checksum==0)
     ((ImageHeader *)imp)->checksum=check_sum;      ((ImageHeader *)imp)->checksum=check_sum;
   else if (header.checksum != check_sum) {    else if (header.checksum != check_sum) {
     fprintf(stderr,"%s: Checksum of image ($%lx) does not match the executable ($%lx)\n",      fprintf(stderr,"%s: Checksum of image ($%lx) does not match the executable ($%lx)\n",
             progname, (unsigned long)(header.checksum),(unsigned long)check_sum);              progname, header.checksum, check_sum);
     exit(1);      exit(1);
   }    }
 #ifdef DOUBLY_INDIRECT  #ifdef DOUBLY_INDIRECT
Line 1936 
Line 2053 
   return imp;    return imp;
 }  }
 #endif  #endif
   
 /* pointer to last '/' or '\' in file, 0 if there is none. */  
 static char *onlypath(char *filename)  
 {  
   return strrchr(filename, DIRSEP);  
 }  
   
 static FILE *openimage(char *fullfilename)  
 {  
   FILE *image_file;  
   char * expfilename = tilde_cstr((Char *)fullfilename, strlen(fullfilename), 1);  
   
   image_file=fopen(expfilename,"rb");  
   if (image_file!=NULL && debug)  
     fprintf(stderr, "Opened image file: %s\n", expfilename);  
   return image_file;  
 }  
   
 /* try to open image file concat(path[0:len],imagename) */  
 static FILE *checkimage(char *path, int len, char *imagename)  
 {  
   int dirlen=len;  
   char fullfilename[dirlen+strlen((char *)imagename)+2];  
   
   memcpy(fullfilename, path, dirlen);  
   if (fullfilename[dirlen-1]!=DIRSEP)  
     fullfilename[dirlen++]=DIRSEP;  
   strcpy(fullfilename+dirlen,imagename);  
   return openimage(fullfilename);  
 }  
   
 static FILE * open_image_file(char * imagename, char * path)  
 {  
   FILE * image_file=NULL;  
   char *origpath=path;  
   
   if(strchr(imagename, DIRSEP)==NULL) {  
     /* first check the directory where the exe file is in !! 01may97jaw */  
     if (onlypath(progname))  
       image_file=checkimage(progname, onlypath(progname)-progname, imagename);  
     if (!image_file)  
       do {  
         char *pend=strchr(path, PATHSEP);  
         if (pend==NULL)  
           pend=path+strlen(path);  
         if (strlen(path)==0) break;  
         image_file=checkimage(path, pend-path, imagename);  
         path=pend+(*pend==PATHSEP);  
       } while (image_file==NULL);  
   } else {  
     image_file=openimage(imagename);  
   }  
   
   if (!image_file) {  
     fprintf(stderr,"%s: cannot open image file %s in path %s for reading\n",  
             progname, imagename, origpath);  
     exit(1);  
   }  
   
   return image_file;  
 }  
 #endif  #endif
   
 #ifdef STANDALONE_ALLOC  #ifdef STANDALONE_ALLOC
Line 2009 
Line 2065 
     exit(1);      exit(1);
   }    }
   r = (Address)((((Cell)r)+(sizeof(Float)-1))&(-sizeof(Float)));    r = (Address)((((Cell)r)+(sizeof(Float)-1))&(-sizeof(Float)));
   debugp(stderr, "malloc succeeds, address=$%lx\n", (long)r);    debugp(stderr, "malloc succeeds, address=%p\n", r);
   return r;    return r;
 }  }
 #endif  #endif
Line 2056 
Line 2112 
   ss_min_ls,    ss_min_ls,
   ss_min_lsu,    ss_min_lsu,
   ss_min_nexts,    ss_min_nexts,
     opt_code_block_size,
 };  };
   
 #ifndef STANDALONE  static void print_diag()
   {
   
   #if !defined(HAVE_GETRUSAGE)
     fprintf(stderr, "*** missing functionality ***\n"
   #ifndef HAVE_GETRUSAGE
             "    no getrusage -> CPUTIME broken\n"
   #endif
             );
   #endif
     if((relocs < nonrelocs) ||
   #if defined(BUGGY_LL_CMP) || defined(BUGGY_LL_MUL) || defined(BUGGY_LL_DIV) || defined(BUGGY_LL_ADD) || defined(BUGGY_LL_SHIFT) || defined(BUGGY_LL_D2F) || defined(BUGGY_LL_F2D)
        1
   #else
        0
   #endif
        )
       debugp(stderr, "relocs: %d:%d\n", relocs, nonrelocs);
       fprintf(stderr, "*** %sperformance problems ***\n%s%s",
   #if defined(BUGGY_LL_CMP) || defined(BUGGY_LL_MUL) || defined(BUGGY_LL_DIV) || defined(BUGGY_LL_ADD) || defined(BUGGY_LL_SHIFT) || defined(BUGGY_LL_D2F) || defined(BUGGY_LL_F2D) || !(defined(FORCE_REG) || defined(FORCE_REG_UNNECESSARY)) || defined(BUGGY_LONG_LONG)
               "",
   #else
               "no ",
   #endif
   #if defined(BUGGY_LL_CMP) || defined(BUGGY_LL_MUL) || defined(BUGGY_LL_DIV) || defined(BUGGY_LL_ADD) || defined(BUGGY_LL_SHIFT) || defined(BUGGY_LL_D2F) || defined(BUGGY_LL_F2D)
               "    double-cell integer type buggy ->\n        "
   #ifdef BUGGY_LL_CMP
               "double comparisons, "
   #endif
   #ifdef BUGGY_LL_MUL
               "*/MOD */ M* UM* "
   #endif
   #ifdef BUGGY_LL_DIV
               /* currently nothing is affected */
   #endif
   #ifdef BUGGY_LL_ADD
               "M+ D+ D- DNEGATE "
   #endif
   #ifdef BUGGY_LL_SHIFT
               "D2/ "
   #endif
   #ifdef BUGGY_LL_D2F
               "D>F "
   #endif
   #ifdef BUGGY_LL_F2D
               "F>D "
   #endif
               "\b\b slow\n"
   #endif
   #if !(defined(FORCE_REG) || defined(FORCE_REG_UNNECESSARY))
               "    automatic register allocation: performance degradation possible\n"
   #endif
               "",
               (relocs < nonrelocs) ? "no dynamic code generation (--debug for details) -> factor 2 slowdown\n" : "");
   }
   
   #ifdef STANDALONE
   void gforth_args(int argc, char ** argv, char ** path, char ** imagename)
   {
   #ifdef HAS_OS
     *path = getenv("GFORTHPATH") ? : DEFAULTPATH;
   #else
     *path = DEFAULTPATH;
   #endif
     *imagename="gforth.fi";
   }
   #else
 void gforth_args(int argc, char ** argv, char ** path, char ** imagename)  void gforth_args(int argc, char ** argv, char ** path, char ** imagename)
 {  {
   int c;    int c;
   #ifdef HAS_OS
     *path = getenv("GFORTHPATH") ? : DEFAULTPATH;
   #else
     *path = DEFAULTPATH;
   #endif
     *imagename="gforth.fi";
     progname = argv[0];
   
   opterr=0;    opterr=0;
   while (1) {    while (1) {
Line 2083 
Line 2213 
       {"no-offset-im", no_argument, &offset_image, 0},        {"no-offset-im", no_argument, &offset_image, 0},
       {"clear-dictionary", no_argument, &clear_dictionary, 1},        {"clear-dictionary", no_argument, &clear_dictionary, 1},
       {"debug", no_argument, &debug, 1},        {"debug", no_argument, &debug, 1},
       {"diag", no_argument, &diag, 1},        {"diag", no_argument, NULL, 'D'},
       {"die-on-signal", no_argument, &die_on_signal, 1},        {"die-on-signal", no_argument, &die_on_signal, 1},
       {"ignore-async-signals", no_argument, &ignore_async_signals, 1},        {"ignore-async-signals", no_argument, &ignore_async_signals, 1},
       {"no-super", no_argument, &no_super, 1},        {"no-super", no_argument, &no_super, 1},
       {"no-dynamic", no_argument, &no_dynamic, 1},        {"no-dynamic", no_argument, &no_dynamic, 1},
       {"dynamic", no_argument, &no_dynamic, 0},        {"dynamic", no_argument, &no_dynamic, 0},
         {"code-block-size", required_argument, NULL, opt_code_block_size},
       {"print-metrics", no_argument, &print_metrics, 1},        {"print-metrics", no_argument, &print_metrics, 1},
       {"print-sequences", no_argument, &print_sequences, 1},        {"print-sequences", no_argument, &print_sequences, 1},
       {"ss-number", required_argument, NULL, ss_number},        {"ss-number", required_argument, NULL, ss_number},
Line 2107 
Line 2238 
       /* no-init-file, no-rc? */        /* no-init-file, no-rc? */
     };      };
   
     c = getopt_long(argc, argv, "+i:m:d:r:f:l:p:vhoncsx", opts, &option_index);      c = getopt_long(argc, argv, "+i:m:d:r:f:l:p:vhoncsxD", opts, &option_index);
   
     switch (c) {      switch (c) {
     case EOF: return;      case EOF: return;
Line 2125 
Line 2256 
     case 'c': clear_dictionary = 1; break;      case 'c': clear_dictionary = 1; break;
     case 's': die_on_signal = 1; break;      case 's': die_on_signal = 1; break;
     case 'x': debug = 1; break;      case 'x': debug = 1; break;
       case 'D': print_diag(); break;
     case 'v': fputs(PACKAGE_STRING"\n", stderr); exit(0);      case 'v': fputs(PACKAGE_STRING"\n", stderr); exit(0);
       case opt_code_block_size: code_area_size = atoi(optarg); break;
     case ss_number: static_super_number = atoi(optarg); break;      case ss_number: static_super_number = atoi(optarg); break;
     case ss_states: maxstates = max(min(atoi(optarg),MAX_STATE),1); break;      case ss_states: maxstates = max(min(atoi(optarg),MAX_STATE),1); break;
 #ifndef NO_DYNAMIC  #ifndef NO_DYNAMIC
Line 2139 
Line 2272 
 Engine Options:\n\  Engine Options:\n\
   --appl-image FILE                 Equivalent to '--image-file=FILE --'\n\    --appl-image FILE                 Equivalent to '--image-file=FILE --'\n\
   --clear-dictionary                Initialize the dictionary with 0 bytes\n\    --clear-dictionary                Initialize the dictionary with 0 bytes\n\
     --code-block-size=SIZE            size of native code blocks [512KB]\n\
   -d SIZE, --data-stack-size=SIZE   Specify data stack size\n\    -d SIZE, --data-stack-size=SIZE   Specify data stack size\n\
   --debug                           Print debugging information during startup\n\    --debug                           Print debugging information during startup\n\
   --diag                            Print diagnostic information during startup\n\    -D, --diag                        Print diagnostic information during startup\n\
   --die-on-signal                   Exit instead of THROWing some signals\n\    --die-on-signal                   Exit instead of THROWing some signals\n\
   --dynamic                         Use dynamic native code\n\    --dynamic                         Use dynamic native code\n\
   -f SIZE, --fp-stack-size=SIZE     Specify floating point stack size\n\    -f SIZE, --fp-stack-size=SIZE     Specify floating point stack size\n\
Line 2181 
Line 2315 
 #endif  #endif
 #endif  #endif
   
 static void print_diag()  
 {  
   
 #if !defined(HAVE_GETRUSAGE)  
   fprintf(stderr, "*** missing functionality ***\n"  
 #ifndef HAVE_GETRUSAGE  
           "    no getrusage -> CPUTIME broken\n"  
 #endif  
           );  
 #endif  
   if((relocs < nonrelocs) ||  
 #if defined(BUGGY_LL_CMP) || defined(BUGGY_LL_MUL) || defined(BUGGY_LL_DIV) || defined(BUGGY_LL_ADD) || defined(BUGGY_LL_SHIFT) || defined(BUGGY_LL_D2F) || defined(BUGGY_LL_F2D)  
      1  
 #else  
      0  
 #endif  
      )  
     debugp(stderr, "relocs: %d:%d\n", relocs, nonrelocs);  
     fprintf(stderr, "*** %sperformance problems ***\n%s%s",  
 #if defined(BUGGY_LL_CMP) || defined(BUGGY_LL_MUL) || defined(BUGGY_LL_DIV) || defined(BUGGY_LL_ADD) || defined(BUGGY_LL_SHIFT) || defined(BUGGY_LL_D2F) || defined(BUGGY_LL_F2D) || !(defined(FORCE_REG) || defined(FORCE_REG_UNNECESSARY)) || defined(BUGGY_LONG_LONG)  
             "",  
 #else  
             "no ",  
 #endif  
 #if defined(BUGGY_LL_CMP) || defined(BUGGY_LL_MUL) || defined(BUGGY_LL_DIV) || defined(BUGGY_LL_ADD) || defined(BUGGY_LL_SHIFT) || defined(BUGGY_LL_D2F) || defined(BUGGY_LL_F2D)  
             "    double-cell integer type buggy ->\n        "  
 #ifdef BUGGY_LL_CMP  
             "CMP, "  
 #endif  
 #ifdef BUGGY_LL_MUL  
             "MUL, "  
 #endif  
 #ifdef BUGGY_LL_DIV  
             "DIV, "  
 #endif  
 #ifdef BUGGY_LL_ADD  
             "ADD, "  
 #endif  
 #ifdef BUGGY_LL_SHIFT  
             "SHIFT, "  
 #endif  
 #ifdef BUGGY_LL_D2F  
             "D2F, "  
 #endif  
 #ifdef BUGGY_LL_F2D  
             "F2D, "  
 #endif  
             "\b\b slow\n"  
 #endif  
 #if !(defined(FORCE_REG) || defined(FORCE_REG_UNNECESSARY))  
             "    automatic register allocation: performance degradation possible\n"  
 #endif  
             "",  
             (relocs < nonrelocs) ? "no dynamic code generation (--debug for details) -> factor 2 slowdown\n" : "");  
 }  
   
 #ifdef STANDALONE  #ifdef STANDALONE
 Cell data_abort_pc;  Cell data_abort_pc;
   
Line 2247 
Line 2325 
 }  }
 #endif  #endif
   
 int main(int argc, char **argv, char **env)  void* gforth_pointers(Cell n)
 {  {
 #ifdef HAS_OS    switch(n) {
   char *path = getenv("GFORTHPATH") ? : DEFAULTPATH;    case 0: return (void*)&gforth_SP;
 #else    case 1: return (void*)&gforth_FP;
   char *path = DEFAULTPATH;    case 2: return (void*)&gforth_LP;
 #endif    case 3: return (void*)&gforth_RP;
 #ifndef INCLUDE_IMAGE    case 4: return (void*)&gforth_UP;
   char *imagename="gforth.fi";    case 5: return (void*)&gforth_engine;
   FILE *image_file;  #ifdef HAS_FILE
   Address image;    case 6: return (void*)&cstr;
     case 7: return (void*)&tilde_cstr;
 #endif  #endif
   int retvalue;    case 8: return (void*)&throw_jmp_handler;
     case 9: return (void*)&gforth_stacks;
 #ifndef STANDALONE    default: return NULL;
   /* buffering of the user output device */  
 #ifdef _IONBF  
   if (isatty(fileno(stdout))) {  
     fflush(stdout);  
     setvbuf(stdout,NULL,_IONBF,0);  
   }    }
 #endif  
 #else  
   prep_terminal();  
 #endif  
   
   progname = argv[0];  
   
 #ifndef STANDALONE  
   if (lt_dlinit()!=0) {  
     fprintf(stderr,"%s: lt_dlinit failed", progname);  
     exit(1);  
   }    }
   
 #ifdef HAS_OS  void gforth_printmetrics()
   gforth_args(argc, argv, &path, &imagename);  
 #ifndef NO_DYNAMIC  
   init_ss_cost();  
 #endif /* !defined(NO_DYNAMIC) */  
 #endif /* defined(HAS_OS) */  
 #endif  
   
 #ifdef STANDALONE  
   image = gforth_engine(0, 0, 0, 0, 0 sr_call);  
   alloc_stacks((ImageHeader *)image);  
 #else  
   image_file = open_image_file(imagename, path);  
   image = gforth_loader(image_file, imagename);  
 #endif  
   gforth_header=(ImageHeader *)image; /* used in SIGSEGV handler */  
   
   if (diag)  
     print_diag();  
   {    {
     char path2[strlen(path)+1];  
     char *p1, *p2;  
     Cell environ[]= {  
       (Cell)argc-(optind-1),  
       (Cell)(argv+(optind-1)),  
       (Cell)strlen(path),  
       (Cell)path2};  
     argv[optind-1] = progname;  
     /*  
        for (i=0; i<environ[0]; i++)  
        printf("%s\n", ((char **)(environ[1]))[i]);  
        */  
     /* make path OS-independent by replacing path separators with NUL */  
     for (p1=path, p2=path2; *p1!='\0'; p1++, p2++)  
       if (*p1==PATHSEP)  
         *p2 = '\0';  
       else  
         *p2 = *p1;  
     *p2='\0';  
     retvalue = gforth_go(image, 4, environ);  
 #if defined(SIGPIPE) && !defined(STANDALONE)  
     bsd_signal(SIGPIPE, SIG_IGN);  
 #endif  
 #ifdef VM_PROFILING  
     vm_print_profile(stderr);  
 #endif  
     deprep_terminal();  
 #ifndef STANDALONE  
     if (lt_dlexit()!=0)  
       fprintf(stderr,"%s: lt_dlexit failed", progname);  
 #endif  
   }  
   if (print_metrics) {    if (print_metrics) {
     int i;      int i;
     fprintf(stderr, "code size = %8ld\n", dyncodesize());      fprintf(stderr, "code size = %8ld\n", dyncodesize());
Line 2354 
Line 2367 
     fprintf(stderr, "%ld %ld lb_states\n", lb_labeler_steps, lb_newstate_new);      fprintf(stderr, "%ld %ld lb_states\n", lb_labeler_steps, lb_newstate_new);
     fprintf(stderr, "%ld %ld lb_table_entries\n", lb_labeler_steps, lb_labeler_dynprog);      fprintf(stderr, "%ld %ld lb_table_entries\n", lb_labeler_steps, lb_labeler_dynprog);
   }    }
   }
   
   void gforth_cleanup()
   {
   #if defined(SIGPIPE) && !defined(STANDALONE)
     bsd_signal(SIGPIPE, SIG_IGN);
   #endif
   #ifdef VM_PROFILING
     vm_print_profile(stderr);
   #endif
     deprep_terminal();
   #ifndef STANDALONE
   #ifdef HAVE_LIBLTDL
     if (lt_dlexit()!=0)
       fprintf(stderr,"%s: lt_dlexit failed", progname);
   #endif
   #endif
   }
   
   user_area* gforth_stacks(Cell dsize, Cell rsize, Cell fsize, Cell lsize)
   {
   #ifdef SIGSTKSZ
     stack_t sigstack;
     int sas_retval=-1;
   #endif
     size_t totalsize;
     Cell a;
     user_area * up0;
     Cell dsizep = wholepage(dsize);
     Cell rsizep = wholepage(rsize);
     Cell fsizep = wholepage(fsize);
     Cell lsizep = wholepage(lsize);
     totalsize = dsizep+fsizep+rsizep+lsizep+6*pagesize;
   #ifdef SIGSTKSZ
     totalsize += 2*SIGSTKSZ;
   #endif
     a = (Cell)alloc_mmap(totalsize);
     if (a != (Cell)MAP_FAILED) {
       up0=(user_area*)a; a+=pagesize;
       page_noaccess((void*)a); a+=pagesize; up0->sp0=a+dsize; a+=dsizep;
       page_noaccess((void*)a); a+=pagesize; up0->rp0=a+rsize; a+=rsizep;
       page_noaccess((void*)a); a+=pagesize; up0->fp0=a+fsize; a+=fsizep;
       page_noaccess((void*)a); a+=pagesize; up0->lp0=a+lsize; a+=lsizep;
       page_noaccess((void*)a); a+=pagesize;
   #ifdef SIGSTKSZ
       sigstack.ss_sp=(void*)a+SIGSTKSZ;
       sigstack.ss_size=SIGSTKSZ;
       sas_retval=sigaltstack(&sigstack,(stack_t *)0);
   #if defined(HAS_FILE) || !defined(STANDALONE)
       debugp(stderr,"sigaltstack: %s\n",strerror(sas_retval));
   #endif
   #endif
       return up0;
     }
     return 0;
   }
   
   void gforth_setstacks()
   {
     gforth_UP->next_task = NULL; /* mark user area as need-to-be-set */
   
     /* ensure that the cached elements (if any) are accessible */
   #if !(defined(GFORTH_DEBUGGING) || defined(INDIRECT_THREADED) || defined(DOUBLY_INDIRECT) || defined(VM_PROFILING))
     gforth_UP->sp0 -= 8; /* make stuff below bottom accessible for stack caching */
     gforth_UP->fp0--;
   #endif
   
     gforth_SP = gforth_UP->sp0;
     gforth_RP = gforth_UP->rp0;
     gforth_FP = gforth_UP->fp0;
     gforth_LP = gforth_UP->lp0;
   }
   
   int gforth_boot(int argc, char** argv, char* path)
   {
     char *path2=malloc(strlen(path)+1);
     char *p1, *p2;
   
     argv[optind-1] = progname;
   
     /* make path OS-independent by replacing path separators with NUL */
     for (p1=path, p2=path2; *p1!='\0'; p1++, p2++)
       if (*p1==PATHSEP)
         *p2 = '\0';
       else
         *p2 = *p1;
     *p2='\0';
   
     *--gforth_SP=(Cell)path2;
     *--gforth_SP=(Cell)strlen(path);
     *--gforth_SP=(Cell)(argv+(optind-1));
     *--gforth_SP=(Cell)(argc-(optind-1));
   
     debugp(stderr, "Booting Gforth: %p\n", gforth_header->boot_entry);
     return gforth_go(gforth_header->boot_entry);
   }
   
   int gforth_quit()
   {
     debugp(stderr, "Quit into Gforth: %p\n", gforth_header->quit_entry);
     return gforth_go(gforth_header->quit_entry);
   }
   
   int gforth_execute(Xt xt)
   {
     debugp(stderr, "Execute Gforth xt %p: %p\n", xt, gforth_header->execute_entry);
   
     *--gforth_SP = (Cell)xt;
   
     return gforth_go(gforth_header->execute_entry);
   }
   
   Xt gforth_find(Char * name)
   {
     Xt xt;
     debugp(stderr, "Find '%s' in Gforth: %p\n", name, gforth_header->find_entry);
   
     *--gforth_SP = (Cell)name;
     *--gforth_SP = strlen(name);
   
     xt = (Xt)gforth_go(gforth_header->find_entry);
     debugp(stderr, "Found %p\n", xt);
     return xt;
   }
   
   int gforth_start(int argc, char ** argv)
   {
     char *path, *imagename;
   
     gforth_args(argc, argv, &path, &imagename);
     gforth_header = gforth_loader(imagename, path);
     gforth_UP = gforth_stacks(dsize, rsize, fsize, lsize);
     gforth_setstacks();
     return gforth_boot(argc, argv, path);
   }
   
   int gforth_main(int argc, char **argv, char **env)
   {
     int retvalue=gforth_start(argc, argv);
   
     if(retvalue > 0) {
       gforth_execute(gforth_find("bootmessage"));
       retvalue = gforth_quit();
     }
     gforth_cleanup();
     gforth_printmetrics();
   
   return retvalue;    return retvalue;
 }  }

Generate output suitable for use with a patch program
Legend:
Removed from v.1.209  
changed lines
  Added in v.1.261
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help