--- gforth/engine/forth.h 2002/09/14 08:34:03 1.30 +++ gforth/engine/forth.h 2012/12/31 15:25:19 1.133 @@ -1,12 +1,12 @@ /* common header file - Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc. + Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012 Free Software Foundation, Inc. This file is part of Gforth. Gforth is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License - as published by the Free Software Foundation; either version 2 + as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, @@ -15,14 +15,27 @@ GNU General Public License for more details. You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. + along with this program; if not, see http://www.gnu.org/licenses/. */ -#define _GNU_SOURCE - #include "config.h" +#include "128bit.h" #include +#include +#include +#ifndef STANDALONE +#if defined(HAVE_LIBLTDL) +#include +#endif +#endif + +#if !defined(FORCE_LL) && !defined(BUGGY_LONG_LONG) +#define BUGGY_LONG_LONG +#endif + +#if defined(DOUBLY_INDIRECT)||defined(INDIRECT_THREADED)||defined(VM_PROFILING) +#define NO_DYNAMIC +#endif #if defined(DOUBLY_INDIRECT) # undef DIRECT_THREADED @@ -30,13 +43,47 @@ # define INDIRECT_THREADED #endif -#if defined(GFORTH_DEBUGGING) +#if defined(GFORTH_DEBUGGING) || defined(INDIRECT_THREADED) || defined(DOUBLY_INDIRECT) || defined(VM_PROFILING) # undef USE_TOS # undef USE_FTOS +# undef USE_NO_TOS +# undef USE_NO_FTOS # define USE_NO_TOS # define USE_NO_FTOS + +#define PRIM_I "prim.i" +#define PRIM_LAB_I "prim_lab.i" +#define PRIM_NAMES_I "prim_names.i" +#define PRIM_SUPEREND_I "prim_superend.i" +#define PRIM_NUM_I "prim_num.i" +#define PRIM_GRP_I "prim_grp.i" +#define COSTS_I "costs.i" +#define SUPER2_I "super2.i" +/* #define PROFILE_I "profile.i" */ + +#else +/* gforth-fast or gforth-native */ +# undef USE_TOS +# undef USE_FTOS +# undef USE_NO_TOS +# undef USE_NO_FTOS +# define USE_TOS + +#define PRIM_I "prim-fast.i" +#define PRIM_LAB_I "prim_lab-fast.i" +#define PRIM_NAMES_I "prim_names-fast.i" +#define PRIM_SUPEREND_I "prim_superend-fast.i" +#define PRIM_NUM_I "prim_num-fast.i" +#define PRIM_GRP_I "prim_grp-fast.i" +#define COSTS_I "costs-fast.i" +#define SUPER2_I "super2-fast.i" +/* profile.c uses profile.i but does not define VM_PROFILING */ +/* #define PROFILE_I "profile-fast.i" */ + #endif + + #include #if defined(NeXT) @@ -51,17 +98,35 @@ #define DOUSER 3 #define DODEFER 4 #define DOFIELD 5 -#define DODOES 6 -#define DOESJUMP 7 - -/* the size of the DOESJUMP, which resides between DOES> and the does-code */ -#define DOES_HANDLER_SIZE (2*sizeof(Cell)) +#define DOVAL 6 +#define DODOES 7 +#define DOABICODE 8 +#define DOSEMIABICODE 9 +#define DOER_MAX 9 #include "machine.h" +/* C interface data types */ + +typedef WYDE_TYPE Wyde; +typedef TETRABYTE_TYPE Tetrabyte; +typedef OCTABYTE_TYPE Octabyte; +typedef unsigned WYDE_TYPE UWyde; +typedef unsigned TETRABYTE_TYPE UTetrabyte; +typedef unsigned OCTABYTE_TYPE UOctabyte; + /* Forth data types */ /* Cell and UCell must be the same size as a pointer */ #define CELL_BITS (sizeof(Cell) * CHAR_BIT) +#define CELL_MIN (((Cell)1)<<(sizeof(Cell)*CHAR_BIT-1)) + +#define HALFCELL_BITS (CELL_BITS/2) +#define HALFCELL_MASK ((~(UCell)0)>>HALFCELL_BITS) +#define UH(x) (((UCell)(x))>>HALFCELL_BITS) +#define LH(x) ((x)&HALFCELL_MASK) +#define L2U(x) (((UCell)(x))<>(CELL_BITS-1)) + #define FLAG(b) (-(b)) #define FILEIO(error) (FLAG(error) & -37) #define FILEEXIST(error) (FLAG(error) & -38) @@ -69,7 +134,24 @@ #define F_TRUE (FLAG(0==0)) #define F_FALSE (FLAG(0!=0)) -#ifdef BUGGY_LONG_LONG +/* define this false if you want native division */ +#ifdef FORCE_CDIV +#define FLOORED_DIV 0 +#else +#define FLOORED_DIV ((1%-3)>0) +#endif + +#if defined(BUGGY_LONG_LONG) + +#define BUGGY_LL_CMP /* compares not possible */ +#define BUGGY_LL_MUL /* multiplication not possible */ +#define BUGGY_LL_DIV /* division not possible */ +#define BUGGY_LL_ADD /* addition not possible */ +#define BUGGY_LL_SHIFT /* shift not possible */ +#define BUGGY_LL_D2F /* to float not possible */ +#define BUGGY_LL_F2D /* from float not possible */ +#define BUGGY_LL_SIZE /* long long "too short", so we use something else */ + typedef struct { Cell hi; UCell lo; @@ -80,21 +162,55 @@ typedef struct { UCell lo; } UDCell; -#define LONG2UD(l) ({UDCell _ud; _ud.hi=0; _ud.lo=(Cell)(l); _ud;}) -#define UD2LONG(ud) ((long)(ud.lo)) +#define DHI(x) (x).hi +#define DLO(x) (x).lo +#define DHI_IS(x,y) (x).hi=(y) +#define DLO_IS(x,y) (x).lo=(y) + +#define UD2D(ud) ({UDCell _ud=(ud); (DCell){_ud.hi,_ud.lo};}) +#define D2UD(d) ({DCell _d1=(d); (UDCell){_d1.hi,_d1.lo};}) + +/* shifts by less than CELL_BITS */ +#define DLSHIFT(d,u) ({DCell _d=(d); UCell _u=(u); \ + ((_u==0) ? \ + _d : \ + (DCell){(_d.hi<<_u)|(_d.lo>>(CELL_BITS-_u)), \ + _d.lo<<_u});}) + +#define UDLSHIFT(ud,u) D2UD(DLSHIFT(UD2D(ud),u)) + +#if SMALL_OFF_T +#define OFF2UD(o) ({UDCell _ud; _ud.hi=0; _ud.lo=(Cell)(o); _ud;}) +#define UD2OFF(ud) ((ud).lo) +#else /* !SMALL_OFF_T */ +#define OFF2UD(o) ({UDCell _ud; off_t _o=(o); _ud.hi=_o>>CELL_BITS; _ud.lo=(Cell)_o; _ud;}) +#define UD2OFF(ud) ({UDCell _ud=(ud); (((off_t)_ud.hi)< and the following Forth code */ -/* not needed in indirect threaded code */ -#if defined(DOUBLY_INDIRECT) -#define MAKE_DOES_HANDLER(addr) MAKE_CF(addr, ((Label)&symbols[DOESJUMP])) -#else /* !defined(DOUBLY_INDIRECT) */ -#define MAKE_DOES_HANDLER(addr) 0 -#endif /* !defined(DOUBLY_INDIRECT) */ - -#ifdef GFORTH_DEBUGGING -#define NAME(string) { saved_ip=ip; asm(""); } -/* the asm here is to avoid reordering of following stuff above the - assignment; this is an old-style asm (no operands), and therefore - is treated like "asm volatile ..."; i.e., it prevents most - reorderings across itself. We want the assignment above first, - because the stack loads may already cause a stack underflow. */ -#elif DEBUG -# define NAME(string) fprintf(stderr,"%08lx: "string"\n",(Cell)ip); -#else -# define NAME(string) -#endif #define CF(const) (-const-2) @@ -185,13 +277,19 @@ typedef Label *Xt; #ifndef FLUSH_ICACHE #warning flush-icache probably will not work (see manual) # define FLUSH_ICACHE(addr,size) +#warning no FLUSH_ICACHE, turning off dynamic native code by default +#undef NO_DYNAMIC_DEFAULT +#define NO_DYNAMIC_DEFAULT 1 +#endif + +#ifndef CHECK_PRIM +#define CHECK_PRIM(start,len) 0 #endif -#ifdef USE_TOS -#define IF_spTOS(x) x +#if defined(GFORTH_DEBUGGING) || defined(INDIRECT_THREADED) || defined(DOUBLY_INDIRECT) || defined(VM_PROFILING) +#define STACK_CACHE_DEFAULT 0 #else -#define IF_spTOS(x) -#define spTOS (sp[0]) +#define STACK_CACHE_DEFAULT STACK_CACHE_DEFAULT_FAST #endif #ifdef USE_FTOS @@ -205,6 +303,17 @@ typedef Label *Xt; #define rpTOS (rp[0]) typedef struct { + Cell next_task; + Cell prev_task; + Cell save_task; + Cell* sp0; + Cell* rp0; + Float* fp0; + Address lp0; + Xt *throw_entry; +} user_area; + +typedef struct { Address base; /* base address of image (0 if relocatable) */ UCell checksum; /* checksum of ca's to protect against some incompatible binary/executable combinations @@ -217,18 +326,138 @@ typedef struct { UCell locals_stack_size; Xt *boot_entry; /* initial ip for booting (in BOOT) */ Xt *throw_entry; /* ip after signal (in THROW) */ - Cell unused1; /* possibly tib stack size */ + Xt *quit_entry; + Xt *execute_entry; + Xt *find_entry; Label *xt_base; /* base of DOUBLE_INDIRECT xts[], for comp-i.fs */ - Address data_stack_base; /* this and the following fields are initialized by the loader */ - Address fp_stack_base; - Address return_stack_base; - Address locals_stack_base; } ImageHeader; /* the image-header is created in main.fs */ -Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp); -Address my_alloc(Cell size); -char *tilde_cstr(Char *from, UCell size, int clear); +#ifdef HAS_F83HEADERSTRING +struct F83Name { + struct F83Name *next; /* the link field for old hands */ + char countetc; + char name[0]; +}; + +#define F83NAME_COUNT(np) ((np)->countetc & 0x1f) +#endif +struct Longname { + struct Longname *next; /* the link field for old hands */ + Cell countetc; + char name[0]; +}; + +#define LONGNAME_COUNT(np) ((np)->countetc & (((~((UCell)0))<<4)>>4)) + +struct Cellpair { + Cell n1; + Cell n2; +}; + +struct Cellquad { + Cell n1; + Cell n2; + Cell n3; + Cell n4; +}; + +#define IOR(flag) ((flag)? -512-errno : 0) + +#ifdef GFORTH_DEBUGGING +#if defined(GLOBALS_NONRELOC) +/* if globals cause non-relocatable primitives, keep saved_ip and rp + in a structure and access it through locals */ +typedef struct saved_regs { + Xt *sr_saved_ip; + Cell *sr_rp; +} saved_regs; +extern saved_regs saved_regs_v; +extern PER_THREAD saved_regs *saved_regs_p; +#define saved_ip (saved_regs_p->sr_saved_ip) +#define rp (saved_regs_p->sr_rp) +/* for use in gforth_engine header */ +#error sr_proto not passed in fflib.fs callbacks (solution: disable GLOBALS_NONRELOC) +#define sr_proto , struct saved_regs *saved_regs_p0 +#define sr_call , saved_regs_p +#else /* !defined(GLOBALS_NONRELOC) */ +extern PER_THREAD Xt *saved_ip; +extern PER_THREAD Cell *rp; +#define sr_proto +#define sr_call +#endif /* !defined(GLOBALS_NONRELOC) */ +#else /* !defined(GFORTH_DEBUGGING) */ +#define sr_proto +#define sr_call +#endif /* !defined(GFORTH_DEBUGGING) */ + +Label *gforth_engine(Xt *ip sr_proto); +Label *gforth_engine2(Xt *ip sr_proto); +Label *gforth_engine3(Xt *ip sr_proto); + + +int gforth_main(int argc, char **argv, char **env); +void gforth_args(int argc, char ** argv, char ** path, char ** imagename); +Address gforth_loader(char* imagename, char* path); +user_area* gforth_stacks(Cell dsize, Cell rsize, Cell fsize, Cell lsize); +void gforth_free_stacks(user_area* t); +void gforth_free(); +Cell gforth_go(Xt* ip0); +int gforth_boot(int argc, char** argv, char* path); +int gforth_start(int argc, char ** argv); +int gforth_quit(); +Xt gforth_find(Char * name); +int gforth_execute(Xt xt); +void gforth_cleanup(); +void gforth_printmetrics(); +#if defined(DOUBLY_INDIRECT) +int gforth_make_image(int debugflag); +#endif + +/* for ABI-CODE and ;ABI-CODE */ +typedef Cell *abifunc(Cell *sp, Float **fpp); +typedef Cell *semiabifunc(Cell *sp, Float **fpp, Address body); + +/* engine/prim support routines */ +Address gforth_alloc(Cell size); +char *cstr(Char *from, UCell size); +char *tilde_cstr(Char *from, UCell size); +Cell opencreate_file(char *s, Cell wfam, int flags, Cell *wiorp); +DCell timeval2us(struct timeval *tvp); +DCell timespec2ns(struct timespec *tvp); +void cmove(Char *c_from, Char *c_to, UCell u); +void cmove_up(Char *c_from, Char *c_to, UCell u); +Cell compare(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2); +struct Longname *listlfind(Char *c_addr, UCell u, struct Longname *longname1); +struct Longname *hashlfind(Char *c_addr, UCell u, Cell *a_addr); +struct Longname *tablelfind(Char *c_addr, UCell u, Cell *a_addr); +UCell hashkey1(Char *c_addr, UCell u, UCell ubits); +struct Cellpair parse_white(Char *c_addr1, UCell u1); +Cell rename_file(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2); +struct Cellquad read_line(Char *c_addr, UCell u1, FILE *wfileid); +struct Cellpair file_status(Char *c_addr, UCell u); +Cell to_float(Char *c_addr, UCell u, Float *r_p, Char dot); +Float v_star(Float *f_addr1, Cell nstride1, Float *f_addr2, Cell nstride2, UCell ucount); +void faxpy(Float ra, Float *f_x, Cell nstridex, Float *f_y, Cell nstridey, UCell ucount); +UCell lshift(UCell u1, UCell n); +UCell rshift(UCell u1, UCell n); +int gforth_system(Char *c_addr, UCell u); +void gforth_ms(UCell u); +UCell gforth_dlopen(Char *c_addr, UCell u); +Cell capscompare(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2); +int gf_ungetc(int c, FILE *stream); +void gf_regetc(FILE *stream); +int gf_ungottenc(FILE *stream); + +/* signal handler stuff */ +void install_signal_handlers(void); +void throw(int code); +/* throw codes */ +#define BALL_DIVZERO -10 +#define BALL_RESULTRANGE -11 + +typedef void Sigfunc(int); +Sigfunc *bsd_signal(int signo, Sigfunc *func); /* dblsub routines */ DCell dnegate(DCell d1); @@ -240,28 +469,50 @@ DCell fmdiv (DCell num, Cell denom); Cell memcasecmp(const Char *s1, const Char *s2, Cell n); -/* peephole routines */ - -Xt *primtable(Label symbols[], Cell size); -Cell prepare_peephole_table(Xt xts[]); -Xt peephole_opt(Xt xt1, Xt xt2, Cell peeptable); void vm_print_profile(FILE *file); void vm_count_block(Xt *ip); /* dynamic superinstruction stuff */ -Label compile_prim(Label prim); +void compile_prim1(Cell *start); +void finish_code(void); +int forget_dyncode(Address code); +Label decompile_code(Label prim); extern int offset_image; extern int die_on_signal; +extern int ignore_async_signals; extern UCell pagesize; extern ImageHeader *gforth_header; extern Label *vm_prims; extern Label *xts; extern Cell npriminfos; -#ifdef GFORTH_DEBUGGING -extern Xt *saved_ip; -extern Cell *rp; +#ifdef HAS_DEBUG +extern int debug; +#else +# define debug 0 +#endif + +extern PER_THREAD Cell *gforth_SP; +extern PER_THREAD Cell *gforth_RP; +extern PER_THREAD Address gforth_LP; +extern PER_THREAD Float *gforth_FP; +extern PER_THREAD user_area* gforth_UP; + +extern void * gforth_pointers(Cell n); + +#ifdef HAS_FFCALL +extern void gforth_callback(Xt* fcall, void * alist); +#endif + +#ifdef NO_IP +extern Label next_code; +#endif + +#ifdef HAS_FILE +extern char* fileattr[6]; +extern char* pfileattr[6]; +extern int ufileattr[6]; #endif #ifdef PRINT_SUPER_LENGTHS @@ -294,5 +545,40 @@ extern char *strsignal(int sig); extern unsigned long int strtoul(const char *nptr, char **endptr, int base); #endif +#define GROUP(x, n) +#define GROUPADD(n) -#define GROUP(x) +#ifdef HAVE_ENDIAN_H +#include +#else +#define BSWAP16(x) ((((x) >> 8) & 0xff | (((x) & 0xff) << 8))) +#define BSWAP32(x) ((BSWAP16((x) >> 16) | (BSWAP16(x) << 16))) +#define BSWAP64(x) ((BSWAP32((x) >> 32) | (BSWAP32(x) << 32))) +#ifdef WORDS_BIGENDIAN +#define htobe16(x) (x) +#define htobe32(x) (x) +#define htobe64(x) (x) +#define be16toh(x) (x) +#define be32toh(x) (x) +#define be64toh(x) (x) +#define htole16(x) BSWAP16(x) +#define htole32(x) BSWAP32(x) +#define htole64(x) BSWAP64(x) +#define le16toh(x) BSWAP16(x) +#define le32toh(x) BSWAP32(x) +#define le64toh(x) BSWAP64(x) +#else +#define htobe16(x) BSWAP16(x) +#define htobe32(x) BSWAP32(x) +#define htobe64(x) BSWAP64(x) +#define be16toh(x) BSWAP16(x) +#define be32toh(x) BSWAP32(x) +#define be64toh(x) BSWAP64(x) +#define htole16(x) (x) +#define htole32(x) (x) +#define htole64(x) (x) +#define le16toh(x) (x) +#define le32toh(x) (x) +#define le64toh(x) (x) +#endif +#endif