[gforth] / gforth / engine / engine.c  

gforth: gforth/engine/engine.c

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help