[gforth] / gforth / engine / main.c

gforth: gforth/engine/main.c

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

CVS Admin

gforth: gforth/engine/main.c

ViewCVS and CVS Help