[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.66 #ifdef GFORTH_DEBUGGING
229 : anton 1.70 #if DEBUG
230 : pazsan 1.73 #define NAME(string) { saved_ip=ip; asm("# "string); fprintf(stderr,"%08lx depth=%3ld: "string"\n",(Cell)ip,sp0+3-sp);}
231 : anton 1.70 #else /* !DEBUG */
232 : anton 1.66 #define NAME(string) { saved_ip=ip; asm(""); }
233 :     /* the asm here is to avoid reordering of following stuff above the
234 :     assignment; this is an old-style asm (no operands), and therefore
235 :     is treated like "asm volatile ..."; i.e., it prevents most
236 :     reorderings across itself. We want the assignment above first,
237 :     because the stack loads may already cause a stack underflow. */
238 : anton 1.70 #endif /* !DEBUG */
239 : anton 1.66 #elif DEBUG
240 : 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); }
241 : anton 1.66 #else
242 : pazsan 1.73 # define NAME(string) asm("# "string);
243 : anton 1.66 #endif
244 :    
245 : pazsan 1.37 #ifdef DEBUG
246 :     #define CFA_TO_NAME(__cfa) \
247 :     Cell len, i; \
248 :     char * name = __cfa; \
249 :     for(i=0; i<32; i+=sizeof(Cell)) { \
250 :     len = ((Cell*)name)[-1]; \
251 :     if(len < 0) { \
252 :     len &= 0x1F; \
253 :     if((len+sizeof(Cell)) > i) break; \
254 :     } len = 0; \
255 :     name -= sizeof(Cell); \
256 :     }
257 :     #endif
258 : anton 1.30
259 : pazsan 1.85 #if defined(HAS_FFCALL) || defined(HAS_LIBFFI)
260 : pazsan 1.88 #define SAVE_REGS IF_fpTOS(fp[0]=fpTOS); gforth_SP=sp; gforth_FP=fp; gforth_RP=rp; gforth_LP=lp;
261 :     #define REST_REGS sp=gforth_SP; fp=gforth_FP; rp=gforth_RP; lp=gforth_LP; IF_fpTOS(fpTOS=fp[0]);
262 : pazsan 1.63 #endif
263 :    
264 : anton 1.50 #if !defined(ENGINE)
265 :     /* normal engine */
266 :     #define VARIANT(v) (v)
267 :     #define JUMP(target) goto I_noop
268 : anton 1.82 #define LABEL(name) H_##name: asm(""); I_##name:
269 : anton 1.50
270 :     #elif ENGINE==2
271 :     /* variant with padding between VM instructions for finding out
272 :     cross-inst jumps (for dynamic code) */
273 : pazsan 1.90 #define gforth_engine gforth_engine2
274 : anton 1.50 #define VARIANT(v) (v)
275 :     #define JUMP(target) goto I_noop
276 : anton 1.78 #define LABEL(name) H_##name: SKIP16; I_##name:
277 : anton 1.50
278 :     #elif ENGINE==3
279 :     /* variant with different immediate arguments for finding out
280 :     immediate arguments (for native code) */
281 : pazsan 1.90 #define gforth_engine gforth_engine3
282 : anton 1.50 #define VARIANT(v) ((v)^0xffffffff)
283 :     #define JUMP(target) goto K_lit
284 : anton 1.83 #define LABEL(name) H_##name: asm(""); I_##name:
285 : anton 1.50 #else
286 :     #error illegal ENGINE value
287 :     #endif /* ENGINE */
288 :    
289 : anton 1.67 /* the asm(""); is there to get a stop compiled on Itanium */
290 :     #define LABEL2(name) K_##name: asm("");
291 : anton 1.77 #define LABEL3(name) J_##name: asm("");
292 : anton 1.50
293 : pazsan 1.90 Label *gforth_engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
294 : anton 1.1 /* executes code at ip, if ip!=NULL
295 :     returns array of machine code labels (for use in a loader), if ip==NULL
296 :     */
297 :     {
298 : anton 1.10 #ifndef GFORTH_DEBUGGING
299 :     register Cell *rp RPREG;
300 :     #endif
301 : anton 1.46 #ifndef NO_IP
302 :     register Xt *ip IPREG = ip0;
303 :     #endif
304 : anton 1.1 register Cell *sp SPREG = sp0;
305 :     register Float *fp FPREG = fp0;
306 :     register Address lp LPREG = lp0;
307 :     register Xt cfa CFAREG;
308 : pazsan 1.79 register Label real_ca CAREG;
309 : anton 1.11 #ifdef MORE_VARS
310 :     MORE_VARS
311 : pazsan 1.63 #endif
312 :     #ifdef HAS_FFCALL
313 :     av_alist alist;
314 : pazsan 1.90 extern va_alist gforth_clist;
315 : pazsan 1.63 float frv;
316 :     int irv;
317 :     double drv;
318 :     long long llrv;
319 :     void * prv;
320 : pazsan 1.84 #endif
321 :     #ifdef HAS_LIBFFI
322 : pazsan 1.90 extern void * gforth_ritem;
323 :     extern void ** gforth_clist;
324 : pazsan 1.84 extern void ffi_callback(ffi_cif * cif, void * resp, void ** args, Xt * ip);
325 : anton 1.11 #endif
326 : pazsan 1.88 register Address up UPREG = gforth_UP;
327 : anton 1.80 register Cell MAYBE_UNUSED spTOS TOSREG;
328 : anton 1.74 register Cell MAYBE_UNUSED spb spbREG;
329 :     register Cell MAYBE_UNUSED spc spcREG;
330 : anton 1.80 register Cell MAYBE_UNUSED spd spdREG;
331 :     register Cell MAYBE_UNUSED spe speREG;
332 : anton 1.81 register Cell MAYBE_UNUSED spf speREG;
333 :     register Cell MAYBE_UNUSED spg speREG;
334 :     register Cell MAYBE_UNUSED sph speREG;
335 : anton 1.24 IF_fpTOS(register Float fpTOS FTOSREG;)
336 : anton 1.1 #if defined(DOUBLY_INDIRECT)
337 :     static Label *symbols;
338 :     static void *routines[]= {
339 : anton 1.27 #define MAX_SYMBOLS (sizeof(routines)/sizeof(routines[0]))
340 : anton 1.1 #else /* !defined(DOUBLY_INDIRECT) */
341 :     static Label symbols[]= {
342 : anton 1.27 #define MAX_SYMBOLS (sizeof(symbols)/sizeof(symbols[0]))
343 : anton 1.1 #endif /* !defined(DOUBLY_INDIRECT) */
344 : anton 1.55 #define INST_ADDR(name) ((Label)&&I_##name)
345 : anton 1.71 #include PRIM_LAB_I
346 : anton 1.34 #undef INST_ADDR
347 :     (Label)0,
348 : anton 1.55 #define INST_ADDR(name) ((Label)&&K_##name)
349 : anton 1.71 #include PRIM_LAB_I
350 : anton 1.46 #undef INST_ADDR
351 : anton 1.55 #define INST_ADDR(name) ((Label)&&J_##name)
352 : anton 1.71 #include PRIM_LAB_I
353 : anton 1.34 #undef INST_ADDR
354 : anton 1.76 (Label)&&after_last,
355 :     (Label)&&before_goto,
356 : anton 1.78 (Label)&&after_goto,
357 :     /* just mention the H_ labels, so the SKIP16s are not optimized away */
358 :     #define INST_ADDR(name) ((Label)&&H_##name)
359 :     #include PRIM_LAB_I
360 :     #undef INST_ADDR
361 : anton 1.1 };
362 :     #ifdef CPU_DEP2
363 :     CPU_DEP2
364 :     #endif
365 :    
366 : anton 1.10 rp = rp0;
367 : anton 1.1 #ifdef DEBUG
368 :     fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n",
369 : anton 1.46 (unsigned)ip0,(unsigned)sp,(unsigned)rp,
370 : anton 1.1 (unsigned)fp,(unsigned)lp,(unsigned)up);
371 :     #endif
372 :    
373 : anton 1.46 if (ip0 == NULL) {
374 : anton 1.1 #if defined(DOUBLY_INDIRECT)
375 : anton 1.38 #define CODE_OFFSET (26*sizeof(Cell))
376 :     #define XT_OFFSET (22*sizeof(Cell))
377 : anton 1.1 int i;
378 : anton 1.3 Cell code_offset = offset_image? CODE_OFFSET : 0;
379 : anton 1.38 Cell xt_offset = offset_image? XT_OFFSET : 0;
380 : pazsan 1.7
381 : anton 1.3 symbols = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+CODE_OFFSET)+code_offset);
382 : anton 1.38 xts = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+XT_OFFSET)+xt_offset);
383 : anton 1.1 for (i=0; i<DOESJUMP+1; i++)
384 : anton 1.38 xts[i] = symbols[i] = (Label)routines[i];
385 : anton 1.1 for (; routines[i]!=0; i++) {
386 :     if (i>=MAX_SYMBOLS) {
387 : anton 1.60 fprintf(stderr,"gforth-ditc: more than %ld primitives\n",(long)MAX_SYMBOLS);
388 : anton 1.1 exit(1);
389 : anton 1.20 }
390 : anton 1.38 xts[i] = symbols[i] = &routines[i];
391 : anton 1.1 }
392 : anton 1.20 #endif /* defined(DOUBLY_INDIRECT) */
393 :     return symbols;
394 : pazsan 1.7 }
395 : anton 1.1
396 : anton 1.81 #if !(defined(GFORTH_DEBUGGING) || defined(INDIRECT_THREADED) || defined(DOUBLY_INDIRECT) || defined(VM_PROFILING))
397 : anton 1.80 sp += STACK_CACHE_DEFAULT-1;
398 : anton 1.81 /* some of those registers are dead, but its simpler to initialize them all */ spTOS = sp[0];
399 : anton 1.80 spb = sp[-1];
400 :     spc = sp[-2];
401 :     spd = sp[-3];
402 :     spe = sp[-4];
403 : anton 1.81 spf = sp[-5];
404 :     spg = sp[-6];
405 :     sph = sp[-7];
406 : anton 1.80 #endif
407 :    
408 : anton 1.24 IF_fpTOS(fpTOS = fp[0]);
409 : pazsan 1.7 /* prep_terminal(); */
410 : anton 1.46 #ifdef NO_IP
411 :     goto *(*(Label *)ip0);
412 : pazsan 1.79 before_goto:
413 :     goto *real_ca;
414 :     after_goto:;
415 : anton 1.46 #else
416 : anton 1.11 SET_IP(ip);
417 : anton 1.28 SUPER_END; /* count the first block, too */
418 : pazsan 1.79 FIRST_NEXT;
419 : anton 1.46 #endif
420 : anton 1.11
421 : anton 1.1 #ifdef CPU_DEP3
422 :     CPU_DEP3
423 : anton 1.46 #endif
424 : anton 1.76
425 : anton 1.78 #include PRIM_I
426 :     after_last: return (Label *)0;
427 :     /*needed only to get the length of the last primitive */
428 :    
429 :     return (Label *)0;
430 : anton 1.50 }
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help