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