Annotation of gforth/engine.c, revision 1.24
1.1 anton 1: /*
2: Copyright 1992 by the ANSI figForth Development Group
3: */
4:
5: #include <ctype.h>
6: #include <stdio.h>
7: #include <string.h>
8: #include <math.h>
9: #include <sys/types.h>
10: #include <sys/stat.h>
11: #include <fcntl.h>
12: #include <assert.h>
13: #include <stdlib.h>
1.2 pazsan 14: #include <time.h>
1.6 pazsan 15: #include <sys/time.h>
1.22 anton 16: #include <unistd.h>
1.1 anton 17: #include "forth.h"
18: #include "io.h"
19:
1.20 anton 20: #ifndef SEEK_SET
21: /* should be defined in stdio.h, but some systems don't have it */
22: #define SEEK_SET 0
23: #endif
24:
1.1 anton 25: typedef union {
26: struct {
1.20 anton 27: #ifdef WORDS_BIGENDIAN
1.1 anton 28: Cell high;
29: Cell low;
30: #else
31: Cell low;
32: Cell high;
33: #endif;
34: } cells;
35: DCell dcell;
36: } Double_Store;
37:
38: typedef struct F83Name {
39: struct F83Name *next; /* the link field for old hands */
40: char countetc;
41: Char name[0];
42: } F83Name;
43:
44: /* are macros for setting necessary? */
45: #define F83NAME_COUNT(np) ((np)->countetc & 0x1f)
46: #define F83NAME_SMUDGE(np) (((np)->countetc & 0x40) != 0)
47: #define F83NAME_IMMEDIATE(np) (((np)->countetc & 0x20) != 0)
48:
1.23 anton 49: /* !!someone should organize this ifdef chaos */
50: #if defined(LONG_LATENCY)
51: #if defined(AUTO_INCREMENT)
52: #define NEXT_P0 (cfa=*ip++)
53: #define IP (ip-1)
54: #else /* AUTO_INCREMENT */
55: #define NEXT_P0 (cfa=*ip)
56: #define IP ip
57: #endif /* AUTO_INCREMENT */
58: #define NEXT_INST (cfa)
59: #define INC_IP(const_inc) ({cfa=IP[const_inc]; ip+=(const_inc);})
60: #else /* LONG_LATENCY */
1.14 anton 61: /* NEXT and NEXT1 are split into several parts to help scheduling,
62: unless CISC_NEXT is defined */
1.23 anton 63: #define NEXT_P0
64: /* in order for execute to work correctly, NEXT_P0 (or other early
65: fetches) should not update the ip (or should we put
66: compensation-code into execute? */
67: #define NEXT_INST (*ip)
68: /* the next instruction (or what is in its place, e.g., an immediate
69: argument */
70: #define INC_IP(const_inc) (ip+=(const_inc))
71: /* increment the ip by const_inc and perform NEXT_P0 (or prefetching) again */
72: #define IP ip
73: /* the pointer to the next instruction (i.e., NEXT_INST could be
74: defined as *IP) */
75: #endif /* LONG_LATENCY */
76:
77: #if defined(CISC_NEXT) && !defined(LONG_LATENCY)
1.14 anton 78: #define NEXT1_P1
79: #define NEXT_P1
80: #define DEF_CA
1.1 anton 81: #ifdef DIRECT_THREADED
1.14 anton 82: #define NEXT1_P2 ({goto *cfa;})
1.1 anton 83: #else
1.14 anton 84: #define NEXT1_P2 ({goto **cfa;})
85: #endif /* DIRECT_THREADED */
86: #define NEXT_P2 ({cfa = *ip++; NEXT1_P2;})
1.23 anton 87: #else /* defined(CISC_NEXT) && !defined(LONG_LATENCY) */
1.14 anton 88: #ifdef DIRECT_THREADED
89: #define NEXT1_P1
90: #define NEXT1_P2 ({goto *cfa;})
91: #define DEF_CA
92: #else /* DIRECT_THREADED */
93: #define NEXT1_P1 ({ca = *cfa;})
94: #define NEXT1_P2 ({goto *ca;})
95: #define DEF_CA Label ca;
96: #endif /* DIRECT_THREADED */
1.23 anton 97: #if defined(LONG_LATENCY)
98: #if defined(AUTO_INCREMENT)
99: #define NEXT_P1 NEXT1_P1
100: #else /* AUTO_INCREMENT */
101: #define NEXT_P1 ({ip++; NEXT1_P1;})
102: #endif /* AUTO_INCREMENT */
103: #else /* LONG_LATENCY */
1.14 anton 104: #define NEXT_P1 ({cfa=*ip++; NEXT1_P1;})
1.23 anton 105: #endif /* LONG_LATENCY */
1.14 anton 106: #define NEXT_P2 NEXT1_P2
1.23 anton 107: #endif /* defined(CISC_NEXT) && !defined(LONG_LATENCY) */
1.1 anton 108:
1.14 anton 109: #define NEXT1 ({DEF_CA NEXT1_P1; NEXT1_P2;})
110: #define NEXT ({DEF_CA NEXT_P1; NEXT_P2;})
1.1 anton 111:
112: #ifdef USE_TOS
113: #define IF_TOS(x) x
114: #else
115: #define IF_TOS(x)
116: #define TOS (sp[0])
117: #endif
118:
119: #ifdef USE_FTOS
120: #define IF_FTOS(x) x
121: #else
122: #define IF_FTOS(x)
123: #define FTOS (fp[0])
124: #endif
125:
126: int emitcounter;
127: #define NULLC '\0'
128:
1.14 anton 129: char *cstr(Char *from, UCell size, int clear)
130: /* if clear is true, scratch can be reused, otherwise we want more of
131: the same */
132: {
133: static char *scratch=NULL;
134: static unsigned scratchsize=0;
135: static char *nextscratch;
136: char *oldnextscratch;
137:
138: if (clear)
139: nextscratch=scratch;
140: if (scratch==NULL) {
141: scratch=malloc(size+1);
142: nextscratch=scratch;
143: scratchsize=size;
144: }
145: else if (nextscratch+size>scratch+scratchsize) {
146: char *oldscratch=scratch;
147: scratch = realloc(scratch, (nextscratch-scratch)+size+1);
148: nextscratch=scratch+(nextscratch-oldscratch);
149: scratchsize=size;
150: }
151: memcpy(nextscratch,from,size);
152: nextscratch[size]='\0';
153: oldnextscratch = nextscratch;
154: nextscratch += size+1;
155: return oldnextscratch;
156: }
1.13 pazsan 157:
1.1 anton 158: #define NEWLINE '\n'
159:
1.21 pazsan 160: #ifndef HAVE_RINT
161: #define rint(x) floor((x)+0.5)
162: #endif
1.13 pazsan 163:
1.1 anton 164: static char* fileattr[6]={"r","rb","r+","r+b","w+","w+b"};
1.6 pazsan 165:
1.11 pazsan 166: static Address up0=NULL;
167:
1.15 anton 168: /* if machine.h has not defined explicit registers, define them as implicit */
169: #ifndef IPREG
170: #define IPREG
171: #endif
172: #ifndef SPREG
173: #define SPREG
174: #endif
175: #ifndef RPREG
176: #define RPREG
177: #endif
178: #ifndef FPREG
179: #define FPREG
180: #endif
181: #ifndef LPREG
182: #define LPREG
183: #endif
184: #ifndef CFAREG
185: #define CFAREG
186: #endif
187: #ifndef UPREG
188: #define UPREG
189: #endif
190: #ifndef TOSREG
191: #define TOSREG
192: #endif
193: #ifndef FTOSREG
194: #define FTOSREG
195: #endif
1.13 pazsan 196:
1.15 anton 197: Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
1.1 anton 198: /* executes code at ip, if ip!=NULL
199: returns array of machine code labels (for use in a loader), if ip==NULL
200: */
1.15 anton 201: {
202: register Xt *ip IPREG = ip0;
203: register Cell *sp SPREG = sp0;
204: register Cell *rp RPREG = rp0;
205: register Float *fp FPREG = fp0;
206: register Address lp LPREG = lp0;
207: register Xt cfa CFAREG;
208: register Address up UPREG = up0;
209: IF_TOS(register Cell TOS TOSREG;)
210: IF_FTOS(register Float FTOS FTOSREG;)
1.1 anton 211: static Label symbols[]= {
212: &&docol,
213: &&docon,
214: &&dovar,
1.4 pazsan 215: &&douser,
1.12 anton 216: &&dodefer,
1.24 ! pazsan 217: &&dostruc,
1.1 anton 218: &&dodoes,
1.6 pazsan 219: &&dodoes, /* dummy for does handler address */
1.1 anton 220: #include "prim_labels.i"
221: };
222: #ifdef CPU_DEP
223: CPU_DEP;
224: #endif
225:
1.16 pazsan 226: #ifdef DEBUG
227: fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n",
1.19 anton 228: (unsigned)ip,(unsigned)sp,(unsigned)rp,
229: (unsigned)fp,(unsigned)lp,(unsigned)up);
1.16 pazsan 230: #endif
231:
1.1 anton 232: if (ip == NULL)
233: return symbols;
1.10 anton 234:
1.1 anton 235: IF_TOS(TOS = sp[0]);
236: IF_FTOS(FTOS = fp[0]);
237: prep_terminal();
1.23 anton 238: NEXT_P0;
1.1 anton 239: NEXT;
240:
241: docol:
242: #ifdef DEBUG
1.16 pazsan 243: fprintf(stderr,"%08x: col: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
1.1 anton 244: #endif
1.15 anton 245: #ifdef CISC_NEXT
1.1 anton 246: /* this is the simple version */
247: *--rp = (Cell)ip;
248: ip = (Xt *)PFA1(cfa);
1.23 anton 249: NEXT_P0;
1.1 anton 250: NEXT;
1.15 anton 251: #else
1.1 anton 252: /* this one is important, so we help the compiler optimizing
253: The following version may be better (for scheduling), but probably has
254: problems with code fields employing calls and delay slots
255: */
256: {
1.4 pazsan 257: DEF_CA
1.1 anton 258: Xt *current_ip = (Xt *)PFA1(cfa);
259: cfa = *current_ip;
260: NEXT1_P1;
261: *--rp = (Cell)ip;
262: ip = current_ip+1;
1.3 pazsan 263: NEXT1_P2;
1.1 anton 264: }
1.15 anton 265: #endif
1.23 anton 266:
1.1 anton 267: docon:
268: #ifdef DEBUG
1.16 pazsan 269: fprintf(stderr,"%08x: con: %08x\n",(Cell)ip,*(Cell*)PFA1(cfa));
1.1 anton 270: #endif
271: #ifdef USE_TOS
272: *sp-- = TOS;
273: TOS = *(Cell *)PFA1(cfa);
274: #else
275: *--sp = *(Cell *)PFA1(cfa);
276: #endif
1.23 anton 277: NEXT_P0;
1.1 anton 278: NEXT;
279:
280: dovar:
281: #ifdef DEBUG
1.16 pazsan 282: fprintf(stderr,"%08x: var: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
1.1 anton 283: #endif
284: #ifdef USE_TOS
285: *sp-- = TOS;
286: TOS = (Cell)PFA1(cfa);
287: #else
288: *--sp = (Cell)PFA1(cfa);
289: #endif
1.23 anton 290: NEXT_P0;
1.1 anton 291: NEXT;
292:
1.4 pazsan 293: douser:
294: #ifdef DEBUG
1.16 pazsan 295: fprintf(stderr,"%08x: user: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
1.4 pazsan 296: #endif
297: #ifdef USE_TOS
298: *sp-- = TOS;
1.5 anton 299: TOS = (Cell)(up+*(Cell*)PFA1(cfa));
1.4 pazsan 300: #else
1.5 anton 301: *--sp = (Cell)(up+*(Cell*)PFA1(cfa));
1.4 pazsan 302: #endif
1.23 anton 303: NEXT_P0;
1.4 pazsan 304: NEXT;
305:
1.12 anton 306: dodefer:
307: #ifdef DEBUG
1.16 pazsan 308: fprintf(stderr,"%08x: defer: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
1.12 anton 309: #endif
310: cfa = *(Xt *)PFA1(cfa);
311: NEXT1;
1.24 ! pazsan 312:
! 313: dostruc:
! 314: #ifdef DEBUG
! 315: fprintf(stderr,"%08x: struc: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
! 316: #endif
! 317: TOS += *(Cell*)PFA1(cfa);
! 318: NEXT_P0;
! 319: NEXT;
1.12 anton 320:
1.1 anton 321: dodoes:
322: /* this assumes the following structure:
323: defining-word:
324:
325: ...
326: DOES>
327: (possible padding)
328: possibly handler: jmp dodoes
329: (possible branch delay slot(s))
330: Forth code after DOES>
331:
332: defined word:
333:
334: cfa: address of or jump to handler OR
335: address of or jump to dodoes, address of DOES-code
336: pfa:
337:
338: */
339: #ifdef DEBUG
1.17 anton 340: fprintf(stderr,"%08x/%08x: does: %08x\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));
1.16 pazsan 341: fflush(stderr);
1.1 anton 342: #endif
343: *--rp = (Cell)ip;
344: /* PFA1 might collide with DOES_CODE1 here, so we use PFA */
1.13 pazsan 345: ip = DOES_CODE1(cfa);
1.1 anton 346: #ifdef USE_TOS
347: *sp-- = TOS;
348: TOS = (Cell)PFA(cfa);
349: #else
350: *--sp = (Cell)PFA(cfa);
351: #endif
1.23 anton 352: NEXT_P0;
1.1 anton 353: NEXT;
1.16 pazsan 354:
1.1 anton 355: #include "primitives.i"
356: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to engine.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth