Annotation of gforth/engine/main.c, revision 1.125

1.1       anton       1: /* command line interpretation, image loading etc. for Gforth
                      2: 
                      3: 
1.103     anton       4:   Copyright (C) 1995,1996,1997,1998,2000,2003 Free Software Foundation, Inc.
1.1       anton       5: 
                      6:   This file is part of Gforth.
                      7: 
                      8:   Gforth is free software; you can redistribute it and/or
                      9:   modify it under the terms of the GNU General Public License
                     10:   as published by the Free Software Foundation; either version 2
                     11:   of the License, or (at your option) any later version.
                     12: 
                     13:   This program is distributed in the hope that it will be useful,
                     14:   but WITHOUT ANY WARRANTY; without even the implied warranty of
                     15:   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     16:   GNU General Public License for more details.
                     17: 
                     18:   You should have received a copy of the GNU General Public License
                     19:   along with this program; if not, write to the Free Software
1.40      anton      20:   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
1.1       anton      21: */
                     22: 
                     23: #include "config.h"
1.82      anton      24: #include "forth.h"
1.1       anton      25: #include <errno.h>
                     26: #include <ctype.h>
                     27: #include <stdio.h>
1.2       pazsan     28: #include <unistd.h>
1.1       anton      29: #include <string.h>
                     30: #include <math.h>
                     31: #include <sys/types.h>
1.32      pazsan     32: #ifndef STANDALONE
1.1       anton      33: #include <sys/stat.h>
1.32      pazsan     34: #endif
1.1       anton      35: #include <fcntl.h>
                     36: #include <assert.h>
                     37: #include <stdlib.h>
1.102     anton      38: #include <signal.h>
1.11      pazsan     39: #ifndef STANDALONE
1.1       anton      40: #if HAVE_SYS_MMAN_H
                     41: #include <sys/mman.h>
                     42: #endif
1.11      pazsan     43: #endif
1.1       anton      44: #include "io.h"
                     45: #include "getopt.h"
1.11      pazsan     46: #ifdef STANDALONE
                     47: #include <systypes.h>
                     48: #endif
1.1       anton      49: 
1.121     anton      50: typedef enum prim_num {
1.119     anton      51: /* definitions of N_execute etc. */
                     52: #include "prim_num.i"
                     53:   N_START_SUPER
1.121     anton      54: } PrimNum;
1.119     anton      55: 
1.79      anton      56: /* global variables for engine.c 
                     57:    We put them here because engine.c is compiled several times in
                     58:    different ways for the same engine. */
                     59: Cell *SP;
                     60: Float *FP;
                     61: Address UP=NULL;
                     62: 
1.115     pazsan     63: #ifdef HAS_FFCALL
                     64: Cell *RP;
                     65: Address LP;
                     66: 
                     67: #include <callback.h>
                     68: 
                     69: va_alist clist;
                     70: 
1.116     pazsan     71: void engine_callback(Xt* fcall, void * alist)
1.115     pazsan     72: {
1.120     pazsan     73:   clist = (va_alist)alist;
1.115     pazsan     74:   engine(fcall, SP, RP, FP, LP);
                     75: }
                     76: #endif
                     77: 
1.79      anton      78: #ifdef GFORTH_DEBUGGING
                     79: /* define some VM registers as global variables, so they survive exceptions;
                     80:    global register variables are not up to the task (according to the 
                     81:    GNU C manual) */
                     82: Xt *saved_ip;
                     83: Cell *rp;
                     84: #endif
                     85: 
                     86: #ifdef NO_IP
                     87: Label next_code;
                     88: #endif
                     89: 
                     90: #ifdef HAS_FILE
                     91: char* fileattr[6]={"rb","rb","r+b","r+b","wb","wb"};
                     92: char* pfileattr[6]={"r","r","r+","r+","w","w"};
                     93: 
                     94: #ifndef O_BINARY
                     95: #define O_BINARY 0
                     96: #endif
                     97: #ifndef O_TEXT
                     98: #define O_TEXT 0
                     99: #endif
                    100: 
                    101: int ufileattr[6]= {
                    102:   O_RDONLY|O_BINARY, O_RDONLY|O_BINARY,
                    103:   O_RDWR  |O_BINARY, O_RDWR  |O_BINARY,
                    104:   O_WRONLY|O_BINARY, O_WRONLY|O_BINARY };
                    105: #endif
                    106: /* end global vars for engine.c */
                    107: 
1.1       anton     108: #define PRIM_VERSION 1
                    109: /* increment this whenever the primitives change in an incompatible way */
                    110: 
1.14      pazsan    111: #ifndef DEFAULTPATH
1.39      anton     112: #  define DEFAULTPATH "."
1.14      pazsan    113: #endif
                    114: 
1.1       anton     115: #ifdef MSDOS
                    116: jmp_buf throw_jmp_buf;
                    117: #endif
                    118: 
1.56      anton     119: #if defined(DOUBLY_INDIRECT)
                    120: #  define CFA(n)       ({Cell _n = (n); ((Cell)(((_n & 0x4000) ? symbols : xts)+(_n&~0x4000UL)));})
1.1       anton     121: #else
1.56      anton     122: #  define CFA(n)       ((Cell)(symbols+((n)&~0x4000UL)))
1.1       anton     123: #endif
                    124: 
                    125: #define maxaligned(n)  (typeof(n))((((Cell)n)+sizeof(Float)-1)&-sizeof(Float))
                    126: 
                    127: static UCell dictsize=0;
                    128: static UCell dsize=0;
                    129: static UCell rsize=0;
                    130: static UCell fsize=0;
                    131: static UCell lsize=0;
                    132: int offset_image=0;
1.4       anton     133: int die_on_signal=0;
1.13      pazsan    134: #ifndef INCLUDE_IMAGE
1.1       anton     135: static int clear_dictionary=0;
1.24      anton     136: UCell pagesize=1;
1.22      pazsan    137: char *progname;
                    138: #else
                    139: char *progname = "gforth";
                    140: int optind = 1;
1.13      pazsan    141: #endif
1.31      pazsan    142: 
1.97      anton     143: #define CODE_BLOCK_SIZE (256*1024)
1.48      anton     144: Address code_area=0;
1.73      anton     145: Cell code_area_size = CODE_BLOCK_SIZE;
1.75      anton     146: Address code_here=NULL+CODE_BLOCK_SIZE; /* does for code-area what HERE
                    147:                                           does for the dictionary */
1.100     anton     148: Address start_flush=NULL; /* start of unflushed code */
1.74      anton     149: Cell last_jump=0; /* if the last prim was compiled without jump, this
                    150:                      is it's number, otherwise this contains 0 */
1.48      anton     151: 
1.60      anton     152: static int no_super=0;   /* true if compile_prim should not fuse prims */
1.81      anton     153: static int no_dynamic=NO_DYNAMIC_DEFAULT; /* if true, no code is generated
                    154:                                             dynamically */
1.110     anton     155: static int print_metrics=0; /* if true, print metrics on exit */
1.109     anton     156: static int static_super_number = 10000000; /* number of ss used if available */
1.125   ! anton     157: #define MAX_STATE 4 /* maximum number of states */
        !           158: static int maxstates = MAX_STATE; /* number of states for stack caching */
1.110     anton     159: static int ss_greedy = 0; /* if true: use greedy, not optimal ss selection */
1.60      anton     160: 
1.30      pazsan    161: #ifdef HAS_DEBUG
1.68      anton     162: int debug=0;
1.31      pazsan    163: #else
                    164: # define perror(x...)
                    165: # define fprintf(x...)
1.30      pazsan    166: #endif
1.31      pazsan    167: 
1.24      anton     168: ImageHeader *gforth_header;
1.43      anton     169: Label *vm_prims;
1.53      anton     170: #ifdef DOUBLY_INDIRECT
                    171: Label *xts; /* same content as vm_prims, but should only be used for xts */
                    172: #endif
1.1       anton     173: 
1.125   ! anton     174: #ifndef NO_DYNAMIC
        !           175: #define MAX_IMMARGS 2
        !           176: 
        !           177: typedef struct {
        !           178:   Label start; /* NULL if not relocatable */
        !           179:   Cell length; /* only includes the jump iff superend is true*/
        !           180:   Cell restlength; /* length of the rest (i.e., the jump or (on superend) 0) */
        !           181:   char superend; /* true if primitive ends superinstruction, i.e.,
        !           182:                      unconditional branch, execute, etc. */
        !           183:   Cell nimmargs;
        !           184:   struct immarg {
        !           185:     Cell offset; /* offset of immarg within prim */
        !           186:     char rel;    /* true if immarg is relative */
        !           187:   } immargs[MAX_IMMARGS];
        !           188: } PrimInfo;
        !           189: 
        !           190: PrimInfo *priminfos;
        !           191: PrimInfo **decomp_prims;
        !           192: 
        !           193: static int is_relocatable(int p)
        !           194: {
        !           195:   return !no_dynamic && priminfos[p].start != NULL;
        !           196: }
        !           197: #else /* defined(NO_DYNAMIC) */
        !           198: static int is_relocatable(int p)
        !           199: {
        !           200:   return 0;
        !           201: }
        !           202: #endif /* defined(NO_DYNAMIC) */
        !           203: 
1.30      pazsan    204: #ifdef MEMCMP_AS_SUBROUTINE
                    205: int gforth_memcmp(const char * s1, const char * s2, size_t n)
                    206: {
                    207:   return memcmp(s1, s2, n);
                    208: }
                    209: #endif
                    210: 
1.125   ! anton     211: static Cell max(Cell a, Cell b)
        !           212: {
        !           213:   return a>b?a:b;
        !           214: }
        !           215: 
        !           216: static Cell min(Cell a, Cell b)
        !           217: {
        !           218:   return a<b?a:b;
        !           219: }
        !           220: 
1.1       anton     221: /* image file format:
1.15      pazsan    222:  *  "#! binary-path -i\n" (e.g., "#! /usr/local/bin/gforth-0.4.0 -i\n")
1.1       anton     223:  *   padding to a multiple of 8
1.84      anton     224:  *   magic: "Gforth3x" means format 0.6,
1.15      pazsan    225:  *              where x is a byte with
                    226:  *              bit 7:   reserved = 0
                    227:  *              bit 6:5: address unit size 2^n octets
                    228:  *              bit 4:3: character size 2^n octets
                    229:  *              bit 2:1: cell size 2^n octets
                    230:  *              bit 0:   endian, big=0, little=1.
                    231:  *  The magic are always 8 octets, no matter what the native AU/character size is
1.1       anton     232:  *  padding to max alignment (no padding necessary on current machines)
1.24      anton     233:  *  ImageHeader structure (see forth.h)
1.1       anton     234:  *  data (size in ImageHeader.image_size)
                    235:  *  tags ((if relocatable, 1 bit/data cell)
                    236:  *
                    237:  * tag==1 means that the corresponding word is an address;
                    238:  * If the word is >=0, the address is within the image;
                    239:  * addresses within the image are given relative to the start of the image.
                    240:  * If the word =-1 (CF_NIL), the address is NIL,
                    241:  * If the word is <CF_NIL and >CF(DODOES), it's a CFA (:, Create, ...)
                    242:  * If the word =CF(DODOES), it's a DOES> CFA
                    243:  * If the word =CF(DOESJUMP), it's a DOES JUMP (2 Cells after DOES>,
                    244:  *                                     possibly containing a jump to dodoes)
1.51      anton     245:  * If the word is <CF(DOESJUMP) and bit 14 is set, it's the xt of a primitive
                    246:  * If the word is <CF(DOESJUMP) and bit 14 is clear, 
                    247:  *                                        it's the threaded code of a primitive
1.85      pazsan    248:  * bits 13..9 of a primitive token state which group the primitive belongs to,
                    249:  * bits 8..0 of a primitive token index into the group
1.1       anton     250:  */
                    251: 
1.115     pazsan    252: Cell groups[32] = {
1.85      pazsan    253:   0,
1.121     anton     254:   0
1.90      anton     255: #undef GROUP
1.115     pazsan    256: #undef GROUPADD
                    257: #define GROUPADD(n) +n
                    258: #define GROUP(x, n) , 0
1.86      anton     259: #include "prim_grp.i"
1.90      anton     260: #undef GROUP
1.115     pazsan    261: #undef GROUPADD
1.85      pazsan    262: #define GROUP(x, n)
1.115     pazsan    263: #define GROUPADD(n)
1.85      pazsan    264: };
                    265: 
1.125   ! anton     266: unsigned char *branch_targets(Cell *image, const unsigned char *bitstring,
        !           267:                              int size, Cell base)
        !           268:      /* produce a bitmask marking all the branch targets */
        !           269: {
        !           270:   int i=0, j, k, steps=(size/sizeof(Cell))/RELINFOBITS;
        !           271:   Cell token;
        !           272:   unsigned char bits;
        !           273:   unsigned char *result=malloc(steps+1);
        !           274:   
        !           275:   memset(result, 0, steps+1);
        !           276:   for(k=0; k<=steps; k++) {
        !           277:     for(j=0, bits=bitstring[k]; j<RELINFOBITS; j++, i++, bits<<=1) {
        !           278:       if((i < size) && (bits & (1U << (RELINFOBITS-1)))) {
        !           279:         token=image[i];
        !           280:        if (token>=base) { /* relocatable address */
        !           281:          UCell bitnum=(token-base)/sizeof(Cell);
        !           282:          result[bitnum/RELINFOBITS] |= 1U << ((~bitnum)&(RELINFOBITS-1));
        !           283:        }
        !           284:       }
        !           285:     }
        !           286:   }
        !           287:   return result;
        !           288: }
        !           289: 
1.115     pazsan    290: void relocate(Cell *image, const unsigned char *bitstring, 
1.90      anton     291:               int size, Cell base, Label symbols[])
1.1       anton     292: {
1.16      pazsan    293:   int i=0, j, k, steps=(size/sizeof(Cell))/RELINFOBITS;
1.11      pazsan    294:   Cell token;
1.1       anton     295:   char bits;
1.37      anton     296:   Cell max_symbols;
1.46      jwilke    297:   /* 
1.85      pazsan    298:    * A virtual start address that's the real start address minus 
1.46      jwilke    299:    * the one in the image 
                    300:    */
1.45      jwilke    301:   Cell *start = (Cell * ) (((void *) image) - ((void *) base));
1.125   ! anton     302:   unsigned char *targets = branch_targets(image, bitstring, size, base);
1.1       anton     303: 
1.85      pazsan    304:   /* group index into table */
1.115     pazsan    305:   if(groups[31]==0) {
                    306:     int groupsum=0;
                    307:     for(i=0; i<32; i++) {
                    308:       groupsum += groups[i];
                    309:       groups[i] = groupsum;
                    310:       /* printf("group[%d]=%d\n",i,groupsum); */
                    311:     }
                    312:     i=0;
                    313:   }
1.46      jwilke    314:   
                    315: /* printf("relocating to %x[%x] start=%x base=%x\n", image, size, start, base); */
1.37      anton     316:   
1.121     anton     317:   for (max_symbols=0; symbols[max_symbols]!=0; max_symbols++)
1.37      anton     318:     ;
1.47      anton     319:   max_symbols--;
1.35      pazsan    320:   size/=sizeof(Cell);
                    321: 
1.31      pazsan    322:   for(k=0; k<=steps; k++) {
1.13      pazsan    323:     for(j=0, bits=bitstring[k]; j<RELINFOBITS; j++, i++, bits<<=1) {
1.1       anton     324:       /*      fprintf(stderr,"relocate: image[%d]\n", i);*/
1.35      pazsan    325:       if((i < size) && (bits & (1U << (RELINFOBITS-1)))) {
                    326:        /* fprintf(stderr,"relocate: image[%d]=%d of %d\n", i, image[i], size/sizeof(Cell)); */
1.45      jwilke    327:         token=image[i];
1.85      pazsan    328:        if(token<0) {
                    329:          int group = (-token & 0x3E00) >> 9;
                    330:          if(group == 0) {
                    331:            switch(token|0x4000) {
1.1       anton     332:            case CF_NIL      : image[i]=0; break;
                    333: #if !defined(DOUBLY_INDIRECT)
                    334:            case CF(DOCOL)   :
                    335:            case CF(DOVAR)   :
                    336:            case CF(DOCON)   :
                    337:            case CF(DOUSER)  : 
                    338:            case CF(DODEFER) : 
1.11      pazsan    339:            case CF(DOFIELD) : MAKE_CF(image+i,symbols[CF(token)]); break;
1.92      anton     340:            case CF(DOESJUMP): image[i]=0; break;
1.1       anton     341: #endif /* !defined(DOUBLY_INDIRECT) */
                    342:            case CF(DODOES)  :
1.45      jwilke    343:              MAKE_DOES_CF(image+i,(Xt *)(image[i+1]+((Cell)start)));
1.1       anton     344:              break;
1.85      pazsan    345:            default          : /* backward compatibility */
1.56      anton     346: /*           printf("Code field generation image[%x]:=CFA(%x)\n",
1.1       anton     347:                     i, CF(image[i])); */
1.55      anton     348:              if (CF((token | 0x4000))<max_symbols) {
1.56      anton     349:                image[i]=(Cell)CFA(CF(token));
                    350: #ifdef DIRECT_THREADED
1.125   ! anton     351:                if ((token & 0x4000) == 0) { /* threade code, no CFA */
        !           352:                  if (targets[k] & (1U<<(RELINFOBITS-1-j)))
        !           353:                    compile_prim1(0);
1.70      anton     354:                  compile_prim1(&image[i]);
1.125   ! anton     355:                }
1.56      anton     356: #endif
1.55      anton     357:              } else
1.115     pazsan    358:                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);
1.1       anton     359:            }
1.85      pazsan    360:          } else {
                    361:            int tok = -token & 0x1FF;
                    362:            if (tok < (groups[group+1]-groups[group])) {
                    363: #if defined(DOUBLY_INDIRECT)
                    364:              image[i]=(Cell)CFA(((groups[group]+tok) | (CF(token) & 0x4000)));
                    365: #else
                    366:              image[i]=(Cell)CFA((groups[group]+tok));
                    367: #endif
                    368: #ifdef DIRECT_THREADED
1.125   ! anton     369:              if ((token & 0x4000) == 0) { /* threade code, no CFA */
        !           370:                if (targets[k] & (1U<<(RELINFOBITS-1-j)))
        !           371:                  compile_prim1(0);
1.85      pazsan    372:                compile_prim1(&image[i]);
1.125   ! anton     373:              }
1.85      pazsan    374: #endif
                    375:            } else
1.115     pazsan    376:              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);
1.85      pazsan    377:          }
                    378:        } else {
1.101     anton     379:           /* if base is > 0: 0 is a null reference so don't adjust*/
1.45      jwilke    380:           if (token>=base) {
                    381:             image[i]+=(Cell)start;
                    382:           }
1.46      jwilke    383:         }
1.1       anton     384:       }
                    385:     }
1.31      pazsan    386:   }
1.125   ! anton     387:   free(targets);
1.70      anton     388:   finish_code();
1.26      jwilke    389:   ((ImageHeader*)(image))->base = (Address) image;
1.1       anton     390: }
                    391: 
                    392: UCell checksum(Label symbols[])
                    393: {
                    394:   UCell r=PRIM_VERSION;
                    395:   Cell i;
                    396: 
                    397:   for (i=DOCOL; i<=DOESJUMP; i++) {
                    398:     r ^= (UCell)(symbols[i]);
                    399:     r = (r << 5) | (r >> (8*sizeof(Cell)-5));
                    400:   }
                    401: #ifdef DIRECT_THREADED
                    402:   /* we have to consider all the primitives */
                    403:   for (; symbols[i]!=(Label)0; i++) {
                    404:     r ^= (UCell)(symbols[i]);
                    405:     r = (r << 5) | (r >> (8*sizeof(Cell)-5));
                    406:   }
                    407: #else
                    408:   /* in indirect threaded code all primitives are accessed through the
                    409:      symbols table, so we just have to put the base address of symbols
                    410:      in the checksum */
                    411:   r ^= (UCell)symbols;
                    412: #endif
                    413:   return r;
                    414: }
                    415: 
1.3       anton     416: Address verbose_malloc(Cell size)
                    417: {
                    418:   Address r;
                    419:   /* leave a little room (64B) for stack underflows */
                    420:   if ((r = malloc(size+64))==NULL) {
                    421:     perror(progname);
                    422:     exit(1);
                    423:   }
                    424:   r = (Address)((((Cell)r)+(sizeof(Float)-1))&(-sizeof(Float)));
                    425:   if (debug)
                    426:     fprintf(stderr, "malloc succeeds, address=$%lx\n", (long)r);
                    427:   return r;
                    428: }
                    429: 
1.33      anton     430: static Address next_address=0;
                    431: void after_alloc(Address r, Cell size)
                    432: {
                    433:   if (r != (Address)-1) {
                    434:     if (debug)
                    435:       fprintf(stderr, "success, address=$%lx\n", (long) r);
                    436:     if (pagesize != 1)
                    437:       next_address = (Address)(((((Cell)r)+size-1)&-pagesize)+2*pagesize); /* leave one page unmapped */
                    438:   } else {
                    439:     if (debug)
                    440:       fprintf(stderr, "failed: %s\n", strerror(errno));
                    441:   }
                    442: }
                    443: 
1.34      anton     444: #ifndef MAP_FAILED
                    445: #define MAP_FAILED ((Address) -1)
                    446: #endif
                    447: #ifndef MAP_FILE
                    448: # define MAP_FILE 0
                    449: #endif
                    450: #ifndef MAP_PRIVATE
                    451: # define MAP_PRIVATE 0
                    452: #endif
1.91      anton     453: #if !defined(MAP_ANON) && defined(MAP_ANONYMOUS)
                    454: # define MAP_ANON MAP_ANONYMOUS
                    455: #endif
1.34      anton     456: 
                    457: #if defined(HAVE_MMAP)
                    458: static Address alloc_mmap(Cell size)
1.1       anton     459: {
                    460:   Address r;
                    461: 
                    462: #if defined(MAP_ANON)
                    463:   if (debug)
                    464:     fprintf(stderr,"try mmap($%lx, $%lx, ..., MAP_ANON, ...); ", (long)next_address, (long)size);
1.34      anton     465:   r = mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_ANON|MAP_PRIVATE, -1, 0);
1.1       anton     466: #else /* !defined(MAP_ANON) */
1.17      anton     467:   /* Ultrix (at least) does not define MAP_FILE and MAP_PRIVATE (both are
                    468:      apparently defaults) */
1.1       anton     469:   static int dev_zero=-1;
                    470: 
                    471:   if (dev_zero == -1)
                    472:     dev_zero = open("/dev/zero", O_RDONLY);
                    473:   if (dev_zero == -1) {
1.34      anton     474:     r = MAP_FAILED;
1.1       anton     475:     if (debug)
                    476:       fprintf(stderr, "open(\"/dev/zero\"...) failed (%s), no mmap; ", 
                    477:              strerror(errno));
                    478:   } else {
                    479:     if (debug)
                    480:       fprintf(stderr,"try mmap($%lx, $%lx, ..., MAP_FILE, dev_zero, ...); ", (long)next_address, (long)size);
                    481:     r=mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FILE|MAP_PRIVATE, dev_zero, 0);
                    482:   }
                    483: #endif /* !defined(MAP_ANON) */
1.34      anton     484:   after_alloc(r, size);
                    485:   return r;  
                    486: }
                    487: #endif
                    488: 
                    489: Address my_alloc(Cell size)
                    490: {
                    491: #if HAVE_MMAP
                    492:   Address r;
                    493: 
                    494:   r=alloc_mmap(size);
1.117     anton     495:   if (r!=(Address)MAP_FAILED)
1.1       anton     496:     return r;
                    497: #endif /* HAVE_MMAP */
1.3       anton     498:   /* use malloc as fallback */
                    499:   return verbose_malloc(size);
1.1       anton     500: }
                    501: 
1.34      anton     502: Address dict_alloc_read(FILE *file, Cell imagesize, Cell dictsize, Cell offset)
1.33      anton     503: {
1.34      anton     504:   Address image = MAP_FAILED;
1.33      anton     505: 
1.56      anton     506: #if defined(HAVE_MMAP)
1.33      anton     507:   if (offset==0) {
1.34      anton     508:     image=alloc_mmap(dictsize);
1.33      anton     509:     if (debug)
1.34      anton     510:       fprintf(stderr,"try mmap($%lx, $%lx, ..., MAP_FIXED|MAP_FILE, imagefile, 0); ", (long)image, (long)imagesize);
                    511:     image = mmap(image, imagesize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FIXED|MAP_FILE|MAP_PRIVATE, fileno(file), 0);
                    512:     after_alloc(image,dictsize);
1.33      anton     513:   }
1.56      anton     514: #endif /* defined(HAVE_MMAP) */
1.117     anton     515:   if (image == (Address)MAP_FAILED) {
1.56      anton     516:     image = my_alloc(dictsize+offset)+offset;
1.33      anton     517:     rewind(file);  /* fseek(imagefile,0L,SEEK_SET); */
1.34      anton     518:     fread(image, 1, imagesize, file);
1.33      anton     519:   }
                    520:   return image;
                    521: }
                    522: 
1.10      pazsan    523: void set_stack_sizes(ImageHeader * header)
                    524: {
                    525:   if (dictsize==0)
                    526:     dictsize = header->dict_size;
                    527:   if (dsize==0)
                    528:     dsize = header->data_stack_size;
                    529:   if (rsize==0)
                    530:     rsize = header->return_stack_size;
                    531:   if (fsize==0)
                    532:     fsize = header->fp_stack_size;
                    533:   if (lsize==0)
                    534:     lsize = header->locals_stack_size;
                    535:   dictsize=maxaligned(dictsize);
                    536:   dsize=maxaligned(dsize);
                    537:   rsize=maxaligned(rsize);
                    538:   lsize=maxaligned(lsize);
                    539:   fsize=maxaligned(fsize);
                    540: }
                    541: 
                    542: void alloc_stacks(ImageHeader * header)
                    543: {
                    544:   header->dict_size=dictsize;
                    545:   header->data_stack_size=dsize;
                    546:   header->fp_stack_size=fsize;
                    547:   header->return_stack_size=rsize;
                    548:   header->locals_stack_size=lsize;
                    549: 
                    550:   header->data_stack_base=my_alloc(dsize);
                    551:   header->fp_stack_base=my_alloc(fsize);
                    552:   header->return_stack_base=my_alloc(rsize);
                    553:   header->locals_stack_base=my_alloc(lsize);
                    554: }
                    555: 
1.44      pazsan    556: #warning You can ignore the warnings about clobbered variables in go_forth
1.11      pazsan    557: int go_forth(Address image, int stack, Cell *entries)
                    558: {
1.38      anton     559:   volatile ImageHeader *image_header = (ImageHeader *)image;
1.18      anton     560:   Cell *sp0=(Cell*)(image_header->data_stack_base + dsize);
1.44      pazsan    561:   Cell *rp0=(Cell *)(image_header->return_stack_base + rsize);
1.18      anton     562:   Float *fp0=(Float *)(image_header->fp_stack_base + fsize);
1.44      pazsan    563: #ifdef GFORTH_DEBUGGING
1.38      anton     564:   volatile Cell *orig_rp0=rp0;
1.44      pazsan    565: #endif
1.18      anton     566:   Address lp0=image_header->locals_stack_base + lsize;
                    567:   Xt *ip0=(Xt *)(image_header->boot_entry);
1.13      pazsan    568: #ifdef SYSSIGNALS
1.11      pazsan    569:   int throw_code;
1.13      pazsan    570: #endif
1.11      pazsan    571: 
                    572:   /* ensure that the cached elements (if any) are accessible */
1.41      anton     573:   IF_spTOS(sp0--);
                    574:   IF_fpTOS(fp0--);
1.11      pazsan    575:   
                    576:   for(;stack>0;stack--)
1.18      anton     577:     *--sp0=entries[stack-1];
1.11      pazsan    578: 
1.30      pazsan    579: #ifdef SYSSIGNALS
1.11      pazsan    580:   get_winsize();
                    581:    
                    582:   install_signal_handlers(); /* right place? */
                    583:   
                    584:   if ((throw_code=setjmp(throw_jmp_buf))) {
                    585:     static Cell signal_data_stack[8];
                    586:     static Cell signal_return_stack[8];
                    587:     static Float signal_fp_stack[1];
1.13      pazsan    588: 
1.11      pazsan    589:     signal_data_stack[7]=throw_code;
1.18      anton     590: 
                    591: #ifdef GFORTH_DEBUGGING
1.97      anton     592:     if (debug)
                    593:       fprintf(stderr,"\ncaught signal, throwing exception %d, ip=%p rp=%p\n",
                    594:              throw_code, saved_ip, rp);
1.38      anton     595:     if (rp <= orig_rp0 && rp > (Cell *)(image_header->return_stack_base+5)) {
1.18      anton     596:       /* no rstack overflow or underflow */
                    597:       rp0 = rp;
1.63      anton     598:       *--rp0 = (Cell)saved_ip;
1.18      anton     599:     }
                    600:     else /* I love non-syntactic ifdefs :-) */
1.97      anton     601:       rp0 = signal_return_stack+8;
                    602: #else  /* !defined(GFORTH_DEBUGGING) */
                    603:     if (debug)
                    604:       fprintf(stderr,"\ncaught signal, throwing exception %d\n", throw_code);
                    605:       rp0 = signal_return_stack+8;
                    606: #endif /* !defined(GFORTH_DEBUGGING) */
1.25      anton     607:     /* fprintf(stderr, "rp=$%x\n",rp0);*/
1.11      pazsan    608:     
1.33      anton     609:     return((int)(Cell)engine(image_header->throw_entry, signal_data_stack+7,
1.18      anton     610:                       rp0, signal_fp_stack, 0));
1.11      pazsan    611:   }
1.13      pazsan    612: #endif
1.11      pazsan    613: 
1.33      anton     614:   return((int)(Cell)engine(ip0,sp0,rp0,fp0,lp0));
1.11      pazsan    615: }
                    616: 
1.30      pazsan    617: #ifndef INCLUDE_IMAGE
1.21      anton     618: void print_sizes(Cell sizebyte)
                    619:      /* print size information */
                    620: {
                    621:   static char* endianstring[]= { "   big","little" };
                    622:   
                    623:   fprintf(stderr,"%s endian, cell=%d bytes, char=%d bytes, au=%d bytes\n",
                    624:          endianstring[sizebyte & 1],
                    625:          1 << ((sizebyte >> 1) & 3),
                    626:          1 << ((sizebyte >> 3) & 3),
                    627:          1 << ((sizebyte >> 5) & 3));
                    628: }
                    629: 
1.106     anton     630: /* static superinstruction stuff */
                    631: 
                    632: struct cost {
                    633:   char loads;       /* number of stack loads */
                    634:   char stores;      /* number of stack stores */
                    635:   char updates;     /* number of stack pointer updates */
1.123     anton     636:   char branch;     /* is it a branch (SET_IP) */
1.125   ! anton     637:   unsigned char state_in;    /* state on entry */
        !           638:   unsigned char state_out;   /* state on exit */
1.123     anton     639:   short offset;     /* offset into super2 table */
1.125   ! anton     640:   unsigned char length;      /* number of components */
1.106     anton     641: };
                    642: 
1.121     anton     643: PrimNum super2[] = {
1.106     anton     644: #include "super2.i"
                    645: };
                    646: 
                    647: struct cost super_costs[] = {
                    648: #include "costs.i"
                    649: };
                    650: 
1.125   ! anton     651: struct super_state {
        !           652:   struct super_state *next;
        !           653:   PrimNum super;
        !           654: };
        !           655: 
1.106     anton     656: #define HASH_SIZE 256
                    657: 
                    658: struct super_table_entry {
                    659:   struct super_table_entry *next;
1.121     anton     660:   PrimNum *start;
1.106     anton     661:   short length;
1.125   ! anton     662:   struct super_state *ss_list; /* list of supers */
1.106     anton     663: } *super_table[HASH_SIZE];
                    664: int max_super=2;
                    665: 
1.125   ! anton     666: struct super_state *state_transitions=NULL;
        !           667: 
1.121     anton     668: int hash_super(PrimNum *start, int length)
1.106     anton     669: {
                    670:   int i, r;
                    671:   
                    672:   for (i=0, r=0; i<length; i++) {
                    673:     r <<= 1;
                    674:     r += start[i];
                    675:   }
                    676:   return r & (HASH_SIZE-1);
                    677: }
                    678: 
1.125   ! anton     679: struct super_state **lookup_super(PrimNum *start, int length)
1.106     anton     680: {
                    681:   int hash=hash_super(start,length);
                    682:   struct super_table_entry *p = super_table[hash];
                    683: 
1.125   ! anton     684:   /* assert(length >= 2); */
1.106     anton     685:   for (; p!=NULL; p = p->next) {
                    686:     if (length == p->length &&
1.121     anton     687:        memcmp((char *)p->start, (char *)start, length*sizeof(PrimNum))==0)
1.125   ! anton     688:       return &(p->ss_list);
1.106     anton     689:   }
1.125   ! anton     690:   return NULL;
1.106     anton     691: }
                    692: 
                    693: void prepare_super_table()
                    694: {
                    695:   int i;
1.109     anton     696:   int nsupers = 0;
1.106     anton     697: 
                    698:   for (i=0; i<sizeof(super_costs)/sizeof(super_costs[0]); i++) {
                    699:     struct cost *c = &super_costs[i];
1.125   ! anton     700:     if ((c->length < 2 || nsupers < static_super_number) &&
        !           701:        c->state_in < maxstates && c->state_out < maxstates) {
        !           702:       struct super_state **ss_listp= lookup_super(super2+c->offset, c->length);
        !           703:       struct super_state *ss = malloc(sizeof(struct super_state));
        !           704:       ss->super= i;
        !           705:       if (c->offset==N_noop && i != N_noop) {
        !           706:        if (is_relocatable(i)) {
        !           707:          ss->next = state_transitions;
        !           708:          state_transitions = ss;
        !           709:        }
        !           710:       } else if (ss_listp != NULL) {
        !           711:        ss->next = *ss_listp;
        !           712:        *ss_listp = ss;
        !           713:       } else {
        !           714:        int hash = hash_super(super2+c->offset, c->length);
        !           715:        struct super_table_entry **p = &super_table[hash];
        !           716:        struct super_table_entry *e = malloc(sizeof(struct super_table_entry));
        !           717:        ss->next = NULL;
        !           718:        e->next = *p;
        !           719:        e->start = super2 + c->offset;
        !           720:        e->length = c->length;
        !           721:        e->ss_list = ss;
        !           722:        *p = e;
        !           723:       }
1.106     anton     724:       if (c->length > max_super)
                    725:        max_super = c->length;
1.125   ! anton     726:       if (c->length >= 2)
        !           727:        nsupers++;
1.106     anton     728:     }
                    729:   }
1.109     anton     730:   if (debug)
                    731:     fprintf(stderr, "Using %d static superinsts\n", nsupers);
1.106     anton     732: }
                    733: 
                    734: /* dynamic replication/superinstruction stuff */
                    735: 
1.69      anton     736: #ifndef NO_DYNAMIC
1.90      anton     737: int compare_priminfo_length(const void *_a, const void *_b)
1.76      anton     738: {
1.90      anton     739:   PrimInfo **a = (PrimInfo **)_a;
                    740:   PrimInfo **b = (PrimInfo **)_b;
1.77      anton     741:   Cell diff = (*a)->length - (*b)->length;
                    742:   if (diff)
                    743:     return diff;
                    744:   else /* break ties by start address; thus the decompiler produces
                    745:           the earliest primitive with the same code (e.g. noop instead
                    746:           of (char) and @ instead of >code-address */
                    747:     return (*b)->start - (*a)->start;
1.76      anton     748: }
1.112     anton     749: #endif /* !defined(NO_DYNAMIC) */
1.76      anton     750: 
1.125   ! anton     751: static char MAYBE_UNUSED superend[]={
1.106     anton     752: #include "prim_superend.i"
                    753: };
1.107     anton     754: 
                    755: Cell npriminfos=0;
1.76      anton     756: 
1.114     anton     757: int compare_labels(const void *pa, const void *pb)
1.113     anton     758: {
1.114     anton     759:   Label a = *(Label *)pa;
                    760:   Label b = *(Label *)pb;
                    761:   return a-b;
                    762: }
1.113     anton     763: 
1.114     anton     764: Label bsearch_next(Label key, Label *a, UCell n)
                    765:      /* a is sorted; return the label >=key that is the closest in a;
                    766:         return NULL if there is no label in a >=key */
                    767: {
                    768:   int mid = (n-1)/2;
                    769:   if (n<1)
                    770:     return NULL;
                    771:   if (n == 1) {
                    772:     if (a[0] < key)
                    773:       return NULL;
                    774:     else
                    775:       return a[0];
                    776:   }
                    777:   if (a[mid] < key)
                    778:     return bsearch_next(key, a+mid+1, n-mid-1);
                    779:   else
                    780:     return bsearch_next(key, a, mid+1);
1.113     anton     781: }
                    782: 
1.47      anton     783: void check_prims(Label symbols1[])
                    784: {
                    785:   int i;
1.90      anton     786: #ifndef NO_DYNAMIC
1.119     anton     787:   Label *symbols2, *symbols3, *ends1, *ends1j, *ends1jsorted;
                    788:   int nends1j;
1.90      anton     789: #endif
1.47      anton     790: 
1.66      anton     791:   if (debug)
                    792: #ifdef __VERSION__
                    793:     fprintf(stderr, "Compiled with gcc-" __VERSION__ "\n");
                    794: #else
                    795: #define xstr(s) str(s)
                    796: #define str(s) #s
                    797:   fprintf(stderr, "Compiled with gcc-" xstr(__GNUC__) "." xstr(__GNUC_MINOR__) "\n"); 
                    798: #endif
1.121     anton     799:   for (i=0; symbols1[i]!=0; i++)
1.47      anton     800:     ;
1.55      anton     801:   npriminfos = i;
1.70      anton     802:   
                    803: #ifndef NO_DYNAMIC
1.66      anton     804:   if (no_dynamic)
                    805:     return;
1.55      anton     806:   symbols2=engine2(0,0,0,0,0);
1.70      anton     807: #if NO_IP
                    808:   symbols3=engine3(0,0,0,0,0);
                    809: #else
                    810:   symbols3=symbols1;
                    811: #endif
1.121     anton     812:   ends1 = symbols1+i+1;
1.119     anton     813:   ends1j =   ends1+i;
1.121     anton     814:   nends1j = i+1;
1.119     anton     815:   ends1jsorted = (Label *)alloca(nends1j*sizeof(Label));
                    816:   memcpy(ends1jsorted,ends1j,nends1j*sizeof(Label));
                    817:   qsort(ends1jsorted, nends1j, sizeof(Label), compare_labels);
1.113     anton     818:   
1.47      anton     819:   priminfos = calloc(i,sizeof(PrimInfo));
1.121     anton     820:   for (i=0; symbols1[i]!=0; i++) {
1.70      anton     821:     int prim_len = ends1[i]-symbols1[i];
1.47      anton     822:     PrimInfo *pi=&priminfos[i];
1.70      anton     823:     int j=0;
                    824:     char *s1 = (char *)symbols1[i];
                    825:     char *s2 = (char *)symbols2[i];
                    826:     char *s3 = (char *)symbols3[i];
1.119     anton     827:     Label endlabel = bsearch_next(symbols1[i]+1,ends1jsorted,nends1j);
1.70      anton     828: 
                    829:     pi->start = s1;
1.121     anton     830:     pi->superend = superend[i]|no_super;
1.70      anton     831:     if (pi->superend)
1.113     anton     832:       pi->length = endlabel-symbols1[i];
1.70      anton     833:     else
                    834:       pi->length = prim_len;
1.113     anton     835:     pi->restlength = endlabel - symbols1[i] - pi->length;
1.70      anton     836:     pi->nimmargs = 0;
                    837:     if (debug)
1.98      anton     838:       fprintf(stderr, "Prim %3d @ %p %p %p, length=%3ld restlength=%2ld superend=%1d",
                    839:              i, s1, s2, s3, (long)(pi->length), (long)(pi->restlength), pi->superend);
1.114     anton     840:     if (endlabel == NULL) {
                    841:       pi->start = NULL; /* not relocatable */
1.122     anton     842:       if (pi->length<0) pi->length=100;
1.114     anton     843:       if (debug)
1.119     anton     844:        fprintf(stderr,"\n   non_reloc: no J label > start found\n");
1.114     anton     845:       continue;
                    846:     }
                    847:     if (ends1[i] > endlabel && !pi->superend) {
1.113     anton     848:       pi->start = NULL; /* not relocatable */
1.122     anton     849:       pi->length = endlabel-symbols1[i];
1.113     anton     850:       if (debug)
1.121     anton     851:        fprintf(stderr,"\n   non_reloc: there is a J label before the K label (restlength<0)\n");
1.113     anton     852:       continue;
                    853:     }
1.114     anton     854:     if (ends1[i] < pi->start && !pi->superend) {
1.113     anton     855:       pi->start = NULL; /* not relocatable */
1.122     anton     856:       pi->length = endlabel-symbols1[i];
1.113     anton     857:       if (debug)
1.119     anton     858:        fprintf(stderr,"\n   non_reloc: K label before I label (length<0)\n");
1.113     anton     859:       continue;
                    860:     }
1.70      anton     861:     assert(prim_len>=0);
1.113     anton     862:     assert(pi->restlength >=0);
1.74      anton     863:     while (j<(pi->length+pi->restlength)) {
1.70      anton     864:       if (s1[j]==s3[j]) {
                    865:        if (s1[j] != s2[j]) {
                    866:          pi->start = NULL; /* not relocatable */
                    867:          if (debug)
                    868:            fprintf(stderr,"\n   non_reloc: engine1!=engine2 offset %3d",j);
1.74      anton     869:          /* assert(j<prim_len); */
1.70      anton     870:          break;
                    871:        }
                    872:        j++;
                    873:       } else {
                    874:        struct immarg *ia=&pi->immargs[pi->nimmargs];
                    875: 
                    876:        pi->nimmargs++;
                    877:        ia->offset=j;
                    878:        if ((~*(Cell *)&(s1[j]))==*(Cell *)&(s3[j])) {
                    879:          ia->rel=0;
                    880:          if (debug)
                    881:            fprintf(stderr,"\n   absolute immarg: offset %3d",j);
                    882:        } else if ((&(s1[j]))+(*(Cell *)&(s1[j]))+4 ==
                    883:                   symbols1[DOESJUMP+1]) {
                    884:          ia->rel=1;
                    885:          if (debug)
                    886:            fprintf(stderr,"\n   relative immarg: offset %3d",j);
                    887:        } else {
                    888:          pi->start = NULL; /* not relocatable */
                    889:          if (debug)
                    890:            fprintf(stderr,"\n   non_reloc: engine1!=engine3 offset %3d",j);
1.74      anton     891:          /* assert(j<prim_len);*/
1.70      anton     892:          break;
                    893:        }
                    894:        j+=4;
1.47      anton     895:       }
                    896:     }
1.70      anton     897:     if (debug)
                    898:       fprintf(stderr,"\n");
                    899:   }
1.76      anton     900:   decomp_prims = calloc(i,sizeof(PrimInfo *));
                    901:   for (i=DOESJUMP+1; i<npriminfos; i++)
                    902:     decomp_prims[i] = &(priminfos[i]);
                    903:   qsort(decomp_prims+DOESJUMP+1, npriminfos-DOESJUMP-1, sizeof(PrimInfo *),
                    904:        compare_priminfo_length);
1.70      anton     905: #endif
                    906: }
                    907: 
1.74      anton     908: void flush_to_here(void)
                    909: {
1.93      anton     910: #ifndef NO_DYNAMIC
1.100     anton     911:   if (start_flush)
                    912:     FLUSH_ICACHE(start_flush, code_here-start_flush);
1.74      anton     913:   start_flush=code_here;
1.93      anton     914: #endif
1.74      anton     915: }
                    916: 
1.93      anton     917: #ifndef NO_DYNAMIC
1.74      anton     918: void append_jump(void)
                    919: {
                    920:   if (last_jump) {
                    921:     PrimInfo *pi = &priminfos[last_jump];
                    922:     
                    923:     memcpy(code_here, pi->start+pi->length, pi->restlength);
                    924:     code_here += pi->restlength;
                    925:     last_jump=0;
                    926:   }
                    927: }
                    928: 
1.75      anton     929: /* Gforth remembers all code blocks in this list.  On forgetting (by
                    930: executing a marker) the code blocks are not freed (because Gforth does
                    931: not remember how they were allocated; hmm, remembering that might be
                    932: easier and cleaner).  Instead, code_here etc. are reset to the old
                    933: value, and the "forgotten" code blocks are reused when they are
                    934: needed. */
                    935: 
                    936: struct code_block_list {
                    937:   struct code_block_list *next;
                    938:   Address block;
                    939:   Cell size;
                    940: } *code_block_list=NULL, **next_code_blockp=&code_block_list;
                    941: 
1.74      anton     942: Address append_prim(Cell p)
                    943: {
                    944:   PrimInfo *pi = &priminfos[p];
                    945:   Address old_code_here = code_here;
                    946: 
                    947:   if (code_area+code_area_size < code_here+pi->length+pi->restlength) {
1.75      anton     948:     struct code_block_list *p;
1.74      anton     949:     append_jump();
1.93      anton     950:     flush_to_here();
1.75      anton     951:     if (*next_code_blockp == NULL) {
                    952:       code_here = start_flush = code_area = my_alloc(code_area_size);
                    953:       p = (struct code_block_list *)malloc(sizeof(struct code_block_list));
                    954:       *next_code_blockp = p;
                    955:       p->next = NULL;
                    956:       p->block = code_here;
                    957:       p->size = code_area_size;
                    958:     } else {
                    959:       p = *next_code_blockp;
                    960:       code_here = start_flush = code_area = p->block;
                    961:     }
1.74      anton     962:     old_code_here = code_here;
1.75      anton     963:     next_code_blockp = &(p->next);
1.74      anton     964:   }
                    965:   memcpy(code_here, pi->start, pi->length);
                    966:   code_here += pi->length;
                    967:   return old_code_here;
                    968: }
                    969: #endif
1.75      anton     970: 
                    971: int forget_dyncode(Address code)
                    972: {
                    973: #ifdef NO_DYNAMIC
                    974:   return -1;
                    975: #else
                    976:   struct code_block_list *p, **pp;
                    977: 
                    978:   for (pp=&code_block_list, p=*pp; p!=NULL; pp=&(p->next), p=*pp) {
                    979:     if (code >= p->block && code < p->block+p->size) {
                    980:       next_code_blockp = &(p->next);
                    981:       code_here = start_flush = code;
                    982:       code_area = p->block;
                    983:       last_jump = 0;
                    984:       return -1;
                    985:     }
                    986:   }
1.78      anton     987:   return -no_dynamic;
1.75      anton     988: #endif /* !defined(NO_DYNAMIC) */
                    989: }
                    990: 
1.104     anton     991: long dyncodesize(void)
                    992: {
                    993: #ifndef NO_DYNAMIC
1.106     anton     994:   struct code_block_list *p;
1.104     anton     995:   long size=0;
                    996:   for (p=code_block_list; p!=NULL; p=p->next) {
                    997:     if (code_here >= p->block && code_here < p->block+p->size)
                    998:       return size + (code_here - p->block);
                    999:     else
                   1000:       size += p->size;
                   1001:   }
                   1002: #endif /* !defined(NO_DYNAMIC) */
                   1003:   return 0;
                   1004: }
                   1005: 
1.90      anton    1006: Label decompile_code(Label _code)
1.75      anton    1007: {
1.76      anton    1008: #ifdef NO_DYNAMIC
1.90      anton    1009:   return _code;
1.76      anton    1010: #else /* !defined(NO_DYNAMIC) */
                   1011:   Cell i;
1.77      anton    1012:   struct code_block_list *p;
1.90      anton    1013:   Address code=_code;
1.76      anton    1014: 
1.77      anton    1015:   /* first, check if we are in code at all */
                   1016:   for (p = code_block_list;; p = p->next) {
                   1017:     if (p == NULL)
                   1018:       return code;
                   1019:     if (code >= p->block && code < p->block+p->size)
                   1020:       break;
                   1021:   }
1.76      anton    1022:   /* reverse order because NOOP might match other prims */
                   1023:   for (i=npriminfos-1; i>DOESJUMP; i--) {
                   1024:     PrimInfo *pi=decomp_prims[i];
                   1025:     if (pi->start==code || (pi->start && memcmp(code,pi->start,pi->length)==0))
1.121     anton    1026:       return vm_prims[super2[super_costs[pi-priminfos].offset]];
1.118     anton    1027:     /* return pi->start;*/
1.76      anton    1028:   }
                   1029:   return code;
                   1030: #endif /* !defined(NO_DYNAMIC) */
1.75      anton    1031: }
1.74      anton    1032: 
1.70      anton    1033: #ifdef NO_IP
                   1034: int nbranchinfos=0;
                   1035: 
                   1036: struct branchinfo {
                   1037:   Label *targetptr; /* *(bi->targetptr) is the target */
                   1038:   Cell *addressptr; /* store the target here */
                   1039: } branchinfos[100000];
                   1040: 
                   1041: int ndoesexecinfos=0;
                   1042: struct doesexecinfo {
                   1043:   int branchinfo; /* fix the targetptr of branchinfos[...->branchinfo] */
                   1044:   Cell *xt; /* cfa of word whose does-code needs calling */
                   1045: } doesexecinfos[10000];
                   1046: 
                   1047: void set_rel_target(Cell *source, Label target)
                   1048: {
                   1049:   *source = ((Cell)target)-(((Cell)source)+4);
                   1050: }
                   1051: 
                   1052: void register_branchinfo(Label source, Cell targetptr)
                   1053: {
                   1054:   struct branchinfo *bi = &(branchinfos[nbranchinfos]);
                   1055:   bi->targetptr = (Label *)targetptr;
                   1056:   bi->addressptr = (Cell *)source;
                   1057:   nbranchinfos++;
                   1058: }
                   1059: 
                   1060: Cell *compile_prim1arg(Cell p)
                   1061: {
                   1062:   int l = priminfos[p].length;
                   1063:   Address old_code_here=code_here;
                   1064: 
1.74      anton    1065:   assert(vm_prims[p]==priminfos[p].start);
                   1066:   append_prim(p);
1.70      anton    1067:   return (Cell*)(old_code_here+priminfos[p].immargs[0].offset);
                   1068: }
                   1069: 
                   1070: Cell *compile_call2(Cell targetptr)
                   1071: {
                   1072:   Cell *next_code_target;
1.73      anton    1073:   PrimInfo *pi = &priminfos[N_call2];
1.74      anton    1074:   Address old_code_here = append_prim(N_call2);
1.70      anton    1075: 
1.74      anton    1076:   next_code_target = (Cell *)(old_code_here + pi->immargs[0].offset);
                   1077:   register_branchinfo(old_code_here + pi->immargs[1].offset, targetptr);
1.70      anton    1078:   return next_code_target;
                   1079: }
                   1080: #endif
                   1081: 
                   1082: void finish_code(void)
                   1083: {
                   1084: #ifdef NO_IP
                   1085:   Cell i;
                   1086: 
                   1087:   compile_prim1(NULL);
                   1088:   for (i=0; i<ndoesexecinfos; i++) {
                   1089:     struct doesexecinfo *dei = &doesexecinfos[i];
                   1090:     branchinfos[dei->branchinfo].targetptr = DOES_CODE1((dei->xt));
                   1091:   }
                   1092:   ndoesexecinfos = 0;
                   1093:   for (i=0; i<nbranchinfos; i++) {
                   1094:     struct branchinfo *bi=&branchinfos[i];
                   1095:     set_rel_target(bi->addressptr, *(bi->targetptr));
                   1096:   }
                   1097:   nbranchinfos = 0;
1.48      anton    1098: #endif
1.93      anton    1099:   flush_to_here();
1.48      anton    1100: }
                   1101: 
1.108     anton    1102: #if 0
1.105     anton    1103: /* compile *start into a dynamic superinstruction, updating *start */
                   1104: void compile_prim_dyn(Cell *start)
1.48      anton    1105: {
1.108     anton    1106: #if defined(NO_IP)
1.70      anton    1107:   static Cell *last_start=NULL;
                   1108:   static Xt last_prim=NULL;
                   1109:   /* delay work by one call in order to get relocated immargs */
                   1110: 
                   1111:   if (last_start) {
                   1112:     unsigned i = last_prim-vm_prims;
                   1113:     PrimInfo *pi=&priminfos[i];
                   1114:     Cell *next_code_target=NULL;
                   1115: 
                   1116:     assert(i<npriminfos);
1.73      anton    1117:     if (i==N_execute||i==N_perform||i==N_lit_perform) {
                   1118:       next_code_target = compile_prim1arg(N_set_next_code);
1.70      anton    1119:     }
1.73      anton    1120:     if (i==N_call) {
1.70      anton    1121:       next_code_target = compile_call2(last_start[1]);
1.73      anton    1122:     } else if (i==N_does_exec) {
1.70      anton    1123:       struct doesexecinfo *dei = &doesexecinfos[ndoesexecinfos++];
1.73      anton    1124:       *compile_prim1arg(N_lit) = (Cell)PFA(last_start[1]);
1.70      anton    1125:       /* we cannot determine the callee now (last_start[1] may be a
                   1126:          forward reference), so just register an arbitrary target, and
                   1127:          register in dei that we need to fix this before resolving
                   1128:          branches */
                   1129:       dei->branchinfo = nbranchinfos;
                   1130:       dei->xt = (Cell *)(last_start[1]);
                   1131:       next_code_target = compile_call2(NULL);
1.125   ! anton    1132:     } else if (!is_relocatable(i)) {
1.73      anton    1133:       next_code_target = compile_prim1arg(N_set_next_code);
                   1134:       set_rel_target(compile_prim1arg(N_abranch),*(Xt)last_prim);
1.70      anton    1135:     } else {
                   1136:       unsigned j;
1.74      anton    1137:       Address old_code_here = append_prim(i);
1.70      anton    1138: 
                   1139:       for (j=0; j<pi->nimmargs; j++) {
                   1140:        struct immarg *ia = &(pi->immargs[j]);
                   1141:        Cell argval = last_start[pi->nimmargs - j]; /* !! specific to prims */
                   1142:        if (ia->rel) { /* !! assumption: relative refs are branches */
1.74      anton    1143:          register_branchinfo(old_code_here + ia->offset, argval);
1.70      anton    1144:        } else /* plain argument */
1.74      anton    1145:          *(Cell *)(old_code_here + ia->offset) = argval;
1.70      anton    1146:       }
                   1147:     }
                   1148:     if (next_code_target!=NULL)
                   1149:       *next_code_target = (Cell)code_here;
                   1150:   }
                   1151:   if (start) {
                   1152:     last_prim = (Xt)*start;
                   1153:     *start = (Cell)code_here;
                   1154:   }
                   1155:   last_start = start;
                   1156:   return;
                   1157: #elif !defined(NO_DYNAMIC)
                   1158:   Label prim=(Label)*start;
1.58      anton    1159:   unsigned i;
1.74      anton    1160:   Address old_code_here;
1.48      anton    1161: 
1.58      anton    1162:   i = ((Xt)prim)-vm_prims;
1.56      anton    1163:   prim = *(Xt)prim;
1.70      anton    1164:   if (no_dynamic) {
                   1165:     *start = (Cell)prim;
                   1166:     return;
                   1167:   }
1.125   ! anton    1168:   if (i>=npriminfos || !is_relocatable(i)) {
1.74      anton    1169:     append_jump();
1.70      anton    1170:     *start = (Cell)prim;
                   1171:     return;
1.47      anton    1172:   }
1.50      anton    1173: #ifdef ALIGN_CODE
1.87      anton    1174:   /*  ALIGN_CODE;*/
1.50      anton    1175: #endif
1.74      anton    1176:   assert(prim==priminfos[i].start);
                   1177:   old_code_here = append_prim(i);
                   1178:   last_jump = (priminfos[i].superend) ? 0 : i;
1.70      anton    1179:   *start = (Cell)old_code_here;
                   1180:   return;
1.61      anton    1181: #else /* !defined(DOUBLY_INDIRECT), no code replication */
1.70      anton    1182:   Label prim=(Label)*start;
1.61      anton    1183: #if !defined(INDIRECT_THREADED)
1.56      anton    1184:   prim = *(Xt)prim;
1.61      anton    1185: #endif
1.70      anton    1186:   *start = (Cell)prim;
                   1187:   return;
1.54      anton    1188: #endif /* !defined(DOUBLY_INDIRECT) */
1.70      anton    1189: }
1.108     anton    1190: #endif /* 0 */
                   1191: 
                   1192: Cell compile_prim_dyn(unsigned p)
                   1193: {
1.121     anton    1194:   Cell static_prim = (Cell)vm_prims[p];
1.108     anton    1195: #if defined(NO_DYNAMIC)
                   1196:   return static_prim;
                   1197: #else /* !defined(NO_DYNAMIC) */
                   1198:   Address old_code_here;
                   1199: 
                   1200:   if (no_dynamic)
                   1201:     return static_prim;
1.125   ! anton    1202:   if (p>=npriminfos || !is_relocatable(p)) {
1.108     anton    1203:     append_jump();
                   1204:     return static_prim;
                   1205:   }
                   1206:   old_code_here = append_prim(p);
                   1207:   last_jump = (priminfos[p].superend) ? 0 : p;
                   1208:   return (Cell)old_code_here;
                   1209: #endif  /* !defined(NO_DYNAMIC) */
                   1210: }
1.70      anton    1211: 
1.109     anton    1212: #ifndef NO_DYNAMIC
                   1213: int cost_codesize(int prim)
                   1214: {
1.121     anton    1215:   return priminfos[prim].length;
1.109     anton    1216: }
                   1217: #endif
                   1218: 
                   1219: int cost_ls(int prim)
                   1220: {
                   1221:   struct cost *c = super_costs+prim;
                   1222: 
                   1223:   return c->loads + c->stores;
                   1224: }
                   1225: 
                   1226: int cost_lsu(int prim)
                   1227: {
                   1228:   struct cost *c = super_costs+prim;
                   1229: 
                   1230:   return c->loads + c->stores + c->updates;
                   1231: }
                   1232: 
                   1233: int cost_nexts(int prim)
                   1234: {
                   1235:   return 1;
                   1236: }
                   1237: 
                   1238: typedef int Costfunc(int);
                   1239: Costfunc *ss_cost =  /* cost function for optimize_bb */
                   1240: #ifdef NO_DYNAMIC
                   1241: cost_lsu;
                   1242: #else
                   1243: cost_codesize;
                   1244: #endif
                   1245: 
1.110     anton    1246: struct {
                   1247:   Costfunc *costfunc;
                   1248:   char *metricname;
                   1249:   long sum;
                   1250: } cost_sums[] = {
                   1251: #ifndef NO_DYNAMIC
                   1252:   { cost_codesize, "codesize", 0 },
                   1253: #endif
                   1254:   { cost_ls,       "ls",       0 },
                   1255:   { cost_lsu,      "lsu",      0 },
                   1256:   { cost_nexts,    "nexts",    0 }
                   1257: };
                   1258: 
1.106     anton    1259: #define MAX_BB 128 /* maximum number of instructions in BB */
1.125   ! anton    1260: #define INF_COST 1000000 /* infinite cost */
        !          1261: #define CANONICAL_STATE 0
        !          1262: 
        !          1263: struct waypoint {
        !          1264:   int cost;     /* the cost from here to the end */
        !          1265:   PrimNum inst; /* the inst used from here to the next waypoint */
        !          1266:   char relocatable; /* the last non-transition was relocatable */
        !          1267:   char no_transition; /* don't use the next transition (relocatability)
        !          1268:                       * or this transition (does not change state) */
        !          1269: };
        !          1270: 
        !          1271: void init_waypoints(struct waypoint ws[])
        !          1272: {
        !          1273:   int k;
        !          1274: 
        !          1275:   for (k=0; k<maxstates; k++)
        !          1276:     ws[k].cost=INF_COST;
        !          1277: }
1.106     anton    1278: 
1.125   ! anton    1279: void transitions(struct waypoint inst[], struct waypoint trans[])
1.107     anton    1280: {
1.125   ! anton    1281:   int k;
        !          1282:   struct super_state *l;
        !          1283:   
        !          1284:   for (k=0; k<maxstates; k++) {
        !          1285:     trans[k] = inst[k];
        !          1286:     trans[k].no_transition = 1;
        !          1287:   }
        !          1288:   for (l = state_transitions; l != NULL; l = l->next) {
        !          1289:     PrimNum s = l->super;
        !          1290:     int jcost;
        !          1291:     struct cost *c=super_costs+s;
        !          1292:     struct waypoint *wi=&(trans[c->state_in]);
        !          1293:     struct waypoint *wo=&(inst[c->state_out]);
        !          1294:     if (wo->cost == INF_COST)
        !          1295:       continue;
        !          1296:     jcost = wo->cost + ss_cost(s);
        !          1297:     if (jcost <= wi->cost) {
        !          1298:       wi->cost = jcost;
        !          1299:       wi->inst = s;
        !          1300:       wi->relocatable = wo->relocatable;
        !          1301:       wi->no_transition = 0;
        !          1302:       /* if (ss_greedy) wi->cost = wo->cost ? */
        !          1303:     }
        !          1304:   }
        !          1305: }
1.107     anton    1306: 
1.125   ! anton    1307: /* use dynamic programming to find the shortest paths within the basic
        !          1308:    block origs[0..ninsts-1] and rewrite the instructions pointed to by
        !          1309:    instps to use it */
        !          1310: void optimize_rewrite(Cell *instps[], PrimNum origs[], int ninsts)
        !          1311: {
        !          1312:   int i,j;
        !          1313:   static struct waypoint inst[MAX_BB+1][MAX_STATE];  /* before instruction*/
        !          1314:   static struct waypoint trans[MAX_BB+1][MAX_STATE]; /* before transition */
        !          1315:   int nextdyn, nextstate, no_transition;
        !          1316:   
        !          1317:   init_waypoints(inst[ninsts]);
        !          1318:   inst[ninsts][CANONICAL_STATE].cost=0;
        !          1319:   transitions(inst[ninsts],trans[ninsts]);
1.107     anton    1320:   for (i=ninsts-1; i>=0; i--) {
1.125   ! anton    1321:     init_waypoints(inst[i]);
        !          1322:     for (j=1; j<=max_super && i+j<=ninsts; j++) {
        !          1323:       struct super_state **superp = lookup_super(origs+i, j);
        !          1324:       if (superp!=NULL) {
        !          1325:        struct super_state *supers = *superp;
        !          1326:        for (; supers!=NULL; supers = supers->next) {
        !          1327:          PrimNum s = supers->super;
        !          1328:          int jcost;
        !          1329:          struct cost *c=super_costs+s;
        !          1330:          struct waypoint *wi=&(inst[i][c->state_in]);
        !          1331:          struct waypoint *wo=&(trans[i+j][c->state_out]);
        !          1332:          int no_transition = wo->no_transition;
        !          1333:          if (!(is_relocatable(s)) && !wo->relocatable) {
        !          1334:            wo=&(inst[i+j][c->state_out]);
        !          1335:            no_transition=1;
        !          1336:          }
        !          1337:          if (wo->cost == INF_COST) 
        !          1338:            continue;
        !          1339:          jcost = wo->cost + ss_cost(s);
        !          1340:          if (jcost <= wi->cost) {
        !          1341:            wi->cost = jcost;
        !          1342:            wi->inst = s;
        !          1343:            wi->relocatable = is_relocatable(s);
        !          1344:            wi->no_transition = no_transition;
        !          1345:            /* if (ss_greedy) wi->cost = wo->cost ? */
        !          1346:          }
1.107     anton    1347:        }
                   1348:       }
                   1349:     }
1.125   ! anton    1350:     transitions(inst[i],trans[i]);
        !          1351:   }
        !          1352:   /* now rewrite the instructions */
        !          1353:   nextdyn=0;
        !          1354:   nextstate=CANONICAL_STATE;
        !          1355:   no_transition = ((!trans[0][nextstate].relocatable) 
        !          1356:                   ||trans[0][nextstate].no_transition);
        !          1357:   for (i=0; i<ninsts; i++) {
        !          1358:     Cell tc=0, tc2;
        !          1359:     if (i==nextdyn) {
        !          1360:       if (!no_transition) {
        !          1361:        /* process trans */
        !          1362:        PrimNum p = trans[i][nextstate].inst;
        !          1363:        struct cost *c = super_costs+p;
        !          1364:        assert(trans[i][nextstate].cost != INF_COST);
        !          1365:        assert(c->state_in==nextstate);
        !          1366:        tc = compile_prim_dyn(p);
        !          1367:        nextstate = c->state_out;
        !          1368:       }
        !          1369:       {
        !          1370:        /* process inst */
        !          1371:        PrimNum p = inst[i][nextstate].inst;
        !          1372:        struct cost *c=super_costs+p;
        !          1373:        assert(c->state_in==nextstate);
        !          1374:        assert(inst[i][nextstate].cost != INF_COST);
        !          1375: #if defined(GFORTH_DEBUGGING)
        !          1376:        assert(p == origs[i]);
        !          1377: #endif
        !          1378:        tc2 = compile_prim_dyn(p);
        !          1379:        if (no_transition || !is_relocatable(p))
        !          1380:          /* !! actually what we care about is if and where
        !          1381:           * compile_prim_dyn() puts NEXTs */
        !          1382:          tc=tc2;
        !          1383:        no_transition = inst[i][nextstate].no_transition;
        !          1384:        nextstate = c->state_out;
        !          1385:        nextdyn += c->length;
        !          1386:       }
        !          1387:     } else {
        !          1388: #if defined(GFORTH_DEBUGGING)
        !          1389:       assert(0);
        !          1390: #endif
        !          1391:       tc=0;
        !          1392:       /* tc= (Cell)vm_prims[inst[i][CANONICAL_STATE].inst]; */
        !          1393:     }
        !          1394:     *(instps[i]) = tc;
        !          1395:   }      
        !          1396:   if (!no_transition) {
        !          1397:     PrimNum p = trans[i][nextstate].inst;
        !          1398:     struct cost *c = super_costs+p;
        !          1399:     assert(c->state_in==nextstate);
        !          1400:     assert(trans[i][nextstate].cost != INF_COST);
        !          1401:     assert(i==nextdyn);
        !          1402:     (void)compile_prim_dyn(p);
        !          1403:     nextstate = c->state_out;
1.107     anton    1404:   }
1.125   ! anton    1405:   assert(nextstate==CANONICAL_STATE);
1.107     anton    1406: }
                   1407: 
                   1408: /* rewrite the instructions pointed to by instps to use the
                   1409:    superinstructions in optimals */
1.125   ! anton    1410: static void rewrite_bb(Cell *instps[], PrimNum *optimals, int ninsts)
1.107     anton    1411: {
1.110     anton    1412:   int i,j, nextdyn;
1.108     anton    1413:   Cell inst;
1.107     anton    1414: 
                   1415:   for (i=0, nextdyn=0; i<ninsts; i++) {
1.108     anton    1416:     if (i==nextdyn) { /* compile dynamically */
1.107     anton    1417:       nextdyn += super_costs[optimals[i]].length;
1.108     anton    1418:       inst = compile_prim_dyn(optimals[i]);
1.110     anton    1419:       for (j=0; j<sizeof(cost_sums)/sizeof(cost_sums[0]); j++)
                   1420:        cost_sums[j].sum += cost_sums[j].costfunc(optimals[i]);
1.108     anton    1421:     } else { /* compile statically */
1.121     anton    1422:       inst = (Cell)vm_prims[optimals[i]];
1.107     anton    1423:     }
1.108     anton    1424:     *(instps[i]) = inst;
1.107     anton    1425:   }
                   1426: }
                   1427: 
1.105     anton    1428: /* compile *start, possibly rewriting it into a static and/or dynamic
                   1429:    superinstruction */
                   1430: void compile_prim1(Cell *start)
1.70      anton    1431: {
1.108     anton    1432: #if defined(DOUBLY_INDIRECT)
1.125   ! anton    1433:   Label prim;
        !          1434: 
        !          1435:   if (start==NULL)
        !          1436:     return;
        !          1437:   prim = (Label)*start;
1.108     anton    1438:   if (prim<((Label)(xts+DOESJUMP)) || prim>((Label)(xts+npriminfos))) {
                   1439:     fprintf(stderr,"compile_prim encountered xt %p\n", prim);
                   1440:     *start=(Cell)prim;
                   1441:     return;
                   1442:   } else {
                   1443:     *start = (Cell)(prim-((Label)xts)+((Label)vm_prims));
                   1444:     return;
                   1445:   }
                   1446: #elif defined(INDIRECT_THREADED)
                   1447:   return;
1.112     anton    1448: #else /* !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED)) */
1.107     anton    1449:   static Cell *instps[MAX_BB];
1.121     anton    1450:   static PrimNum origs[MAX_BB];
1.106     anton    1451:   static int ninsts=0;
1.121     anton    1452:   PrimNum prim_num;
1.106     anton    1453: 
                   1454:   if (start==NULL)
                   1455:     goto end_bb;
                   1456:   prim_num = ((Xt)*start)-vm_prims;
                   1457:   if (prim_num >= npriminfos)
                   1458:     goto end_bb;
                   1459:   assert(ninsts<MAX_BB);
1.107     anton    1460:   instps[ninsts] = start;
1.121     anton    1461:   origs[ninsts] = prim_num;
1.107     anton    1462:   ninsts++;
1.121     anton    1463:   if (ninsts >= MAX_BB || superend[prim_num]) {
1.106     anton    1464:   end_bb:
1.125   ! anton    1465:     optimize_rewrite(instps,origs,ninsts);
1.106     anton    1466:     ninsts=0;
                   1467:   }
1.112     anton    1468: #endif /* !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED)) */
1.47      anton    1469: }
                   1470: 
1.1       anton    1471: Address loader(FILE *imagefile, char* filename)
                   1472: /* returns the address of the image proper (after the preamble) */
                   1473: {
                   1474:   ImageHeader header;
                   1475:   Address image;
                   1476:   Address imp; /* image+preamble */
1.17      anton    1477:   Char magic[8];
                   1478:   char magic7; /* size byte of magic number */
1.1       anton    1479:   Cell preamblesize=0;
1.6       pazsan   1480:   Cell data_offset = offset_image ? 56*sizeof(Cell) : 0;
1.1       anton    1481:   UCell check_sum;
1.15      pazsan   1482:   Cell ausize = ((RELINFOBITS ==  8) ? 0 :
                   1483:                 (RELINFOBITS == 16) ? 1 :
                   1484:                 (RELINFOBITS == 32) ? 2 : 3);
                   1485:   Cell charsize = ((sizeof(Char) == 1) ? 0 :
                   1486:                   (sizeof(Char) == 2) ? 1 :
                   1487:                   (sizeof(Char) == 4) ? 2 : 3) + ausize;
                   1488:   Cell cellsize = ((sizeof(Cell) == 1) ? 0 :
                   1489:                   (sizeof(Cell) == 2) ? 1 :
                   1490:                   (sizeof(Cell) == 4) ? 2 : 3) + ausize;
1.21      anton    1491:   Cell sizebyte = (ausize << 5) + (charsize << 3) + (cellsize << 1) +
                   1492: #ifdef WORDS_BIGENDIAN
                   1493:        0
                   1494: #else
                   1495:        1
                   1496: #endif
                   1497:     ;
1.1       anton    1498: 
1.43      anton    1499:   vm_prims = engine(0,0,0,0,0);
1.47      anton    1500:   check_prims(vm_prims);
1.106     anton    1501:   prepare_super_table();
1.1       anton    1502: #ifndef DOUBLY_INDIRECT
1.59      anton    1503: #ifdef PRINT_SUPER_LENGTHS
                   1504:   print_super_lengths();
                   1505: #endif
1.43      anton    1506:   check_sum = checksum(vm_prims);
1.1       anton    1507: #else /* defined(DOUBLY_INDIRECT) */
1.43      anton    1508:   check_sum = (UCell)vm_prims;
1.1       anton    1509: #endif /* defined(DOUBLY_INDIRECT) */
1.10      pazsan   1510:   
                   1511:   do {
                   1512:     if(fread(magic,sizeof(Char),8,imagefile) < 8) {
1.84      anton    1513:       fprintf(stderr,"%s: image %s doesn't seem to be a Gforth (>=0.6) image.\n",
1.10      pazsan   1514:              progname, filename);
                   1515:       exit(1);
1.1       anton    1516:     }
1.10      pazsan   1517:     preamblesize+=8;
1.84      anton    1518:   } while(memcmp(magic,"Gforth3",7));
1.17      anton    1519:   magic7 = magic[7];
1.1       anton    1520:   if (debug) {
1.17      anton    1521:     magic[7]='\0';
1.21      anton    1522:     fprintf(stderr,"Magic found: %s ", magic);
                   1523:     print_sizes(magic7);
1.1       anton    1524:   }
                   1525: 
1.21      anton    1526:   if (magic7 != sizebyte)
                   1527:     {
                   1528:       fprintf(stderr,"This image is:         ");
                   1529:       print_sizes(magic7);
                   1530:       fprintf(stderr,"whereas the machine is ");
                   1531:       print_sizes(sizebyte);
1.1       anton    1532:       exit(-2);
                   1533:     };
                   1534: 
                   1535:   fread((void *)&header,sizeof(ImageHeader),1,imagefile);
1.10      pazsan   1536: 
                   1537:   set_stack_sizes(&header);
1.1       anton    1538:   
                   1539: #if HAVE_GETPAGESIZE
                   1540:   pagesize=getpagesize(); /* Linux/GNU libc offers this */
                   1541: #elif HAVE_SYSCONF && defined(_SC_PAGESIZE)
                   1542:   pagesize=sysconf(_SC_PAGESIZE); /* POSIX.4 */
                   1543: #elif PAGESIZE
                   1544:   pagesize=PAGESIZE; /* in limits.h according to Gallmeister's POSIX.4 book */
                   1545: #endif
                   1546:   if (debug)
1.5       jwilke   1547:     fprintf(stderr,"pagesize=%ld\n",(unsigned long) pagesize);
1.1       anton    1548: 
1.34      anton    1549:   image = dict_alloc_read(imagefile, preamblesize+header.image_size,
                   1550:                          preamblesize+dictsize, data_offset);
1.33      anton    1551:   imp=image+preamblesize;
1.57      anton    1552:   alloc_stacks((ImageHeader *)imp);
1.1       anton    1553:   if (clear_dictionary)
1.33      anton    1554:     memset(imp+header.image_size, 0, dictsize-header.image_size);
1.90      anton    1555:   if(header.base==0 || header.base  == (Address)0x100) {
1.1       anton    1556:     Cell reloc_size=((header.image_size-1)/sizeof(Cell))/8+1;
                   1557:     char reloc_bits[reloc_size];
1.33      anton    1558:     fseek(imagefile, preamblesize+header.image_size, SEEK_SET);
1.10      pazsan   1559:     fread(reloc_bits, 1, reloc_size, imagefile);
1.90      anton    1560:     relocate((Cell *)imp, reloc_bits, header.image_size, (Cell)header.base, vm_prims);
1.1       anton    1561: #if 0
                   1562:     { /* let's see what the relocator did */
                   1563:       FILE *snapshot=fopen("snapshot.fi","wb");
                   1564:       fwrite(image,1,imagesize,snapshot);
                   1565:       fclose(snapshot);
                   1566:     }
                   1567: #endif
1.46      jwilke   1568:   }
                   1569:   else if(header.base!=imp) {
                   1570:     fprintf(stderr,"%s: Cannot load nonrelocatable image (compiled for address $%lx) at address $%lx\n",
                   1571:            progname, (unsigned long)header.base, (unsigned long)imp);
                   1572:     exit(1);
1.1       anton    1573:   }
                   1574:   if (header.checksum==0)
                   1575:     ((ImageHeader *)imp)->checksum=check_sum;
                   1576:   else if (header.checksum != check_sum) {
                   1577:     fprintf(stderr,"%s: Checksum of image ($%lx) does not match the executable ($%lx)\n",
                   1578:            progname, (unsigned long)(header.checksum),(unsigned long)check_sum);
                   1579:     exit(1);
                   1580:   }
1.53      anton    1581: #ifdef DOUBLY_INDIRECT
                   1582:   ((ImageHeader *)imp)->xt_base = xts;
                   1583: #endif
1.1       anton    1584:   fclose(imagefile);
                   1585: 
1.56      anton    1586:   /* unnecessary, except maybe for CODE words */
                   1587:   /* FLUSH_ICACHE(imp, header.image_size);*/
1.1       anton    1588: 
                   1589:   return imp;
                   1590: }
                   1591: 
1.72      anton    1592: /* pointer to last '/' or '\' in file, 0 if there is none. */
                   1593: char *onlypath(char *filename)
1.10      pazsan   1594: {
1.72      anton    1595:   return strrchr(filename, DIRSEP);
1.1       anton    1596: }
                   1597: 
                   1598: FILE *openimage(char *fullfilename)
1.10      pazsan   1599: {
                   1600:   FILE *image_file;
1.28      anton    1601:   char * expfilename = tilde_cstr(fullfilename, strlen(fullfilename), 1);
1.10      pazsan   1602: 
1.28      anton    1603:   image_file=fopen(expfilename,"rb");
1.1       anton    1604:   if (image_file!=NULL && debug)
1.28      anton    1605:     fprintf(stderr, "Opened image file: %s\n", expfilename);
1.10      pazsan   1606:   return image_file;
1.1       anton    1607: }
                   1608: 
1.28      anton    1609: /* try to open image file concat(path[0:len],imagename) */
1.1       anton    1610: FILE *checkimage(char *path, int len, char *imagename)
1.10      pazsan   1611: {
                   1612:   int dirlen=len;
1.1       anton    1613:   char fullfilename[dirlen+strlen(imagename)+2];
1.10      pazsan   1614: 
1.1       anton    1615:   memcpy(fullfilename, path, dirlen);
1.71      pazsan   1616:   if (fullfilename[dirlen-1]!=DIRSEP)
                   1617:     fullfilename[dirlen++]=DIRSEP;
1.1       anton    1618:   strcpy(fullfilename+dirlen,imagename);
1.10      pazsan   1619:   return openimage(fullfilename);
1.1       anton    1620: }
                   1621: 
1.10      pazsan   1622: FILE * open_image_file(char * imagename, char * path)
1.1       anton    1623: {
1.10      pazsan   1624:   FILE * image_file=NULL;
1.28      anton    1625:   char *origpath=path;
1.10      pazsan   1626:   
1.71      pazsan   1627:   if(strchr(imagename, DIRSEP)==NULL) {
1.10      pazsan   1628:     /* first check the directory where the exe file is in !! 01may97jaw */
                   1629:     if (onlypath(progname))
1.72      anton    1630:       image_file=checkimage(progname, onlypath(progname)-progname, imagename);
1.10      pazsan   1631:     if (!image_file)
                   1632:       do {
                   1633:        char *pend=strchr(path, PATHSEP);
                   1634:        if (pend==NULL)
                   1635:          pend=path+strlen(path);
                   1636:        if (strlen(path)==0) break;
                   1637:        image_file=checkimage(path, pend-path, imagename);
                   1638:        path=pend+(*pend==PATHSEP);
                   1639:       } while (image_file==NULL);
                   1640:   } else {
                   1641:     image_file=openimage(imagename);
                   1642:   }
1.1       anton    1643: 
1.10      pazsan   1644:   if (!image_file) {
                   1645:     fprintf(stderr,"%s: cannot open image file %s in path %s for reading\n",
1.28      anton    1646:            progname, imagename, origpath);
1.10      pazsan   1647:     exit(1);
1.7       anton    1648:   }
                   1649: 
1.10      pazsan   1650:   return image_file;
                   1651: }
1.11      pazsan   1652: #endif
                   1653: 
                   1654: #ifdef HAS_OS
                   1655: UCell convsize(char *s, UCell elemsize)
                   1656: /* converts s of the format [0-9]+[bekMGT]? (e.g. 25k) into the number
                   1657:    of bytes.  the letter at the end indicates the unit, where e stands
                   1658:    for the element size. default is e */
                   1659: {
                   1660:   char *endp;
                   1661:   UCell n,m;
                   1662: 
                   1663:   m = elemsize;
                   1664:   n = strtoul(s,&endp,0);
                   1665:   if (endp!=NULL) {
                   1666:     if (strcmp(endp,"b")==0)
                   1667:       m=1;
                   1668:     else if (strcmp(endp,"k")==0)
                   1669:       m=1024;
                   1670:     else if (strcmp(endp,"M")==0)
                   1671:       m=1024*1024;
                   1672:     else if (strcmp(endp,"G")==0)
                   1673:       m=1024*1024*1024;
                   1674:     else if (strcmp(endp,"T")==0) {
                   1675: #if (SIZEOF_CHAR_P > 4)
1.24      anton    1676:       m=1024L*1024*1024*1024;
1.11      pazsan   1677: #else
                   1678:       fprintf(stderr,"%s: size specification \"%s\" too large for this machine\n", progname, endp);
                   1679:       exit(1);
                   1680: #endif
                   1681:     } else if (strcmp(endp,"e")!=0 && strcmp(endp,"")!=0) {
                   1682:       fprintf(stderr,"%s: cannot grok size specification %s: invalid unit \"%s\"\n", progname, s, endp);
                   1683:       exit(1);
                   1684:     }
                   1685:   }
                   1686:   return n*m;
                   1687: }
1.10      pazsan   1688: 
1.109     anton    1689: enum {
                   1690:   ss_number = 256,
1.125   ! anton    1691:   ss_states,
1.109     anton    1692:   ss_min_codesize,
                   1693:   ss_min_ls,
                   1694:   ss_min_lsu,
                   1695:   ss_min_nexts,
                   1696: };
                   1697: 
1.10      pazsan   1698: void gforth_args(int argc, char ** argv, char ** path, char ** imagename)
                   1699: {
                   1700:   int c;
                   1701: 
1.1       anton    1702:   opterr=0;
                   1703:   while (1) {
                   1704:     int option_index=0;
                   1705:     static struct option opts[] = {
1.29      anton    1706:       {"appl-image", required_argument, NULL, 'a'},
1.1       anton    1707:       {"image-file", required_argument, NULL, 'i'},
                   1708:       {"dictionary-size", required_argument, NULL, 'm'},
                   1709:       {"data-stack-size", required_argument, NULL, 'd'},
                   1710:       {"return-stack-size", required_argument, NULL, 'r'},
                   1711:       {"fp-stack-size", required_argument, NULL, 'f'},
                   1712:       {"locals-stack-size", required_argument, NULL, 'l'},
                   1713:       {"path", required_argument, NULL, 'p'},
                   1714:       {"version", no_argument, NULL, 'v'},
                   1715:       {"help", no_argument, NULL, 'h'},
                   1716:       /* put something != 0 into offset_image */
                   1717:       {"offset-image", no_argument, &offset_image, 1},
                   1718:       {"no-offset-im", no_argument, &offset_image, 0},
                   1719:       {"clear-dictionary", no_argument, &clear_dictionary, 1},
1.4       anton    1720:       {"die-on-signal", no_argument, &die_on_signal, 1},
1.1       anton    1721:       {"debug", no_argument, &debug, 1},
1.60      anton    1722:       {"no-super", no_argument, &no_super, 1},
                   1723:       {"no-dynamic", no_argument, &no_dynamic, 1},
1.66      anton    1724:       {"dynamic", no_argument, &no_dynamic, 0},
1.110     anton    1725:       {"print-metrics", no_argument, &print_metrics, 1},
1.109     anton    1726:       {"ss-number", required_argument, NULL, ss_number},
1.125   ! anton    1727:       {"ss-states", required_argument, NULL, ss_states},
1.109     anton    1728: #ifndef NO_DYNAMIC
                   1729:       {"ss-min-codesize", no_argument, NULL, ss_min_codesize},
                   1730: #endif
                   1731:       {"ss-min-ls",       no_argument, NULL, ss_min_ls},
                   1732:       {"ss-min-lsu",      no_argument, NULL, ss_min_lsu},
                   1733:       {"ss-min-nexts",    no_argument, NULL, ss_min_nexts},
1.110     anton    1734:       {"ss-greedy",       no_argument, &ss_greedy, 1},
1.1       anton    1735:       {0,0,0,0}
                   1736:       /* no-init-file, no-rc? */
                   1737:     };
                   1738:     
1.36      pazsan   1739:     c = getopt_long(argc, argv, "+i:m:d:r:f:l:p:vhoncsx", opts, &option_index);
1.1       anton    1740:     
                   1741:     switch (c) {
1.29      anton    1742:     case EOF: return;
                   1743:     case '?': optind--; return;
                   1744:     case 'a': *imagename = optarg; return;
1.10      pazsan   1745:     case 'i': *imagename = optarg; break;
1.1       anton    1746:     case 'm': dictsize = convsize(optarg,sizeof(Cell)); break;
                   1747:     case 'd': dsize = convsize(optarg,sizeof(Cell)); break;
                   1748:     case 'r': rsize = convsize(optarg,sizeof(Cell)); break;
                   1749:     case 'f': fsize = convsize(optarg,sizeof(Float)); break;
                   1750:     case 'l': lsize = convsize(optarg,sizeof(Cell)); break;
1.10      pazsan   1751:     case 'p': *path = optarg; break;
1.36      pazsan   1752:     case 'o': offset_image = 1; break;
                   1753:     case 'n': offset_image = 0; break;
                   1754:     case 'c': clear_dictionary = 1; break;
                   1755:     case 's': die_on_signal = 1; break;
                   1756:     case 'x': debug = 1; break;
1.83      anton    1757:     case 'v': fputs(PACKAGE_STRING"\n", stderr); exit(0);
1.109     anton    1758:     case ss_number: static_super_number = atoi(optarg); break;
1.125   ! anton    1759:     case ss_states: maxstates = max(min(atoi(optarg),MAX_STATE),1); break;
1.109     anton    1760: #ifndef NO_DYNAMIC
                   1761:     case ss_min_codesize: ss_cost = cost_codesize; break;
                   1762: #endif
                   1763:     case ss_min_ls:       ss_cost = cost_ls;       break;
                   1764:     case ss_min_lsu:      ss_cost = cost_lsu;      break;
                   1765:     case ss_min_nexts:    ss_cost = cost_nexts;    break;
1.1       anton    1766:     case 'h': 
1.29      anton    1767:       fprintf(stderr, "Usage: %s [engine options] ['--'] [image arguments]\n\
1.1       anton    1768: Engine Options:\n\
1.29      anton    1769:   --appl-image FILE                equivalent to '--image-file=FILE --'\n\
1.10      pazsan   1770:   --clear-dictionary               Initialize the dictionary with 0 bytes\n\
                   1771:   -d SIZE, --data-stack-size=SIZE   Specify data stack size\n\
                   1772:   --debug                          Print debugging information during startup\n\
                   1773:   --die-on-signal                  exit instead of CATCHing some signals\n\
1.66      anton    1774:   --dynamic                        use dynamic native code\n\
1.10      pazsan   1775:   -f SIZE, --fp-stack-size=SIZE            Specify floating point stack size\n\
                   1776:   -h, --help                       Print this message and exit\n\
                   1777:   -i FILE, --image-file=FILE       Use image FILE instead of `gforth.fi'\n\
                   1778:   -l SIZE, --locals-stack-size=SIZE Specify locals stack size\n\
                   1779:   -m SIZE, --dictionary-size=SIZE   Specify Forth dictionary size\n\
1.60      anton    1780:   --no-dynamic                     Use only statically compiled primitives\n\
1.10      pazsan   1781:   --no-offset-im                   Load image at normal position\n\
1.60      anton    1782:   --no-super                        No dynamically formed superinstructions\n\
1.10      pazsan   1783:   --offset-image                   Load image at a different position\n\
                   1784:   -p PATH, --path=PATH             Search path for finding image and sources\n\
1.110     anton    1785:   --print-metrics                  Print some code generation metrics on exit\n\
1.10      pazsan   1786:   -r SIZE, --return-stack-size=SIZE Specify return stack size\n\
1.111     anton    1787:   --ss-greedy                       greedy, not optimal superinst selection\n\
                   1788:   --ss-min-codesize                 select superinsts for smallest native code\n\
                   1789:   --ss-min-ls                       minimize loads and stores\n\
                   1790:   --ss-min-lsu                      minimize loads, stores, and pointer updates\n\
                   1791:   --ss-min-nexts                    minimize the number of static superinsts\n\
                   1792:   --ss-number=N                     use N static superinsts (default max)\n\
1.125   ! anton    1793:   --ss-states=N                     N states for stack caching (default max)\n\
1.66      anton    1794:   -v, --version                            Print engine version and exit\n\
1.1       anton    1795: SIZE arguments consist of an integer followed by a unit. The unit can be\n\
1.10      pazsan   1796:   `b' (byte), `e' (element; default), `k' (KB), `M' (MB), `G' (GB) or `T' (TB).\n",
                   1797:              argv[0]);
                   1798:       optind--;
                   1799:       return;
1.1       anton    1800:     }
                   1801:   }
1.10      pazsan   1802: }
1.11      pazsan   1803: #endif
1.10      pazsan   1804: 
                   1805: #ifdef INCLUDE_IMAGE
                   1806: extern Cell image[];
                   1807: extern const char reloc_bits[];
                   1808: #endif
1.67      pazsan   1809: 
1.10      pazsan   1810: int main(int argc, char **argv, char **env)
                   1811: {
1.30      pazsan   1812: #ifdef HAS_OS
1.10      pazsan   1813:   char *path = getenv("GFORTHPATH") ? : DEFAULTPATH;
1.30      pazsan   1814: #else
                   1815:   char *path = DEFAULTPATH;
                   1816: #endif
1.13      pazsan   1817: #ifndef INCLUDE_IMAGE
1.10      pazsan   1818:   char *imagename="gforth.fi";
                   1819:   FILE *image_file;
                   1820:   Address image;
                   1821: #endif
                   1822:   int retvalue;
                   1823:          
1.56      anton    1824: #if defined(i386) && defined(ALIGNMENT_CHECK)
1.10      pazsan   1825:   /* turn on alignment checks on the 486.
                   1826:    * on the 386 this should have no effect. */
                   1827:   __asm__("pushfl; popl %eax; orl $0x40000, %eax; pushl %eax; popfl;");
                   1828:   /* this is unusable with Linux' libc.4.6.27, because this library is
                   1829:      not alignment-clean; we would have to replace some library
                   1830:      functions (e.g., memcpy) to make it work. Also GCC doesn't try to keep
                   1831:      the stack FP-aligned. */
                   1832: #endif
                   1833: 
                   1834:   /* buffering of the user output device */
1.11      pazsan   1835: #ifdef _IONBF
1.10      pazsan   1836:   if (isatty(fileno(stdout))) {
                   1837:     fflush(stdout);
                   1838:     setvbuf(stdout,NULL,_IONBF,0);
1.1       anton    1839:   }
1.11      pazsan   1840: #endif
1.1       anton    1841: 
1.10      pazsan   1842:   progname = argv[0];
                   1843: 
1.11      pazsan   1844: #ifdef HAS_OS
1.10      pazsan   1845:   gforth_args(argc, argv, &path, &imagename);
1.109     anton    1846: #ifndef NO_DYNAMIC
                   1847:   if (no_dynamic && ss_cost == cost_codesize) {
1.122     anton    1848:     ss_cost = cost_nexts;
                   1849:     cost_sums[0] = cost_sums[1]; /* don't use cost_codesize for print-metrics */
1.109     anton    1850:     if (debug)
1.122     anton    1851:       fprintf(stderr, "--no-dynamic conflicts with --ss-min-codesize, reverting to --ss-min-nexts\n");
1.109     anton    1852:   }
                   1853: #endif /* !defined(NO_DYNAMIC) */
                   1854: #endif /* defined(HAS_OS) */
1.10      pazsan   1855: 
                   1856: #ifdef INCLUDE_IMAGE
                   1857:   set_stack_sizes((ImageHeader *)image);
1.22      pazsan   1858:   if(((ImageHeader *)image)->base != image)
                   1859:     relocate(image, reloc_bits, ((ImageHeader *)image)->image_size,
                   1860:             (Label*)engine(0, 0, 0, 0, 0));
1.10      pazsan   1861:   alloc_stacks((ImageHeader *)image);
                   1862: #else
                   1863:   image_file = open_image_file(imagename, path);
                   1864:   image = loader(image_file, imagename);
                   1865: #endif
1.24      anton    1866:   gforth_header=(ImageHeader *)image; /* used in SIGSEGV handler */
1.1       anton    1867: 
                   1868:   {
1.10      pazsan   1869:     char path2[strlen(path)+1];
1.1       anton    1870:     char *p1, *p2;
                   1871:     Cell environ[]= {
                   1872:       (Cell)argc-(optind-1),
                   1873:       (Cell)(argv+(optind-1)),
1.10      pazsan   1874:       (Cell)strlen(path),
1.1       anton    1875:       (Cell)path2};
                   1876:     argv[optind-1] = progname;
                   1877:     /*
                   1878:        for (i=0; i<environ[0]; i++)
                   1879:        printf("%s\n", ((char **)(environ[1]))[i]);
                   1880:        */
                   1881:     /* make path OS-independent by replacing path separators with NUL */
1.10      pazsan   1882:     for (p1=path, p2=path2; *p1!='\0'; p1++, p2++)
1.1       anton    1883:       if (*p1==PATHSEP)
                   1884:        *p2 = '\0';
                   1885:       else
                   1886:        *p2 = *p1;
                   1887:     *p2='\0';
1.10      pazsan   1888:     retvalue = go_forth(image, 4, environ);
1.102     anton    1889: #ifdef SIGPIPE
                   1890:     bsd_signal(SIGPIPE, SIG_IGN);
                   1891: #endif
1.42      anton    1892: #ifdef VM_PROFILING
                   1893:     vm_print_profile(stderr);
                   1894: #endif
1.1       anton    1895:     deprep_terminal();
1.104     anton    1896:   }
1.110     anton    1897:   if (print_metrics) {
                   1898:     int i;
                   1899:     fprintf(stderr, "code size = %8ld\n", dyncodesize());
                   1900:     for (i=0; i<sizeof(cost_sums)/sizeof(cost_sums[0]); i++)
                   1901:       fprintf(stderr, "metric %8s: %8ld\n",
                   1902:              cost_sums[i].metricname, cost_sums[i].sum);
1.1       anton    1903:   }
1.13      pazsan   1904:   return retvalue;
1.1       anton    1905: }

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>