[gforth] / gforth / engine / engine.c  

gforth: gforth/engine/engine.c

1 : anton 1.1 /* Gforth virtual machine (aka inner interpreter)
2 :    
3 : anton 1.61 Copyright (C) 1995,1996,1997,1998,2000,2003 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 :     #include "config.h"
23 : pazsan 1.31 #include "forth.h"
24 : anton 1.1 #include <ctype.h>
25 :     #include <stdio.h>
26 :     #include <string.h>
27 :     #include <math.h>
28 : pazsan 1.4 #include <assert.h>
29 :     #include <stdlib.h>
30 :     #include <errno.h>
31 :     #include "io.h"
32 :     #include "threaded.h"
33 :     #ifndef STANDALONE
34 : anton 1.1 #include <sys/types.h>
35 :     #include <sys/stat.h>
36 :     #include <fcntl.h>
37 :     #include <time.h>
38 :     #include <sys/time.h>
39 :     #include <unistd.h>
40 :     #include <pwd.h>
41 : pazsan 1.17 #include <dirent.h>
42 : anton 1.21 #include <sys/resource.h>
43 : anton 1.19 #ifdef HAVE_FNMATCH_H
44 : anton 1.18 #include <fnmatch.h>
45 : anton 1.19 #else
46 :     #include "fnmatch.h"
47 :     #endif
48 : pazsan 1.4 #else
49 :     #include "systypes.h"
50 :     #endif
51 : anton 1.1
52 :     #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) /* what else? */
53 :     #include <dlfcn.h>
54 :     #endif
55 : pazsan 1.8 #if defined(_WIN32)
56 :     #include <windows.h>
57 :     #endif
58 : anton 1.1 #ifdef hpux
59 :     #include <dl.h>
60 :     #endif
61 :    
62 :     #ifndef SEEK_SET
63 :     /* should be defined in stdio.h, but some systems don't have it */
64 :     #define SEEK_SET 0
65 :     #endif
66 :    
67 : anton 1.53 #ifndef HAVE_FSEEKO
68 :     #define fseeko fseek
69 :     #endif
70 :    
71 :     #ifndef HAVE_FTELLO
72 :     #define ftello ftell
73 :     #endif
74 :    
75 : anton 1.1 #define NULLC '\0'
76 :    
77 : pazsan 1.14 #ifdef MEMCMP_AS_SUBROUTINE
78 :     extern int gforth_memcmp(const char * s1, const char * s2, size_t n);
79 : anton 1.15 #define memcmp(s1,s2,n) gforth_memcmp(s1,s2,n)
80 : pazsan 1.14 #endif
81 :    
82 : anton 1.1 #define NEWLINE '\n'
83 :    
84 : anton 1.26 /* conversion on fetch */
85 :    
86 : anton 1.41 #define vm_Cell2f(_cell,_x) ((_x)=(Bool)(_cell))
87 :     #define vm_Cell2c(_cell,_x) ((_x)=(Char)(_cell))
88 :     #define vm_Cell2n(_cell,_x) ((_x)=(Cell)(_cell))
89 :     #define vm_Cell2w(_cell,_x) ((_x)=(Cell)(_cell))
90 :     #define vm_Cell2u(_cell,_x) ((_x)=(UCell)(_cell))
91 :     #define vm_Cell2a_(_cell,_x) ((_x)=(Cell *)(_cell))
92 :     #define vm_Cell2c_(_cell,_x) ((_x)=(Char *)(_cell))
93 :     #define vm_Cell2f_(_cell,_x) ((_x)=(Float *)(_cell))
94 :     #define vm_Cell2df_(_cell,_x) ((_x)=(DFloat *)(_cell))
95 :     #define vm_Cell2sf_(_cell,_x) ((_x)=(SFloat *)(_cell))
96 :     #define vm_Cell2xt(_cell,_x) ((_x)=(Xt)(_cell))
97 :     #define vm_Cell2f83name(_cell,_x) ((_x)=(struct F83Name *)(_cell))
98 :     #define vm_Cell2longname(_cell,_x) ((_x)=(struct Longname *)(_cell))
99 :     #define vm_Float2r(_float,_x) (_x=_float)
100 : anton 1.26
101 :     /* conversion on store */
102 :    
103 : anton 1.41 #define vm_f2Cell(_x,_cell) ((_cell)=(Cell)(_x))
104 :     #define vm_c2Cell(_x,_cell) ((_cell)=(Cell)(_x))
105 :     #define vm_n2Cell(_x,_cell) ((_cell)=(Cell)(_x))
106 :     #define vm_w2Cell(_x,_cell) ((_cell)=(Cell)(_x))
107 :     #define vm_u2Cell(_x,_cell) ((_cell)=(Cell)(_x))
108 :     #define vm_a_2Cell(_x,_cell) ((_cell)=(Cell)(_x))
109 :     #define vm_c_2Cell(_x,_cell) ((_cell)=(Cell)(_x))
110 :     #define vm_f_2Cell(_x,_cell) ((_cell)=(Cell)(_x))
111 :     #define vm_df_2Cell(_x,_cell) ((_cell)=(Cell)(_x))
112 :     #define vm_sf_2Cell(_x,_cell) ((_cell)=(Cell)(_x))
113 :     #define vm_xt2Cell(_x,_cell) ((_cell)=(Cell)(_x))
114 :     #define vm_f83name2Cell(_x,_cell) ((_cell)=(Cell)(_x))
115 :     #define vm_longname2Cell(_x,_cell) ((_cell)=(Cell)(_x))
116 :     #define vm_r2Float(_x,_float) (_float=_x)
117 : anton 1.26
118 : anton 1.41 #define vm_Cell2Cell(_x,_y) (_y=_x)
119 : anton 1.29
120 : anton 1.46 #ifdef NO_IP
121 :     #define IMM_ARG(access,value) (VARIANT(value))
122 :     #else
123 :     #define IMM_ARG(access,value) (access)
124 :     #endif
125 :    
126 : anton 1.1 /* if machine.h has not defined explicit registers, define them as implicit */
127 :     #ifndef IPREG
128 :     #define IPREG
129 :     #endif
130 :     #ifndef SPREG
131 :     #define SPREG
132 :     #endif
133 :     #ifndef RPREG
134 :     #define RPREG
135 :     #endif
136 :     #ifndef FPREG
137 :     #define FPREG
138 :     #endif
139 :     #ifndef LPREG
140 :     #define LPREG
141 :     #endif
142 :     #ifndef CFAREG
143 :     #define CFAREG
144 :     #endif
145 :     #ifndef UPREG
146 :     #define UPREG
147 :     #endif
148 :     #ifndef TOSREG
149 :     #define TOSREG
150 :     #endif
151 :     #ifndef FTOSREG
152 :     #define FTOSREG
153 :     #endif
154 :    
155 :     #ifndef CPU_DEP1
156 :     # define CPU_DEP1 0
157 :     #endif
158 :    
159 : anton 1.28 /* instructions containing these must be the last instruction of a
160 :     super-instruction (e.g., branches, EXECUTE, and other instructions
161 :     ending the basic block). Instructions containing SET_IP get this
162 :     automatically, so you usually don't have to write it. If you have
163 :     to write it, write it after IP points to the next instruction.
164 :     Used for profiling. Don't write it in a word containing SET_IP, or
165 :     the following block will be counted twice. */
166 :     #ifdef VM_PROFILING
167 :     #define SUPER_END vm_count_block(IP)
168 :     #else
169 :     #define SUPER_END
170 :     #endif
171 : anton 1.35 #define SUPER_CONTINUE
172 : anton 1.46
173 : pazsan 1.37 #ifdef DEBUG
174 :     #define CFA_TO_NAME(__cfa) \
175 :     Cell len, i; \
176 :     char * name = __cfa; \
177 :     for(i=0; i<32; i+=sizeof(Cell)) { \
178 :     len = ((Cell*)name)[-1]; \
179 :     if(len < 0) { \
180 :     len &= 0x1F; \
181 :     if((len+sizeof(Cell)) > i) break; \
182 :     } len = 0; \
183 :     name -= sizeof(Cell); \
184 :     }
185 :     #endif
186 : anton 1.30
187 : anton 1.50 #if !defined(ENGINE)
188 :     /* normal engine */
189 :     #define VARIANT(v) (v)
190 :     #define JUMP(target) goto I_noop
191 : anton 1.51 #define LABEL(name) J_##name: asm(""); I_##name:
192 : anton 1.50
193 :     #elif ENGINE==2
194 :     /* variant with padding between VM instructions for finding out
195 :     cross-inst jumps (for dynamic code) */
196 :     #define engine engine2
197 :     #define VARIANT(v) (v)
198 :     #define JUMP(target) goto I_noop
199 : anton 1.52 #define LABEL(name) J_##name: SKIP16; I_##name:
200 : anton 1.50 #define IN_ENGINE2
201 :    
202 :     #elif ENGINE==3
203 :     /* variant with different immediate arguments for finding out
204 :     immediate arguments (for native code) */
205 :     #define engine engine3
206 :     #define VARIANT(v) ((v)^0xffffffff)
207 :     #define JUMP(target) goto K_lit
208 : anton 1.51 #define LABEL(name) J_##name: asm(""); I_##name:
209 : anton 1.50 #else
210 :     #error illegal ENGINE value
211 :     #endif /* ENGINE */
212 :    
213 :     #define LABEL2(name) K_##name:
214 :    
215 :    
216 :     Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
217 : anton 1.1 /* executes code at ip, if ip!=NULL
218 :     returns array of machine code labels (for use in a loader), if ip==NULL
219 :     */
220 :     {
221 : anton 1.10 #ifndef GFORTH_DEBUGGING
222 :     register Cell *rp RPREG;
223 :     #endif
224 : anton 1.46 #ifndef NO_IP
225 :     register Xt *ip IPREG = ip0;
226 :     #endif
227 : anton 1.1 register Cell *sp SPREG = sp0;
228 :     register Float *fp FPREG = fp0;
229 :     register Address lp LPREG = lp0;
230 :     register Xt cfa CFAREG;
231 : anton 1.11 #ifdef MORE_VARS
232 :     MORE_VARS
233 :     #endif
234 : anton 1.1 register Address up UPREG = UP;
235 : anton 1.24 IF_spTOS(register Cell spTOS TOSREG;)
236 :     IF_fpTOS(register Float fpTOS FTOSREG;)
237 : anton 1.1 #if defined(DOUBLY_INDIRECT)
238 :     static Label *symbols;
239 :     static void *routines[]= {
240 : anton 1.27 #define MAX_SYMBOLS (sizeof(routines)/sizeof(routines[0]))
241 : anton 1.1 #else /* !defined(DOUBLY_INDIRECT) */
242 :     static Label symbols[]= {
243 : anton 1.27 #define MAX_SYMBOLS (sizeof(symbols)/sizeof(symbols[0]))
244 : anton 1.1 #endif /* !defined(DOUBLY_INDIRECT) */
245 : pazsan 1.4 (Label)&&docol,
246 :     (Label)&&docon,
247 :     (Label)&&dovar,
248 :     (Label)&&douser,
249 :     (Label)&&dodefer,
250 :     (Label)&&dofield,
251 :     (Label)&&dodoes,
252 : anton 1.1 /* the following entry is normally unused;
253 : anton 1.34 it is there because its index indicates a does-handler */
254 : pazsan 1.7 CPU_DEP1,
255 : anton 1.55 #define INST_ADDR(name) ((Label)&&I_##name)
256 : anton 1.34 #include "prim_lab.i"
257 :     #undef INST_ADDR
258 :     (Label)&&after_last,
259 :     (Label)0,
260 : anton 1.55 #define INST_ADDR(name) ((Label)&&K_##name)
261 : anton 1.46 #include "prim_lab.i"
262 :     #undef INST_ADDR
263 : anton 1.55 #define INST_ADDR(name) ((Label)&&J_##name)
264 : anton 1.1 #include "prim_lab.i"
265 : anton 1.34 #undef INST_ADDR
266 : anton 1.1 };
267 :     #ifdef CPU_DEP2
268 :     CPU_DEP2
269 :     #endif
270 :    
271 : anton 1.10 rp = rp0;
272 : anton 1.1 #ifdef DEBUG
273 :     fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n",
274 : anton 1.46 (unsigned)ip0,(unsigned)sp,(unsigned)rp,
275 : anton 1.1 (unsigned)fp,(unsigned)lp,(unsigned)up);
276 :     #endif
277 :    
278 : anton 1.46 if (ip0 == NULL) {
279 : anton 1.1 #if defined(DOUBLY_INDIRECT)
280 : anton 1.38 #define CODE_OFFSET (26*sizeof(Cell))
281 :     #define XT_OFFSET (22*sizeof(Cell))
282 : anton 1.1 int i;
283 : anton 1.3 Cell code_offset = offset_image? CODE_OFFSET : 0;
284 : anton 1.38 Cell xt_offset = offset_image? XT_OFFSET : 0;
285 : pazsan 1.7
286 : anton 1.3 symbols = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+CODE_OFFSET)+code_offset);
287 : anton 1.38 xts = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+XT_OFFSET)+xt_offset);
288 : anton 1.1 for (i=0; i<DOESJUMP+1; i++)
289 : anton 1.38 xts[i] = symbols[i] = (Label)routines[i];
290 : anton 1.1 for (; routines[i]!=0; i++) {
291 :     if (i>=MAX_SYMBOLS) {
292 : anton 1.60 fprintf(stderr,"gforth-ditc: more than %ld primitives\n",(long)MAX_SYMBOLS);
293 : anton 1.1 exit(1);
294 : anton 1.20 }
295 : anton 1.38 xts[i] = symbols[i] = &routines[i];
296 : anton 1.1 }
297 : anton 1.20 #endif /* defined(DOUBLY_INDIRECT) */
298 :     return symbols;
299 : pazsan 1.7 }
300 : anton 1.1
301 : anton 1.24 IF_spTOS(spTOS = sp[0]);
302 :     IF_fpTOS(fpTOS = fp[0]);
303 : pazsan 1.7 /* prep_terminal(); */
304 : anton 1.46 #ifdef NO_IP
305 :     goto *(*(Label *)ip0);
306 :     #else
307 : anton 1.11 SET_IP(ip);
308 : anton 1.28 SUPER_END; /* count the first block, too */
309 : anton 1.1 NEXT;
310 : anton 1.46 #endif
311 : anton 1.11
312 : anton 1.1 #ifdef CPU_DEP3
313 :     CPU_DEP3
314 :     #endif
315 :    
316 :     docol:
317 :     {
318 : anton 1.46 #ifdef NO_IP
319 :     *--rp = next_code;
320 :     goto **(Label *)PFA1(cfa);
321 :     #else
322 : anton 1.1 #ifdef DEBUG
323 : pazsan 1.37 {
324 :     CFA_TO_NAME(cfa);
325 :     fprintf(stderr,"%08lx: col: %08lx %.*s\n",(Cell)ip,(Cell)PFA1(cfa),
326 :     len,name);
327 :     }
328 : anton 1.1 #endif
329 :     #ifdef CISC_NEXT
330 :     /* this is the simple version */
331 :     *--rp = (Cell)ip;
332 : anton 1.11 SET_IP((Xt *)PFA1(cfa));
333 : anton 1.28 SUPER_END;
334 : anton 1.1 NEXT;
335 :     #else
336 : anton 1.11 /* this one is important, so we help the compiler optimizing */
337 : anton 1.1 {
338 :     DEF_CA
339 : anton 1.11 rp[-1] = (Cell)ip;
340 :     SET_IP((Xt *)PFA1(cfa));
341 : anton 1.28 SUPER_END;
342 : anton 1.11 NEXT_P1;
343 :     rp--;
344 :     NEXT_P2;
345 : anton 1.1 }
346 :     #endif
347 : anton 1.46 #endif
348 : anton 1.1 }
349 :    
350 :     docon:
351 :     {
352 :     #ifdef DEBUG
353 :     fprintf(stderr,"%08lx: con: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
354 :     #endif
355 :     #ifdef USE_TOS
356 : anton 1.24 *sp-- = spTOS;
357 :     spTOS = *(Cell *)PFA1(cfa);
358 : anton 1.1 #else
359 :     *--sp = *(Cell *)PFA1(cfa);
360 :     #endif
361 :     }
362 : anton 1.46 #ifdef NO_IP
363 :     goto *next_code;
364 :     #else
365 : anton 1.1 NEXT_P0;
366 :     NEXT;
367 : anton 1.46 #endif
368 : anton 1.1
369 :     dovar:
370 :     {
371 :     #ifdef DEBUG
372 :     fprintf(stderr,"%08lx: var: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
373 :     #endif
374 :     #ifdef USE_TOS
375 : anton 1.24 *sp-- = spTOS;
376 :     spTOS = (Cell)PFA1(cfa);
377 : anton 1.1 #else
378 :     *--sp = (Cell)PFA1(cfa);
379 :     #endif
380 :     }
381 : anton 1.46 #ifdef NO_IP
382 :     goto *next_code;
383 :     #else
384 : anton 1.1 NEXT_P0;
385 :     NEXT;
386 : anton 1.46 #endif
387 : anton 1.1
388 :     douser:
389 :     {
390 :     #ifdef DEBUG
391 :     fprintf(stderr,"%08lx: user: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
392 :     #endif
393 :     #ifdef USE_TOS
394 : anton 1.24 *sp-- = spTOS;
395 :     spTOS = (Cell)(up+*(Cell*)PFA1(cfa));
396 : anton 1.1 #else
397 :     *--sp = (Cell)(up+*(Cell*)PFA1(cfa));
398 :     #endif
399 :     }
400 : anton 1.46 #ifdef NO_IP
401 :     goto *next_code;
402 :     #else
403 : anton 1.1 NEXT_P0;
404 :     NEXT;
405 : anton 1.46 #endif
406 : anton 1.1
407 :     dodefer:
408 :     {
409 :     #ifdef DEBUG
410 :     fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
411 :     #endif
412 : anton 1.28 SUPER_END;
413 : anton 1.1 EXEC(*(Xt *)PFA1(cfa));
414 :     }
415 :    
416 :     dofield:
417 :     {
418 :     #ifdef DEBUG
419 :     fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
420 :     #endif
421 : anton 1.24 spTOS += *(Cell*)PFA1(cfa);
422 : anton 1.1 }
423 : anton 1.46 #ifdef NO_IP
424 :     goto *next_code;
425 :     #else
426 : anton 1.1 NEXT_P0;
427 :     NEXT;
428 : anton 1.46 #endif
429 : anton 1.1
430 :     dodoes:
431 :     /* this assumes the following structure:
432 :     defining-word:
433 :    
434 :     ...
435 :     DOES>
436 :     (possible padding)
437 :     possibly handler: jmp dodoes
438 :     (possible branch delay slot(s))
439 :     Forth code after DOES>
440 :    
441 :     defined word:
442 :    
443 :     cfa: address of or jump to handler OR
444 :     address of or jump to dodoes, address of DOES-code
445 :     pfa:
446 :    
447 :     */
448 : anton 1.46 #ifdef NO_IP
449 :     *--rp = next_code;
450 :     IF_spTOS(spTOS = sp[0]);
451 :     sp--;
452 :     spTOS = (Cell)PFA(cfa);
453 :     goto **(Label *)DOES_CODE1(cfa);
454 :     #else
455 : anton 1.1 {
456 :     /* fprintf(stderr, "Got CFA %08lx at doescode %08lx/%08lx: does: %08lx\n",cfa,(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));*/
457 :     #ifdef DEBUG
458 :     fprintf(stderr,"%08lx/%08lx: does: %08lx\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));
459 :     fflush(stderr);
460 :     #endif
461 :     *--rp = (Cell)ip;
462 :     /* PFA1 might collide with DOES_CODE1 here, so we use PFA */
463 :     #ifdef USE_TOS
464 : anton 1.24 *sp-- = spTOS;
465 :     spTOS = (Cell)PFA(cfa);
466 : anton 1.1 #else
467 :     *--sp = (Cell)PFA(cfa);
468 :     #endif
469 : anton 1.11 SET_IP(DOES_CODE1(cfa));
470 : anton 1.28 SUPER_END;
471 : anton 1.24 /* fprintf(stderr,"TOS = %08lx, IP=%08lx\n", spTOS, IP);*/
472 : anton 1.1 }
473 :     NEXT;
474 : anton 1.46 #endif
475 : anton 1.1
476 :     #include "prim.i"
477 : anton 1.34 after_last: return (Label *)0;
478 :     /*needed only to get the length of the last primitive */
479 : anton 1.50 }
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help