Return to forth.h CVS log

Up to [gforth] / gforth / engine

lit@ and lit+ are now defined as superinstructions
compile lit @ and lit + instead of lit@ and lit+
extended prims2x to support superinstructions with non-C-names
  (syntax: forth-name /c-name = ...)
support profiling of interpreters with superinstructions
  (with simple instructions in the output).
profile output with prefixes only (enable by editing profile.c).
optional reporting of static superinstruction lengths (compared to
  dynamic superinstructions); enable by compiling with -DPRINT_SUPER_LENGTHS

    1: /* common header file
    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: #define _GNU_SOURCE
   23: 
   24: #include "config.h"
   25: #include <stdio.h>
   26: 
   27: #if defined(DOUBLY_INDIRECT)
   28: #  undef DIRECT_THREADED
   29: #  undef INDIRECT_THREADED
   30: #  define INDIRECT_THREADED
   31: #endif
   32: 
   33: #if defined(GFORTH_DEBUGGING)
   34: #  undef USE_TOS
   35: #  undef USE_FTOS
   36: #  define USE_NO_TOS
   37: #  define USE_NO_FTOS
   38: #endif
   39: 
   40: #include <limits.h>
   41: 
   42: #if defined(NeXT)
   43: #  include <libc.h>
   44: #endif /* NeXT */
   45: 
   46: /* symbol indexed constants */
   47: 
   48: #define DOCOL	0
   49: #define DOCON	1
   50: #define DOVAR	2
   51: #define DOUSER	3
   52: #define DODEFER	4
   53: #define DOFIELD	5
   54: #define DODOES	6
   55: #define DOESJUMP	7
   56: 
   57: /* the size of the DOESJUMP, which resides between DOES> and the does-code */
   58: #define DOES_HANDLER_SIZE	(2*sizeof(Cell))
   59: 
   60: #include "machine.h"
   61: 
   62: /* Forth data types */
   63: /* Cell and UCell must be the same size as a pointer */
   64: #define CELL_BITS	(sizeof(Cell) * CHAR_BIT)
   65: #define FLAG(b) (-(b))
   66: #define FILEIO(error)	(FLAG(error) & -37)
   67: #define FILEEXIST(error)	(FLAG(error) & -38)
   68: 
   69: #define F_TRUE (FLAG(0==0))
   70: #define F_FALSE (FLAG(0!=0))
   71: 
   72: #ifdef BUGGY_LONG_LONG
   73: typedef struct {
   74:   Cell hi;
   75:   UCell lo;
   76: } DCell;
   77: 
   78: typedef struct {
   79:   UCell hi;
   80:   UCell lo;
   81: } UDCell;
   82: 
   83: #define LONG2UD(l)	({UDCell _ud; _ud.hi=0; _ud.lo=(Cell)(l); _ud;})
   84: #define UD2LONG(ud)	((long)(ud.lo))
   85: #define DZERO		((DCell){0,0})
   86: 
   87: #else /* ! defined(BUGGY_LONG_LONG) */
   88: 
   89: /* DCell and UDCell must be twice as large as Cell */
   90: typedef DOUBLE_CELL_TYPE DCell;
   91: typedef unsigned DOUBLE_CELL_TYPE UDCell;
   92: 
   93: #define LONG2UD(l)	((UDCell)(l))
   94: #define UD2LONG(ud)	((long)(ud))
   95: #define DZERO		((DCell)0)
   96: 
   97: #endif /* ! defined(BUGGY_LONG_LONG) */
   98: 
   99: typedef union {
  100:   struct {
  101: #if defined(WORDS_BIGENDIAN)||defined(BUGGY_LONG_LONG)
  102:     Cell high;
  103:     UCell low;
  104: #else
  105:     UCell low;
  106:     Cell high;
  107: #endif
  108:   } cells;
  109:   DCell d;
  110:   UDCell ud;
  111: } Double_Store;
  112: 
  113: #define FETCH_DCELL_T(d_,lo,hi,t_)	({ \
  114: 				     Double_Store _d; \
  115: 				     _d.cells.low = (lo); \
  116: 				     _d.cells.high = (hi); \
  117: 				     (d_) = _d.t_; \
  118: 				 })
  119: 
  120: #define STORE_DCELL_T(d_,lo,hi,t_)	({ \
  121: 				     Double_Store _d; \
  122: 				     _d.t_ = (d_); \
  123: 				     (lo) = _d.cells.low; \
  124: 				     (hi) = _d.cells.high; \
  125: 				 })
  126: 
  127: #define vm_twoCell2d(d_,lo,hi)  FETCH_DCELL_T(d_,lo,hi,d)
  128: #define vm_twoCell2ud(d_,lo,hi) FETCH_DCELL_T(d_,lo,hi,ud)
  129: 
  130: #define vm_d2twoCell(d_,lo,hi)  STORE_DCELL_T(d_,lo,hi,d)
  131: #define vm_ud2twoCell(d_,lo,hi) STORE_DCELL_T(d_,lo,hi,ud)
  132: 
  133: typedef Label *Xt;
  134: 
  135: /* PFA gives the parameter field address corresponding to a cfa */
  136: #define PFA(cfa)	(((Cell *)cfa)+2)
  137: /* PFA1 is a special version for use just after a NEXT1 */
  138: #define PFA1(cfa)	PFA(cfa)
  139: /* CODE_ADDRESS is the address of the code jumped to through the code field */
  140: #define CODE_ADDRESS(cfa)	(*(Xt)(cfa))
  141: 
  142: /* DOES_CODE is the Forth code does jumps to */
  143: #if !defined(DOUBLY_INDIRECT)
  144: #  define DOES_CA (symbols[DODOES])
  145: #else /* defined(DOUBLY_INDIRECT) */
  146: #  define DOES_CA ((Label)&xts[DODOES])
  147: #endif /* defined(DOUBLY_INDIRECT) */
  148: 
  149: 
  150: 
  151: #define DOES_CODE(cfa)	({Xt _cfa=(Xt)(cfa); \
  152: 			  (Xt *)(_cfa[0]==DOES_CA ? _cfa[1] : NULL);})
  153: #define DOES_CODE1(cfa)	((Xt *)(cfa[1]))
  154: /* MAKE_CF creates an appropriate code field at the cfa;
  155:    ca is the code address */
  156: #define MAKE_CF(cfa,ca) ((*(Label *)(cfa)) = ((Label)ca))
  157: /* make a code field for a defining-word-defined word */
  158: #define MAKE_DOES_CF(cfa,does_code)  ({MAKE_CF(cfa,DOES_CA);	\
  159: 				       ((Cell *)cfa)[1] = (Cell)(does_code);})
  160: /* the does handler resides between DOES> and the following Forth code */
  161: /* not needed in indirect threaded code */
  162: #if defined(DOUBLY_INDIRECT)
  163: #define MAKE_DOES_HANDLER(addr)	MAKE_CF(addr, ((Label)&symbols[DOESJUMP]))
  164: #else /* !defined(DOUBLY_INDIRECT) */
  165: #define MAKE_DOES_HANDLER(addr)	0
  166: #endif /* !defined(DOUBLY_INDIRECT) */
  167: 
  168: #ifdef DEBUG
  169: #	define	NAME(string)	fprintf(stderr,"%08lx: "string"\n",(Cell)ip);
  170: #else
  171: #	define	NAME(string)
  172: #endif
  173: 
  174: #define CF(const)	(-const-2)
  175: 
  176: #define CF_NIL	-1
  177: 
  178: #ifndef FLUSH_ICACHE
  179: #warning flush-icache probably will not work (see manual)
  180: #	define FLUSH_ICACHE(addr,size)
  181: #endif
  182: 
  183: #ifdef USE_TOS
  184: #define IF_spTOS(x) x
  185: #else
  186: #define IF_spTOS(x)
  187: #define spTOS (sp[0])
  188: #endif
  189: 
  190: #ifdef USE_FTOS
  191: #define IF_fpTOS(x) x
  192: #else
  193: #define IF_fpTOS(x)
  194: #define fpTOS (fp[0])
  195: #endif
  196: 
  197: #define IF_rpTOS(x)
  198: #define rpTOS (rp[0])
  199: 
  200: typedef struct {
  201:   Address base;		/* base address of image (0 if relocatable) */
  202:   UCell checksum;	/* checksum of ca's to protect against some
  203: 			   incompatible	binary/executable combinations
  204: 			   (0 if relocatable) */
  205:   UCell image_size;	/* all sizes in bytes */
  206:   UCell dict_size;
  207:   UCell data_stack_size;
  208:   UCell fp_stack_size;
  209:   UCell return_stack_size;
  210:   UCell locals_stack_size;
  211:   Xt *boot_entry;	/* initial ip for booting (in BOOT) */
  212:   Xt *throw_entry;	/* ip after signal (in THROW) */
  213:   Cell unused1;		/* possibly tib stack size */
  214:   Label *xt_base;         /* base of DOUBLE_INDIRECT xts[], for comp-i.fs */
  215:   Address data_stack_base; /* this and the following fields are initialized by the loader */
  216:   Address fp_stack_base;
  217:   Address return_stack_base;
  218:   Address locals_stack_base;
  219: } ImageHeader;
  220: /* the image-header is created in main.fs */
  221: 
  222: Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp);
  223: Address my_alloc(Cell size);
  224: char *tilde_cstr(Char *from, UCell size, int clear);
  225: 
  226: /* dblsub routines */
  227: DCell dnegate(DCell d1);
  228: UDCell ummul (UCell a, UCell b);
  229: DCell mmul (Cell a, Cell b);
  230: UDCell umdiv (UDCell u, UCell v);
  231: DCell smdiv (DCell num, Cell denom);
  232: DCell fmdiv (DCell num, Cell denom);
  233: 
  234: Cell memcasecmp(const Char *s1, const Char *s2, Cell n);
  235: 
  236: /* peephole routines */
  237: 
  238: Xt *primtable(Label symbols[], Cell size);
  239: Cell prepare_peephole_table(Xt xts[]);
  240: Xt peephole_opt(Xt xt1, Xt xt2, Cell peeptable);
  241: void vm_print_profile(FILE *file);
  242: void vm_count_block(Xt *ip);
  243: 
  244: /* dynamic superinstruction stuff */
  245: Label compile_prim(Label prim);
  246: 
  247: extern int offset_image;
  248: extern int die_on_signal;
  249: extern UCell pagesize;
  250: extern ImageHeader *gforth_header;
  251: extern Label *vm_prims;
  252: extern Label *xts;
  253: extern Cell npriminfos;
  254: 
  255: #ifdef GFORTH_DEBUGGING
  256: extern Xt *ip;
  257: extern Cell *rp;
  258: #endif
  259: 
  260: #ifdef PRINT_SUPER_LENGTHS
  261: Cell prim_length(Cell prim);
  262: void print_super_lengths();
  263: #endif
  264: 
  265: /* declare all the functions that are missing */
  266: #ifndef HAVE_ATANH
  267: extern double atanh(double r1);
  268: extern double asinh(double r1);
  269: extern double acosh(double r1);
  270: #endif
  271: #ifndef HAVE_ECVT
  272: /* extern char* ecvt(double x, int len, int* exp, int* sign);*/
  273: #endif
  274: #ifndef HAVE_MEMMOVE
  275: /* extern char *memmove(char *dest, const char *src, long n); */
  276: #endif
  277: #ifndef HAVE_POW10
  278: extern double pow10(double x);
  279: #endif
  280: #ifndef HAVE_STRERROR
  281: extern char *strerror(int err);
  282: #endif
  283: #ifndef HAVE_STRSIGNAL
  284: extern char *strsignal(int sig);
  285: #endif
  286: #ifndef HAVE_STRTOUL
  287: extern unsigned long int strtoul(const char *nptr, char **endptr, int base);
  288: #endif
  289: 
  290: 
  291: #define GROUP(x)