[gforth] / gforth / engine / engine.c  

gforth: gforth/engine/engine.c

1 : anton 1.1 /* Gforth virtual machine (aka inner interpreter)
2 :    
3 : anton 1.109 Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008 Free Software Foundation, Inc.
4 : anton 1.1
5 :     This file is part of Gforth.
6 :    
7 :     Gforth is free software; you can redistribute it and/or
8 :     modify it under the terms of the GNU General Public License
9 : anton 1.105 as published by the Free Software Foundation, either version 3
10 : anton 1.1 of the License, or (at your option) any later version.
11 :    
12 :     This program is distributed in the hope that it will be useful,
13 :     but WITHOUT ANY WARRANTY; without even the implied warranty of
14 :     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 :     GNU General Public License for more details.
16 :    
17 :     You should have received a copy of the GNU General Public License
18 : anton 1.105 along with this program; if not, see http://www.gnu.org/licenses/.
19 : anton 1.1 */
20 :    
21 : anton 1.72 #if defined(GFORTH_DEBUGGING) || defined(INDIRECT_THREADED) || defined(DOUBLY_INDIRECT) || defined(VM_PROFILING)
22 : anton 1.68 #define USE_NO_TOS
23 : anton 1.72 #else
24 :     #define USE_TOS
25 :     #endif
26 : anton 1.68
27 : anton 1.1 #include "config.h"
28 : pazsan 1.31 #include "forth.h"
29 : anton 1.1 #include <ctype.h>
30 :     #include <stdio.h>
31 :     #include <string.h>
32 :     #include <math.h>
33 : pazsan 1.4 #include <assert.h>
34 :     #include <stdlib.h>
35 :     #include <errno.h>
36 :     #include "io.h"
37 :     #include "threaded.h"
38 :     #ifndef STANDALONE
39 : anton 1.1 #include <sys/types.h>
40 :     #include <sys/stat.h>
41 :     #include <fcntl.h>
42 :     #include <time.h>
43 :     #include <sys/time.h>
44 :     #include <unistd.h>
45 :     #include <pwd.h>
46 : pazsan 1.17 #include <dirent.h>
47 : pazsan 1.89 #include <wchar.h>
48 : anton 1.21 #include <sys/resource.h>
49 : anton 1.19 #ifdef HAVE_FNMATCH_H
50 : anton 1.18 #include <fnmatch.h>
51 : anton 1.19 #else
52 :     #include "fnmatch.h"
53 :     #endif
54 : pazsan 1.4 #else
55 : pazsan 1.96 /* #include <systypes.h> */
56 : pazsan 1.4 #endif
57 : anton 1.1
58 :     #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) /* what else? */
59 :     #include <dlfcn.h>
60 :     #endif
61 : pazsan 1.8 #if defined(_WIN32)
62 :     #include <windows.h>
63 :     #endif
64 : anton 1.1 #ifdef hpux
65 :     #include <dl.h>
66 :     #endif
67 :    
68 : pazsan 1.63 #ifdef HAS_FFCALL
69 :     #include <avcall.h>
70 :     #include <callback.h>
71 :     #endif
72 :    
73 : anton 1.1 #ifndef SEEK_SET
74 :     /* should be defined in stdio.h, but some systems don't have it */
75 :     #define SEEK_SET 0
76 :     #endif
77 :    
78 : anton 1.53 #ifndef HAVE_FSEEKO
79 :     #define fseeko fseek
80 :     #endif
81 :    
82 :     #ifndef HAVE_FTELLO
83 :     #define ftello ftell
84 :     #endif
85 :    
86 : anton 1.1 #define NULLC '\0'
87 :    
88 : pazsan 1.14 #ifdef MEMCMP_AS_SUBROUTINE
89 :     extern int gforth_memcmp(const char * s1, const char * s2, size_t n);
90 : anton 1.15 #define memcmp(s1,s2,n) gforth_memcmp(s1,s2,n)
91 : pazsan 1.14 #endif
92 :    
93 : anton 1.1 #define NEWLINE '\n'
94 : anton 1.94
95 :     /* These two flags control whether divisions are checked by software.
96 :     The CHECK_DIVISION_SW is for those cases where the event is a
97 :     division by zero or overflow on the C level, and might be reported
98 :     by hardware; we might check forr that in autoconf and set the
99 :     switch appropriately, but currently don't. The CHECK_DIVISION flag
100 :     is for the other cases. */
101 :     #ifdef GFORTH_DEBUGGING
102 :     #define CHECK_DIVISION_SW 1
103 : anton 1.91 #define CHECK_DIVISION 1
104 : anton 1.94 #else
105 :     #define CHECK_DIVISION_SW 0
106 :     #define CHECK_DIVISION 0
107 :     #endif
108 : anton 1.1
109 : anton 1.26 /* conversion on fetch */
110 :    
111 : anton 1.41 #define vm_Cell2f(_cell,_x) ((_x)=(Bool)(_cell))
112 :     #define vm_Cell2c(_cell,_x) ((_x)=(Char)(_cell))
113 :     #define vm_Cell2n(_cell,_x) ((_x)=(Cell)(_cell))
114 :     #define vm_Cell2w(_cell,_x) ((_x)=(Cell)(_cell))
115 :     #define vm_Cell2u(_cell,_x) ((_x)=(UCell)(_cell))
116 :     #define vm_Cell2a_(_cell,_x) ((_x)=(Cell *)(_cell))
117 :     #define vm_Cell2c_(_cell,_x) ((_x)=(Char *)(_cell))
118 :     #define vm_Cell2f_(_cell,_x) ((_x)=(Float *)(_cell))
119 :     #define vm_Cell2df_(_cell,_x) ((_x)=(DFloat *)(_cell))
120 :     #define vm_Cell2sf_(_cell,_x) ((_x)=(SFloat *)(_cell))
121 :     #define vm_Cell2xt(_cell,_x) ((_x)=(Xt)(_cell))
122 :     #define vm_Cell2f83name(_cell,_x) ((_x)=(struct F83Name *)(_cell))
123 :     #define vm_Cell2longname(_cell,_x) ((_x)=(struct Longname *)(_cell))
124 :     #define vm_Float2r(_float,_x) (_x=_float)
125 : anton 1.26
126 :     /* conversion on store */
127 :    
128 : anton 1.41 #define vm_f2Cell(_x,_cell) ((_cell)=(Cell)(_x))
129 :     #define vm_c2Cell(_x,_cell) ((_cell)=(Cell)(_x))
130 :     #define vm_n2Cell(_x,_cell) ((_cell)=(Cell)(_x))
131 :     #define vm_w2Cell(_x,_cell) ((_cell)=(Cell)(_x))
132 :     #define vm_u2Cell(_x,_cell) ((_cell)=(Cell)(_x))
133 :     #define vm_a_2Cell(_x,_cell) ((_cell)=(Cell)(_x))
134 :     #define vm_c_2Cell(_x,_cell) ((_cell)=(Cell)(_x))
135 :     #define vm_f_2Cell(_x,_cell) ((_cell)=(Cell)(_x))
136 :     #define vm_df_2Cell(_x,_cell) ((_cell)=(Cell)(_x))
137 :     #define vm_sf_2Cell(_x,_cell) ((_cell)=(Cell)(_x))
138 :     #define vm_xt2Cell(_x,_cell) ((_cell)=(Cell)(_x))
139 :     #define vm_f83name2Cell(_x,_cell) ((_cell)=(Cell)(_x))
140 :     #define vm_longname2Cell(_x,_cell) ((_cell)=(Cell)(_x))
141 :     #define vm_r2Float(_x,_float) (_float=_x)
142 : anton 1.26
143 : anton 1.41 #define vm_Cell2Cell(_x,_y) (_y=_x)
144 : anton 1.29
145 : anton 1.46 #ifdef NO_IP
146 :     #define IMM_ARG(access,value) (VARIANT(value))
147 :     #else
148 :     #define IMM_ARG(access,value) (access)
149 :     #endif
150 :    
151 : anton 1.1 /* if machine.h has not defined explicit registers, define them as implicit */
152 :     #ifndef IPREG
153 :     #define IPREG
154 :     #endif
155 :     #ifndef SPREG
156 :     #define SPREG
157 :     #endif
158 :     #ifndef RPREG
159 :     #define RPREG
160 :     #endif
161 :     #ifndef FPREG
162 :     #define FPREG
163 :     #endif
164 :     #ifndef LPREG
165 :     #define LPREG
166 :     #endif
167 : pazsan 1.79 #ifndef CAREG
168 :     #define CAREG
169 :     #endif
170 : anton 1.1 #ifndef CFAREG
171 :     #define CFAREG
172 :     #endif
173 :     #ifndef UPREG
174 :     #define UPREG
175 :     #endif
176 :     #ifndef TOSREG
177 :     #define TOSREG
178 :     #endif
179 : anton 1.69 #ifndef spbREG
180 :     #define spbREG
181 :     #endif
182 : anton 1.74 #ifndef spcREG
183 :     #define spcREG
184 :     #endif
185 : anton 1.80 #ifndef spdREG
186 :     #define spdREG
187 :     #endif
188 :     #ifndef speREG
189 :     #define speREG
190 :     #endif
191 : anton 1.81 #ifndef spfREG
192 :     #define spfREG
193 :     #endif
194 :     #ifndef spgREG
195 :     #define spgREG
196 :     #endif
197 :     #ifndef sphREG
198 :     #define sphREG
199 :     #endif
200 : anton 1.1 #ifndef FTOSREG
201 :     #define FTOSREG
202 :     #endif
203 :    
204 :     #ifndef CPU_DEP1
205 :     # define CPU_DEP1 0
206 :     #endif
207 :    
208 : anton 1.62 /* instructions containing SUPER_END must be the last instruction of a
209 : anton 1.28 super-instruction (e.g., branches, EXECUTE, and other instructions
210 :     ending the basic block). Instructions containing SET_IP get this
211 :     automatically, so you usually don't have to write it. If you have
212 :     to write it, write it after IP points to the next instruction.
213 :     Used for profiling. Don't write it in a word containing SET_IP, or
214 :     the following block will be counted twice. */
215 :     #ifdef VM_PROFILING
216 :     #define SUPER_END vm_count_block(IP)
217 :     #else
218 :     #define SUPER_END
219 :     #endif
220 : anton 1.35 #define SUPER_CONTINUE
221 : anton 1.46
222 : anton 1.98 #ifdef ASMCOMMENT
223 :     /* an individualized asm statement so that (hopefully) gcc's optimizer
224 :     does not do cross-jumping */
225 :     #define asmcomment(string) asm(ASMCOMMENT string)
226 :     #else
227 :     /* we don't know how to do an asm comment, so we just do an empty asm */
228 :     #define asmcomment(string) asm("")
229 :     #endif
230 :    
231 : anton 1.66 #ifdef GFORTH_DEBUGGING
232 : anton 1.70 #if DEBUG
233 : pazsan 1.102 #define NAME(string) { saved_ip=ip; asmcomment(string); fprintf(stderr,"%08lx depth=%3ld tos=%016lx: "string"\n",(Cell)ip,sp0+3-sp,sp[0]);}
234 : anton 1.70 #else /* !DEBUG */
235 : anton 1.66 #define NAME(string) { saved_ip=ip; asm(""); }
236 :     /* the asm here is to avoid reordering of following stuff above the
237 :     assignment; this is an old-style asm (no operands), and therefore
238 :     is treated like "asm volatile ..."; i.e., it prevents most
239 :     reorderings across itself. We want the assignment above first,
240 :     because the stack loads may already cause a stack underflow. */
241 : anton 1.70 #endif /* !DEBUG */
242 : anton 1.66 #elif DEBUG
243 : anton 1.72 # define NAME(string) {Cell __depth=sp0+3-sp; int i; fprintf(stderr,"%08lx depth=%3ld: "string,(Cell)ip,sp0+3-sp); for (i=__depth-1; i>0; i--) fprintf(stderr, " $%lx",sp[i]); fprintf(stderr, " $%lx\n",spTOS); }
244 : anton 1.66 #else
245 : anton 1.98 # define NAME(string) asmcomment(string);
246 : anton 1.66 #endif
247 :    
248 : pazsan 1.37 #ifdef DEBUG
249 :     #define CFA_TO_NAME(__cfa) \
250 :     Cell len, i; \
251 :     char * name = __cfa; \
252 :     for(i=0; i<32; i+=sizeof(Cell)) { \
253 :     len = ((Cell*)name)[-1]; \
254 :     if(len < 0) { \
255 :     len &= 0x1F; \
256 :     if((len+sizeof(Cell)) > i) break; \
257 :     } len = 0; \
258 :     name -= sizeof(Cell); \
259 :     }
260 :     #endif
261 : anton 1.30
262 : pazsan 1.101 #ifdef STANDALONE
263 :     jmp_buf throw_jmp_buf;
264 :    
265 :     void throw(int code)
266 :     {
267 :     longjmp(throw_jmp_buf,code); /* !! or use siglongjmp ? */
268 :     }
269 :     #endif
270 :    
271 : pazsan 1.85 #if defined(HAS_FFCALL) || defined(HAS_LIBFFI)
272 : pazsan 1.88 #define SAVE_REGS IF_fpTOS(fp[0]=fpTOS); gforth_SP=sp; gforth_FP=fp; gforth_RP=rp; gforth_LP=lp;
273 :     #define REST_REGS sp=gforth_SP; fp=gforth_FP; rp=gforth_RP; lp=gforth_LP; IF_fpTOS(fpTOS=fp[0]);
274 : pazsan 1.63 #endif
275 :    
276 : anton 1.50 #if !defined(ENGINE)
277 :     /* normal engine */
278 :     #define VARIANT(v) (v)
279 :     #define JUMP(target) goto I_noop
280 : anton 1.82 #define LABEL(name) H_##name: asm(""); I_##name:
281 : anton 1.100 #define LABEL3(name) J_##name: asm("");
282 : anton 1.50
283 :     #elif ENGINE==2
284 :     /* variant with padding between VM instructions for finding out
285 :     cross-inst jumps (for dynamic code) */
286 : pazsan 1.90 #define gforth_engine gforth_engine2
287 : anton 1.50 #define VARIANT(v) (v)
288 :     #define JUMP(target) goto I_noop
289 : anton 1.78 #define LABEL(name) H_##name: SKIP16; I_##name:
290 : anton 1.100 /* the SKIP16 after LABEL3 is there, because the ARM gcc may place
291 :     some constants after the final branch, and may refer to them from
292 :     the code before label3. Since we don't copy the constants, we have
293 :     to make sure that such code is recognized as non-relocatable. */
294 :     #define LABEL3(name) J_##name: SKIP16;
295 : anton 1.50
296 :     #elif ENGINE==3
297 :     /* variant with different immediate arguments for finding out
298 :     immediate arguments (for native code) */
299 : pazsan 1.90 #define gforth_engine gforth_engine3
300 : anton 1.50 #define VARIANT(v) ((v)^0xffffffff)
301 :     #define JUMP(target) goto K_lit
302 : anton 1.83 #define LABEL(name) H_##name: asm(""); I_##name:
303 : anton 1.100 #define LABEL3(name) J_##name: asm("");
304 : anton 1.50 #else
305 :     #error illegal ENGINE value
306 :     #endif /* ENGINE */
307 :    
308 : anton 1.67 /* the asm(""); is there to get a stop compiled on Itanium */
309 :     #define LABEL2(name) K_##name: asm("");
310 : anton 1.50
311 : anton 1.106 Label *gforth_engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0 sr_proto)
312 : anton 1.1 /* executes code at ip, if ip!=NULL
313 :     returns array of machine code labels (for use in a loader), if ip==NULL
314 :     */
315 :     {
316 : anton 1.107 #if defined(GFORTH_DEBUGGING)
317 :     #if defined(GLOBALS_NONRELOC)
318 :     register saved_regs *saved_regs_p TOSREG = saved_regs_p0;
319 :     #endif /* defined(GLOBALS_NONRELOC) */
320 :     #else /* !defined(GFORTH_DEBUGGING) */
321 : anton 1.10 register Cell *rp RPREG;
322 : anton 1.107 #endif /* !defined(GFORTH_DEBUGGING) */
323 : anton 1.46 #ifndef NO_IP
324 :     register Xt *ip IPREG = ip0;
325 :     #endif
326 : anton 1.1 register Cell *sp SPREG = sp0;
327 :     register Float *fp FPREG = fp0;
328 :     register Address lp LPREG = lp0;
329 :     register Xt cfa CFAREG;
330 : pazsan 1.79 register Label real_ca CAREG;
331 : anton 1.11 #ifdef MORE_VARS
332 :     MORE_VARS
333 : pazsan 1.63 #endif
334 :     #ifdef HAS_FFCALL
335 :     av_alist alist;
336 : pazsan 1.90 extern va_alist gforth_clist;
337 : pazsan 1.63 float frv;
338 :     int irv;
339 :     double drv;
340 :     long long llrv;
341 :     void * prv;
342 : pazsan 1.84 #endif
343 : pazsan 1.88 register Address up UPREG = gforth_UP;
344 : anton 1.107 #if !defined(GFORTH_DEBUGGING)
345 : anton 1.80 register Cell MAYBE_UNUSED spTOS TOSREG;
346 : anton 1.74 register Cell MAYBE_UNUSED spb spbREG;
347 :     register Cell MAYBE_UNUSED spc spcREG;
348 : anton 1.80 register Cell MAYBE_UNUSED spd spdREG;
349 :     register Cell MAYBE_UNUSED spe speREG;
350 : anton 1.81 register Cell MAYBE_UNUSED spf speREG;
351 :     register Cell MAYBE_UNUSED spg speREG;
352 :     register Cell MAYBE_UNUSED sph speREG;
353 : anton 1.24 IF_fpTOS(register Float fpTOS FTOSREG;)
354 : anton 1.107 #endif /* !defined(GFORTH_DEBUGGING) */
355 : anton 1.1 #if defined(DOUBLY_INDIRECT)
356 :     static Label *symbols;
357 :     static void *routines[]= {
358 : anton 1.27 #define MAX_SYMBOLS (sizeof(routines)/sizeof(routines[0]))
359 : anton 1.1 #else /* !defined(DOUBLY_INDIRECT) */
360 :     static Label symbols[]= {
361 : anton 1.27 #define MAX_SYMBOLS (sizeof(symbols)/sizeof(symbols[0]))
362 : anton 1.1 #endif /* !defined(DOUBLY_INDIRECT) */
363 : anton 1.55 #define INST_ADDR(name) ((Label)&&I_##name)
364 : anton 1.71 #include PRIM_LAB_I
365 : anton 1.34 #undef INST_ADDR
366 :     (Label)0,
367 : anton 1.55 #define INST_ADDR(name) ((Label)&&K_##name)
368 : anton 1.71 #include PRIM_LAB_I
369 : anton 1.46 #undef INST_ADDR
370 : anton 1.55 #define INST_ADDR(name) ((Label)&&J_##name)
371 : anton 1.71 #include PRIM_LAB_I
372 : anton 1.34 #undef INST_ADDR
373 : anton 1.76 (Label)&&after_last,
374 :     (Label)&&before_goto,
375 : anton 1.78 (Label)&&after_goto,
376 :     /* just mention the H_ labels, so the SKIP16s are not optimized away */
377 :     #define INST_ADDR(name) ((Label)&&H_##name)
378 :     #include PRIM_LAB_I
379 :     #undef INST_ADDR
380 : anton 1.1 };
381 : pazsan 1.99 #ifdef STANDALONE
382 : pazsan 1.97 #define INST_ADDR(name) ((Label)&&I_##name)
383 :     #include "image.i"
384 :     #undef INST_ADDR
385 :     #endif
386 : anton 1.1 #ifdef CPU_DEP2
387 :     CPU_DEP2
388 :     #endif
389 :    
390 : anton 1.10 rp = rp0;
391 : anton 1.1 #ifdef DEBUG
392 :     fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n",
393 : anton 1.46 (unsigned)ip0,(unsigned)sp,(unsigned)rp,
394 : anton 1.1 (unsigned)fp,(unsigned)lp,(unsigned)up);
395 :     #endif
396 :    
397 : anton 1.46 if (ip0 == NULL) {
398 : anton 1.1 #if defined(DOUBLY_INDIRECT)
399 : anton 1.38 #define CODE_OFFSET (26*sizeof(Cell))
400 :     #define XT_OFFSET (22*sizeof(Cell))
401 : anton 1.1 int i;
402 : anton 1.3 Cell code_offset = offset_image? CODE_OFFSET : 0;
403 : anton 1.38 Cell xt_offset = offset_image? XT_OFFSET : 0;
404 : pazsan 1.7
405 : anton 1.3 symbols = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+CODE_OFFSET)+code_offset);
406 : anton 1.38 xts = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+XT_OFFSET)+xt_offset);
407 : anton 1.1 for (i=0; i<DOESJUMP+1; i++)
408 : anton 1.38 xts[i] = symbols[i] = (Label)routines[i];
409 : anton 1.1 for (; routines[i]!=0; i++) {
410 :     if (i>=MAX_SYMBOLS) {
411 : anton 1.60 fprintf(stderr,"gforth-ditc: more than %ld primitives\n",(long)MAX_SYMBOLS);
412 : anton 1.1 exit(1);
413 : anton 1.20 }
414 : anton 1.38 xts[i] = symbols[i] = &routines[i];
415 : anton 1.1 }
416 : anton 1.20 #endif /* defined(DOUBLY_INDIRECT) */
417 : pazsan 1.99 #ifdef STANDALONE
418 :     return image;
419 :     #else
420 : anton 1.20 return symbols;
421 : pazsan 1.99 #endif
422 : pazsan 1.7 }
423 : anton 1.1
424 : anton 1.81 #if !(defined(GFORTH_DEBUGGING) || defined(INDIRECT_THREADED) || defined(DOUBLY_INDIRECT) || defined(VM_PROFILING))
425 : anton 1.80 sp += STACK_CACHE_DEFAULT-1;
426 : anton 1.81 /* some of those registers are dead, but its simpler to initialize them all */ spTOS = sp[0];
427 : anton 1.80 spb = sp[-1];
428 :     spc = sp[-2];
429 :     spd = sp[-3];
430 :     spe = sp[-4];
431 : anton 1.81 spf = sp[-5];
432 :     spg = sp[-6];
433 :     sph = sp[-7];
434 : anton 1.80 #endif
435 :    
436 : anton 1.24 IF_fpTOS(fpTOS = fp[0]);
437 : pazsan 1.7 /* prep_terminal(); */
438 : anton 1.46 #ifdef NO_IP
439 :     goto *(*(Label *)ip0);
440 : pazsan 1.79 before_goto:
441 :     goto *real_ca;
442 :     after_goto:;
443 : anton 1.46 #else
444 : anton 1.11 SET_IP(ip);
445 : anton 1.28 SUPER_END; /* count the first block, too */
446 : pazsan 1.79 FIRST_NEXT;
447 : anton 1.46 #endif
448 : anton 1.11
449 : anton 1.1 #ifdef CPU_DEP3
450 :     CPU_DEP3
451 : anton 1.46 #endif
452 : anton 1.76
453 : anton 1.78 #include PRIM_I
454 :     after_last: return (Label *)0;
455 :     /*needed only to get the length of the last primitive */
456 :    
457 :     return (Label *)0;
458 : anton 1.50 }
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help