gforth/engine/engine.c - view

File: [gforth] / gforth / engine / engine.c
Revision 1.46: download - view: text, annotated - select for diffs
Sun Nov 24 13:54:01 2002 UTC (21 years, 5 months ago) by anton
Branches: MAIN
CVS tags: HEAD

new engine gforth-native (works on 386 arch only for now).
  appropriate changes in control-flow instructions in prim
  new primitives SET-NEXT-CODE and CALL2 (not necessary for the other engines)
  new primitives COMPILE-PRIM1 and FINISH-CODE
  prims2x.fs now produces IMMARG(...) macros for initializing immediate args
  prims2x.fs: changes in some of the output-c-tail words (goes with the
     changes in the control-flow words).
  appropriate changes in engine.c
  engine.c: rewrite of check_prims, support for gforth-native (NO_IP)
  threaded.c: support for NO_IP
  various kernel files: started to eliminate return stack manipulations for
    embedding data (e.g. string literals); incomplete.
dynamic superinstructions now use LABEL2 instead of IS_NEXT_JUMP
FORCE_REG has no effect if DOUBLY_INDIRECT (gcc-2.95.1 crashes otherwise;
   it's unclear which change provoked this).

1: /* Gforth virtual machine (aka inner interpreter) 2: 3: Copyright (C) 1995,1996,1997,1998,2000 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 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: Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. 20: */ 21: 22: undefine(`symbols') 23: 24: #include "config.h" 25: #include "forth.h" 26: #include <ctype.h> 27: #include <stdio.h> 28: #include <string.h> 29: #include <math.h> 30: #include <assert.h> 31: #include <stdlib.h> 32: #include <errno.h> 33: #include "io.h" 34: #include "threaded.h" 35: #ifndef STANDALONE 36: #include <sys/types.h> 37: #include <sys/stat.h> 38: #include <fcntl.h> 39: #include <time.h> 40: #include <sys/time.h> 41: #include <unistd.h> 42: #include <pwd.h> 43: #include <dirent.h> 44: #include <sys/resource.h> 45: #ifdef HAVE_FNMATCH_H 46: #include <fnmatch.h> 47: #else 48: #include "fnmatch.h" 49: #endif 50: #else 51: #include "systypes.h" 52: #endif 53: 54: #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) /* what else? */ 55: #include <dlfcn.h> 56: #endif 57: #if defined(_WIN32) 58: #include <windows.h> 59: #endif 60: #ifdef hpux 61: #include <dl.h> 62: #endif 63: 64: #ifndef SEEK_SET 65: /* should be defined in stdio.h, but some systems don't have it */ 66: #define SEEK_SET 0 67: #endif 68: 69: #define IOR(flag) ((flag)? -512-errno : 0) 70: 71: struct F83Name { 72: struct F83Name *next; /* the link field for old hands */ 73: char countetc; 74: char name[0]; 75: }; 76: 77: #define F83NAME_COUNT(np) ((np)->countetc & 0x1f) 78: 79: struct Longname { 80: struct Longname *next; /* the link field for old hands */ 81: Cell countetc; 82: char name[0]; 83: }; 84: 85: #define LONGNAME_COUNT(np) ((np)->countetc & (((~((UCell)0))<<3)>>3)) 86: 87: Cell *SP; 88: Float *FP; 89: Address UP=NULL; 90: 91: #if 0 92: /* not used currently */ 93: int emitcounter; 94: #endif 95: #define NULLC '\0' 96: 97: #ifdef MEMCMP_AS_SUBROUTINE 98: extern int gforth_memcmp(const char * s1, const char * s2, size_t n); 99: #define memcmp(s1,s2,n) gforth_memcmp(s1,s2,n) 100: #endif 101: 102: #ifdef HAS_FILE 103: char *cstr(Char *from, UCell size, int clear) 104: /* return a C-string corresponding to the Forth string ( FROM SIZE ). 105: the C-string lives until the next call of cstr with CLEAR being true */ 106: { 107: static struct cstr_buffer { 108: char *buffer; 109: size_t size; 110: } *buffers=NULL; 111: static int nbuffers=0; 112: static int used=0; 113: struct cstr_buffer *b; 114: 115: if (buffers==NULL) 116: buffers=malloc(0); 117: if (clear) 118: used=0; 119: if (used>=nbuffers) { 120: buffers=realloc(buffers,sizeof(struct cstr_buffer)*(used+1)); 121: buffers[used]=(struct cstr_buffer){malloc(0),0}; 122: nbuffers=used+1; 123: } 124: b=&buffers[used]; 125: if (size+1 > b->size) { 126: b->buffer = realloc(b->buffer,size+1); 127: b->size = size+1; 128: } 129: memcpy(b->buffer,from,size); 130: b->buffer[size]='\0'; 131: used++; 132: return b->buffer; 133: } 134: 135: char *tilde_cstr(Char *from, UCell size, int clear) 136: /* like cstr(), but perform tilde expansion on the string */ 137: { 138: char *s1,*s2; 139: int s1_len, s2_len; 140: struct passwd *getpwnam (), *user_entry; 141: 142: if (size<1 || from[0]!='~') 143: return cstr(from, size, clear); 144: if (size<2 || from[1]=='/') { 145: s1 = (char *)getenv ("HOME"); 146: if(s1 == NULL) 147: s1 = ""; 148: s2 = from+1; 149: s2_len = size-1; 150: } else { 151: UCell i; 152: for (i=1; i<size && from[i]!='/'; i++) 153: ; 154: if (i==2 && from[1]=='+') /* deal with "~+", i.e., the wd */ 155: return cstr(from+3, size<3?0:size-3,clear); 156: { 157: char user[i]; 158: memcpy(user,from+1,i-1); 159: user[i-1]='\0'; 160: user_entry=getpwnam(user); 161: } 162: if (user_entry==NULL) 163: return cstr(from, size, clear); 164: s1 = user_entry->pw_dir; 165: s2 = from+i; 166: s2_len = size-i; 167: } 168: s1_len = strlen(s1); 169: if (s1_len>1 && s1[s1_len-1]=='/') 170: s1_len--; 171: { 172: char path[s1_len+s2_len]; 173: memcpy(path,s1,s1_len); 174: memcpy(path+s1_len,s2,s2_len); 175: return cstr(path,s1_len+s2_len,clear); 176: } 177: } 178: #endif 179: 180: DCell timeval2us(struct timeval *tvp) 181: { 182: #ifndef BUGGY_LONG_LONG 183: return (tvp->tv_sec*(DCell)1000000)+tvp->tv_usec; 184: #else 185: DCell d2; 186: DCell d1=mmul(tvp->tv_sec,1000000); 187: d2.lo = d1.lo+tvp->tv_usec; 188: d2.hi = d1.hi + (d2.lo<d1.lo); 189: return d2; 190: #endif 191: } 192: 193: #define NEWLINE '\n' 194: 195: #ifndef HAVE_RINT 196: #define rint(x) floor((x)+0.5) 197: #endif 198: 199: #ifdef HAS_FILE 200: static char* fileattr[6]={"rb","rb","r+b","r+b","wb","wb"}; 201: static char* pfileattr[6]={"r","r","r+","r+","w","w"}; 202: 203: #ifndef O_BINARY 204: #define O_BINARY 0 205: #endif 206: #ifndef O_TEXT 207: #define O_TEXT 0 208: #endif 209: 210: static int ufileattr[6]= { 211: O_RDONLY|O_BINARY, O_RDONLY|O_BINARY, 212: O_RDWR |O_BINARY, O_RDWR |O_BINARY, 213: O_WRONLY|O_BINARY, O_WRONLY|O_BINARY }; 214: #endif 215: 216: /* conversion on fetch */ 217: 218: #define vm_Cell2f(_cell,_x) ((_x)=(Bool)(_cell)) 219: #define vm_Cell2c(_cell,_x) ((_x)=(Char)(_cell)) 220: #define vm_Cell2n(_cell,_x) ((_x)=(Cell)(_cell)) 221: #define vm_Cell2w(_cell,_x) ((_x)=(Cell)(_cell)) 222: #define vm_Cell2u(_cell,_x) ((_x)=(UCell)(_cell)) 223: #define vm_Cell2a_(_cell,_x) ((_x)=(Cell *)(_cell)) 224: #define vm_Cell2c_(_cell,_x) ((_x)=(Char *)(_cell)) 225: #define vm_Cell2f_(_cell,_x) ((_x)=(Float *)(_cell)) 226: #define vm_Cell2df_(_cell,_x) ((_x)=(DFloat *)(_cell)) 227: #define vm_Cell2sf_(_cell,_x) ((_x)=(SFloat *)(_cell)) 228: #define vm_Cell2xt(_cell,_x) ((_x)=(Xt)(_cell)) 229: #define vm_Cell2f83name(_cell,_x) ((_x)=(struct F83Name *)(_cell)) 230: #define vm_Cell2longname(_cell,_x) ((_x)=(struct Longname *)(_cell)) 231: #define vm_Float2r(_float,_x) (_x=_float) 232: 233: /* conversion on store */ 234: 235: #define vm_f2Cell(_x,_cell) ((_cell)=(Cell)(_x)) 236: #define vm_c2Cell(_x,_cell) ((_cell)=(Cell)(_x)) 237: #define vm_n2Cell(_x,_cell) ((_cell)=(Cell)(_x)) 238: #define vm_w2Cell(_x,_cell) ((_cell)=(Cell)(_x)) 239: #define vm_u2Cell(_x,_cell) ((_cell)=(Cell)(_x)) 240: #define vm_a_2Cell(_x,_cell) ((_cell)=(Cell)(_x)) 241: #define vm_c_2Cell(_x,_cell) ((_cell)=(Cell)(_x)) 242: #define vm_f_2Cell(_x,_cell) ((_cell)=(Cell)(_x)) 243: #define vm_df_2Cell(_x,_cell) ((_cell)=(Cell)(_x)) 244: #define vm_sf_2Cell(_x,_cell) ((_cell)=(Cell)(_x)) 245: #define vm_xt2Cell(_x,_cell) ((_cell)=(Cell)(_x)) 246: #define vm_f83name2Cell(_x,_cell) ((_cell)=(Cell)(_x)) 247: #define vm_longname2Cell(_x,_cell) ((_cell)=(Cell)(_x)) 248: #define vm_r2Float(_x,_float) (_float=_x) 249: 250: #define vm_Cell2Cell(_x,_y) (_y=_x) 251: 252: #ifdef NO_IP 253: #define IMM_ARG(access,value) (VARIANT(value)) 254: #else 255: #define IMM_ARG(access,value) (access) 256: #endif 257: 258: /* if machine.h has not defined explicit registers, define them as implicit */ 259: #ifndef IPREG 260: #define IPREG 261: #endif 262: #ifndef SPREG 263: #define SPREG 264: #endif 265: #ifndef RPREG 266: #define RPREG 267: #endif 268: #ifndef FPREG 269: #define FPREG 270: #endif 271: #ifndef LPREG 272: #define LPREG 273: #endif 274: #ifndef CFAREG 275: #define CFAREG 276: #endif 277: #ifndef UPREG 278: #define UPREG 279: #endif 280: #ifndef TOSREG 281: #define TOSREG 282: #endif 283: #ifndef FTOSREG 284: #define FTOSREG 285: #endif 286: 287: #ifndef CPU_DEP1 288: # define CPU_DEP1 0 289: #endif 290: 291: /* instructions containing these must be the last instruction of a 292: super-instruction (e.g., branches, EXECUTE, and other instructions 293: ending the basic block). Instructions containing SET_IP get this 294: automatically, so you usually don't have to write it. If you have 295: to write it, write it after IP points to the next instruction. 296: Used for profiling. Don't write it in a word containing SET_IP, or 297: the following block will be counted twice. */ 298: #ifdef VM_PROFILING 299: #define SUPER_END vm_count_block(IP) 300: #else 301: #define SUPER_END 302: #endif 303: #define SUPER_CONTINUE 304: 305: #ifdef GFORTH_DEBUGGING 306: /* define some VM registers as global variables, so they survive exceptions; 307: global register variables are not up to the task (according to the 308: GNU C manual) */ 309: Xt *saved_ip; 310: Cell *rp; 311: #endif 312: 313: #ifdef NO_IP 314: static Label next_code; 315: #endif 316: 317: #ifdef DEBUG 318: #define CFA_TO_NAME(__cfa) \ 319: Cell len, i; \ 320: char * name = __cfa; \ 321: for(i=0; i<32; i+=sizeof(Cell)) { \ 322: len = ((Cell*)name)[-1]; \ 323: if(len < 0) { \ 324: len &= 0x1F; \ 325: if((len+sizeof(Cell)) > i) break; \ 326: } len = 0; \ 327: name -= sizeof(Cell); \ 328: } 329: #endif 330: 331: Xt *primtable(Label symbols[], Cell size) 332: /* used in primitive primtable for peephole optimization */ 333: { 334: Xt *xts = (Xt *)malloc(size*sizeof(Xt)); 335: Cell i; 336: 337: for (i=0; i<size; i++) 338: xts[i] = &symbols[i]; 339: return xts; 340: } 341: 342: define(enginerest, 343: `(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0) 344: /* executes code at ip, if ip!=NULL 345: returns array of machine code labels (for use in a loader), if ip==NULL 346: */ 347: { 348: #ifndef GFORTH_DEBUGGING 349: register Cell *rp RPREG; 350: #endif 351: #ifndef NO_IP 352: register Xt *ip IPREG = ip0; 353: #endif 354: register Cell *sp SPREG = sp0; 355: register Float *fp FPREG = fp0; 356: register Address lp LPREG = lp0; 357: register Xt cfa CFAREG; 358: #ifdef MORE_VARS 359: MORE_VARS 360: #endif 361: register Address up UPREG = UP; 362: IF_spTOS(register Cell spTOS TOSREG;) 363: IF_fpTOS(register Float fpTOS FTOSREG;) 364: #if defined(DOUBLY_INDIRECT) 365: static Label *symbols; 366: static void *routines[]= { 367: #define MAX_SYMBOLS (sizeof(routines)/sizeof(routines[0])) 368: #else /* !defined(DOUBLY_INDIRECT) */ 369: static Label symbols[]= { 370: #define MAX_SYMBOLS (sizeof(symbols)/sizeof(symbols[0])) 371: #endif /* !defined(DOUBLY_INDIRECT) */ 372: (Label)&&docol, 373: (Label)&&docon, 374: (Label)&&dovar, 375: (Label)&&douser, 376: (Label)&&dodefer, 377: (Label)&&dofield, 378: (Label)&&dodoes, 379: /* the following entry is normally unused; 380: it is there because its index indicates a does-handler */ 381: CPU_DEP1, 382: #define INST_ADDR(name) (Label)&&I_##name 383: #include "prim_lab.i" 384: #undef INST_ADDR 385: (Label)&&after_last, 386: (Label)0, 387: #define INST_ADDR(name) (Label)&&K_##name 388: #include "prim_lab.i" 389: #undef INST_ADDR 390: #ifdef IN_ENGINE2 391: #define INST_ADDR(name) (Label)&&J_##name 392: #include "prim_lab.i" 393: #undef INST_ADDR 394: #endif 395: }; 396: #ifdef CPU_DEP2 397: CPU_DEP2 398: #endif 399: 400: rp = rp0; 401: #ifdef DEBUG 402: fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n", 403: (unsigned)ip0,(unsigned)sp,(unsigned)rp, 404: (unsigned)fp,(unsigned)lp,(unsigned)up); 405: #endif 406: 407: if (ip0 == NULL) { 408: #if defined(DOUBLY_INDIRECT) 409: #define CODE_OFFSET (26*sizeof(Cell)) 410: #define XT_OFFSET (22*sizeof(Cell)) 411: int i; 412: Cell code_offset = offset_image? CODE_OFFSET : 0; 413: Cell xt_offset = offset_image? XT_OFFSET : 0; 414: 415: symbols = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+CODE_OFFSET)+code_offset); 416: xts = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+XT_OFFSET)+xt_offset); 417: for (i=0; i<DOESJUMP+1; i++) 418: xts[i] = symbols[i] = (Label)routines[i]; 419: for (; routines[i]!=0; i++) { 420: if (i>=MAX_SYMBOLS) { 421: fprintf(stderr,"gforth-ditc: more than %d primitives\n",MAX_SYMBOLS); 422: exit(1); 423: } 424: xts[i] = symbols[i] = &routines[i]; 425: } 426: #endif /* defined(DOUBLY_INDIRECT) */ 427: return symbols; 428: } 429: 430: IF_spTOS(spTOS = sp[0]); 431: IF_fpTOS(fpTOS = fp[0]); 432: /* prep_terminal(); */ 433: #ifdef NO_IP 434: goto *(*(Label *)ip0); 435: #else 436: SET_IP(ip); 437: SUPER_END; /* count the first block, too */ 438: NEXT; 439: #endif 440: 441: #ifdef CPU_DEP3 442: CPU_DEP3 443: #endif 444: 445: docol: 446: { 447: #ifdef NO_IP 448: *--rp = next_code; 449: goto **(Label *)PFA1(cfa); 450: #else 451: #ifdef DEBUG 452: { 453: CFA_TO_NAME(cfa); 454: fprintf(stderr,"%08lx: col: %08lx %.*s\n",(Cell)ip,(Cell)PFA1(cfa), 455: len,name); 456: } 457: #endif 458: #ifdef CISC_NEXT 459: /* this is the simple version */ 460: *--rp = (Cell)ip; 461: SET_IP((Xt *)PFA1(cfa)); 462: SUPER_END; 463: NEXT; 464: #else 465: /* this one is important, so we help the compiler optimizing */ 466: { 467: DEF_CA 468: rp[-1] = (Cell)ip; 469: SET_IP((Xt *)PFA1(cfa)); 470: SUPER_END; 471: NEXT_P1; 472: rp--; 473: NEXT_P2; 474: } 475: #endif 476: #endif 477: } 478: 479: docon: 480: { 481: #ifdef DEBUG 482: fprintf(stderr,"%08lx: con: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa)); 483: #endif 484: #ifdef USE_TOS 485: *sp-- = spTOS; 486: spTOS = *(Cell *)PFA1(cfa); 487: #else 488: *--sp = *(Cell *)PFA1(cfa); 489: #endif 490: } 491: #ifdef NO_IP 492: goto *next_code; 493: #else 494: NEXT_P0; 495: NEXT; 496: #endif 497: 498: dovar: 499: { 500: #ifdef DEBUG 501: fprintf(stderr,"%08lx: var: %08lx\n",(Cell)ip,(Cell)PFA1(cfa)); 502: #endif 503: #ifdef USE_TOS 504: *sp-- = spTOS; 505: spTOS = (Cell)PFA1(cfa); 506: #else 507: *--sp = (Cell)PFA1(cfa); 508: #endif 509: } 510: #ifdef NO_IP 511: goto *next_code; 512: #else 513: NEXT_P0; 514: NEXT; 515: #endif 516: 517: douser: 518: { 519: #ifdef DEBUG 520: fprintf(stderr,"%08lx: user: %08lx\n",(Cell)ip,(Cell)PFA1(cfa)); 521: #endif 522: #ifdef USE_TOS 523: *sp-- = spTOS; 524: spTOS = (Cell)(up+*(Cell*)PFA1(cfa)); 525: #else 526: *--sp = (Cell)(up+*(Cell*)PFA1(cfa)); 527: #endif 528: } 529: #ifdef NO_IP 530: goto *next_code; 531: #else 532: NEXT_P0; 533: NEXT; 534: #endif 535: 536: dodefer: 537: { 538: #ifdef DEBUG 539: fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa)); 540: #endif 541: SUPER_END; 542: EXEC(*(Xt *)PFA1(cfa)); 543: } 544: 545: dofield: 546: { 547: #ifdef DEBUG 548: fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa)); 549: #endif 550: spTOS += *(Cell*)PFA1(cfa); 551: } 552: #ifdef NO_IP 553: goto *next_code; 554: #else 555: NEXT_P0; 556: NEXT; 557: #endif 558: 559: dodoes: 560: /* this assumes the following structure: 561: defining-word: 562: 563: ... 564: DOES> 565: (possible padding) 566: possibly handler: jmp dodoes 567: (possible branch delay slot(s)) 568: Forth code after DOES> 569: 570: defined word: 571: 572: cfa: address of or jump to handler OR 573: address of or jump to dodoes, address of DOES-code 574: pfa: 575: 576: */ 577: #ifdef NO_IP 578: *--rp = next_code; 579: IF_spTOS(spTOS = sp[0]); 580: sp--; 581: spTOS = (Cell)PFA(cfa); 582: goto **(Label *)DOES_CODE1(cfa); 583: #else 584: { 585: /* fprintf(stderr, "Got CFA %08lx at doescode %08lx/%08lx: does: %08lx\n",cfa,(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));*/ 586: #ifdef DEBUG 587: fprintf(stderr,"%08lx/%08lx: does: %08lx\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa)); 588: fflush(stderr); 589: #endif 590: *--rp = (Cell)ip; 591: /* PFA1 might collide with DOES_CODE1 here, so we use PFA */ 592: #ifdef USE_TOS 593: *sp-- = spTOS; 594: spTOS = (Cell)PFA(cfa); 595: #else 596: *--sp = (Cell)PFA(cfa); 597: #endif 598: SET_IP(DOES_CODE1(cfa)); 599: SUPER_END; 600: /* fprintf(stderr,"TOS = %08lx, IP=%08lx\n", spTOS, IP);*/ 601: } 602: NEXT; 603: #endif 604: 605: #ifndef IN_ENGINE2 606: #define LABEL(name) I_##name: 607: #else 608: #define LABEL(name) J_##name: asm(".skip 16"); I_##name: 609: #endif 610: #define LABEL2(name) K_##name: 611: #include "prim.i" 612: #undef LABEL 613: after_last: return (Label *)0; 614: /*needed only to get the length of the last primitive */ 615: }' 616: ) 617: 618: #define VARIANT(v) (v) 619: #define JUMP(target) goto I_noop 620: 621: Label *engine enginerest 622: 623: #ifndef NO_DYNAMIC 624: 625: #ifdef NO_IP 626: #undef VARIANT 627: #define VARIANT(v) ((v)^0xffffffff) 628: #undef JUMP 629: #define JUMP(target) goto K_lit 630: Label *engine3 enginerest 631: #endif 632: 633: #undef VARIANT 634: #define VARIANT(v) (v) 635: #undef JUMP 636: #define JUMP(target) goto I_noop 637: #define IN_ENGINE2 638: Label *engine2 enginerest 639: #endif