--- gforth/engine/forth.h 2003/03/09 15:17:03 1.51 +++ 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,2003 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,23 @@ 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/. */ #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 @@ -34,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) @@ -55,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) @@ -73,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; @@ -84,6 +162,23 @@ typedef struct { UCell lo; } UDCell; +#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) @@ -93,17 +188,29 @@ typedef struct { #endif /* !SMALL_OFF_T */ #define DZERO ((DCell){0,0}) -#else /* ! defined(BUGGY_LONG_LONG) */ +#else /* !defined(BUGGY_LONG_LONG) */ /* DCell and UDCell must be twice as large as Cell */ typedef DOUBLE_CELL_TYPE DCell; -typedef unsigned DOUBLE_CELL_TYPE UDCell; +typedef DOUBLE_UCELL_TYPE UDCell; + +#define DHI(x) ({ Double_Store _d; _d.d=(x); _d.cells.high; }) +#define DLO(x) ({ Double_Store _d; _d.d=(x); _d.cells.low; }) + +/* beware with the assignment: x is referenced twice! */ +#define DHI_IS(x,y) ({ Double_Store _d; _d.d=(x); _d.cells.high=(y); (x)=_d.d; }) +#define DLO_IS(x,y) ({ Double_Store _d; _d.d=(x); _d.cells.low =(y); (x)=_d.d; }) +#define UD2D(ud) ((DCell)(ud)) +#define D2UD(d) ((UDCell)(d)) #define OFF2UD(o) ((UDCell)(o)) #define UD2OFF(ud) ((off_t)(ud)) #define DZERO ((DCell)0) +/* shifts by less than CELL_BITS */ +#define DLSHIFT(d,u) ((d)<<(u)) +#define UDLSHIFT(d,u) ((d)<<(u)) -#endif /* ! defined(BUGGY_LONG_LONG) */ +#endif /* !defined(BUGGY_LONG_LONG) */ typedef union { struct { @@ -162,21 +269,6 @@ typedef Label *Xt; ca is the code address */ #define MAKE_CF(cfa,ca) ((*(Label *)(cfa)) = ((Label)ca)) /* make a code field for a defining-word-defined word */ -#define MAKE_DOES_CF(cfa,does_code) ({MAKE_CF(cfa,DOES_CA); \ - ((Cell *)cfa)[1] = (Cell)(does_code);}) - -#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) @@ -190,11 +282,14 @@ typedef Label *Xt; #define NO_DYNAMIC_DEFAULT 1 #endif -#ifdef USE_TOS -#define IF_spTOS(x) x +#ifndef CHECK_PRIM +#define CHECK_PRIM(start,len) 0 +#endif + +#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 @@ -208,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 @@ -220,22 +326,29 @@ 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 */ +#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))<<3)>>3)) +#define LONGNAME_COUNT(np) ((np)->countetc & (((~((UCell)0))<<4)>>4)) struct Cellpair { Cell n1; @@ -251,15 +364,67 @@ struct Cellquad { #define IOR(flag) ((flag)? -512-errno : 0) -Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp); -Label *engine2(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp); -Label *engine3(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp); +#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 my_alloc(Cell size); -char *cstr(Char *from, UCell size, int clear); -char *tilde_cstr(Char *from, UCell size, int clear); +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); @@ -269,14 +434,28 @@ struct Longname *tablelfind(Char *c_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, Cell wfileid); +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 *rp); +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); @@ -294,7 +473,6 @@ 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); @@ -302,6 +480,7 @@ 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; @@ -314,13 +493,16 @@ extern int debug; # define debug 0 #endif -extern Cell *SP; -extern Float *FP; -extern Address UP; +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; -#ifdef GFORTH_DEBUGGING -extern Xt *saved_ip; -extern Cell *rp; +extern void * gforth_pointers(Cell n); + +#ifdef HAS_FFCALL +extern void gforth_callback(Xt* fcall, void * alist); #endif #ifdef NO_IP @@ -363,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) + +#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