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