[gforth] / gforth / engine / engine.c  

gforth: gforth/engine/engine.c

1 : anton 1.1 /* Gforth virtual machine (aka inner interpreter)
2 :    
3 : anton 1.75 Copyright (C) 1995,1996,1997,1998,2000,2003,2004 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 : anton 1.21 #include <sys/resource.h>
50 : anton 1.19 #ifdef HAVE_FNMATCH_H
51 : anton 1.18 #include <fnmatch.h>
52 : anton 1.19 #else
53 :     #include "fnmatch.h"
54 :     #endif
55 : pazsan 1.4 #else
56 :     #include "systypes.h"
57 :     #endif
58 : anton 1.1
59 :     #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) /* what else? */
60 :     #include <dlfcn.h>
61 :     #endif
62 : pazsan 1.8 #if defined(_WIN32)
63 :     #include <windows.h>
64 :     #endif
65 : anton 1.1 #ifdef hpux
66 :     #include <dl.h>
67 :     #endif
68 :    
69 : pazsan 1.63 #ifdef HAS_FFCALL
70 :     #include <avcall.h>
71 :     #include <callback.h>
72 :     #endif
73 :    
74 : anton 1.1 #ifndef SEEK_SET
75 :     /* should be defined in stdio.h, but some systems don't have it */
76 :     #define SEEK_SET 0
77 :     #endif
78 :    
79 : anton 1.53 #ifndef HAVE_FSEEKO
80 :     #define fseeko fseek
81 :     #endif
82 :    
83 :     #ifndef HAVE_FTELLO
84 :     #define ftello ftell
85 :     #endif
86 :    
87 : anton 1.1 #define NULLC '\0'
88 :    
89 : pazsan 1.14 #ifdef MEMCMP_AS_SUBROUTINE
90 :     extern int gforth_memcmp(const char * s1, const char * s2, size_t n);
91 : anton 1.15 #define memcmp(s1,s2,n) gforth_memcmp(s1,s2,n)
92 : pazsan 1.14 #endif
93 :    
94 : anton 1.1 #define NEWLINE '\n'
95 :    
96 : anton 1.26 /* conversion on fetch */
97 :    
98 : anton 1.41 #define vm_Cell2f(_cell,_x) ((_x)=(Bool)(_cell))
99 :     #define vm_Cell2c(_cell,_x) ((_x)=(Char)(_cell))
100 :     #define vm_Cell2n(_cell,_x) ((_x)=(Cell)(_cell))
101 :     #define vm_Cell2w(_cell,_x) ((_x)=(Cell)(_cell))
102 :     #define vm_Cell2u(_cell,_x) ((_x)=(UCell)(_cell))
103 :     #define vm_Cell2a_(_cell,_x) ((_x)=(Cell *)(_cell))
104 :     #define vm_Cell2c_(_cell,_x) ((_x)=(Char *)(_cell))
105 :     #define vm_Cell2f_(_cell,_x) ((_x)=(Float *)(_cell))
106 :     #define vm_Cell2df_(_cell,_x) ((_x)=(DFloat *)(_cell))
107 :     #define vm_Cell2sf_(_cell,_x) ((_x)=(SFloat *)(_cell))
108 :     #define vm_Cell2xt(_cell,_x) ((_x)=(Xt)(_cell))
109 :     #define vm_Cell2f83name(_cell,_x) ((_x)=(struct F83Name *)(_cell))
110 :     #define vm_Cell2longname(_cell,_x) ((_x)=(struct Longname *)(_cell))
111 :     #define vm_Float2r(_float,_x) (_x=_float)
112 : anton 1.26
113 :     /* conversion on store */
114 :    
115 : anton 1.41 #define vm_f2Cell(_x,_cell) ((_cell)=(Cell)(_x))
116 :     #define vm_c2Cell(_x,_cell) ((_cell)=(Cell)(_x))
117 :     #define vm_n2Cell(_x,_cell) ((_cell)=(Cell)(_x))
118 :     #define vm_w2Cell(_x,_cell) ((_cell)=(Cell)(_x))
119 :     #define vm_u2Cell(_x,_cell) ((_cell)=(Cell)(_x))
120 :     #define vm_a_2Cell(_x,_cell) ((_cell)=(Cell)(_x))
121 :     #define vm_c_2Cell(_x,_cell) ((_cell)=(Cell)(_x))
122 :     #define vm_f_2Cell(_x,_cell) ((_cell)=(Cell)(_x))
123 :     #define vm_df_2Cell(_x,_cell) ((_cell)=(Cell)(_x))
124 :     #define vm_sf_2Cell(_x,_cell) ((_cell)=(Cell)(_x))
125 :     #define vm_xt2Cell(_x,_cell) ((_cell)=(Cell)(_x))
126 :     #define vm_f83name2Cell(_x,_cell) ((_cell)=(Cell)(_x))
127 :     #define vm_longname2Cell(_x,_cell) ((_cell)=(Cell)(_x))
128 :     #define vm_r2Float(_x,_float) (_float=_x)
129 : anton 1.26
130 : anton 1.41 #define vm_Cell2Cell(_x,_y) (_y=_x)
131 : anton 1.29
132 : anton 1.46 #ifdef NO_IP
133 :     #define IMM_ARG(access,value) (VARIANT(value))
134 :     #else
135 :     #define IMM_ARG(access,value) (access)
136 :     #endif
137 :    
138 : anton 1.1 /* if machine.h has not defined explicit registers, define them as implicit */
139 :     #ifndef IPREG
140 :     #define IPREG
141 :     #endif
142 :     #ifndef SPREG
143 :     #define SPREG
144 :     #endif
145 :     #ifndef RPREG
146 :     #define RPREG
147 :     #endif
148 :     #ifndef FPREG
149 :     #define FPREG
150 :     #endif
151 :     #ifndef LPREG
152 :     #define LPREG
153 :     #endif
154 :     #ifndef CFAREG
155 :     #define CFAREG
156 :     #endif
157 :     #ifndef UPREG
158 :     #define UPREG
159 :     #endif
160 :     #ifndef TOSREG
161 :     #define TOSREG
162 :     #endif
163 : anton 1.69 #ifndef spbREG
164 :     #define spbREG
165 :     #endif
166 : anton 1.74 #ifndef spcREG
167 :     #define spcREG
168 :     #endif
169 : anton 1.1 #ifndef FTOSREG
170 :     #define FTOSREG
171 :     #endif
172 :    
173 :     #ifndef CPU_DEP1
174 :     # define CPU_DEP1 0
175 :     #endif
176 :    
177 : anton 1.62 /* instructions containing SUPER_END must be the last instruction of a
178 : anton 1.28 super-instruction (e.g., branches, EXECUTE, and other instructions
179 :     ending the basic block). Instructions containing SET_IP get this
180 :     automatically, so you usually don't have to write it. If you have
181 :     to write it, write it after IP points to the next instruction.
182 :     Used for profiling. Don't write it in a word containing SET_IP, or
183 :     the following block will be counted twice. */
184 :     #ifdef VM_PROFILING
185 :     #define SUPER_END vm_count_block(IP)
186 :     #else
187 :     #define SUPER_END
188 :     #endif
189 : anton 1.35 #define SUPER_CONTINUE
190 : anton 1.46
191 : anton 1.66 #ifdef GFORTH_DEBUGGING
192 : anton 1.70 #if DEBUG
193 : pazsan 1.73 #define NAME(string) { saved_ip=ip; asm("# "string); fprintf(stderr,"%08lx depth=%3ld: "string"\n",(Cell)ip,sp0+3-sp);}
194 : anton 1.70 #else /* !DEBUG */
195 : anton 1.66 #define NAME(string) { saved_ip=ip; asm(""); }
196 :     /* the asm here is to avoid reordering of following stuff above the
197 :     assignment; this is an old-style asm (no operands), and therefore
198 :     is treated like "asm volatile ..."; i.e., it prevents most
199 :     reorderings across itself. We want the assignment above first,
200 :     because the stack loads may already cause a stack underflow. */
201 : anton 1.70 #endif /* !DEBUG */
202 : anton 1.66 #elif DEBUG
203 : 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); }
204 : anton 1.66 #else
205 : pazsan 1.73 # define NAME(string) asm("# "string);
206 : anton 1.66 #endif
207 :    
208 : pazsan 1.37 #ifdef DEBUG
209 :     #define CFA_TO_NAME(__cfa) \
210 :     Cell len, i; \
211 :     char * name = __cfa; \
212 :     for(i=0; i<32; i+=sizeof(Cell)) { \
213 :     len = ((Cell*)name)[-1]; \
214 :     if(len < 0) { \
215 :     len &= 0x1F; \
216 :     if((len+sizeof(Cell)) > i) break; \
217 :     } len = 0; \
218 :     name -= sizeof(Cell); \
219 :     }
220 :     #endif
221 : anton 1.30
222 : pazsan 1.63 #ifdef HAS_FFCALL
223 :     #define SAVE_REGS IF_spTOS(sp[0]=spTOS); IF_fpTOS(fp[0]=fpTOS); SP=sp; FP=fp; RP=rp; LP=lp;
224 :     #define REST_REGS sp=SP; fp=FP; rp=RP; lp=LP; IF_spTOS(spTOS=sp[0]); IF_fpTOS(fpTOS=fp[0]);
225 :     #endif
226 :    
227 : anton 1.50 #if !defined(ENGINE)
228 :     /* normal engine */
229 :     #define VARIANT(v) (v)
230 :     #define JUMP(target) goto I_noop
231 : anton 1.78 #define LABEL(name) H_##name: I_##name:
232 : anton 1.50
233 :     #elif ENGINE==2
234 :     /* variant with padding between VM instructions for finding out
235 :     cross-inst jumps (for dynamic code) */
236 :     #define engine engine2
237 :     #define VARIANT(v) (v)
238 :     #define JUMP(target) goto I_noop
239 : anton 1.78 #define LABEL(name) H_##name: SKIP16; I_##name:
240 : anton 1.50 #define IN_ENGINE2
241 :    
242 :     #elif ENGINE==3
243 :     /* variant with different immediate arguments for finding out
244 :     immediate arguments (for native code) */
245 :     #define engine engine3
246 :     #define VARIANT(v) ((v)^0xffffffff)
247 :     #define JUMP(target) goto K_lit
248 : anton 1.78 #define LABEL(name) H_##name: I_##name:
249 : anton 1.50 #else
250 :     #error illegal ENGINE value
251 :     #endif /* ENGINE */
252 :    
253 : anton 1.67 /* the asm(""); is there to get a stop compiled on Itanium */
254 :     #define LABEL2(name) K_##name: asm("");
255 : anton 1.77 #define LABEL3(name) J_##name: asm("");
256 : anton 1.50
257 :     Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
258 : anton 1.1 /* executes code at ip, if ip!=NULL
259 :     returns array of machine code labels (for use in a loader), if ip==NULL
260 :     */
261 :     {
262 : anton 1.10 #ifndef GFORTH_DEBUGGING
263 :     register Cell *rp RPREG;
264 :     #endif
265 : anton 1.46 #ifndef NO_IP
266 :     register Xt *ip IPREG = ip0;
267 :     #endif
268 : anton 1.1 register Cell *sp SPREG = sp0;
269 :     register Float *fp FPREG = fp0;
270 :     register Address lp LPREG = lp0;
271 :     register Xt cfa CFAREG;
272 : anton 1.76 register Label real_ca;
273 : anton 1.11 #ifdef MORE_VARS
274 :     MORE_VARS
275 : pazsan 1.63 #endif
276 :     #ifdef HAS_FFCALL
277 :     av_alist alist;
278 :     extern va_alist clist;
279 :     float frv;
280 :     int irv;
281 :     double drv;
282 :     long long llrv;
283 :     void * prv;
284 : anton 1.11 #endif
285 : anton 1.1 register Address up UPREG = UP;
286 : anton 1.72 IF_spTOS(register Cell MAYBE_UNUSED spTOS TOSREG;)
287 : anton 1.74 register Cell MAYBE_UNUSED spb spbREG;
288 :     register Cell MAYBE_UNUSED spc spcREG;
289 : anton 1.24 IF_fpTOS(register Float fpTOS FTOSREG;)
290 : anton 1.1 #if defined(DOUBLY_INDIRECT)
291 :     static Label *symbols;
292 :     static void *routines[]= {
293 : anton 1.27 #define MAX_SYMBOLS (sizeof(routines)/sizeof(routines[0]))
294 : anton 1.1 #else /* !defined(DOUBLY_INDIRECT) */
295 :     static Label symbols[]= {
296 : anton 1.27 #define MAX_SYMBOLS (sizeof(symbols)/sizeof(symbols[0]))
297 : anton 1.1 #endif /* !defined(DOUBLY_INDIRECT) */
298 : anton 1.55 #define INST_ADDR(name) ((Label)&&I_##name)
299 : anton 1.71 #include PRIM_LAB_I
300 : anton 1.34 #undef INST_ADDR
301 :     (Label)0,
302 : anton 1.55 #define INST_ADDR(name) ((Label)&&K_##name)
303 : anton 1.71 #include PRIM_LAB_I
304 : anton 1.46 #undef INST_ADDR
305 : anton 1.55 #define INST_ADDR(name) ((Label)&&J_##name)
306 : anton 1.71 #include PRIM_LAB_I
307 : anton 1.34 #undef INST_ADDR
308 : anton 1.76 (Label)&&after_last,
309 :     (Label)&&before_goto,
310 : anton 1.78 (Label)&&after_goto,
311 :     /* just mention the H_ labels, so the SKIP16s are not optimized away */
312 :     #define INST_ADDR(name) ((Label)&&H_##name)
313 :     #include PRIM_LAB_I
314 :     #undef INST_ADDR
315 : anton 1.1 };
316 :     #ifdef CPU_DEP2
317 :     CPU_DEP2
318 :     #endif
319 :    
320 : anton 1.10 rp = rp0;
321 : anton 1.1 #ifdef DEBUG
322 :     fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n",
323 : anton 1.46 (unsigned)ip0,(unsigned)sp,(unsigned)rp,
324 : anton 1.1 (unsigned)fp,(unsigned)lp,(unsigned)up);
325 :     #endif
326 :    
327 : anton 1.46 if (ip0 == NULL) {
328 : anton 1.1 #if defined(DOUBLY_INDIRECT)
329 : anton 1.38 #define CODE_OFFSET (26*sizeof(Cell))
330 :     #define XT_OFFSET (22*sizeof(Cell))
331 : anton 1.1 int i;
332 : anton 1.3 Cell code_offset = offset_image? CODE_OFFSET : 0;
333 : anton 1.38 Cell xt_offset = offset_image? XT_OFFSET : 0;
334 : pazsan 1.7
335 : anton 1.3 symbols = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+CODE_OFFSET)+code_offset);
336 : anton 1.38 xts = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+XT_OFFSET)+xt_offset);
337 : anton 1.1 for (i=0; i<DOESJUMP+1; i++)
338 : anton 1.38 xts[i] = symbols[i] = (Label)routines[i];
339 : anton 1.1 for (; routines[i]!=0; i++) {
340 :     if (i>=MAX_SYMBOLS) {
341 : anton 1.60 fprintf(stderr,"gforth-ditc: more than %ld primitives\n",(long)MAX_SYMBOLS);
342 : anton 1.1 exit(1);
343 : anton 1.20 }
344 : anton 1.38 xts[i] = symbols[i] = &routines[i];
345 : anton 1.1 }
346 : anton 1.20 #endif /* defined(DOUBLY_INDIRECT) */
347 :     return symbols;
348 : pazsan 1.7 }
349 : anton 1.1
350 : anton 1.24 IF_spTOS(spTOS = sp[0]);
351 :     IF_fpTOS(fpTOS = fp[0]);
352 : pazsan 1.7 /* prep_terminal(); */
353 : anton 1.46 #ifdef NO_IP
354 :     goto *(*(Label *)ip0);
355 :     #else
356 : anton 1.11 SET_IP(ip);
357 : anton 1.28 SUPER_END; /* count the first block, too */
358 : anton 1.1 NEXT;
359 : anton 1.46 #endif
360 : anton 1.11
361 : anton 1.1 #ifdef CPU_DEP3
362 :     CPU_DEP3
363 : anton 1.46 #endif
364 : anton 1.76
365 : anton 1.78 #include PRIM_I
366 :     after_last: return (Label *)0;
367 :     /*needed only to get the length of the last primitive */
368 :    
369 : anton 1.76 before_goto:
370 :     goto *real_ca;
371 :     after_goto:
372 : anton 1.78 return (Label *)0;
373 : anton 1.50 }
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help