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

CVS Admin

gforth: gforth/engine/main.c

ViewCVS and CVS Help