Annotation of gforth/engine/main.c, revision 1.253
1.1 anton 1: /* command line interpretation, image loading etc. for Gforth
2:
3:
1.239 anton 4: Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,2009,2010,2011 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
1.193 anton 10: as published by the Free Software Foundation, either version 3
1.1 anton 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
1.193 anton 19: along with this program; if not, see http://www.gnu.org/licenses/.
1.1 anton 20: */
21:
22: #include "config.h"
1.82 anton 23: #include "forth.h"
1.1 anton 24: #include <errno.h>
25: #include <ctype.h>
26: #include <stdio.h>
1.2 pazsan 27: #include <unistd.h>
1.1 anton 28: #include <string.h>
29: #include <math.h>
30: #include <sys/types.h>
1.214 anton 31: #ifdef HAVE_ALLOCA_H
1.213 anton 32: #include <alloca.h>
1.214 anton 33: #endif
1.32 pazsan 34: #ifndef STANDALONE
1.1 anton 35: #include <sys/stat.h>
1.32 pazsan 36: #endif
1.1 anton 37: #include <fcntl.h>
38: #include <assert.h>
39: #include <stdlib.h>
1.102 anton 40: #include <signal.h>
1.220 anton 41:
1.11 pazsan 42: #ifndef STANDALONE
1.1 anton 43: #if HAVE_SYS_MMAN_H
44: #include <sys/mman.h>
45: #endif
1.11 pazsan 46: #endif
1.1 anton 47: #include "io.h"
48: #include "getopt.h"
1.228 pazsan 49: #ifndef STANDALONE
50: #include <locale.h>
1.11 pazsan 51: #endif
1.1 anton 52:
1.190 anton 53: /* output rules etc. for burg with --debug and --print-sequences */
54: /* #define BURG_FORMAT*/
55:
1.121 anton 56: typedef enum prim_num {
1.119 anton 57: /* definitions of N_execute etc. */
1.126 anton 58: #include PRIM_NUM_I
1.119 anton 59: N_START_SUPER
1.121 anton 60: } PrimNum;
1.119 anton 61:
1.79 anton 62: /* global variables for engine.c
63: We put them here because engine.c is compiled several times in
64: different ways for the same engine. */
1.251 pazsan 65: PER_THREAD Cell *gforth_SP;
66: PER_THREAD Float *gforth_FP;
67: PER_THREAD Address gforth_UP=NULL;
68: PER_THREAD Cell *gforth_RP;
69: PER_THREAD Address gforth_LP;
1.79 anton 70:
1.253 ! pazsan 71: void gforth_push(Cell n)
! 72: {
! 73: *--gforth_SP=n;
! 74: }
! 75:
! 76: Cell gforth_pop()
! 77: {
! 78: return *gforth_SP++;
! 79: }
! 80:
! 81: void gforth_fpush(Float r)
! 82: {
! 83: *--gforth_FP=r;
! 84: }
! 85:
! 86: Float gforth_fpop()
! 87: {
! 88: return *gforth_FP++;
! 89: }
! 90:
1.115 pazsan 91: #ifdef HAS_FFCALL
92:
93: #include <callback.h>
94:
1.251 pazsan 95: PER_THREAD va_alist gforth_clist;
1.115 pazsan 96:
1.161 pazsan 97: void gforth_callback(Xt* fcall, void * alist)
1.115 pazsan 98: {
1.140 pazsan 99: /* save global valiables */
1.161 pazsan 100: Cell *rp = gforth_RP;
101: Cell *sp = gforth_SP;
102: Float *fp = gforth_FP;
103: Address lp = gforth_LP;
1.168 pazsan 104: va_alist clist = gforth_clist;
1.140 pazsan 105:
1.161 pazsan 106: gforth_clist = (va_alist)alist;
1.140 pazsan 107:
1.197 anton 108: gforth_engine(fcall, sp, rp, fp, lp sr_call);
1.140 pazsan 109:
110: /* restore global variables */
1.161 pazsan 111: gforth_RP = rp;
112: gforth_SP = sp;
113: gforth_FP = fp;
114: gforth_LP = lp;
1.168 pazsan 115: gforth_clist = clist;
1.115 pazsan 116: }
117: #endif
118:
1.79 anton 119: #ifdef GFORTH_DEBUGGING
120: /* define some VM registers as global variables, so they survive exceptions;
121: global register variables are not up to the task (according to the
122: GNU C manual) */
1.197 anton 123: #if defined(GLOBALS_NONRELOC)
124: saved_regs saved_regs_v;
1.251 pazsan 125: PER_THREAD saved_regs *saved_regs_p = &saved_regs_v;
1.197 anton 126: #else /* !defined(GLOBALS_NONRELOC) */
1.251 pazsan 127: PER_THREAD Xt *saved_ip;
128: PER_THREAD Cell *rp;
1.197 anton 129: #endif /* !defined(GLOBALS_NONRELOC) */
130: #endif /* !defined(GFORTH_DEBUGGING) */
1.79 anton 131:
132: #ifdef NO_IP
133: Label next_code;
134: #endif
135:
136: #ifdef HAS_FILE
137: char* fileattr[6]={"rb","rb","r+b","r+b","wb","wb"};
138: char* pfileattr[6]={"r","r","r+","r+","w","w"};
139:
140: #ifndef O_BINARY
141: #define O_BINARY 0
142: #endif
143: #ifndef O_TEXT
144: #define O_TEXT 0
145: #endif
146:
147: int ufileattr[6]= {
148: O_RDONLY|O_BINARY, O_RDONLY|O_BINARY,
149: O_RDWR |O_BINARY, O_RDWR |O_BINARY,
150: O_WRONLY|O_BINARY, O_WRONLY|O_BINARY };
151: #endif
152: /* end global vars for engine.c */
153:
1.1 anton 154: #define PRIM_VERSION 1
155: /* increment this whenever the primitives change in an incompatible way */
156:
1.14 pazsan 157: #ifndef DEFAULTPATH
1.39 anton 158: # define DEFAULTPATH "."
1.14 pazsan 159: #endif
160:
1.1 anton 161: #ifdef MSDOS
1.246 pazsan 162: jmp_buf throw_jmp_handler;
1.1 anton 163: #endif
164:
1.56 anton 165: #if defined(DOUBLY_INDIRECT)
166: # define CFA(n) ({Cell _n = (n); ((Cell)(((_n & 0x4000) ? symbols : xts)+(_n&~0x4000UL)));})
1.1 anton 167: #else
1.56 anton 168: # define CFA(n) ((Cell)(symbols+((n)&~0x4000UL)))
1.1 anton 169: #endif
170:
171: #define maxaligned(n) (typeof(n))((((Cell)n)+sizeof(Float)-1)&-sizeof(Float))
172:
173: static UCell dictsize=0;
174: static UCell dsize=0;
175: static UCell rsize=0;
176: static UCell fsize=0;
177: static UCell lsize=0;
178: int offset_image=0;
1.4 anton 179: int die_on_signal=0;
1.169 anton 180: int ignore_async_signals=0;
1.13 pazsan 181: #ifndef INCLUDE_IMAGE
1.1 anton 182: static int clear_dictionary=0;
1.24 anton 183: UCell pagesize=1;
1.22 pazsan 184: char *progname;
185: #else
186: char *progname = "gforth";
187: int optind = 1;
1.13 pazsan 188: #endif
1.181 anton 189: #ifndef MAP_NORESERVE
190: #define MAP_NORESERVE 0
191: #endif
1.183 pazsan 192: /* IF you have an old Cygwin, this may help:
1.182 pazsan 193: #ifdef __CYGWIN__
194: #define MAP_NORESERVE 0
195: #endif
1.183 pazsan 196: */
1.181 anton 197: static int map_noreserve=MAP_NORESERVE;
1.31 pazsan 198:
1.167 anton 199: #define CODE_BLOCK_SIZE (512*1024) /* !! overflow handling for -native */
1.48 anton 200: Address code_area=0;
1.73 anton 201: Cell code_area_size = CODE_BLOCK_SIZE;
1.211 anton 202: Address code_here; /* does for code-area what HERE does for the dictionary */
1.100 anton 203: Address start_flush=NULL; /* start of unflushed code */
1.74 anton 204: Cell last_jump=0; /* if the last prim was compiled without jump, this
205: is it's number, otherwise this contains 0 */
1.48 anton 206:
1.60 anton 207: static int no_super=0; /* true if compile_prim should not fuse prims */
1.81 anton 208: static int no_dynamic=NO_DYNAMIC_DEFAULT; /* if true, no code is generated
209: dynamically */
1.110 anton 210: static int print_metrics=0; /* if true, print metrics on exit */
1.194 anton 211: static int static_super_number = 10000; /* number of ss used if available */
1.152 anton 212: #define MAX_STATE 9 /* maximum number of states */
1.125 anton 213: static int maxstates = MAX_STATE; /* number of states for stack caching */
1.110 anton 214: static int ss_greedy = 0; /* if true: use greedy, not optimal ss selection */
1.144 pazsan 215: static int diag = 0; /* if true: print diagnostic informations */
1.158 anton 216: static int tpa_noequiv = 0; /* if true: no state equivalence checking */
217: static int tpa_noautomaton = 0; /* if true: no tree parsing automaton */
218: static int tpa_trace = 0; /* if true: data for line graph of new states etc. */
1.189 anton 219: static int print_sequences = 0; /* print primitive sequences for optimization */
1.144 pazsan 220: static int relocs = 0;
221: static int nonrelocs = 0;
1.60 anton 222:
1.30 pazsan 223: #ifdef HAS_DEBUG
1.68 anton 224: int debug=0;
1.190 anton 225: # define debugp(x...) do { if (debug) fprintf(x); } while (0)
1.31 pazsan 226: #else
227: # define perror(x...)
228: # define fprintf(x...)
1.144 pazsan 229: # define debugp(x...)
1.30 pazsan 230: #endif
1.31 pazsan 231:
1.24 anton 232: ImageHeader *gforth_header;
1.43 anton 233: Label *vm_prims;
1.53 anton 234: #ifdef DOUBLY_INDIRECT
235: Label *xts; /* same content as vm_prims, but should only be used for xts */
236: #endif
1.1 anton 237:
1.125 anton 238: #ifndef NO_DYNAMIC
1.186 anton 239: #ifndef CODE_ALIGNMENT
1.185 anton 240: #define CODE_ALIGNMENT 0
241: #endif
242:
1.125 anton 243: #define MAX_IMMARGS 2
244:
245: typedef struct {
246: Label start; /* NULL if not relocatable */
247: Cell length; /* only includes the jump iff superend is true*/
248: Cell restlength; /* length of the rest (i.e., the jump or (on superend) 0) */
249: char superend; /* true if primitive ends superinstruction, i.e.,
250: unconditional branch, execute, etc. */
251: Cell nimmargs;
252: struct immarg {
253: Cell offset; /* offset of immarg within prim */
254: char rel; /* true if immarg is relative */
255: } immargs[MAX_IMMARGS];
256: } PrimInfo;
257:
258: PrimInfo *priminfos;
259: PrimInfo **decomp_prims;
260:
1.139 anton 261: const char const* const prim_names[]={
262: #include PRIM_NAMES_I
263: };
264:
1.148 anton 265: void init_ss_cost(void);
266:
1.125 anton 267: static int is_relocatable(int p)
268: {
269: return !no_dynamic && priminfos[p].start != NULL;
270: }
271: #else /* defined(NO_DYNAMIC) */
272: static int is_relocatable(int p)
273: {
274: return 0;
275: }
276: #endif /* defined(NO_DYNAMIC) */
277:
1.30 pazsan 278: #ifdef MEMCMP_AS_SUBROUTINE
279: int gforth_memcmp(const char * s1, const char * s2, size_t n)
280: {
281: return memcmp(s1, s2, n);
282: }
1.240 pazsan 283:
284: Char *gforth_memmove(Char * dest, const Char* src, Cell n)
285: {
286: return memmove(dest, src, n);
287: }
288:
289: Char *gforth_memset(Char * s, Cell c, UCell n)
290: {
291: return memset(s, c, n);
292: }
293:
294: Char *gforth_memcpy(Char * dest, const Char* src, Cell n)
295: {
296: return memcpy(dest, src, n);
297: }
1.30 pazsan 298: #endif
299:
1.125 anton 300: static Cell max(Cell a, Cell b)
301: {
302: return a>b?a:b;
303: }
304:
305: static Cell min(Cell a, Cell b)
306: {
307: return a<b?a:b;
308: }
309:
1.175 pazsan 310: #ifndef STANDALONE
1.1 anton 311: /* image file format:
1.15 pazsan 312: * "#! binary-path -i\n" (e.g., "#! /usr/local/bin/gforth-0.4.0 -i\n")
1.1 anton 313: * padding to a multiple of 8
1.234 anton 314: * magic: "Gforth4x" means format 0.8,
1.15 pazsan 315: * where x is a byte with
316: * bit 7: reserved = 0
317: * bit 6:5: address unit size 2^n octets
318: * bit 4:3: character size 2^n octets
319: * bit 2:1: cell size 2^n octets
320: * bit 0: endian, big=0, little=1.
321: * The magic are always 8 octets, no matter what the native AU/character size is
1.1 anton 322: * padding to max alignment (no padding necessary on current machines)
1.24 anton 323: * ImageHeader structure (see forth.h)
1.1 anton 324: * data (size in ImageHeader.image_size)
325: * tags ((if relocatable, 1 bit/data cell)
326: *
327: * tag==1 means that the corresponding word is an address;
328: * If the word is >=0, the address is within the image;
329: * addresses within the image are given relative to the start of the image.
330: * If the word =-1 (CF_NIL), the address is NIL,
331: * If the word is <CF_NIL and >CF(DODOES), it's a CFA (:, Create, ...)
332: * If the word =CF(DODOES), it's a DOES> CFA
1.231 anton 333: * !! ABI-CODE and ;ABI-CODE
1.229 dvdkhlng 334: * If the word is <CF(DOER_MAX) and bit 14 is set, it's the xt of a primitive
335: * If the word is <CF(DOER_MAX) and bit 14 is clear,
1.51 anton 336: * it's the threaded code of a primitive
1.85 pazsan 337: * bits 13..9 of a primitive token state which group the primitive belongs to,
338: * bits 8..0 of a primitive token index into the group
1.1 anton 339: */
340:
1.115 pazsan 341: Cell groups[32] = {
1.85 pazsan 342: 0,
1.121 anton 343: 0
1.90 anton 344: #undef GROUP
1.115 pazsan 345: #undef GROUPADD
346: #define GROUPADD(n) +n
347: #define GROUP(x, n) , 0
1.126 anton 348: #include PRIM_GRP_I
1.90 anton 349: #undef GROUP
1.115 pazsan 350: #undef GROUPADD
1.85 pazsan 351: #define GROUP(x, n)
1.115 pazsan 352: #define GROUPADD(n)
1.85 pazsan 353: };
354:
1.161 pazsan 355: static unsigned char *branch_targets(Cell *image, const unsigned char *bitstring,
1.125 anton 356: int size, Cell base)
357: /* produce a bitmask marking all the branch targets */
358: {
1.130 anton 359: int i=0, j, k, steps=(((size-1)/sizeof(Cell))/RELINFOBITS)+1;
1.125 anton 360: Cell token;
361: unsigned char bits;
1.130 anton 362: unsigned char *result=malloc(steps);
363:
364: memset(result, 0, steps);
365: for(k=0; k<steps; k++) {
1.125 anton 366: for(j=0, bits=bitstring[k]; j<RELINFOBITS; j++, i++, bits<<=1) {
1.130 anton 367: if(bits & (1U << (RELINFOBITS-1))) {
368: assert(i*sizeof(Cell) < size);
1.125 anton 369: token=image[i];
370: if (token>=base) { /* relocatable address */
371: UCell bitnum=(token-base)/sizeof(Cell);
1.154 anton 372: if (bitnum/RELINFOBITS < (UCell)steps)
373: result[bitnum/RELINFOBITS] |= 1U << ((~bitnum)&(RELINFOBITS-1));
1.125 anton 374: }
375: }
376: }
377: }
378: return result;
379: }
380:
1.162 pazsan 381: void gforth_relocate(Cell *image, const Char *bitstring,
382: UCell size, Cell base, Label symbols[])
1.1 anton 383: {
1.130 anton 384: int i=0, j, k, steps=(((size-1)/sizeof(Cell))/RELINFOBITS)+1;
1.11 pazsan 385: Cell token;
1.1 anton 386: char bits;
1.37 anton 387: Cell max_symbols;
1.46 jwilke 388: /*
1.85 pazsan 389: * A virtual start address that's the real start address minus
1.46 jwilke 390: * the one in the image
391: */
1.45 jwilke 392: Cell *start = (Cell * ) (((void *) image) - ((void *) base));
1.125 anton 393: unsigned char *targets = branch_targets(image, bitstring, size, base);
1.1 anton 394:
1.85 pazsan 395: /* group index into table */
1.115 pazsan 396: if(groups[31]==0) {
397: int groupsum=0;
398: for(i=0; i<32; i++) {
399: groupsum += groups[i];
400: groups[i] = groupsum;
401: /* printf("group[%d]=%d\n",i,groupsum); */
402: }
403: i=0;
404: }
1.46 jwilke 405:
406: /* printf("relocating to %x[%x] start=%x base=%x\n", image, size, start, base); */
1.37 anton 407:
1.121 anton 408: for (max_symbols=0; symbols[max_symbols]!=0; max_symbols++)
1.37 anton 409: ;
1.47 anton 410: max_symbols--;
1.35 pazsan 411:
1.130 anton 412: for(k=0; k<steps; k++) {
1.13 pazsan 413: for(j=0, bits=bitstring[k]; j<RELINFOBITS; j++, i++, bits<<=1) {
1.1 anton 414: /* fprintf(stderr,"relocate: image[%d]\n", i);*/
1.130 anton 415: if(bits & (1U << (RELINFOBITS-1))) {
416: assert(i*sizeof(Cell) < size);
1.35 pazsan 417: /* fprintf(stderr,"relocate: image[%d]=%d of %d\n", i, image[i], size/sizeof(Cell)); */
1.45 jwilke 418: token=image[i];
1.85 pazsan 419: if(token<0) {
420: int group = (-token & 0x3E00) >> 9;
421: if(group == 0) {
422: switch(token|0x4000) {
1.1 anton 423: case CF_NIL : image[i]=0; break;
424: #if !defined(DOUBLY_INDIRECT)
425: case CF(DOCOL) :
426: case CF(DOVAR) :
427: case CF(DOCON) :
1.188 pazsan 428: case CF(DOVAL) :
1.1 anton 429: case CF(DOUSER) :
430: case CF(DODEFER) :
1.229 dvdkhlng 431: case CF(DOFIELD) :
1.233 pazsan 432: case CF(DODOES) :
1.231 anton 433: case CF(DOABICODE) :
434: case CF(DOSEMIABICODE):
435: MAKE_CF(image+i,symbols[CF(token)]); break;
1.1 anton 436: #endif /* !defined(DOUBLY_INDIRECT) */
1.85 pazsan 437: default : /* backward compatibility */
1.56 anton 438: /* printf("Code field generation image[%x]:=CFA(%x)\n",
1.1 anton 439: i, CF(image[i])); */
1.55 anton 440: if (CF((token | 0x4000))<max_symbols) {
1.56 anton 441: image[i]=(Cell)CFA(CF(token));
442: #ifdef DIRECT_THREADED
1.125 anton 443: if ((token & 0x4000) == 0) { /* threade code, no CFA */
444: if (targets[k] & (1U<<(RELINFOBITS-1-j)))
445: compile_prim1(0);
1.70 anton 446: compile_prim1(&image[i]);
1.125 anton 447: }
1.56 anton 448: #endif
1.55 anton 449: } else
1.250 pazsan 450: fprintf(stderr,"Primitive %ld used in this image at %p (offset $%x) is not implemented by this\n engine (%s); executing this code will crash.\n",(long)CF(token), &image[i], i, PACKAGE_VERSION);
1.1 anton 451: }
1.85 pazsan 452: } else {
453: int tok = -token & 0x1FF;
454: if (tok < (groups[group+1]-groups[group])) {
455: #if defined(DOUBLY_INDIRECT)
456: image[i]=(Cell)CFA(((groups[group]+tok) | (CF(token) & 0x4000)));
457: #else
458: image[i]=(Cell)CFA((groups[group]+tok));
459: #endif
460: #ifdef DIRECT_THREADED
1.125 anton 461: if ((token & 0x4000) == 0) { /* threade code, no CFA */
462: if (targets[k] & (1U<<(RELINFOBITS-1-j)))
463: compile_prim1(0);
1.85 pazsan 464: compile_prim1(&image[i]);
1.125 anton 465: }
1.85 pazsan 466: #endif
467: } else
1.250 pazsan 468: fprintf(stderr,"Primitive %lx, %d of group %d used in this image at %p (offset $%x) is not implemented by this\n engine (%s); executing this code will crash.\n", (long)-token, tok, group, &image[i],i,PACKAGE_VERSION);
1.85 pazsan 469: }
470: } else {
1.101 anton 471: /* if base is > 0: 0 is a null reference so don't adjust*/
1.45 jwilke 472: if (token>=base) {
473: image[i]+=(Cell)start;
474: }
1.46 jwilke 475: }
1.1 anton 476: }
477: }
1.31 pazsan 478: }
1.125 anton 479: free(targets);
1.70 anton 480: finish_code();
1.26 jwilke 481: ((ImageHeader*)(image))->base = (Address) image;
1.1 anton 482: }
483:
1.162 pazsan 484: #ifndef DOUBLY_INDIRECT
1.161 pazsan 485: static UCell checksum(Label symbols[])
1.1 anton 486: {
487: UCell r=PRIM_VERSION;
488: Cell i;
489:
1.229 dvdkhlng 490: for (i=DOCOL; i<=DOER_MAX; i++) {
1.1 anton 491: r ^= (UCell)(symbols[i]);
492: r = (r << 5) | (r >> (8*sizeof(Cell)-5));
493: }
494: #ifdef DIRECT_THREADED
495: /* we have to consider all the primitives */
496: for (; symbols[i]!=(Label)0; i++) {
497: r ^= (UCell)(symbols[i]);
498: r = (r << 5) | (r >> (8*sizeof(Cell)-5));
499: }
500: #else
501: /* in indirect threaded code all primitives are accessed through the
502: symbols table, so we just have to put the base address of symbols
503: in the checksum */
504: r ^= (UCell)symbols;
505: #endif
506: return r;
507: }
1.162 pazsan 508: #endif
1.1 anton 509:
1.161 pazsan 510: static Address verbose_malloc(Cell size)
1.3 anton 511: {
512: Address r;
513: /* leave a little room (64B) for stack underflows */
514: if ((r = malloc(size+64))==NULL) {
515: perror(progname);
516: exit(1);
517: }
518: r = (Address)((((Cell)r)+(sizeof(Float)-1))&(-sizeof(Float)));
1.250 pazsan 519: debugp(stderr, "malloc succeeds, address=%p\n", r);
1.3 anton 520: return r;
521: }
522:
1.213 anton 523: static void *next_address=0;
1.161 pazsan 524: static void after_alloc(Address r, Cell size)
1.33 anton 525: {
526: if (r != (Address)-1) {
1.250 pazsan 527: debugp(stderr, "success, address=%p\n", r);
1.173 anton 528: #if 0
529: /* not needed now that we protect the stacks with mprotect */
1.33 anton 530: if (pagesize != 1)
531: next_address = (Address)(((((Cell)r)+size-1)&-pagesize)+2*pagesize); /* leave one page unmapped */
1.173 anton 532: #endif
1.33 anton 533: } else {
1.144 pazsan 534: debugp(stderr, "failed: %s\n", strerror(errno));
1.33 anton 535: }
536: }
537:
1.34 anton 538: #ifndef MAP_FAILED
539: #define MAP_FAILED ((Address) -1)
540: #endif
541: #ifndef MAP_FILE
542: # define MAP_FILE 0
543: #endif
544: #ifndef MAP_PRIVATE
545: # define MAP_PRIVATE 0
546: #endif
1.218 anton 547: #ifndef PROT_NONE
548: # define PROT_NONE 0
549: #endif
1.91 anton 550: #if !defined(MAP_ANON) && defined(MAP_ANONYMOUS)
551: # define MAP_ANON MAP_ANONYMOUS
552: #endif
1.34 anton 553:
554: #if defined(HAVE_MMAP)
555: static Address alloc_mmap(Cell size)
1.1 anton 556: {
1.213 anton 557: void *r;
1.1 anton 558:
559: #if defined(MAP_ANON)
1.250 pazsan 560: debugp(stderr,"try mmap(%p, $%lx, ..., MAP_ANON, ...); ", next_address, size);
1.181 anton 561: r = mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_ANON|MAP_PRIVATE|map_noreserve, -1, 0);
1.1 anton 562: #else /* !defined(MAP_ANON) */
1.17 anton 563: /* Ultrix (at least) does not define MAP_FILE and MAP_PRIVATE (both are
564: apparently defaults) */
1.1 anton 565: static int dev_zero=-1;
566:
567: if (dev_zero == -1)
568: dev_zero = open("/dev/zero", O_RDONLY);
569: if (dev_zero == -1) {
1.34 anton 570: r = MAP_FAILED;
1.144 pazsan 571: debugp(stderr, "open(\"/dev/zero\"...) failed (%s), no mmap; ",
1.1 anton 572: strerror(errno));
573: } else {
1.250 pazsan 574: debugp(stderr,"try mmap(%p, $%lx, ..., MAP_FILE, dev_zero, ...); ", next_address, size);
1.181 anton 575: r=mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FILE|MAP_PRIVATE|map_noreserve, dev_zero, 0);
1.1 anton 576: }
577: #endif /* !defined(MAP_ANON) */
1.34 anton 578: after_alloc(r, size);
579: return r;
580: }
1.172 anton 581:
1.213 anton 582: static void page_noaccess(void *a)
1.172 anton 583: {
584: /* try mprotect first; with munmap the page might be allocated later */
1.222 anton 585: debugp(stderr, "try mprotect(%p,$%lx,PROT_NONE); ", a, (long)pagesize);
1.172 anton 586: if (mprotect(a, pagesize, PROT_NONE)==0) {
587: debugp(stderr, "ok\n");
588: return;
589: }
590: debugp(stderr, "failed: %s\n", strerror(errno));
1.222 anton 591: debugp(stderr, "try munmap(%p,$%lx); ", a, (long)pagesize);
1.172 anton 592: if (munmap(a,pagesize)==0) {
593: debugp(stderr, "ok\n");
594: return;
595: }
596: debugp(stderr, "failed: %s\n", strerror(errno));
597: }
598:
1.173 anton 599: static size_t wholepage(size_t n)
1.172 anton 600: {
601: return (n+pagesize-1)&~(pagesize-1);
602: }
1.34 anton 603: #endif
604:
1.161 pazsan 605: Address gforth_alloc(Cell size)
1.34 anton 606: {
607: #if HAVE_MMAP
608: Address r;
609:
610: r=alloc_mmap(size);
1.117 anton 611: if (r!=(Address)MAP_FAILED)
1.1 anton 612: return r;
613: #endif /* HAVE_MMAP */
1.3 anton 614: /* use malloc as fallback */
615: return verbose_malloc(size);
1.1 anton 616: }
617:
1.213 anton 618: static void *dict_alloc_read(FILE *file, Cell imagesize, Cell dictsize, Cell offset)
1.33 anton 619: {
1.213 anton 620: void *image = MAP_FAILED;
1.33 anton 621:
1.56 anton 622: #if defined(HAVE_MMAP)
1.33 anton 623: if (offset==0) {
1.34 anton 624: image=alloc_mmap(dictsize);
1.213 anton 625: if (image != (void *)MAP_FAILED) {
626: void *image1;
1.250 pazsan 627: debugp(stderr,"try mmap(%p, $%lx, ..., MAP_FIXED|MAP_FILE, imagefile, 0); ", image, imagesize);
1.181 anton 628: image1 = mmap(image, imagesize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FIXED|MAP_FILE|MAP_PRIVATE|map_noreserve, fileno(file), 0);
1.150 anton 629: after_alloc(image1,dictsize);
1.213 anton 630: if (image1 == (void *)MAP_FAILED)
1.150 anton 631: goto read_image;
632: }
1.33 anton 633: }
1.56 anton 634: #endif /* defined(HAVE_MMAP) */
1.213 anton 635: if (image == (void *)MAP_FAILED) {
1.161 pazsan 636: image = gforth_alloc(dictsize+offset)+offset;
1.149 anton 637: read_image:
1.33 anton 638: rewind(file); /* fseek(imagefile,0L,SEEK_SET); */
1.34 anton 639: fread(image, 1, imagesize, file);
1.33 anton 640: }
641: return image;
642: }
1.175 pazsan 643: #endif
1.33 anton 644:
1.10 pazsan 645: void set_stack_sizes(ImageHeader * header)
646: {
647: if (dictsize==0)
648: dictsize = header->dict_size;
649: if (dsize==0)
650: dsize = header->data_stack_size;
651: if (rsize==0)
652: rsize = header->return_stack_size;
653: if (fsize==0)
654: fsize = header->fp_stack_size;
655: if (lsize==0)
656: lsize = header->locals_stack_size;
657: dictsize=maxaligned(dictsize);
658: dsize=maxaligned(dsize);
659: rsize=maxaligned(rsize);
660: lsize=maxaligned(lsize);
661: fsize=maxaligned(fsize);
662: }
663:
1.178 pazsan 664: #ifdef STANDALONE
665: void alloc_stacks(ImageHeader * h)
666: {
667: #define SSTACKSIZE 0x200
668: static Cell dstack[SSTACKSIZE+1];
669: static Cell rstack[SSTACKSIZE+1];
670:
671: h->dict_size=dictsize;
672: h->data_stack_size=dsize;
673: h->fp_stack_size=fsize;
674: h->return_stack_size=rsize;
675: h->locals_stack_size=lsize;
676:
677: h->data_stack_base=dstack+SSTACKSIZE;
678: // h->fp_stack_base=gforth_alloc(fsize);
679: h->return_stack_base=rstack+SSTACKSIZE;
680: // h->locals_stack_base=gforth_alloc(lsize);
681: }
682: #else
1.173 anton 683: void alloc_stacks(ImageHeader * h)
1.10 pazsan 684: {
1.173 anton 685: h->dict_size=dictsize;
686: h->data_stack_size=dsize;
687: h->fp_stack_size=fsize;
688: h->return_stack_size=rsize;
689: h->locals_stack_size=lsize;
1.10 pazsan 690:
1.176 pazsan 691: #if defined(HAVE_MMAP) && !defined(STANDALONE)
1.172 anton 692: if (pagesize > 1) {
1.173 anton 693: size_t p = pagesize;
694: size_t totalsize =
695: wholepage(dsize)+wholepage(fsize)+wholepage(rsize)+wholepage(lsize)+5*p;
1.213 anton 696: void *a = alloc_mmap(totalsize);
697: if (a != (void *)MAP_FAILED) {
1.173 anton 698: page_noaccess(a); a+=p; h-> data_stack_base=a; a+=wholepage(dsize);
699: page_noaccess(a); a+=p; h-> fp_stack_base=a; a+=wholepage(fsize);
700: page_noaccess(a); a+=p; h->return_stack_base=a; a+=wholepage(rsize);
701: page_noaccess(a); a+=p; h->locals_stack_base=a; a+=wholepage(lsize);
1.172 anton 702: page_noaccess(a);
703: debugp(stderr,"stack addresses: d=%p f=%p r=%p l=%p\n",
1.173 anton 704: h->data_stack_base,
705: h->fp_stack_base,
706: h->return_stack_base,
707: h->locals_stack_base);
1.172 anton 708: return;
709: }
710: }
711: #endif
1.173 anton 712: h->data_stack_base=gforth_alloc(dsize);
713: h->fp_stack_base=gforth_alloc(fsize);
714: h->return_stack_base=gforth_alloc(rsize);
715: h->locals_stack_base=gforth_alloc(lsize);
1.10 pazsan 716: }
1.178 pazsan 717: #endif
1.10 pazsan 718:
1.161 pazsan 719: #warning You can ignore the warnings about clobbered variables in gforth_go
1.213 anton 720: int gforth_go(void *image, int stack, Cell *entries)
1.11 pazsan 721: {
1.38 anton 722: volatile ImageHeader *image_header = (ImageHeader *)image;
1.18 anton 723: Cell *sp0=(Cell*)(image_header->data_stack_base + dsize);
1.44 pazsan 724: Cell *rp0=(Cell *)(image_header->return_stack_base + rsize);
1.18 anton 725: Float *fp0=(Float *)(image_header->fp_stack_base + fsize);
1.44 pazsan 726: #ifdef GFORTH_DEBUGGING
1.38 anton 727: volatile Cell *orig_rp0=rp0;
1.44 pazsan 728: #endif
1.18 anton 729: Address lp0=image_header->locals_stack_base + lsize;
730: Xt *ip0=(Xt *)(image_header->boot_entry);
1.13 pazsan 731: #ifdef SYSSIGNALS
1.11 pazsan 732: int throw_code;
1.246 pazsan 733: jmp_buf throw_jmp_buf;
1.13 pazsan 734: #endif
1.247 pazsan 735: Cell signal_data_stack[24];
736: Cell signal_return_stack[16];
737: Float signal_fp_stack[1];
1.11 pazsan 738:
739: /* ensure that the cached elements (if any) are accessible */
1.238 pazsan 740: #if !(defined(GFORTH_DEBUGGING) || defined(INDIRECT_THREADED) || defined(DOUBLY_INDIRECT) || defined(VM_PROFILING))
1.151 anton 741: sp0 -= 8; /* make stuff below bottom accessible for stack caching */
1.187 anton 742: fp0--;
1.151 anton 743: #endif
1.11 pazsan 744:
745: for(;stack>0;stack--)
1.18 anton 746: *--sp0=entries[stack-1];
1.11 pazsan 747:
1.177 pazsan 748: #if defined(SYSSIGNALS) && !defined(STANDALONE)
1.11 pazsan 749: get_winsize();
1.249 pazsan 750:
751: install_signal_handlers(); /* right place? */
752:
753: throw_jmp_handler = &throw_jmp_buf;
754:
755: debugp(stderr, "setjmp(%p)\n", *throw_jmp_handler);
756: while((throw_code=setjmp(*throw_jmp_handler))) {
757: signal_data_stack[15]=throw_code;
758:
1.18 anton 759: #ifdef GFORTH_DEBUGGING
1.249 pazsan 760: debugp(stderr,"\ncaught signal, throwing exception %d, ip=%p rp=%p\n",
761: throw_code, saved_ip, rp);
762: if (rp <= orig_rp0 && rp > (Cell *)(image_header->return_stack_base+5)) {
763: /* no rstack overflow or underflow */
764: rp0 = rp;
765: *--rp0 = (Cell)saved_ip;
766: }
767: else /* I love non-syntactic ifdefs :-) */
768: rp0 = signal_return_stack+16;
1.248 pazsan 769: #else /* !defined(GFORTH_DEBUGGING) */
1.249 pazsan 770: debugp(stderr,"\ncaught signal, throwing exception %d\n", throw_code);
771: rp0 = signal_return_stack+16;
1.97 anton 772: #endif /* !defined(GFORTH_DEBUGGING) */
1.249 pazsan 773: /* fprintf(stderr, "rp=$%x\n",rp0);*/
774:
775: ip0=image_header->throw_entry;
776: sp0=signal_data_stack+15;
777: fp0=signal_fp_stack;
778: }
1.13 pazsan 779: #endif
1.11 pazsan 780:
1.197 anton 781: return((int)(Cell)gforth_engine(ip0,sp0,rp0,fp0,lp0 sr_call));
1.11 pazsan 782: }
783:
1.177 pazsan 784: #if !defined(INCLUDE_IMAGE) && !defined(STANDALONE)
1.161 pazsan 785: static void print_sizes(Cell sizebyte)
1.21 anton 786: /* print size information */
787: {
788: static char* endianstring[]= { " big","little" };
789:
790: fprintf(stderr,"%s endian, cell=%d bytes, char=%d bytes, au=%d bytes\n",
791: endianstring[sizebyte & 1],
792: 1 << ((sizebyte >> 1) & 3),
793: 1 << ((sizebyte >> 3) & 3),
794: 1 << ((sizebyte >> 5) & 3));
795: }
796:
1.106 anton 797: /* static superinstruction stuff */
798:
1.141 anton 799: struct cost { /* super_info might be a more accurate name */
1.106 anton 800: char loads; /* number of stack loads */
801: char stores; /* number of stack stores */
802: char updates; /* number of stack pointer updates */
1.123 anton 803: char branch; /* is it a branch (SET_IP) */
1.125 anton 804: unsigned char state_in; /* state on entry */
805: unsigned char state_out; /* state on exit */
1.142 anton 806: unsigned char imm_ops; /* number of immediate operands */
1.123 anton 807: short offset; /* offset into super2 table */
1.125 anton 808: unsigned char length; /* number of components */
1.106 anton 809: };
810:
1.121 anton 811: PrimNum super2[] = {
1.126 anton 812: #include SUPER2_I
1.106 anton 813: };
814:
815: struct cost super_costs[] = {
1.126 anton 816: #include COSTS_I
1.106 anton 817: };
818:
1.125 anton 819: struct super_state {
820: struct super_state *next;
821: PrimNum super;
822: };
823:
1.106 anton 824: #define HASH_SIZE 256
825:
826: struct super_table_entry {
827: struct super_table_entry *next;
1.121 anton 828: PrimNum *start;
1.106 anton 829: short length;
1.125 anton 830: struct super_state *ss_list; /* list of supers */
1.106 anton 831: } *super_table[HASH_SIZE];
832: int max_super=2;
833:
1.125 anton 834: struct super_state *state_transitions=NULL;
835:
1.161 pazsan 836: static int hash_super(PrimNum *start, int length)
1.106 anton 837: {
838: int i, r;
839:
840: for (i=0, r=0; i<length; i++) {
841: r <<= 1;
842: r += start[i];
843: }
844: return r & (HASH_SIZE-1);
845: }
846:
1.161 pazsan 847: static struct super_state **lookup_super(PrimNum *start, int length)
1.106 anton 848: {
849: int hash=hash_super(start,length);
850: struct super_table_entry *p = super_table[hash];
851:
1.125 anton 852: /* assert(length >= 2); */
1.106 anton 853: for (; p!=NULL; p = p->next) {
854: if (length == p->length &&
1.121 anton 855: memcmp((char *)p->start, (char *)start, length*sizeof(PrimNum))==0)
1.125 anton 856: return &(p->ss_list);
1.106 anton 857: }
1.125 anton 858: return NULL;
1.106 anton 859: }
860:
1.161 pazsan 861: static void prepare_super_table()
1.106 anton 862: {
863: int i;
1.109 anton 864: int nsupers = 0;
1.106 anton 865:
866: for (i=0; i<sizeof(super_costs)/sizeof(super_costs[0]); i++) {
867: struct cost *c = &super_costs[i];
1.125 anton 868: if ((c->length < 2 || nsupers < static_super_number) &&
869: c->state_in < maxstates && c->state_out < maxstates) {
870: struct super_state **ss_listp= lookup_super(super2+c->offset, c->length);
871: struct super_state *ss = malloc(sizeof(struct super_state));
872: ss->super= i;
873: if (c->offset==N_noop && i != N_noop) {
874: if (is_relocatable(i)) {
875: ss->next = state_transitions;
876: state_transitions = ss;
877: }
878: } else if (ss_listp != NULL) {
879: ss->next = *ss_listp;
880: *ss_listp = ss;
881: } else {
882: int hash = hash_super(super2+c->offset, c->length);
883: struct super_table_entry **p = &super_table[hash];
884: struct super_table_entry *e = malloc(sizeof(struct super_table_entry));
885: ss->next = NULL;
886: e->next = *p;
887: e->start = super2 + c->offset;
888: e->length = c->length;
889: e->ss_list = ss;
890: *p = e;
891: }
1.106 anton 892: if (c->length > max_super)
893: max_super = c->length;
1.125 anton 894: if (c->length >= 2)
895: nsupers++;
1.106 anton 896: }
897: }
1.144 pazsan 898: debugp(stderr, "Using %d static superinsts\n", nsupers);
1.195 anton 899: if (nsupers>0 && !tpa_noautomaton && !tpa_noequiv) {
900: /* Currently these two things don't work together; see Section 3.2
901: of <http://www.complang.tuwien.ac.at/papers/ertl+06pldi.ps.gz>,
902: in particular Footnote 6 for the reason; hmm, we should be able
903: to use an automaton without state equivalence, but that costs
904: significant space so we only do it if the user explicitly
905: disables state equivalence. */
906: debugp(stderr, "Disabling tpa-automaton, because nsupers>0 and state equivalence is enabled.\n");
1.218 anton 907: tpa_noautomaton = 1;
1.194 anton 908: }
1.106 anton 909: }
910:
911: /* dynamic replication/superinstruction stuff */
912:
1.69 anton 913: #ifndef NO_DYNAMIC
1.161 pazsan 914: static int compare_priminfo_length(const void *_a, const void *_b)
1.76 anton 915: {
1.90 anton 916: PrimInfo **a = (PrimInfo **)_a;
917: PrimInfo **b = (PrimInfo **)_b;
1.77 anton 918: Cell diff = (*a)->length - (*b)->length;
919: if (diff)
920: return diff;
921: else /* break ties by start address; thus the decompiler produces
922: the earliest primitive with the same code (e.g. noop instead
923: of (char) and @ instead of >code-address */
924: return (*b)->start - (*a)->start;
1.76 anton 925: }
1.112 anton 926: #endif /* !defined(NO_DYNAMIC) */
1.76 anton 927:
1.125 anton 928: static char MAYBE_UNUSED superend[]={
1.126 anton 929: #include PRIM_SUPEREND_I
1.106 anton 930: };
1.107 anton 931:
932: Cell npriminfos=0;
1.76 anton 933:
1.146 anton 934: Label goto_start;
935: Cell goto_len;
936:
1.162 pazsan 937: #ifndef NO_DYNAMIC
1.161 pazsan 938: static int compare_labels(const void *pa, const void *pb)
1.113 anton 939: {
1.114 anton 940: Label a = *(Label *)pa;
941: Label b = *(Label *)pb;
942: return a-b;
943: }
1.162 pazsan 944: #endif
1.113 anton 945:
1.161 pazsan 946: static Label bsearch_next(Label key, Label *a, UCell n)
1.114 anton 947: /* a is sorted; return the label >=key that is the closest in a;
948: return NULL if there is no label in a >=key */
949: {
950: int mid = (n-1)/2;
951: if (n<1)
952: return NULL;
953: if (n == 1) {
954: if (a[0] < key)
955: return NULL;
956: else
957: return a[0];
958: }
959: if (a[mid] < key)
960: return bsearch_next(key, a+mid+1, n-mid-1);
961: else
962: return bsearch_next(key, a, mid+1);
1.113 anton 963: }
964:
1.161 pazsan 965: static void check_prims(Label symbols1[])
1.47 anton 966: {
967: int i;
1.90 anton 968: #ifndef NO_DYNAMIC
1.146 anton 969: Label *symbols2, *symbols3, *ends1, *ends1j, *ends1jsorted, *goto_p;
1.119 anton 970: int nends1j;
1.90 anton 971: #endif
1.47 anton 972:
1.66 anton 973: if (debug)
974: #ifdef __VERSION__
975: fprintf(stderr, "Compiled with gcc-" __VERSION__ "\n");
976: #else
977: #define xstr(s) str(s)
978: #define str(s) #s
979: fprintf(stderr, "Compiled with gcc-" xstr(__GNUC__) "." xstr(__GNUC_MINOR__) "\n");
980: #endif
1.121 anton 981: for (i=0; symbols1[i]!=0; i++)
1.47 anton 982: ;
1.55 anton 983: npriminfos = i;
1.70 anton 984:
985: #ifndef NO_DYNAMIC
1.66 anton 986: if (no_dynamic)
987: return;
1.197 anton 988: symbols2=gforth_engine2(0,0,0,0,0 sr_call);
1.70 anton 989: #if NO_IP
1.197 anton 990: symbols3=gforth_engine3(0,0,0,0,0 sr_call);
1.70 anton 991: #else
992: symbols3=symbols1;
993: #endif
1.121 anton 994: ends1 = symbols1+i+1;
1.119 anton 995: ends1j = ends1+i;
1.146 anton 996: goto_p = ends1j+i+1; /* goto_p[0]==before; ...[1]==after;*/
1.121 anton 997: nends1j = i+1;
1.119 anton 998: ends1jsorted = (Label *)alloca(nends1j*sizeof(Label));
999: memcpy(ends1jsorted,ends1j,nends1j*sizeof(Label));
1000: qsort(ends1jsorted, nends1j, sizeof(Label), compare_labels);
1.146 anton 1001:
1002: /* check whether the "goto *" is relocatable */
1003: goto_len = goto_p[1]-goto_p[0];
1004: debugp(stderr, "goto * %p %p len=%ld\n",
1.190 anton 1005: goto_p[0],symbols2[goto_p-symbols1],(long)goto_len);
1.146 anton 1006: if (memcmp(goto_p[0],symbols2[goto_p-symbols1],goto_len)!=0) { /* unequal */
1007: no_dynamic=1;
1008: debugp(stderr," not relocatable, disabling dynamic code generation\n");
1.148 anton 1009: init_ss_cost();
1.146 anton 1010: return;
1011: }
1012: goto_start = goto_p[0];
1.113 anton 1013:
1.47 anton 1014: priminfos = calloc(i,sizeof(PrimInfo));
1.121 anton 1015: for (i=0; symbols1[i]!=0; i++) {
1.70 anton 1016: int prim_len = ends1[i]-symbols1[i];
1.47 anton 1017: PrimInfo *pi=&priminfos[i];
1.154 anton 1018: struct cost *sc=&super_costs[i];
1.70 anton 1019: int j=0;
1020: char *s1 = (char *)symbols1[i];
1021: char *s2 = (char *)symbols2[i];
1022: char *s3 = (char *)symbols3[i];
1.119 anton 1023: Label endlabel = bsearch_next(symbols1[i]+1,ends1jsorted,nends1j);
1.70 anton 1024:
1025: pi->start = s1;
1.121 anton 1026: pi->superend = superend[i]|no_super;
1.147 anton 1027: pi->length = prim_len;
1.113 anton 1028: pi->restlength = endlabel - symbols1[i] - pi->length;
1.70 anton 1029: pi->nimmargs = 0;
1.144 pazsan 1030: relocs++;
1.190 anton 1031: #if defined(BURG_FORMAT)
1032: { /* output as burg-style rules */
1033: int p=super_costs[i].offset;
1034: if (p==N_noop)
1035: debugp(stderr, "S%d: S%d = %d (%d);", sc->state_in, sc->state_out, i+1, pi->length);
1036: else
1037: debugp(stderr, "S%d: op%d(S%d) = %d (%d);", sc->state_in, p, sc->state_out, i+1, pi->length);
1038: }
1039: #else
1.154 anton 1040: debugp(stderr, "%-15s %d-%d %4d %p %p %p len=%3ld rest=%2ld send=%1d",
1041: prim_names[i], sc->state_in, sc->state_out,
1042: i, s1, s2, s3, (long)(pi->length), (long)(pi->restlength),
1043: pi->superend);
1.190 anton 1044: #endif
1.114 anton 1045: if (endlabel == NULL) {
1046: pi->start = NULL; /* not relocatable */
1.122 anton 1047: if (pi->length<0) pi->length=100;
1.190 anton 1048: #ifndef BURG_FORMAT
1.144 pazsan 1049: debugp(stderr,"\n non_reloc: no J label > start found\n");
1.190 anton 1050: #endif
1.144 pazsan 1051: relocs--;
1052: nonrelocs++;
1.114 anton 1053: continue;
1054: }
1055: if (ends1[i] > endlabel && !pi->superend) {
1.113 anton 1056: pi->start = NULL; /* not relocatable */
1.122 anton 1057: pi->length = endlabel-symbols1[i];
1.190 anton 1058: #ifndef BURG_FORMAT
1.144 pazsan 1059: debugp(stderr,"\n non_reloc: there is a J label before the K label (restlength<0)\n");
1.190 anton 1060: #endif
1.144 pazsan 1061: relocs--;
1062: nonrelocs++;
1.113 anton 1063: continue;
1064: }
1.114 anton 1065: if (ends1[i] < pi->start && !pi->superend) {
1.113 anton 1066: pi->start = NULL; /* not relocatable */
1.122 anton 1067: pi->length = endlabel-symbols1[i];
1.190 anton 1068: #ifndef BURG_FORMAT
1.144 pazsan 1069: debugp(stderr,"\n non_reloc: K label before I label (length<0)\n");
1.190 anton 1070: #endif
1.144 pazsan 1071: relocs--;
1072: nonrelocs++;
1.113 anton 1073: continue;
1074: }
1.235 dvdkhlng 1075: if (CHECK_PRIM(s1, prim_len)) {
1076: #ifndef BURG_FORMAT
1077: debugp(stderr,"\n non_reloc: architecture specific check failed\n");
1078: #endif
1079: pi->start = NULL; /* not relocatable */
1080: relocs--;
1081: nonrelocs++;
1082: continue;
1083: }
1.138 anton 1084: assert(pi->length>=0);
1.113 anton 1085: assert(pi->restlength >=0);
1.74 anton 1086: while (j<(pi->length+pi->restlength)) {
1.70 anton 1087: if (s1[j]==s3[j]) {
1088: if (s1[j] != s2[j]) {
1089: pi->start = NULL; /* not relocatable */
1.190 anton 1090: #ifndef BURG_FORMAT
1.144 pazsan 1091: debugp(stderr,"\n non_reloc: engine1!=engine2 offset %3d",j);
1.190 anton 1092: #endif
1.74 anton 1093: /* assert(j<prim_len); */
1.144 pazsan 1094: relocs--;
1095: nonrelocs++;
1.70 anton 1096: break;
1097: }
1098: j++;
1099: } else {
1100: struct immarg *ia=&pi->immargs[pi->nimmargs];
1101:
1102: pi->nimmargs++;
1103: ia->offset=j;
1104: if ((~*(Cell *)&(s1[j]))==*(Cell *)&(s3[j])) {
1105: ia->rel=0;
1.144 pazsan 1106: debugp(stderr,"\n absolute immarg: offset %3d",j);
1.70 anton 1107: } else if ((&(s1[j]))+(*(Cell *)&(s1[j]))+4 ==
1.229 dvdkhlng 1108: symbols1[DOER_MAX+1]) {
1.70 anton 1109: ia->rel=1;
1.144 pazsan 1110: debugp(stderr,"\n relative immarg: offset %3d",j);
1.70 anton 1111: } else {
1112: pi->start = NULL; /* not relocatable */
1.190 anton 1113: #ifndef BURG_FORMAT
1.144 pazsan 1114: debugp(stderr,"\n non_reloc: engine1!=engine3 offset %3d",j);
1.190 anton 1115: #endif
1.74 anton 1116: /* assert(j<prim_len);*/
1.144 pazsan 1117: relocs--;
1118: nonrelocs++;
1.70 anton 1119: break;
1120: }
1121: j+=4;
1.47 anton 1122: }
1123: }
1.144 pazsan 1124: debugp(stderr,"\n");
1.70 anton 1125: }
1.76 anton 1126: decomp_prims = calloc(i,sizeof(PrimInfo *));
1.229 dvdkhlng 1127: for (i=DOER_MAX+1; i<npriminfos; i++)
1.76 anton 1128: decomp_prims[i] = &(priminfos[i]);
1.229 dvdkhlng 1129: qsort(decomp_prims+DOER_MAX+1, npriminfos-DOER_MAX-1, sizeof(PrimInfo *),
1.76 anton 1130: compare_priminfo_length);
1.70 anton 1131: #endif
1132: }
1133:
1.161 pazsan 1134: static void flush_to_here(void)
1.74 anton 1135: {
1.93 anton 1136: #ifndef NO_DYNAMIC
1.100 anton 1137: if (start_flush)
1.210 anton 1138: FLUSH_ICACHE((caddr_t)start_flush, code_here-start_flush);
1.74 anton 1139: start_flush=code_here;
1.93 anton 1140: #endif
1.74 anton 1141: }
1142:
1.209 anton 1143: static void MAYBE_UNUSED align_code(void)
1.185 anton 1144: /* align code_here on some platforms */
1145: {
1146: #ifndef NO_DYNAMIC
1.186 anton 1147: #if defined(CODE_PADDING)
1.185 anton 1148: Cell alignment = CODE_ALIGNMENT;
1.186 anton 1149: static char nops[] = CODE_PADDING;
1150: UCell maxpadding=MAX_PADDING;
1.185 anton 1151: UCell offset = ((UCell)code_here)&(alignment-1);
1152: UCell length = alignment-offset;
1.186 anton 1153: if (length <= maxpadding) {
1154: memcpy(code_here,nops+offset,length);
1.185 anton 1155: code_here += length;
1156: }
1.186 anton 1157: #endif /* defined(CODE_PADDING) */
1.185 anton 1158: #endif /* defined(NO_DYNAMIC */
1159: }
1160:
1.93 anton 1161: #ifndef NO_DYNAMIC
1.161 pazsan 1162: static void append_jump(void)
1.74 anton 1163: {
1164: if (last_jump) {
1165: PrimInfo *pi = &priminfos[last_jump];
1166:
1167: memcpy(code_here, pi->start+pi->length, pi->restlength);
1168: code_here += pi->restlength;
1.147 anton 1169: memcpy(code_here, goto_start, goto_len);
1170: code_here += goto_len;
1.185 anton 1171: align_code();
1.74 anton 1172: last_jump=0;
1173: }
1174: }
1175:
1.75 anton 1176: /* Gforth remembers all code blocks in this list. On forgetting (by
1177: executing a marker) the code blocks are not freed (because Gforth does
1178: not remember how they were allocated; hmm, remembering that might be
1179: easier and cleaner). Instead, code_here etc. are reset to the old
1180: value, and the "forgotten" code blocks are reused when they are
1181: needed. */
1182:
1183: struct code_block_list {
1184: struct code_block_list *next;
1185: Address block;
1186: Cell size;
1187: } *code_block_list=NULL, **next_code_blockp=&code_block_list;
1188:
1.222 anton 1189: static void reserve_code_space(UCell size)
1.74 anton 1190: {
1.222 anton 1191: if (code_area+code_area_size < code_here+size) {
1.75 anton 1192: struct code_block_list *p;
1.74 anton 1193: append_jump();
1.223 anton 1194: debugp(stderr,"Did not use %ld bytes in code block\n",
1195: (long)(code_area+code_area_size-code_here));
1.93 anton 1196: flush_to_here();
1.75 anton 1197: if (*next_code_blockp == NULL) {
1.161 pazsan 1198: code_here = start_flush = code_area = gforth_alloc(code_area_size);
1.75 anton 1199: p = (struct code_block_list *)malloc(sizeof(struct code_block_list));
1200: *next_code_blockp = p;
1201: p->next = NULL;
1202: p->block = code_here;
1203: p->size = code_area_size;
1204: } else {
1205: p = *next_code_blockp;
1206: code_here = start_flush = code_area = p->block;
1207: }
1208: next_code_blockp = &(p->next);
1.74 anton 1209: }
1.222 anton 1210: }
1211:
1212: static Address append_prim(Cell p)
1213: {
1214: PrimInfo *pi = &priminfos[p];
1215: Address old_code_here;
1216: reserve_code_space(pi->length+pi->restlength+goto_len+CODE_ALIGNMENT-1);
1.74 anton 1217: memcpy(code_here, pi->start, pi->length);
1.222 anton 1218: old_code_here = code_here;
1.74 anton 1219: code_here += pi->length;
1220: return old_code_here;
1221: }
1.222 anton 1222:
1223: static void reserve_code_super(PrimNum origs[], int ninsts)
1224: {
1225: int i;
1226: UCell size = CODE_ALIGNMENT-1; /* alignment may happen first */
1227: if (no_dynamic)
1228: return;
1229: /* use size of the original primitives as an upper bound for the
1230: size of the superinstruction. !! This is only safe if we
1231: optimize for code size (the default) */
1232: for (i=0; i<ninsts; i++) {
1233: PrimNum p = origs[i];
1234: PrimInfo *pi = &priminfos[p];
1235: if (is_relocatable(p))
1236: size += pi->length;
1237: else
1238: if (i>0)
1239: size += priminfos[origs[i-1]].restlength+goto_len+CODE_ALIGNMENT-1;
1240: }
1241: size += priminfos[origs[i-1]].restlength+goto_len;
1242: reserve_code_space(size);
1243: }
1.74 anton 1244: #endif
1.75 anton 1245:
1246: int forget_dyncode(Address code)
1247: {
1248: #ifdef NO_DYNAMIC
1249: return -1;
1250: #else
1251: struct code_block_list *p, **pp;
1252:
1253: for (pp=&code_block_list, p=*pp; p!=NULL; pp=&(p->next), p=*pp) {
1254: if (code >= p->block && code < p->block+p->size) {
1255: next_code_blockp = &(p->next);
1256: code_here = start_flush = code;
1257: code_area = p->block;
1258: last_jump = 0;
1259: return -1;
1260: }
1261: }
1.78 anton 1262: return -no_dynamic;
1.75 anton 1263: #endif /* !defined(NO_DYNAMIC) */
1264: }
1265:
1.161 pazsan 1266: static long dyncodesize(void)
1.104 anton 1267: {
1268: #ifndef NO_DYNAMIC
1.106 anton 1269: struct code_block_list *p;
1.104 anton 1270: long size=0;
1271: for (p=code_block_list; p!=NULL; p=p->next) {
1272: if (code_here >= p->block && code_here < p->block+p->size)
1273: return size + (code_here - p->block);
1274: else
1275: size += p->size;
1276: }
1277: #endif /* !defined(NO_DYNAMIC) */
1278: return 0;
1279: }
1280:
1.90 anton 1281: Label decompile_code(Label _code)
1.75 anton 1282: {
1.76 anton 1283: #ifdef NO_DYNAMIC
1.90 anton 1284: return _code;
1.76 anton 1285: #else /* !defined(NO_DYNAMIC) */
1286: Cell i;
1.77 anton 1287: struct code_block_list *p;
1.90 anton 1288: Address code=_code;
1.76 anton 1289:
1.77 anton 1290: /* first, check if we are in code at all */
1291: for (p = code_block_list;; p = p->next) {
1292: if (p == NULL)
1293: return code;
1294: if (code >= p->block && code < p->block+p->size)
1295: break;
1296: }
1.76 anton 1297: /* reverse order because NOOP might match other prims */
1.229 dvdkhlng 1298: for (i=npriminfos-1; i>DOER_MAX; i--) {
1.76 anton 1299: PrimInfo *pi=decomp_prims[i];
1300: if (pi->start==code || (pi->start && memcmp(code,pi->start,pi->length)==0))
1.121 anton 1301: return vm_prims[super2[super_costs[pi-priminfos].offset]];
1.118 anton 1302: /* return pi->start;*/
1.76 anton 1303: }
1304: return code;
1305: #endif /* !defined(NO_DYNAMIC) */
1.75 anton 1306: }
1.74 anton 1307:
1.70 anton 1308: #ifdef NO_IP
1309: int nbranchinfos=0;
1310:
1311: struct branchinfo {
1.136 anton 1312: Label **targetpp; /* **(bi->targetpp) is the target */
1.70 anton 1313: Cell *addressptr; /* store the target here */
1314: } branchinfos[100000];
1315:
1316: int ndoesexecinfos=0;
1317: struct doesexecinfo {
1318: int branchinfo; /* fix the targetptr of branchinfos[...->branchinfo] */
1.136 anton 1319: Label *targetp; /*target for branch (because this is not in threaded code)*/
1.70 anton 1320: Cell *xt; /* cfa of word whose does-code needs calling */
1321: } doesexecinfos[10000];
1322:
1.161 pazsan 1323: static void set_rel_target(Cell *source, Label target)
1.70 anton 1324: {
1325: *source = ((Cell)target)-(((Cell)source)+4);
1326: }
1327:
1.161 pazsan 1328: static void register_branchinfo(Label source, Cell *targetpp)
1.70 anton 1329: {
1330: struct branchinfo *bi = &(branchinfos[nbranchinfos]);
1.136 anton 1331: bi->targetpp = (Label **)targetpp;
1.70 anton 1332: bi->addressptr = (Cell *)source;
1333: nbranchinfos++;
1334: }
1335:
1.161 pazsan 1336: static Address compile_prim1arg(PrimNum p, Cell **argp)
1.70 anton 1337: {
1.133 anton 1338: Address old_code_here=append_prim(p);
1.70 anton 1339:
1.74 anton 1340: assert(vm_prims[p]==priminfos[p].start);
1.133 anton 1341: *argp = (Cell*)(old_code_here+priminfos[p].immargs[0].offset);
1342: return old_code_here;
1.70 anton 1343: }
1344:
1.161 pazsan 1345: static Address compile_call2(Cell *targetpp, Cell **next_code_targetp)
1.70 anton 1346: {
1.73 anton 1347: PrimInfo *pi = &priminfos[N_call2];
1.74 anton 1348: Address old_code_here = append_prim(N_call2);
1.70 anton 1349:
1.134 anton 1350: *next_code_targetp = (Cell *)(old_code_here + pi->immargs[0].offset);
1.136 anton 1351: register_branchinfo(old_code_here + pi->immargs[1].offset, targetpp);
1.134 anton 1352: return old_code_here;
1.70 anton 1353: }
1354: #endif
1355:
1356: void finish_code(void)
1357: {
1358: #ifdef NO_IP
1359: Cell i;
1360:
1361: compile_prim1(NULL);
1362: for (i=0; i<ndoesexecinfos; i++) {
1363: struct doesexecinfo *dei = &doesexecinfos[i];
1.136 anton 1364: dei->targetp = (Label *)DOES_CODE1((dei->xt));
1365: branchinfos[dei->branchinfo].targetpp = &(dei->targetp);
1.70 anton 1366: }
1367: ndoesexecinfos = 0;
1368: for (i=0; i<nbranchinfos; i++) {
1369: struct branchinfo *bi=&branchinfos[i];
1.136 anton 1370: set_rel_target(bi->addressptr, **(bi->targetpp));
1.70 anton 1371: }
1372: nbranchinfos = 0;
1.128 anton 1373: #else
1374: compile_prim1(NULL);
1.48 anton 1375: #endif
1.93 anton 1376: flush_to_here();
1.48 anton 1377: }
1378:
1.162 pazsan 1379: #if !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED))
1.128 anton 1380: #ifdef NO_IP
1.161 pazsan 1381: static Cell compile_prim_dyn(PrimNum p, Cell *tcp)
1.128 anton 1382: /* compile prim #p dynamically (mod flags etc.) and return start
1383: address of generated code for putting it into the threaded
1384: code. This function is only called if all the associated
1385: inline arguments of p are already in place (at tcp[1] etc.) */
1386: {
1387: PrimInfo *pi=&priminfos[p];
1388: Cell *next_code_target=NULL;
1.135 anton 1389: Address codeaddr;
1390: Address primstart;
1.128 anton 1391:
1392: assert(p<npriminfos);
1393: if (p==N_execute || p==N_perform || p==N_lit_perform) {
1.134 anton 1394: codeaddr = compile_prim1arg(N_set_next_code, &next_code_target);
1.135 anton 1395: primstart = append_prim(p);
1396: goto other_prim;
1397: } else if (p==N_call) {
1.136 anton 1398: codeaddr = compile_call2(tcp+1, &next_code_target);
1.128 anton 1399: } else if (p==N_does_exec) {
1400: struct doesexecinfo *dei = &doesexecinfos[ndoesexecinfos++];
1.133 anton 1401: Cell *arg;
1402: codeaddr = compile_prim1arg(N_lit,&arg);
1403: *arg = (Cell)PFA(tcp[1]);
1.128 anton 1404: /* we cannot determine the callee now (last_start[1] may be a
1405: forward reference), so just register an arbitrary target, and
1406: register in dei that we need to fix this before resolving
1407: branches */
1408: dei->branchinfo = nbranchinfos;
1409: dei->xt = (Cell *)(tcp[1]);
1.134 anton 1410: compile_call2(0, &next_code_target);
1.128 anton 1411: } else if (!is_relocatable(p)) {
1.133 anton 1412: Cell *branch_target;
1413: codeaddr = compile_prim1arg(N_set_next_code, &next_code_target);
1414: compile_prim1arg(N_branch,&branch_target);
1415: set_rel_target(branch_target,vm_prims[p]);
1.128 anton 1416: } else {
1417: unsigned j;
1.135 anton 1418:
1419: codeaddr = primstart = append_prim(p);
1420: other_prim:
1.128 anton 1421: for (j=0; j<pi->nimmargs; j++) {
1422: struct immarg *ia = &(pi->immargs[j]);
1.136 anton 1423: Cell *argp = tcp + pi->nimmargs - j;
1424: Cell argval = *argp; /* !! specific to prims */
1.128 anton 1425: if (ia->rel) { /* !! assumption: relative refs are branches */
1.136 anton 1426: register_branchinfo(primstart + ia->offset, argp);
1.128 anton 1427: } else /* plain argument */
1.135 anton 1428: *(Cell *)(primstart + ia->offset) = argval;
1.128 anton 1429: }
1430: }
1431: if (next_code_target!=NULL)
1432: *next_code_target = (Cell)code_here;
1.135 anton 1433: return (Cell)codeaddr;
1.128 anton 1434: }
1435: #else /* !defined(NO_IP) */
1.161 pazsan 1436: static Cell compile_prim_dyn(PrimNum p, Cell *tcp)
1.128 anton 1437: /* compile prim #p dynamically (mod flags etc.) and return start
1438: address of generated code for putting it into the threaded code */
1.108 anton 1439: {
1.121 anton 1440: Cell static_prim = (Cell)vm_prims[p];
1.108 anton 1441: #if defined(NO_DYNAMIC)
1442: return static_prim;
1443: #else /* !defined(NO_DYNAMIC) */
1444: Address old_code_here;
1445:
1446: if (no_dynamic)
1447: return static_prim;
1.125 anton 1448: if (p>=npriminfos || !is_relocatable(p)) {
1.108 anton 1449: append_jump();
1450: return static_prim;
1451: }
1452: old_code_here = append_prim(p);
1.147 anton 1453: last_jump = p;
1454: if (priminfos[p].superend)
1455: append_jump();
1.108 anton 1456: return (Cell)old_code_here;
1457: #endif /* !defined(NO_DYNAMIC) */
1458: }
1.128 anton 1459: #endif /* !defined(NO_IP) */
1.162 pazsan 1460: #endif
1.70 anton 1461:
1.109 anton 1462: #ifndef NO_DYNAMIC
1.161 pazsan 1463: static int cost_codesize(int prim)
1.109 anton 1464: {
1.121 anton 1465: return priminfos[prim].length;
1.109 anton 1466: }
1467: #endif
1468:
1.161 pazsan 1469: static int cost_ls(int prim)
1.109 anton 1470: {
1471: struct cost *c = super_costs+prim;
1472:
1473: return c->loads + c->stores;
1474: }
1475:
1.161 pazsan 1476: static int cost_lsu(int prim)
1.109 anton 1477: {
1478: struct cost *c = super_costs+prim;
1479:
1480: return c->loads + c->stores + c->updates;
1481: }
1482:
1.161 pazsan 1483: static int cost_nexts(int prim)
1.109 anton 1484: {
1485: return 1;
1486: }
1487:
1488: typedef int Costfunc(int);
1489: Costfunc *ss_cost = /* cost function for optimize_bb */
1490: #ifdef NO_DYNAMIC
1491: cost_lsu;
1492: #else
1493: cost_codesize;
1494: #endif
1495:
1.110 anton 1496: struct {
1497: Costfunc *costfunc;
1498: char *metricname;
1499: long sum;
1500: } cost_sums[] = {
1501: #ifndef NO_DYNAMIC
1502: { cost_codesize, "codesize", 0 },
1503: #endif
1504: { cost_ls, "ls", 0 },
1505: { cost_lsu, "lsu", 0 },
1506: { cost_nexts, "nexts", 0 }
1507: };
1508:
1.148 anton 1509: #ifndef NO_DYNAMIC
1510: void init_ss_cost(void) {
1511: if (no_dynamic && ss_cost == cost_codesize) {
1512: ss_cost = cost_nexts;
1513: cost_sums[0] = cost_sums[1]; /* don't use cost_codesize for print-metrics */
1514: debugp(stderr, "--no-dynamic conflicts with --ss-min-codesize, reverting to --ss-min-nexts\n");
1515: }
1516: }
1517: #endif
1518:
1.106 anton 1519: #define MAX_BB 128 /* maximum number of instructions in BB */
1.125 anton 1520: #define INF_COST 1000000 /* infinite cost */
1521: #define CANONICAL_STATE 0
1522:
1523: struct waypoint {
1524: int cost; /* the cost from here to the end */
1525: PrimNum inst; /* the inst used from here to the next waypoint */
1526: char relocatable; /* the last non-transition was relocatable */
1527: char no_transition; /* don't use the next transition (relocatability)
1528: * or this transition (does not change state) */
1529: };
1530:
1.156 anton 1531: struct tpa_state { /* tree parsing automaton (like) state */
1.155 anton 1532: /* labeling is back-to-front */
1533: struct waypoint *inst; /* in front of instruction */
1534: struct waypoint *trans; /* in front of instruction and transition */
1535: };
1536:
1.156 anton 1537: struct tpa_state *termstate = NULL; /* initialized in loader() */
1.155 anton 1538:
1.158 anton 1539: /* statistics about tree parsing (lazyburg) stuff */
1540: long lb_basic_blocks = 0;
1541: long lb_labeler_steps = 0;
1542: long lb_labeler_automaton = 0;
1543: long lb_labeler_dynprog = 0;
1544: long lb_newstate_equiv = 0;
1545: long lb_newstate_new = 0;
1546: long lb_applicable_base_rules = 0;
1547: long lb_applicable_chain_rules = 0;
1548:
1.162 pazsan 1549: #if !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED))
1.161 pazsan 1550: static void init_waypoints(struct waypoint ws[])
1.125 anton 1551: {
1552: int k;
1553:
1554: for (k=0; k<maxstates; k++)
1555: ws[k].cost=INF_COST;
1556: }
1.106 anton 1557:
1.161 pazsan 1558: static struct tpa_state *empty_tpa_state()
1.155 anton 1559: {
1.156 anton 1560: struct tpa_state *s = malloc(sizeof(struct tpa_state));
1.155 anton 1561:
1.157 anton 1562: s->inst = calloc(maxstates,sizeof(struct waypoint));
1.155 anton 1563: init_waypoints(s->inst);
1.157 anton 1564: s->trans = calloc(maxstates,sizeof(struct waypoint));
1.155 anton 1565: /* init_waypoints(s->trans);*/
1566: return s;
1567: }
1568:
1.161 pazsan 1569: static void transitions(struct tpa_state *t)
1.107 anton 1570: {
1.125 anton 1571: int k;
1572: struct super_state *l;
1573:
1574: for (k=0; k<maxstates; k++) {
1.155 anton 1575: t->trans[k] = t->inst[k];
1576: t->trans[k].no_transition = 1;
1.125 anton 1577: }
1578: for (l = state_transitions; l != NULL; l = l->next) {
1579: PrimNum s = l->super;
1580: int jcost;
1581: struct cost *c=super_costs+s;
1.155 anton 1582: struct waypoint *wi=&(t->trans[c->state_in]);
1583: struct waypoint *wo=&(t->inst[c->state_out]);
1.158 anton 1584: lb_applicable_chain_rules++;
1.125 anton 1585: if (wo->cost == INF_COST)
1586: continue;
1587: jcost = wo->cost + ss_cost(s);
1588: if (jcost <= wi->cost) {
1589: wi->cost = jcost;
1590: wi->inst = s;
1591: wi->relocatable = wo->relocatable;
1592: wi->no_transition = 0;
1593: /* if (ss_greedy) wi->cost = wo->cost ? */
1594: }
1595: }
1596: }
1.107 anton 1597:
1.161 pazsan 1598: static struct tpa_state *make_termstate()
1.155 anton 1599: {
1.157 anton 1600: struct tpa_state *s = empty_tpa_state();
1.155 anton 1601:
1602: s->inst[CANONICAL_STATE].cost = 0;
1603: transitions(s);
1604: return s;
1605: }
1.162 pazsan 1606: #endif
1.155 anton 1607:
1.156 anton 1608: #define TPA_SIZE 16384
1609:
1610: struct tpa_entry {
1611: struct tpa_entry *next;
1612: PrimNum inst;
1613: struct tpa_state *state_behind; /* note: brack-to-front labeling */
1614: struct tpa_state *state_infront; /* note: brack-to-front labeling */
1615: } *tpa_table[TPA_SIZE];
1616:
1.162 pazsan 1617: #if !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED))
1.161 pazsan 1618: static Cell hash_tpa(PrimNum p, struct tpa_state *t)
1.156 anton 1619: {
1620: UCell it = (UCell )t;
1621: return (p+it+(it>>14))&(TPA_SIZE-1);
1622: }
1623:
1.161 pazsan 1624: static struct tpa_state **lookup_tpa(PrimNum p, struct tpa_state *t2)
1.156 anton 1625: {
1626: int hash=hash_tpa(p, t2);
1627: struct tpa_entry *te = tpa_table[hash];
1628:
1.158 anton 1629: if (tpa_noautomaton) {
1630: static struct tpa_state *t;
1631: t = NULL;
1632: return &t;
1633: }
1.156 anton 1634: for (; te!=NULL; te = te->next) {
1635: if (p == te->inst && t2 == te->state_behind)
1636: return &(te->state_infront);
1637: }
1638: te = (struct tpa_entry *)malloc(sizeof(struct tpa_entry));
1639: te->next = tpa_table[hash];
1640: te->inst = p;
1641: te->state_behind = t2;
1642: te->state_infront = NULL;
1643: tpa_table[hash] = te;
1644: return &(te->state_infront);
1645: }
1646:
1.161 pazsan 1647: static void tpa_state_normalize(struct tpa_state *t)
1.157 anton 1648: {
1649: /* normalize so cost of canonical state=0; this may result in
1.222 anton 1650: negative costs for some states */
1.157 anton 1651: int d = t->inst[CANONICAL_STATE].cost;
1652: int i;
1653:
1654: for (i=0; i<maxstates; i++) {
1655: if (t->inst[i].cost != INF_COST)
1656: t->inst[i].cost -= d;
1657: if (t->trans[i].cost != INF_COST)
1658: t->trans[i].cost -= d;
1659: }
1660: }
1661:
1.161 pazsan 1662: static int tpa_state_equivalent(struct tpa_state *t1, struct tpa_state *t2)
1.157 anton 1663: {
1664: return (memcmp(t1->inst, t2->inst, maxstates*sizeof(struct waypoint)) == 0 &&
1665: memcmp(t1->trans,t2->trans,maxstates*sizeof(struct waypoint)) == 0);
1666: }
1.162 pazsan 1667: #endif
1.157 anton 1668:
1669: struct tpa_state_entry {
1670: struct tpa_state_entry *next;
1671: struct tpa_state *state;
1672: } *tpa_state_table[TPA_SIZE];
1673:
1.163 pazsan 1674: #if !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED))
1.161 pazsan 1675: static Cell hash_tpa_state(struct tpa_state *t)
1.157 anton 1676: {
1677: int *ti = (int *)(t->inst);
1678: int *tt = (int *)(t->trans);
1679: int r=0;
1680: int i;
1681:
1682: for (i=0; ti+i < (int *)(t->inst+maxstates); i++)
1683: r += ti[i]+tt[i];
1684: return (r+(r>>14)+(r>>22)) & (TPA_SIZE-1);
1685: }
1686:
1.161 pazsan 1687: static struct tpa_state *lookup_tpa_state(struct tpa_state *t)
1.157 anton 1688: {
1689: Cell hash = hash_tpa_state(t);
1690: struct tpa_state_entry *te = tpa_state_table[hash];
1691: struct tpa_state_entry *tn;
1692:
1.158 anton 1693: if (!tpa_noequiv) {
1694: for (; te!=NULL; te = te->next) {
1695: if (tpa_state_equivalent(t, te->state)) {
1696: lb_newstate_equiv++;
1697: free(t->inst);
1698: free(t->trans);
1699: free(t);
1700: return te->state;
1701: }
1.157 anton 1702: }
1.158 anton 1703: tn = (struct tpa_state_entry *)malloc(sizeof(struct tpa_state_entry));
1704: tn->next = te;
1705: tn->state = t;
1706: tpa_state_table[hash] = tn;
1707: }
1708: lb_newstate_new++;
1709: if (tpa_trace)
1710: fprintf(stderr, "%ld %ld lb_states\n", lb_labeler_steps, lb_newstate_new);
1.157 anton 1711: return t;
1712: }
1713:
1.125 anton 1714: /* use dynamic programming to find the shortest paths within the basic
1715: block origs[0..ninsts-1] and rewrite the instructions pointed to by
1716: instps to use it */
1.161 pazsan 1717: static void optimize_rewrite(Cell *instps[], PrimNum origs[], int ninsts)
1.125 anton 1718: {
1719: int i,j;
1.156 anton 1720: struct tpa_state *ts[ninsts+1];
1.125 anton 1721: int nextdyn, nextstate, no_transition;
1.222 anton 1722: Address old_code_area;
1.125 anton 1723:
1.158 anton 1724: lb_basic_blocks++;
1.155 anton 1725: ts[ninsts] = termstate;
1.189 anton 1726: #ifndef NO_DYNAMIC
1727: if (print_sequences) {
1728: for (i=0; i<ninsts; i++)
1.190 anton 1729: #if defined(BURG_FORMAT)
1730: fprintf(stderr, "op%d ", super_costs[origs[i]].offset);
1731: #else
1.189 anton 1732: fprintf(stderr, "%s ", prim_names[origs[i]]);
1.190 anton 1733: #endif
1.189 anton 1734: fprintf(stderr, "\n");
1735: }
1736: #endif
1.107 anton 1737: for (i=ninsts-1; i>=0; i--) {
1.156 anton 1738: struct tpa_state **tp = lookup_tpa(origs[i],ts[i+1]);
1739: struct tpa_state *t = *tp;
1.158 anton 1740: lb_labeler_steps++;
1741: if (t) {
1.156 anton 1742: ts[i] = t;
1.158 anton 1743: lb_labeler_automaton++;
1744: }
1.156 anton 1745: else {
1.158 anton 1746: lb_labeler_dynprog++;
1.156 anton 1747: ts[i] = empty_tpa_state();
1748: for (j=1; j<=max_super && i+j<=ninsts; j++) {
1749: struct super_state **superp = lookup_super(origs+i, j);
1750: if (superp!=NULL) {
1751: struct super_state *supers = *superp;
1752: for (; supers!=NULL; supers = supers->next) {
1753: PrimNum s = supers->super;
1754: int jcost;
1755: struct cost *c=super_costs+s;
1756: struct waypoint *wi=&(ts[i]->inst[c->state_in]);
1757: struct waypoint *wo=&(ts[i+j]->trans[c->state_out]);
1758: int no_transition = wo->no_transition;
1.158 anton 1759: lb_applicable_base_rules++;
1.156 anton 1760: if (!(is_relocatable(s)) && !wo->relocatable) {
1761: wo=&(ts[i+j]->inst[c->state_out]);
1762: no_transition=1;
1763: }
1764: if (wo->cost == INF_COST)
1765: continue;
1766: jcost = wo->cost + ss_cost(s);
1767: if (jcost <= wi->cost) {
1768: wi->cost = jcost;
1769: wi->inst = s;
1770: wi->relocatable = is_relocatable(s);
1771: wi->no_transition = no_transition;
1772: /* if (ss_greedy) wi->cost = wo->cost ? */
1773: }
1.125 anton 1774: }
1.107 anton 1775: }
1776: }
1.156 anton 1777: transitions(ts[i]);
1.157 anton 1778: tpa_state_normalize(ts[i]);
1779: *tp = ts[i] = lookup_tpa_state(ts[i]);
1.158 anton 1780: if (tpa_trace)
1781: fprintf(stderr, "%ld %ld lb_table_entries\n", lb_labeler_steps, lb_labeler_dynprog);
1.107 anton 1782: }
1.125 anton 1783: }
1784: /* now rewrite the instructions */
1.222 anton 1785: reserve_code_super(origs,ninsts);
1786: old_code_area = code_area;
1.125 anton 1787: nextdyn=0;
1788: nextstate=CANONICAL_STATE;
1.155 anton 1789: no_transition = ((!ts[0]->trans[nextstate].relocatable)
1790: ||ts[0]->trans[nextstate].no_transition);
1.125 anton 1791: for (i=0; i<ninsts; i++) {
1792: Cell tc=0, tc2;
1793: if (i==nextdyn) {
1794: if (!no_transition) {
1795: /* process trans */
1.155 anton 1796: PrimNum p = ts[i]->trans[nextstate].inst;
1.125 anton 1797: struct cost *c = super_costs+p;
1.155 anton 1798: assert(ts[i]->trans[nextstate].cost != INF_COST);
1.125 anton 1799: assert(c->state_in==nextstate);
1.128 anton 1800: tc = compile_prim_dyn(p,NULL);
1.125 anton 1801: nextstate = c->state_out;
1802: }
1803: {
1804: /* process inst */
1.155 anton 1805: PrimNum p = ts[i]->inst[nextstate].inst;
1.125 anton 1806: struct cost *c=super_costs+p;
1807: assert(c->state_in==nextstate);
1.155 anton 1808: assert(ts[i]->inst[nextstate].cost != INF_COST);
1.125 anton 1809: #if defined(GFORTH_DEBUGGING)
1810: assert(p == origs[i]);
1811: #endif
1.128 anton 1812: tc2 = compile_prim_dyn(p,instps[i]);
1.125 anton 1813: if (no_transition || !is_relocatable(p))
1814: /* !! actually what we care about is if and where
1815: * compile_prim_dyn() puts NEXTs */
1816: tc=tc2;
1.155 anton 1817: no_transition = ts[i]->inst[nextstate].no_transition;
1.125 anton 1818: nextstate = c->state_out;
1819: nextdyn += c->length;
1820: }
1821: } else {
1822: #if defined(GFORTH_DEBUGGING)
1823: assert(0);
1824: #endif
1825: tc=0;
1.155 anton 1826: /* tc= (Cell)vm_prims[ts[i]->inst[CANONICAL_STATE].inst]; */
1.125 anton 1827: }
1828: *(instps[i]) = tc;
1829: }
1830: if (!no_transition) {
1.155 anton 1831: PrimNum p = ts[i]->trans[nextstate].inst;
1.125 anton 1832: struct cost *c = super_costs+p;
1833: assert(c->state_in==nextstate);
1.155 anton 1834: assert(ts[i]->trans[nextstate].cost != INF_COST);
1.125 anton 1835: assert(i==nextdyn);
1.128 anton 1836: (void)compile_prim_dyn(p,NULL);
1.125 anton 1837: nextstate = c->state_out;
1.107 anton 1838: }
1.125 anton 1839: assert(nextstate==CANONICAL_STATE);
1.222 anton 1840: assert(code_area==old_code_area); /* does reserve_code_super() work? */
1.107 anton 1841: }
1.162 pazsan 1842: #endif
1.107 anton 1843:
1.105 anton 1844: /* compile *start, possibly rewriting it into a static and/or dynamic
1845: superinstruction */
1846: void compile_prim1(Cell *start)
1.70 anton 1847: {
1.108 anton 1848: #if defined(DOUBLY_INDIRECT)
1.125 anton 1849: Label prim;
1850:
1851: if (start==NULL)
1852: return;
1853: prim = (Label)*start;
1.229 dvdkhlng 1854: if (prim<((Label)(xts+DOER_MAX)) || prim>((Label)(xts+npriminfos))) {
1.108 anton 1855: fprintf(stderr,"compile_prim encountered xt %p\n", prim);
1856: *start=(Cell)prim;
1857: return;
1858: } else {
1859: *start = (Cell)(prim-((Label)xts)+((Label)vm_prims));
1860: return;
1861: }
1862: #elif defined(INDIRECT_THREADED)
1863: return;
1.112 anton 1864: #else /* !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED)) */
1.128 anton 1865: static Cell *instps[MAX_BB];
1866: static PrimNum origs[MAX_BB];
1867: static int ninsts=0;
1868: PrimNum prim_num;
1869:
1870: if (start==NULL || ninsts >= MAX_BB ||
1871: (ninsts>0 && superend[origs[ninsts-1]])) {
1872: /* after bb, or at the start of the next bb */
1873: optimize_rewrite(instps,origs,ninsts);
1874: /* fprintf(stderr,"optimize_rewrite(...,%d)\n",ninsts); */
1875: ninsts=0;
1.185 anton 1876: if (start==NULL) {
1877: align_code();
1.128 anton 1878: return;
1.185 anton 1879: }
1.128 anton 1880: }
1881: prim_num = ((Xt)*start)-vm_prims;
1882: if(prim_num >= npriminfos) {
1.232 anton 1883: /* code word */
1.128 anton 1884: optimize_rewrite(instps,origs,ninsts);
1.129 anton 1885: /* fprintf(stderr,"optimize_rewrite(...,%d)\n",ninsts);*/
1.128 anton 1886: ninsts=0;
1.232 anton 1887: append_jump();
1888: *start = *(Cell *)*start;
1.128 anton 1889: return;
1890: }
1891: assert(ninsts<MAX_BB);
1892: instps[ninsts] = start;
1893: origs[ninsts] = prim_num;
1894: ninsts++;
1.112 anton 1895: #endif /* !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED)) */
1.47 anton 1896: }
1897:
1.176 pazsan 1898: #ifndef STANDALONE
1.161 pazsan 1899: Address gforth_loader(FILE *imagefile, char* filename)
1.1 anton 1900: /* returns the address of the image proper (after the preamble) */
1901: {
1902: ImageHeader header;
1903: Address image;
1904: Address imp; /* image+preamble */
1.17 anton 1905: Char magic[8];
1906: char magic7; /* size byte of magic number */
1.1 anton 1907: Cell preamblesize=0;
1.6 pazsan 1908: Cell data_offset = offset_image ? 56*sizeof(Cell) : 0;
1.1 anton 1909: UCell check_sum;
1.15 pazsan 1910: Cell ausize = ((RELINFOBITS == 8) ? 0 :
1911: (RELINFOBITS == 16) ? 1 :
1912: (RELINFOBITS == 32) ? 2 : 3);
1913: Cell charsize = ((sizeof(Char) == 1) ? 0 :
1914: (sizeof(Char) == 2) ? 1 :
1915: (sizeof(Char) == 4) ? 2 : 3) + ausize;
1916: Cell cellsize = ((sizeof(Cell) == 1) ? 0 :
1917: (sizeof(Cell) == 2) ? 1 :
1918: (sizeof(Cell) == 4) ? 2 : 3) + ausize;
1.21 anton 1919: Cell sizebyte = (ausize << 5) + (charsize << 3) + (cellsize << 1) +
1920: #ifdef WORDS_BIGENDIAN
1921: 0
1922: #else
1923: 1
1924: #endif
1925: ;
1.1 anton 1926:
1.197 anton 1927: vm_prims = gforth_engine(0,0,0,0,0 sr_call);
1.47 anton 1928: check_prims(vm_prims);
1.106 anton 1929: prepare_super_table();
1.1 anton 1930: #ifndef DOUBLY_INDIRECT
1.59 anton 1931: #ifdef PRINT_SUPER_LENGTHS
1932: print_super_lengths();
1933: #endif
1.43 anton 1934: check_sum = checksum(vm_prims);
1.1 anton 1935: #else /* defined(DOUBLY_INDIRECT) */
1.43 anton 1936: check_sum = (UCell)vm_prims;
1.1 anton 1937: #endif /* defined(DOUBLY_INDIRECT) */
1.155 anton 1938: #if !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED))
1939: termstate = make_termstate();
1940: #endif /* !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED)) */
1.10 pazsan 1941:
1942: do {
1943: if(fread(magic,sizeof(Char),8,imagefile) < 8) {
1.234 anton 1944: fprintf(stderr,"%s: image %s doesn't seem to be a Gforth (>=0.8) image.\n",
1.10 pazsan 1945: progname, filename);
1946: exit(1);
1.1 anton 1947: }
1.10 pazsan 1948: preamblesize+=8;
1.234 anton 1949: } while(memcmp(magic,"Gforth4",7));
1.17 anton 1950: magic7 = magic[7];
1.1 anton 1951: if (debug) {
1.17 anton 1952: magic[7]='\0';
1.21 anton 1953: fprintf(stderr,"Magic found: %s ", magic);
1954: print_sizes(magic7);
1.1 anton 1955: }
1956:
1.21 anton 1957: if (magic7 != sizebyte)
1958: {
1959: fprintf(stderr,"This image is: ");
1960: print_sizes(magic7);
1961: fprintf(stderr,"whereas the machine is ");
1962: print_sizes(sizebyte);
1.1 anton 1963: exit(-2);
1964: };
1965:
1966: fread((void *)&header,sizeof(ImageHeader),1,imagefile);
1.10 pazsan 1967:
1968: set_stack_sizes(&header);
1.1 anton 1969:
1970: #if HAVE_GETPAGESIZE
1971: pagesize=getpagesize(); /* Linux/GNU libc offers this */
1972: #elif HAVE_SYSCONF && defined(_SC_PAGESIZE)
1973: pagesize=sysconf(_SC_PAGESIZE); /* POSIX.4 */
1974: #elif PAGESIZE
1975: pagesize=PAGESIZE; /* in limits.h according to Gallmeister's POSIX.4 book */
1976: #endif
1.144 pazsan 1977: debugp(stderr,"pagesize=%ld\n",(unsigned long) pagesize);
1.1 anton 1978:
1.34 anton 1979: image = dict_alloc_read(imagefile, preamblesize+header.image_size,
1.222 anton 1980: dictsize, data_offset);
1.33 anton 1981: imp=image+preamblesize;
1.178 pazsan 1982:
1.1 anton 1983: if (clear_dictionary)
1.225 pazsan 1984: memset(imp+header.image_size, 0, dictsize-header.image_size-preamblesize);
1.90 anton 1985: if(header.base==0 || header.base == (Address)0x100) {
1.1 anton 1986: Cell reloc_size=((header.image_size-1)/sizeof(Cell))/8+1;
1.162 pazsan 1987: Char reloc_bits[reloc_size];
1.33 anton 1988: fseek(imagefile, preamblesize+header.image_size, SEEK_SET);
1.10 pazsan 1989: fread(reloc_bits, 1, reloc_size, imagefile);
1.161 pazsan 1990: gforth_relocate((Cell *)imp, reloc_bits, header.image_size, (Cell)header.base, vm_prims);
1.1 anton 1991: #if 0
1992: { /* let's see what the relocator did */
1993: FILE *snapshot=fopen("snapshot.fi","wb");
1994: fwrite(image,1,imagesize,snapshot);
1995: fclose(snapshot);
1996: }
1997: #endif
1.46 jwilke 1998: }
1999: else if(header.base!=imp) {
1.250 pazsan 2000: fprintf(stderr,"%s: Cannot load nonrelocatable image (compiled for address %p) at address %p\n",
1.247 pazsan 2001: progname, header.base, imp);
1.46 jwilke 2002: exit(1);
1.1 anton 2003: }
2004: if (header.checksum==0)
2005: ((ImageHeader *)imp)->checksum=check_sum;
2006: else if (header.checksum != check_sum) {
2007: fprintf(stderr,"%s: Checksum of image ($%lx) does not match the executable ($%lx)\n",
1.247 pazsan 2008: progname, header.checksum, check_sum);
1.1 anton 2009: exit(1);
2010: }
1.53 anton 2011: #ifdef DOUBLY_INDIRECT
2012: ((ImageHeader *)imp)->xt_base = xts;
2013: #endif
1.1 anton 2014: fclose(imagefile);
2015:
1.56 anton 2016: /* unnecessary, except maybe for CODE words */
2017: /* FLUSH_ICACHE(imp, header.image_size);*/
1.1 anton 2018:
2019: return imp;
2020: }
1.176 pazsan 2021: #endif
1.1 anton 2022:
1.72 anton 2023: /* pointer to last '/' or '\' in file, 0 if there is none. */
1.161 pazsan 2024: static char *onlypath(char *filename)
1.10 pazsan 2025: {
1.72 anton 2026: return strrchr(filename, DIRSEP);
1.1 anton 2027: }
2028:
1.161 pazsan 2029: static FILE *openimage(char *fullfilename)
1.10 pazsan 2030: {
2031: FILE *image_file;
1.242 pazsan 2032: char * expfilename = tilde_cstr((Char *)fullfilename, strlen(fullfilename));
1.10 pazsan 2033:
1.28 anton 2034: image_file=fopen(expfilename,"rb");
1.1 anton 2035: if (image_file!=NULL && debug)
1.28 anton 2036: fprintf(stderr, "Opened image file: %s\n", expfilename);
1.242 pazsan 2037: free(expfilename);
1.10 pazsan 2038: return image_file;
1.1 anton 2039: }
2040:
1.28 anton 2041: /* try to open image file concat(path[0:len],imagename) */
1.161 pazsan 2042: static FILE *checkimage(char *path, int len, char *imagename)
1.10 pazsan 2043: {
2044: int dirlen=len;
1.162 pazsan 2045: char fullfilename[dirlen+strlen((char *)imagename)+2];
1.10 pazsan 2046:
1.1 anton 2047: memcpy(fullfilename, path, dirlen);
1.71 pazsan 2048: if (fullfilename[dirlen-1]!=DIRSEP)
2049: fullfilename[dirlen++]=DIRSEP;
1.1 anton 2050: strcpy(fullfilename+dirlen,imagename);
1.10 pazsan 2051: return openimage(fullfilename);
1.1 anton 2052: }
2053:
1.161 pazsan 2054: static FILE * open_image_file(char * imagename, char * path)
1.1 anton 2055: {
1.10 pazsan 2056: FILE * image_file=NULL;
1.28 anton 2057: char *origpath=path;
1.10 pazsan 2058:
1.71 pazsan 2059: if(strchr(imagename, DIRSEP)==NULL) {
1.10 pazsan 2060: /* first check the directory where the exe file is in !! 01may97jaw */
2061: if (onlypath(progname))
1.72 anton 2062: image_file=checkimage(progname, onlypath(progname)-progname, imagename);
1.10 pazsan 2063: if (!image_file)
2064: do {
2065: char *pend=strchr(path, PATHSEP);
2066: if (pend==NULL)
2067: pend=path+strlen(path);
2068: if (strlen(path)==0) break;
2069: image_file=checkimage(path, pend-path, imagename);
2070: path=pend+(*pend==PATHSEP);
2071: } while (image_file==NULL);
2072: } else {
2073: image_file=openimage(imagename);
2074: }
1.1 anton 2075:
1.10 pazsan 2076: if (!image_file) {
2077: fprintf(stderr,"%s: cannot open image file %s in path %s for reading\n",
1.28 anton 2078: progname, imagename, origpath);
1.10 pazsan 2079: exit(1);
1.7 anton 2080: }
2081:
1.10 pazsan 2082: return image_file;
2083: }
1.11 pazsan 2084: #endif
2085:
1.178 pazsan 2086: #ifdef STANDALONE_ALLOC
1.177 pazsan 2087: Address gforth_alloc(Cell size)
2088: {
2089: Address r;
2090: /* leave a little room (64B) for stack underflows */
2091: if ((r = malloc(size+64))==NULL) {
2092: perror(progname);
2093: exit(1);
2094: }
2095: r = (Address)((((Cell)r)+(sizeof(Float)-1))&(-sizeof(Float)));
1.250 pazsan 2096: debugp(stderr, "malloc succeeds, address=%p\n", r);
1.177 pazsan 2097: return r;
2098: }
2099: #endif
2100:
1.11 pazsan 2101: #ifdef HAS_OS
1.161 pazsan 2102: static UCell convsize(char *s, UCell elemsize)
1.11 pazsan 2103: /* converts s of the format [0-9]+[bekMGT]? (e.g. 25k) into the number
2104: of bytes. the letter at the end indicates the unit, where e stands
2105: for the element size. default is e */
2106: {
2107: char *endp;
2108: UCell n,m;
2109:
2110: m = elemsize;
2111: n = strtoul(s,&endp,0);
2112: if (endp!=NULL) {
2113: if (strcmp(endp,"b")==0)
2114: m=1;
2115: else if (strcmp(endp,"k")==0)
2116: m=1024;
2117: else if (strcmp(endp,"M")==0)
2118: m=1024*1024;
2119: else if (strcmp(endp,"G")==0)
2120: m=1024*1024*1024;
2121: else if (strcmp(endp,"T")==0) {
2122: #if (SIZEOF_CHAR_P > 4)
1.24 anton 2123: m=1024L*1024*1024*1024;
1.11 pazsan 2124: #else
2125: fprintf(stderr,"%s: size specification \"%s\" too large for this machine\n", progname, endp);
2126: exit(1);
2127: #endif
2128: } else if (strcmp(endp,"e")!=0 && strcmp(endp,"")!=0) {
2129: fprintf(stderr,"%s: cannot grok size specification %s: invalid unit \"%s\"\n", progname, s, endp);
2130: exit(1);
2131: }
2132: }
2133: return n*m;
2134: }
1.10 pazsan 2135:
1.109 anton 2136: enum {
2137: ss_number = 256,
1.125 anton 2138: ss_states,
1.109 anton 2139: ss_min_codesize,
2140: ss_min_ls,
2141: ss_min_lsu,
2142: ss_min_nexts,
1.224 anton 2143: opt_code_block_size,
1.109 anton 2144: };
2145:
1.179 pazsan 2146: #ifndef STANDALONE
1.10 pazsan 2147: void gforth_args(int argc, char ** argv, char ** path, char ** imagename)
2148: {
2149: int c;
2150:
1.1 anton 2151: opterr=0;
2152: while (1) {
2153: int option_index=0;
2154: static struct option opts[] = {
1.29 anton 2155: {"appl-image", required_argument, NULL, 'a'},
1.1 anton 2156: {"image-file", required_argument, NULL, 'i'},
2157: {"dictionary-size", required_argument, NULL, 'm'},
2158: {"data-stack-size", required_argument, NULL, 'd'},
2159: {"return-stack-size", required_argument, NULL, 'r'},
2160: {"fp-stack-size", required_argument, NULL, 'f'},
2161: {"locals-stack-size", required_argument, NULL, 'l'},
1.181 anton 2162: {"vm-commit", no_argument, &map_noreserve, 0},
1.1 anton 2163: {"path", required_argument, NULL, 'p'},
2164: {"version", no_argument, NULL, 'v'},
2165: {"help", no_argument, NULL, 'h'},
2166: /* put something != 0 into offset_image */
2167: {"offset-image", no_argument, &offset_image, 1},
2168: {"no-offset-im", no_argument, &offset_image, 0},
2169: {"clear-dictionary", no_argument, &clear_dictionary, 1},
1.201 anton 2170: {"debug", no_argument, &debug, 1},
2171: {"diag", no_argument, &diag, 1},
1.4 anton 2172: {"die-on-signal", no_argument, &die_on_signal, 1},
1.169 anton 2173: {"ignore-async-signals", no_argument, &ignore_async_signals, 1},
1.60 anton 2174: {"no-super", no_argument, &no_super, 1},
2175: {"no-dynamic", no_argument, &no_dynamic, 1},
1.66 anton 2176: {"dynamic", no_argument, &no_dynamic, 0},
1.224 anton 2177: {"code-block-size", required_argument, NULL, opt_code_block_size},
1.110 anton 2178: {"print-metrics", no_argument, &print_metrics, 1},
1.189 anton 2179: {"print-sequences", no_argument, &print_sequences, 1},
1.109 anton 2180: {"ss-number", required_argument, NULL, ss_number},
1.125 anton 2181: {"ss-states", required_argument, NULL, ss_states},
1.109 anton 2182: #ifndef NO_DYNAMIC
2183: {"ss-min-codesize", no_argument, NULL, ss_min_codesize},
2184: #endif
2185: {"ss-min-ls", no_argument, NULL, ss_min_ls},
2186: {"ss-min-lsu", no_argument, NULL, ss_min_lsu},
2187: {"ss-min-nexts", no_argument, NULL, ss_min_nexts},
1.110 anton 2188: {"ss-greedy", no_argument, &ss_greedy, 1},
1.158 anton 2189: {"tpa-noequiv", no_argument, &tpa_noequiv, 1},
2190: {"tpa-noautomaton", no_argument, &tpa_noautomaton, 1},
2191: {"tpa-trace", no_argument, &tpa_trace, 1},
1.1 anton 2192: {0,0,0,0}
2193: /* no-init-file, no-rc? */
2194: };
2195:
1.36 pazsan 2196: c = getopt_long(argc, argv, "+i:m:d:r:f:l:p:vhoncsx", opts, &option_index);
1.1 anton 2197:
2198: switch (c) {
1.29 anton 2199: case EOF: return;
2200: case '?': optind--; return;
2201: case 'a': *imagename = optarg; return;
1.10 pazsan 2202: case 'i': *imagename = optarg; break;
1.1 anton 2203: case 'm': dictsize = convsize(optarg,sizeof(Cell)); break;
2204: case 'd': dsize = convsize(optarg,sizeof(Cell)); break;
2205: case 'r': rsize = convsize(optarg,sizeof(Cell)); break;
2206: case 'f': fsize = convsize(optarg,sizeof(Float)); break;
2207: case 'l': lsize = convsize(optarg,sizeof(Cell)); break;
1.10 pazsan 2208: case 'p': *path = optarg; break;
1.36 pazsan 2209: case 'o': offset_image = 1; break;
2210: case 'n': offset_image = 0; break;
2211: case 'c': clear_dictionary = 1; break;
2212: case 's': die_on_signal = 1; break;
2213: case 'x': debug = 1; break;
1.83 anton 2214: case 'v': fputs(PACKAGE_STRING"\n", stderr); exit(0);
1.224 anton 2215: case opt_code_block_size: code_area_size = atoi(optarg); break;
1.109 anton 2216: case ss_number: static_super_number = atoi(optarg); break;
1.125 anton 2217: case ss_states: maxstates = max(min(atoi(optarg),MAX_STATE),1); break;
1.109 anton 2218: #ifndef NO_DYNAMIC
2219: case ss_min_codesize: ss_cost = cost_codesize; break;
2220: #endif
2221: case ss_min_ls: ss_cost = cost_ls; break;
2222: case ss_min_lsu: ss_cost = cost_lsu; break;
2223: case ss_min_nexts: ss_cost = cost_nexts; break;
1.1 anton 2224: case 'h':
1.29 anton 2225: fprintf(stderr, "Usage: %s [engine options] ['--'] [image arguments]\n\
1.1 anton 2226: Engine Options:\n\
1.181 anton 2227: --appl-image FILE Equivalent to '--image-file=FILE --'\n\
1.10 pazsan 2228: --clear-dictionary Initialize the dictionary with 0 bytes\n\
1.224 anton 2229: --code-block-size=SIZE size of native code blocks [512KB]\n\
1.10 pazsan 2230: -d SIZE, --data-stack-size=SIZE Specify data stack size\n\
2231: --debug Print debugging information during startup\n\
1.144 pazsan 2232: --diag Print diagnostic information during startup\n\
1.181 anton 2233: --die-on-signal Exit instead of THROWing some signals\n\
2234: --dynamic Use dynamic native code\n\
1.10 pazsan 2235: -f SIZE, --fp-stack-size=SIZE Specify floating point stack size\n\
2236: -h, --help Print this message and exit\n\
1.181 anton 2237: --ignore-async-signals Ignore instead of THROWing async. signals\n\
1.10 pazsan 2238: -i FILE, --image-file=FILE Use image FILE instead of `gforth.fi'\n\
2239: -l SIZE, --locals-stack-size=SIZE Specify locals stack size\n\
2240: -m SIZE, --dictionary-size=SIZE Specify Forth dictionary size\n\
1.60 anton 2241: --no-dynamic Use only statically compiled primitives\n\
1.10 pazsan 2242: --no-offset-im Load image at normal position\n\
1.181 anton 2243: --no-super No dynamically formed superinstructions\n\
1.10 pazsan 2244: --offset-image Load image at a different position\n\
2245: -p PATH, --path=PATH Search path for finding image and sources\n\
1.110 anton 2246: --print-metrics Print some code generation metrics on exit\n\
1.201 anton 2247: --print-sequences Print primitive sequences for optimization\n\
1.10 pazsan 2248: -r SIZE, --return-stack-size=SIZE Specify return stack size\n\
1.181 anton 2249: --ss-greedy Greedy, not optimal superinst selection\n\
2250: --ss-min-codesize Select superinsts for smallest native code\n\
2251: --ss-min-ls Minimize loads and stores\n\
2252: --ss-min-lsu Minimize loads, stores, and pointer updates\n\
2253: --ss-min-nexts Minimize the number of static superinsts\n\
2254: --ss-number=N Use N static superinsts (default max)\n\
2255: --ss-states=N N states for stack caching (default max)\n\
2256: --tpa-noequiv Automaton without state equivalence\n\
2257: --tpa-noautomaton Dynamic programming only\n\
2258: --tpa-trace Report new states etc.\n\
1.66 anton 2259: -v, --version Print engine version and exit\n\
1.181 anton 2260: --vm-commit Use OS default for memory overcommit\n\
1.1 anton 2261: SIZE arguments consist of an integer followed by a unit. The unit can be\n\
1.10 pazsan 2262: `b' (byte), `e' (element; default), `k' (KB), `M' (MB), `G' (GB) or `T' (TB).\n",
2263: argv[0]);
2264: optind--;
2265: return;
1.1 anton 2266: }
2267: }
1.10 pazsan 2268: }
1.11 pazsan 2269: #endif
1.179 pazsan 2270: #endif
1.10 pazsan 2271:
1.161 pazsan 2272: static void print_diag()
1.144 pazsan 2273: {
2274:
1.207 pazsan 2275: #if !defined(HAVE_GETRUSAGE)
1.145 pazsan 2276: fprintf(stderr, "*** missing functionality ***\n"
1.144 pazsan 2277: #ifndef HAVE_GETRUSAGE
2278: " no getrusage -> CPUTIME broken\n"
2279: #endif
2280: );
2281: #endif
2282: if((relocs < nonrelocs) ||
2283: #if defined(BUGGY_LL_CMP) || defined(BUGGY_LL_MUL) || defined(BUGGY_LL_DIV) || defined(BUGGY_LL_ADD) || defined(BUGGY_LL_SHIFT) || defined(BUGGY_LL_D2F) || defined(BUGGY_LL_F2D)
2284: 1
2285: #else
2286: 0
2287: #endif
2288: )
2289: debugp(stderr, "relocs: %d:%d\n", relocs, nonrelocs);
1.209 anton 2290: fprintf(stderr, "*** %sperformance problems ***\n%s%s",
1.204 anton 2291: #if defined(BUGGY_LL_CMP) || defined(BUGGY_LL_MUL) || defined(BUGGY_LL_DIV) || defined(BUGGY_LL_ADD) || defined(BUGGY_LL_SHIFT) || defined(BUGGY_LL_D2F) || defined(BUGGY_LL_F2D) || !(defined(FORCE_REG) || defined(FORCE_REG_UNNECESSARY)) || defined(BUGGY_LONG_LONG)
1.165 pazsan 2292: "",
2293: #else
2294: "no ",
2295: #endif
1.144 pazsan 2296: #if defined(BUGGY_LL_CMP) || defined(BUGGY_LL_MUL) || defined(BUGGY_LL_DIV) || defined(BUGGY_LL_ADD) || defined(BUGGY_LL_SHIFT) || defined(BUGGY_LL_D2F) || defined(BUGGY_LL_F2D)
2297: " double-cell integer type buggy ->\n "
2298: #ifdef BUGGY_LL_CMP
1.219 anton 2299: "double comparisons, "
1.144 pazsan 2300: #endif
2301: #ifdef BUGGY_LL_MUL
1.219 anton 2302: "*/MOD */ M* UM* "
1.144 pazsan 2303: #endif
2304: #ifdef BUGGY_LL_DIV
1.219 anton 2305: /* currently nothing is affected */
1.144 pazsan 2306: #endif
2307: #ifdef BUGGY_LL_ADD
1.219 anton 2308: "M+ D+ D- DNEGATE "
1.144 pazsan 2309: #endif
2310: #ifdef BUGGY_LL_SHIFT
1.219 anton 2311: "D2/ "
1.144 pazsan 2312: #endif
2313: #ifdef BUGGY_LL_D2F
1.219 anton 2314: "D>F "
1.144 pazsan 2315: #endif
2316: #ifdef BUGGY_LL_F2D
1.219 anton 2317: "F>D "
1.144 pazsan 2318: #endif
2319: "\b\b slow\n"
1.145 pazsan 2320: #endif
1.200 anton 2321: #if !(defined(FORCE_REG) || defined(FORCE_REG_UNNECESSARY))
1.145 pazsan 2322: " automatic register allocation: performance degradation possible\n"
2323: #endif
1.198 anton 2324: "",
1.209 anton 2325: (relocs < nonrelocs) ? "no dynamic code generation (--debug for details) -> factor 2 slowdown\n" : "");
1.144 pazsan 2326: }
2327:
1.179 pazsan 2328: #ifdef STANDALONE
2329: Cell data_abort_pc;
2330:
2331: void data_abort_C(void)
2332: {
2333: while(1) {
2334: }
2335: }
1.10 pazsan 2336: #endif
1.67 pazsan 2337:
1.244 pazsan 2338: void* gforth_pointers(Cell n)
1.242 pazsan 2339: {
1.244 pazsan 2340: switch(n) {
2341: case 0: return (void*)&gforth_SP;
2342: case 1: return (void*)&gforth_FP;
2343: case 2: return (void*)&gforth_LP;
2344: case 3: return (void*)&gforth_RP;
2345: case 4: return (void*)&gforth_UP;
2346: case 5: return (void*)&gforth_engine;
1.242 pazsan 2347: #ifdef HAS_FILE
1.244 pazsan 2348: case 6: return (void*)&cstr;
2349: case 7: return (void*)&tilde_cstr;
1.242 pazsan 2350: #endif
1.246 pazsan 2351: case 8: return (void*)&throw_jmp_handler;
1.244 pazsan 2352: default: return NULL;
2353: }
1.242 pazsan 2354: }
2355:
1.253 ! pazsan 2356: void gforth_init(int argc, char **argv, char **env, char ** path, char ** imagename)
1.10 pazsan 2357: {
1.221 anton 2358: #if 0 && defined(__i386)
2359: /* disabled because the drawbacks may be worse than the benefits */
1.220 anton 2360: /* set 387 precision control to use 53-bit mantissae to avoid most
2361: cases of double rounding */
2362: short fpu_control = 0x027f ;
2363: asm("fldcw %0" : : "m"(fpu_control));
2364: #endif /* defined(__i386) */
1.241 pazsan 2365:
1.215 anton 2366: #ifdef MACOSX_DEPLOYMENT_TARGET
2367: setenv("MACOSX_DEPLOYMENT_TARGET", MACOSX_DEPLOYMENT_TARGET, 0);
2368: #endif
2369: #ifdef LTDL_LIBRARY_PATH
2370: setenv("LTDL_LIBRARY_PATH", LTDL_LIBRARY_PATH, 0);
2371: #endif
1.179 pazsan 2372: #ifndef STANDALONE
1.10 pazsan 2373: /* buffering of the user output device */
1.11 pazsan 2374: #ifdef _IONBF
1.10 pazsan 2375: if (isatty(fileno(stdout))) {
2376: fflush(stdout);
2377: setvbuf(stdout,NULL,_IONBF,0);
1.1 anton 2378: }
1.11 pazsan 2379: #endif
1.228 pazsan 2380: setlocale(LC_ALL, "");
2381: setlocale(LC_NUMERIC, "C");
1.180 pazsan 2382: #else
2383: prep_terminal();
1.179 pazsan 2384: #endif
1.1 anton 2385:
1.199 pazsan 2386: #ifndef STANDALONE
1.212 anton 2387: #ifdef HAVE_LIBLTDL
1.191 anton 2388: if (lt_dlinit()!=0) {
2389: fprintf(stderr,"%s: lt_dlinit failed", progname);
2390: exit(1);
2391: }
1.212 anton 2392: #endif
1.11 pazsan 2393: #ifdef HAS_OS
1.253 ! pazsan 2394: gforth_args(argc, argv, path, imagename);
1.109 anton 2395: #ifndef NO_DYNAMIC
1.148 anton 2396: init_ss_cost();
1.109 anton 2397: #endif /* !defined(NO_DYNAMIC) */
2398: #endif /* defined(HAS_OS) */
1.179 pazsan 2399: #endif
1.253 ! pazsan 2400: }
! 2401:
! 2402: int gforth_main(int argc, char **argv, char **env)
! 2403: {
! 2404: #ifdef HAS_OS
! 2405: char *path = getenv("GFORTHPATH") ? : DEFAULTPATH;
! 2406: #else
! 2407: char *path = DEFAULTPATH;
! 2408: #endif
! 2409: int retvalue;
! 2410: Address image;
! 2411: char *imagename="gforth.fi";
! 2412: FILE *image_file;
! 2413:
! 2414: progname = argv[0];
! 2415:
! 2416: gforth_init(argc, argv, env, &path, &imagename);
! 2417:
1.224 anton 2418: code_here = ((void *)0)+code_area_size;
1.175 pazsan 2419: #ifdef STANDALONE
1.197 anton 2420: image = gforth_engine(0, 0, 0, 0, 0 sr_call);
1.10 pazsan 2421: #else
2422: image_file = open_image_file(imagename, path);
1.161 pazsan 2423: image = gforth_loader(image_file, imagename);
1.10 pazsan 2424: #endif
1.253 ! pazsan 2425: alloc_stacks((ImageHeader *)image);
1.24 anton 2426: gforth_header=(ImageHeader *)image; /* used in SIGSEGV handler */
1.1 anton 2427:
1.144 pazsan 2428: if (diag)
2429: print_diag();
1.1 anton 2430: {
1.10 pazsan 2431: char path2[strlen(path)+1];
1.1 anton 2432: char *p1, *p2;
2433: Cell environ[]= {
2434: (Cell)argc-(optind-1),
2435: (Cell)(argv+(optind-1)),
1.10 pazsan 2436: (Cell)strlen(path),
1.1 anton 2437: (Cell)path2};
2438: argv[optind-1] = progname;
2439: /*
2440: for (i=0; i<environ[0]; i++)
2441: printf("%s\n", ((char **)(environ[1]))[i]);
2442: */
2443: /* make path OS-independent by replacing path separators with NUL */
1.10 pazsan 2444: for (p1=path, p2=path2; *p1!='\0'; p1++, p2++)
1.1 anton 2445: if (*p1==PATHSEP)
2446: *p2 = '\0';
2447: else
2448: *p2 = *p1;
2449: *p2='\0';
1.161 pazsan 2450: retvalue = gforth_go(image, 4, environ);
1.178 pazsan 2451: #if defined(SIGPIPE) && !defined(STANDALONE)
1.102 anton 2452: bsd_signal(SIGPIPE, SIG_IGN);
2453: #endif
1.42 anton 2454: #ifdef VM_PROFILING
2455: vm_print_profile(stderr);
2456: #endif
1.1 anton 2457: deprep_terminal();
1.199 pazsan 2458: #ifndef STANDALONE
1.212 anton 2459: #ifdef HAVE_LIBLTDL
1.191 anton 2460: if (lt_dlexit()!=0)
2461: fprintf(stderr,"%s: lt_dlexit failed", progname);
1.199 pazsan 2462: #endif
1.212 anton 2463: #endif
1.104 anton 2464: }
1.110 anton 2465: if (print_metrics) {
2466: int i;
2467: fprintf(stderr, "code size = %8ld\n", dyncodesize());
1.177 pazsan 2468: #ifndef STANDALONE
1.110 anton 2469: for (i=0; i<sizeof(cost_sums)/sizeof(cost_sums[0]); i++)
2470: fprintf(stderr, "metric %8s: %8ld\n",
2471: cost_sums[i].metricname, cost_sums[i].sum);
1.177 pazsan 2472: #endif
1.158 anton 2473: fprintf(stderr,"lb_basic_blocks = %ld\n", lb_basic_blocks);
2474: fprintf(stderr,"lb_labeler_steps = %ld\n", lb_labeler_steps);
2475: fprintf(stderr,"lb_labeler_automaton = %ld\n", lb_labeler_automaton);
2476: fprintf(stderr,"lb_labeler_dynprog = %ld\n", lb_labeler_dynprog);
2477: fprintf(stderr,"lb_newstate_equiv = %ld\n", lb_newstate_equiv);
2478: fprintf(stderr,"lb_newstate_new = %ld\n", lb_newstate_new);
2479: fprintf(stderr,"lb_applicable_base_rules = %ld\n", lb_applicable_base_rules);
2480: fprintf(stderr,"lb_applicable_chain_rules = %ld\n", lb_applicable_chain_rules);
2481: }
2482: if (tpa_trace) {
2483: fprintf(stderr, "%ld %ld lb_states\n", lb_labeler_steps, lb_newstate_new);
2484: fprintf(stderr, "%ld %ld lb_table_entries\n", lb_labeler_steps, lb_labeler_dynprog);
1.1 anton 2485: }
1.13 pazsan 2486: return retvalue;
1.1 anton 2487: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>