/* Basile's static analysis (should have a better name) header melt-runtime.h Copyright (C) 2008, 2009 Free Software Foundation, Inc. Contributed by Basile Starynkevitch This file is part of GCC. GCC 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 3, or (at your option) any later version. GCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GCC; see the file COPYING3. If not see . */ #ifndef MELT_INCLUDED_ #define MELT_INCLUDED_ /* we need PPL because some static inline functions use it below (e.g. melt_raw_new_ppl_empty_constraint_system). This is notably true for gtype-desc.c which is generated by gengtype and won't compile without this include. */ #include "ppl_c.h" /* DYNAMIC_OBJSTRUCT is a cute hack to "dynamically" compute field positions; this is only used to compile warmelt-*-0.c files notably when new fields have been added in warmelt-first.melt. When enabled, slows down significantly MELT. */ #ifndef MELTGCC_DYNAMIC_OBJSTRUCT #define MELTGCC_DYNAMIC_OBJSTRUCT 0 #endif /***** if GGC-collected data, e.g. tree-s, edge-s, ... is computed by melt/MELT routines and is referenced only by the melt/MELT call frames, it should be carefully handled by full GC. This is done by specially generated code chunk in each MELT generated routines which mark such GGC data outside on full garbage collections. This code is invoked by calling the closure routine with a magic incantation, i.e. with the xargdescr_ set to (char*)-1 *****/ #include "gcc-plugin.h" /* we include toplev.h for the error routines */ #include "toplev.h" #define dbgprintf_raw(Fmt,...) do{if (dump_file) \ {fprintf(dump_file, Fmt, ##__VA_ARGS__); fflush(dump_file);}}while(0) #define dbgprintf(Fmt,...) dbgprintf_raw("@%s:%d: " Fmt "\n", \ basename(__FILE__), __LINE__, ##__VA_ARGS__) /* the version string of GCC when MELT was initialized */ extern char* melt_gccversionstr; extern long melt_dbgcounter; extern long melt_debugskipcount; #ifdef MELT_IS_PLUGIN extern int flag_melt_debug; #endif #define debugeprintf_raw(Fmt,...) do{if (flag_melt_debug) \ {fprintf(stderr, Fmt, ##__VA_ARGS__); fflush(stderr);}}while(0) #define debugeprintf(Fmt,...) debugeprintf_raw("!@%s:%d:\n@! " Fmt "\n", \ basename(__FILE__), __LINE__, ##__VA_ARGS__) #define debugeprintfnonl(Fmt,...) debugeprintf_raw("!@%s:%d:\n@! " Fmt, \ basename(__FILE__), __LINE__, ##__VA_ARGS__) #define debugeprintvalue(Msg,Val) do{if (flag_melt_debug){ \ void* __val = (Val); \ fprintf(stderr,"!@%s:%d:\n@! %s @%p= ", \ basename(__FILE__), __LINE__, (Msg), __val); \ melt_dbgeprint(__val); }} while(0) #define debugebacktrace(Msg,Depth) do{if (flag_melt_debug){ \ void* __val = (Val); \ fprintf(stderr,"!@%s:%d: %s **backtrace** ", \ basename(__FILE__), __LINE__, (Msg)); \ melt_dbgbacktrace((Depth)); }} while(0) /* the maximal debug depth - should be a parameter */ #define MELTDBG_MAXDEPTH 7 /* unspecified flexible dimension in structure */ #if defined(__STDC__) && __STDC__VERSION >= 199901L #define FLEXIBLE_DIM /*flexible */ #define HAVE_FLEXIBLE_DIM 1 #elsif __GNUC__>=4 #define FLEXIBLE_DIM /*gcc flexible*/ #define HAVE_FLEXIBLE_DIM 1 #else #define FLEXIBLE_DIM /*flexibly*/1 #define HAVE_FLEXIBLE_DIM 0 #endif /* array of (at least 100, increasing order but non consecutive) primes, zero terminated. Each prime is at least 1/8-th bigger than previous */ extern const long melt_primtab[256]; /* function to retrieve a MELT program -or plugin- argument; return NULL if not found */ const char* melt_argument(const char* argname); /* naming convention: all struct melt*_st are inside the melt_un */ typedef union melt_un *melt_ptr_t; typedef struct meltobject_st *meltobject_ptr_t; typedef struct meltmapobjects_st *meltmapobjects_ptr_t; typedef struct meltclosure_st *meltclosure_ptr_t; typedef struct meltroutine_st *meltroutine_ptr_t; typedef struct meltmultiple_st *meltmultiple_ptr_t; typedef struct meltbox_st *meltbox_ptr_t; typedef struct meltpair_st *meltpair_ptr_t; struct debugprint_melt_st { FILE *dfil; int dmaxdepth; int dcount; }; void melt_debug_out (struct debugprint_melt_st *dp, melt_ptr_t ptr, int depth); void melt_dbgeprint (void *p); void melt_dbgbacktrace (int depth); /******************* closures, routines ************************/ /* when the argdescr string of a closure routine is MELTPAR_MARKGGC the routine just marks the frame passed as first argument */ #define MELTPAR_MARKGGC ((char*)(-1L)) union meltparam_un { /* for melt value pointers, we pass the address of a local, to be compatible with our copying garbage collector */ melt_ptr_t *bp_aptr; /* letter p */ #define BPAR_PTR 'p' #define BPARSTR_PTR "p" /* we no longer have BPAR_RESTPTR as 'R' */ tree bp_tree; /* letter t */ tree *bp_treeptr; /* for extra results */ #define BPAR_TREE 't' #define BPARSTR_TREE "t" gimple bp_gimple; /* letter g */ gimple *bp_gimpleptr; /* for extra results */ #define BPAR_GIMPLE 'g' #define BPARSTR_GIMPLE "g" gimple_seq bp_gimpleseq; /* letter g */ gimple_seq *bp_gimpleseqptr; /* for extra results */ #define BPAR_GIMPLESEQ 'G' #define BPARSTR_GIMPLESEQ "G" long bp_long; /* letter l */ long *bp_longptr; /* for results */ #define BPAR_LONG 'l' #define BPARSTR_LONG "l" edge bp_edge; /* letter e */ edge *bp_edgeptr; /* for results */ #define BPAR_EDGE 'e' #define BPARSTR_EDGE "e" basic_block bp_bb; /* letter b */ basic_block *bp_bbptr; /* for results */ #define BPAR_BB 'b' #define BPARSTR_BB "b" /* readonly constant strings - not in GP nor in heap */ const char *bp_cstring; /* letter S */ const char **bp_cstringptr; /* for results */ #define BPAR_CSTRING 's' #define BPARSTR_CSTRING "s" /* PPL and special stuff are getting the upper case letters */ /* PPL coefficients */ ppl_Coefficient_t bp_ppl_coefficient; ppl_Coefficient_t* bp_ppl_coefficientptr; #define BPAR_PPL_COEFFICIENT 'A' #define BPARSTR_PPL_COEFFICIENT "A" /* PPL constraints */ ppl_Constraint_t bp_ppl_constraint; ppl_Constraint_t* bp_ppl_constraintptr; #define BPAR_PPL_CONSTRAINT 'B' #define BPARSTR_PPL_CONSTRAINT "B" /* PPL constraint systems */ ppl_Constraint_System_t bp_ppl_constraint_system; ppl_Constraint_System_t* bp_ppl_constraint_systemptr; #define BPAR_PPL_CONSTRAINT_SYSTEM 'C' #define BPARSTR_PPL_CONSTRAINT_SYSTEM "C" /* PPL linear expressions */ ppl_Linear_Expression_t bp_ppl_linear_expression; ppl_Linear_Expression_t* bp_ppl_linear_expressionptr; #define BPAR_PPL_LINEAR_EXPRESSION 'D' #define BPARSTR_PPL_LINEAR_EXPRESSION "D" /* PPL polyhedrons */ ppl_Polyhedron_t bl_ppl_polyhedron; ppl_Polyhedron_t* bp_ppl_polyhedronptr; #define BPAR_PPL_POLYHEDRON 'E' #define BPARSTR_PPL_POLYHEDRON "E" }; /*** the closures contain routines which are called by applying closures; each routine is called with: + the called closure + this first pointer argument + a (non null, can be empty) constant string describing the extra arguments (eg "ppt" for two value pointers and one tree) + the array of union meltparam_un for extra arguments + a (non null, can be empty) constant string describing the extra results + the array of union meltparam_un for extra results and the result of the call is a pointer (the main result) BTW, on AMD64 or x86_64 processors [a very common host at time of writing], http://www.x86-64.org/documentation/abi.pdf the first six arguments are passed thru registers; on POWERPC eight arguments are passed thru registers */ typedef melt_ptr_t meltroutfun_t (meltclosure_ptr_t closp_, melt_ptr_t firstargp_, const char xargdescr_[], union meltparam_un *xargtab_, const char xresdescr_[], union meltparam_un *xrestab_); /* the application routine does not call the GC; of course, the applied closure can call the GC! */ melt_ptr_t melt_apply (meltclosure_ptr_t clos_p, melt_ptr_t firstarg, const char xargdescr_[], union meltparam_un *xargtab_, const char xresdescr_[], union meltparam_un *xrestab_); /* gnu indent has some trouble with GTY hence */ /* *INDENT-OFF* */ DEF_VEC_P (melt_ptr_t); DEF_VEC_ALLOC_P (melt_ptr_t, gc); DEF_VEC_P (meltobject_ptr_t); DEF_VEC_ALLOC_P (meltobject_ptr_t, gc); /* sadly we cannot use these types in GTY-ed structure because gengtype don't follow typedefs but these typedef-s are still useful */ typedef VEC (meltobject_ptr_t, gc) melt_objectvec_t; typedef VEC (melt_ptr_t, gc) melt_valvec_t; enum obmag_en { OBMAG__NONE = 0, OBMAG_OBJECT = 30000, OBMAG_BOX, OBMAG_MULTIPLE, OBMAG_CLOSURE, OBMAG_ROUTINE, OBMAG_LIST, OBMAG_PAIR, OBMAG_INT, OBMAG_MIXINT, OBMAG_MIXLOC, OBMAG_MIXBIGINT, OBMAG_REAL, OBMAG_STRING, OBMAG_STRBUF, OBMAG_TREE, OBMAG_GIMPLE, OBMAG_GIMPLESEQ, OBMAG_BASICBLOCK, OBMAG_EDGE, OBMAG_MAPOBJECTS, OBMAG_MAPSTRINGS, OBMAG_MAPTREES, OBMAG_MAPGIMPLES, OBMAG_MAPGIMPLESEQS, OBMAG_MAPBASICBLOCKS, OBMAG_MAPEDGES, OBMAG_DECAY, OBMAG__SPARE1, OBMAG__SPARE2, OBMAG__SPARE3, OBMAG__SPARE4, OBMAG__SPARE5, OBMAG__SPARE6, OBMAG__SPARE7, OBMAG__SPARE8, OBMAG__SPARE9, OBMAG__SPARE10, OBMAG__SPARE11, OBMAG__SPARE12, OBMAG__SPARE13, OBMAG__SPARE14, OBMAG__SPARE15, OBMAG__SPARE16, OBMAG__SPARE17, OBMAG__SPARE18, OBMAG__SPARE19, OBMAG__SPARE20, OBMAG__SPARE21, OBMAG__SPARE22, OBMAG__SPARE23, OBMAG__SPARE24, OBMAG__SPARE25, OBMAG__SPARE26, OBMAG__SPARE27, OBMAG__SPARE28, OBMAG__SPARE29, OBMAG__SPARE30, OBMAG__SPARE31, OBMAG__SPARE32, OBMAG__SPARE33, OBMAG__SPARE34, OBMAG__SPARE35, OBMAG__SPARE36, OBMAG__SPARE37, OBMAG_SPEC_FILE, /* closed when deleted */ OBMAG_SPEC_RAWFILE, /* not closed when deleted */ OBMAG_SPEC_MPFR, OBMAG_SPECPPL_COEFFICIENT, OBMAG_SPECPPL_LINEAR_EXPRESSION, OBMAG_SPECPPL_CONSTRAINT, OBMAG_SPECPPL_CONSTRAINT_SYSTEM, OBMAG_SPECPPL_GENERATOR, OBMAG_SPECPPL_GENERATOR_SYSTEM, OBMAG_SPECPPL_POLYHEDRON, OBMAG__LAST }; /* maxhash can also be used as a bit mask */ #define MELT_MAXHASH 0x3fffffff /* maxlen can also be used as a bit mask */ #define MELT_MAXLEN 0x1fffffff /*** objects are a la ObjVlisp, single-inheritance with a root class, the discr of an object is its class each object has its hashcode, its magic (used to discriminate non-object values), its number of slots or instance variables object_arity, and an array of slots called vartab[] objects should be allocated in young region, hence discr should be forwarded in the garbage collector */ /* *INDENT-ON* */ /* when OBMAG_OBJECT -- */ struct GTY (()) meltobject_st { /* for objects, the discriminant is their class */ meltobject_ptr_t obj_class; unsigned obj_hash; /* hash code of the object */ unsigned short obj_num; /* discriminate the melt_un containing it as discr */ #define object_magic obj_num unsigned short obj_len; #if ENABLE_CHECKING unsigned long obj_serial; #endif melt_ptr_t GTY ((length ("%h.obj_len"))) obj_vartab[FLEXIBLE_DIM]; }; #if ENABLE_CHECKING #define MELT_OBJECT_STRUCT(N) { \ meltobject_ptr_t obj_class; \ unsigned obj_hash; \ unsigned short obj_num; \ unsigned short obj_len; \ unsigned long obj_serial; \ melt_ptr_t* obj_vartab[N]; \ long _gap; } void melt_object_set_serial(meltobject_ptr_t ob); #else /*!ENABLE_CHECKING*/ #define MELT_OBJECT_STRUCT(N) { \ meltobject_ptr_t obj_class; \ unsigned obj_hash; \ unsigned short obj_num; \ unsigned short obj_len; \ melt_ptr_t* obj_vartab[N]; \ long _gap; } /* set serial is a nop */ static inline void melt_object_set_serial(meltobject_ptr_t ob) {} #endif /* some types, including objects, strbuf, stringmaps, objectmaps, all the other *maps, contain a pointer to a non value; this pointer should be carefully updated in the forwarding step (and checked if young) */ /* forwarded pointers; nobody see them except the melt copying garbage collector */ struct GTY (()) meltforward_st { meltobject_ptr_t discr; /* actually always (void*)1 for forwarded */ melt_ptr_t forward; }; /* when OBMAG_DECAY */ struct GTY ((mark_hook ("melt_mark_decay"))) meltdecay_st { meltobject_ptr_t discr; melt_ptr_t val; unsigned remain; /* remaining number of marking */ }; /* when OBMAG_BOX */ struct GTY (()) meltbox_st { meltobject_ptr_t discr; melt_ptr_t val; }; /* when OBMAG_MULTIPLE */ struct GTY (()) meltmultiple_st { meltobject_ptr_t discr; unsigned nbval; melt_ptr_t GTY ((length ("%h.nbval"))) tabval[FLEXIBLE_DIM]; }; #define MELT_MULTIPLE_STRUCT(N) { \ meltobject_ptr_t discr; \ unsigned nbval; \ melt_ptr_t tabval[N]; \ long _gap; } /* when OBMAG_CLOSURE */ struct GTY (()) meltclosure_st { meltobject_ptr_t discr; meltroutine_ptr_t rout; unsigned nbval; melt_ptr_t GTY ((length ("%h.nbval"))) tabval[FLEXIBLE_DIM]; }; #define MELT_CLOSURE_STRUCT(N) { \ meltobject_ptr_t discr; \ meltroutine_ptr_t rout; \ unsigned nbval; \ melt_ptr_t tabval[N]; \ long _gap; } /* when OBMAG_ROUTINE */ #define MELT_ROUTDESCR_LEN 96 struct GTY (()) meltroutine_st { meltobject_ptr_t discr; char routdescr[MELT_ROUTDESCR_LEN]; meltroutfun_t* GTY ((skip)) routfunad; melt_ptr_t routdata; unsigned nbval; melt_ptr_t GTY ((length ("%h.nbval"))) tabval[FLEXIBLE_DIM]; }; /* unsafely set inside the meltroutine_st pointed by Rptr the routine function pointer to Rout */ #define MELT_ROUTINE_SET_ROUTCODE(Rptr,Rout) do { \ ((struct meltroutine_st*)(Rptr))->routfunad \ = (Rout); \ } while(0) #define MELT_ROUTINE_STRUCT(N) { \ meltobject_ptr_t discr; \ char routdescr[MELT_ROUTDESCR_LEN]; \ meltroutfun_t* routfunad; \ melt_ptr_t routdata; \ unsigned nbval; \ melt_ptr_t tabval[N]; \ long _gap; } /* when OBMAG_PAIR */ struct GTY ((chain_next ("%h.tl"))) meltpair_st { meltobject_ptr_t discr; melt_ptr_t hd; struct meltpair_st *tl; }; /* when OBMAG_LIST */ struct GTY (()) meltlist_st { meltobject_ptr_t discr; struct meltpair_st *first; struct meltpair_st *last; }; /* when OBMAG_INT - */ struct GTY (()) meltint_st { meltobject_ptr_t discr; long val; }; /* when OBMAG_MIXINT - */ struct GTY (()) meltmixint_st { meltobject_ptr_t discr; melt_ptr_t ptrval; long intval; }; /* when OBMAG_MIXLOC - */ struct GTY (()) meltmixloc_st { meltobject_ptr_t discr; melt_ptr_t ptrval; long intval; location_t locval; }; /* when OBMAG_MIXBIGINT - an exported array mpz compatible; since we use an exported mpz format, the value can be copied and trashed by MELT garbage collector without harm. */ struct GTY (()) meltmixbigint_st { meltobject_ptr_t discr; melt_ptr_t ptrval; bool negative; unsigned biglen; long GTY ((length ("%h.biglen"))) tabig[FLEXIBLE_DIM]; /* of length LEN */ }; /* when OBMAG_REAL */ struct GTY (()) meltreal_st { meltobject_ptr_t discr; REAL_VALUE_TYPE val; }; /* a union of special pointers which have to be explicitly deleted */ union special_melt_un { /* all the pointers here have to be pointers to struct or to void, because the generated gtype-desc.c don't include all the files which define mpfr_ptr ppl_Coefficient_t etc... */ /* generic pointer */ void *sp_pointer; /* stdio file */ FILE *sp_file; /*mpfr_ptr= */ void *sp_mpfr; /* malloced pointer to mpfr_t */ ppl_Coefficient_t sp_coefficient; ppl_Linear_Expression_t sp_linear_expression; ppl_Constraint_t sp_constraint; ppl_Constraint_System_t sp_constraint_system; ppl_Generator_t sp_generator; ppl_Generator_System_t sp_generator_system; ppl_Polyhedron_t sp_polyhedron; }; /* PPL special have to be explicitly deleted; hence we need a hook to mark them, an inside mark, and to maintain lists of existing such PPL special boxes -which we scan to delete the unmarked ones */ /* when OBMAG_SPEC* eg OBMAG_SPEC_MPFR, OBMAG_SPECPPL_COEFFICIENT; etc. */ struct GTY ((mark_hook ("melt_mark_special"))) meltspecial_st { meltobject_ptr_t discr; int mark; struct meltspecial_st *GTY ((skip)) nextspec; union special_melt_un GTY ((skip)) val; }; static inline void melt_mark_special (struct meltspecial_st *p) { p->mark = 1; } static inline void melt_mark_decay (struct meltdecay_st *p) { /* this is tricky since it actually changes the marked data; however, changing pointers to NULL is ok! */ if (p->remain <= 0) p->val = NULL; else p->remain--; } /* make a special value; return NULL if the discriminant is not special; all special values should be made thru this */ struct meltspecial_st* meltgc_make_special(melt_ptr_t discr); /* when OBMAG_STRING - */ struct GTY (()) meltstring_st { meltobject_ptr_t discr; char val[FLEXIBLE_DIM]; /* null terminated */ }; #define MELT_STRING_STRUCT(N) { \ meltobject_ptr_t discr; \ char val[(N)+1]; /* null terminated */ \ long _gap; } /* when OBMAG_STRBUF - string buffers */ struct GTY (()) meltstrbuf_st { meltobject_ptr_t discr; char *GTY ((length ("1+melt_primtab[%h.buflenix]"))) bufzn; unsigned char buflenix; /* allocated length index of buffer */ unsigned bufstart; unsigned bufend; /* start & end useful positions */ /* the following field is usually the value of buf (for objects in the young zone), to allocate the object and its fields at once; hence its GTY-ed length is zero */ char GTY ((length ("0"))) buf_space[FLEXIBLE_DIM]; }; /* when OBMAG_TREE - boxed tree-s */ struct GTY (()) melttree_st { meltobject_ptr_t discr; tree val; }; /* when OBMAG_GIMPLE - boxed gimple-s */ struct GTY (()) meltgimple_st { meltobject_ptr_t discr; gimple val; }; /* when OBMAG_GIMPLESEQ - boxed gimpleseq-s */ struct GTY (()) meltgimpleseq_st { meltobject_ptr_t discr; gimple_seq val; }; /* when OBMAG_BASICBLOCK - boxed basic_block-s */ struct GTY (()) meltbasicblock_st { meltobject_ptr_t discr; basic_block val; }; /* when OBMAG_EDGE */ struct GTY (()) meltedge_st { meltobject_ptr_t discr; edge val; }; /*** hashed maps of objects to melt ***/ struct GTY (()) entryobjectsmelt_st { meltobject_ptr_t e_at; melt_ptr_t e_va; }; /* when OBMAG_MAPOBJECTS */ struct GTY (()) meltmapobjects_st { meltobject_ptr_t discr; unsigned count; unsigned char lenix; struct entryobjectsmelt_st *GTY ((length ("melt_primtab[%h.lenix]"))) entab; /* the following field is usually the value of entab (for objects in the young zone), to allocate the object and its fields at once; hence its GTY-ed length is zero */ struct entryobjectsmelt_st GTY ((length ("0"))) map_space[FLEXIBLE_DIM]; }; /*** hashed maps of trees to melt ***/ struct GTY (()) entrytreesmelt_st { tree e_at; melt_ptr_t e_va; }; /* when OBMAG_MAPTREES */ struct GTY (()) meltmaptrees_st { /* change meltmappointers_st when changing this structure */ meltobject_ptr_t discr; unsigned count; unsigned char lenix; struct entrytreesmelt_st *GTY ((length ("melt_primtab[%h.lenix]"))) entab; }; /*** hashed maps of gimples to melt ***/ struct GTY (()) entrygimplesmelt_st { gimple e_at; melt_ptr_t e_va; }; /* when OBMAG_MAPGIMPLES */ struct GTY (()) meltmapgimples_st { /* change meltmappointers_st when changing this structure */ meltobject_ptr_t discr; unsigned count; unsigned char lenix; struct entrygimplesmelt_st *GTY ((length ("melt_primtab[%h.lenix]"))) entab; }; /*** hashed maps of gimpleseqs to melt ***/ struct GTY (()) entrygimpleseqsmelt_st { gimple_seq e_at; melt_ptr_t e_va; }; /* when OBMAG_MAPGIMPLESEQS */ struct GTY (()) meltmapgimpleseqs_st { /* change meltmappointers_st when changing this structure */ meltobject_ptr_t discr; unsigned count; unsigned char lenix; struct entrygimpleseqsmelt_st *GTY ((length ("melt_primtab[%h.lenix]"))) entab; }; /*** hashed maps of strings to melt ***/ struct GTY (()) entrystringsmelt_st { const char *GTY (()) e_at; melt_ptr_t e_va; }; /* when OBMAG_MAPSTRINGS */ struct GTY (()) meltmapstrings_st { meltobject_ptr_t discr; unsigned count; unsigned char lenix; struct entrystringsmelt_st *GTY ((length ("melt_primtab[%h.lenix]"))) entab; }; /*** hashed maps of basicblocks to melt ***/ struct GTY (()) entrybasicblocksmelt_st { basic_block e_at; melt_ptr_t e_va; }; /* when OBMAG_MAPBASICBLOCKS */ struct GTY (()) meltmapbasicblocks_st { /* change meltmappointers_st when changing this structure */ meltobject_ptr_t discr; unsigned count; unsigned char lenix; struct entrybasicblocksmelt_st *GTY ((length ("melt_primtab[%h.lenix]"))) entab; }; /*** hashed maps of edges to melt ***/ struct GTY (()) entryedgesmelt_st { edge e_at; melt_ptr_t e_va; }; /* when OBMAG_MAPEDGES */ struct GTY (()) meltmapedges_st { /* change meltmappointers_st when changing this structure */ meltobject_ptr_t discr; unsigned count; unsigned char lenix; struct entryedgesmelt_st *GTY ((length ("melt_primtab[%h.lenix]"))) entab; }; /**** our union for everything ***/ /* never use an array of melt_un, only array of pointers melt_ptr_t */ typedef union GTY ((desc ("%0.u_discr->object_magic"))) melt_un { meltobject_ptr_t GTY ((skip)) u_discr; struct meltforward_st GTY ((skip)) u_forward; struct meltobject_st GTY ((tag ("OBMAG_OBJECT"))) u_object; struct meltbox_st GTY ((tag ("OBMAG_BOX"))) u_box; struct meltdecay_st GTY ((tag ("OBMAG_DECAY"))) u_decay; struct meltmultiple_st GTY ((tag ("OBMAG_MULTIPLE"))) u_multiple; struct meltclosure_st GTY ((tag ("OBMAG_CLOSURE"))) u_closure; struct meltroutine_st GTY ((tag ("OBMAG_ROUTINE"))) u_routine; struct meltlist_st GTY ((tag ("OBMAG_LIST"))) u_list; struct meltint_st GTY ((tag ("OBMAG_INT"))) u_int; struct meltmixint_st GTY ((tag ("OBMAG_MIXINT"))) u_mixint; struct meltmixloc_st GTY ((tag ("OBMAG_MIXLOC"))) u_mixloc; struct meltmixbigint_st GTY ((tag ("OBMAG_MIXBIGINT"))) u_mixbigint; struct meltreal_st GTY ((tag ("OBMAG_REAL"))) u_real; struct meltpair_st GTY ((tag ("OBMAG_PAIR"))) u_pair; struct meltspecial_st GTY ((tag ("OBMAG_SPEC_FILE"), tag ("OBMAG_SPEC_MPFR"), tag ("OBMAG_SPECPPL_COEFFICIENT"), tag ("OBMAG_SPECPPL_LINEAR_EXPRESSION"), tag ("OBMAG_SPECPPL_CONSTRAINT"), tag ("OBMAG_SPECPPL_CONSTRAINT_SYSTEM"), tag ("OBMAG_SPECPPL_GENERATOR"), tag ("OBMAG_SPECPPL_GENERATOR_SYSTEM"), tag ("OBMAG_SPECPPL_POLYHEDRON")) ) u_special; struct meltstring_st GTY ((tag ("OBMAG_STRING"))) u_string; struct meltstrbuf_st GTY ((tag ("OBMAG_STRBUF"))) u_strbuf; struct melttree_st GTY ((tag ("OBMAG_TREE"))) u_tree; struct meltgimple_st GTY ((tag ("OBMAG_GIMPLE"))) u_gimple; struct meltgimpleseq_st GTY ((tag ("OBMAG_GIMPLESEQ"))) u_gimpleseq; struct meltbasicblock_st GTY ((tag ("OBMAG_BASICBLOCK"))) u_basicblock; struct meltedge_st GTY ((tag ("OBMAG_EDGE"))) u_edge; struct meltmapobjects_st GTY ((tag ("OBMAG_MAPOBJECTS"))) u_mapobjects; struct meltmapstrings_st GTY ((tag ("OBMAG_MAPSTRINGS"))) u_mapstrings; struct meltmaptrees_st GTY ((tag ("OBMAG_MAPTREES"))) u_maptrees; struct meltmapgimples_st GTY ((tag ("OBMAG_MAPGIMPLES"))) u_mapgimples; struct meltmapgimpleseqs_st GTY ((tag ("OBMAG_MAPGIMPLESEQS"))) u_mapgimpleseqs; struct meltmapbasicblocks_st GTY ((tag ("OBMAG_MAPBASICBLOCKS"))) u_mapbasicblocks; struct meltmapedges_st GTY ((tag ("OBMAG_MAPEDGES"))) u_mapedges; } melt_un_t; /* return the magic of the discriminant or 0 */ static inline int melt_magic_discr (melt_ptr_t p) { if (!p || !p->u_discr) return 0; return p->u_discr->object_magic; } /* test if a pointer is an output - either a string buffer or a file */ static inline bool melt_is_out (melt_ptr_t p) { int d = melt_magic_discr(p); return d == OBMAG_STRBUF || d == OBMAG_SPEC_FILE || d == OBMAG_SPEC_RAWFILE; } /* test if a pointer is a file */ static inline bool melt_is_file (melt_ptr_t p) { int d = melt_magic_discr(p); return d == OBMAG_SPEC_FILE || d == OBMAG_SPEC_RAWFILE; } /* return the nth of a multiple (starting from 0) */ static inline melt_ptr_t melt_multiple_nth (melt_ptr_t mul, int n) { if (!mul || ((meltmultiple_ptr_t)mul)->discr->object_magic != OBMAG_MULTIPLE) return NULL; if (n >= 0 && n < (int) ((meltmultiple_ptr_t)mul)->nbval) return ((meltmultiple_ptr_t)mul)->tabval[n]; else if (n < 0 && n + (int) ((meltmultiple_ptr_t)mul)->nbval >= 0) return ((meltmultiple_ptr_t)mul)->tabval[n + ((meltmultiple_ptr_t)mul)->nbval]; return NULL; } /* set the nth of a multiple (but beware of circularities!) */ void meltgc_multiple_put_nth (melt_ptr_t mul, int n, melt_ptr_t val); /* return the length of a multiple */ static inline int melt_multiple_length (melt_ptr_t mul) { if (!mul || ((meltmultiple_ptr_t)mul)->discr->object_magic != OBMAG_MULTIPLE) return 0; return ((meltmultiple_ptr_t)mul)->nbval; } /* test if something is a tuple of a given length or bigger */ static inline bool melt_is_multiple_at_least(melt_ptr_t mul, int ln) { if (!mul || ln<0 || ((meltmultiple_ptr_t)mul)->discr->object_magic != OBMAG_MULTIPLE) return 0; return (int)((meltmultiple_ptr_t)mul)->nbval >= (int)ln; } /* test if something is a tuple of an exactly given length */ static inline bool melt_is_multiple_of_length(melt_ptr_t mul, int ln) { if (!mul || ln<0 || ((meltmultiple_ptr_t)mul)->discr->object_magic != OBMAG_MULTIPLE) return 0; return (int)((meltmultiple_ptr_t)mul)->nbval == (int)ln; } /* sort a multiple MUL using as compare function the closure CMPCLO which should return a boxed integer (0 for equality, <0 for less than, >0 for greater than), when applied to two values to compare. If the closure does not return an integer the whole sort returns null; otherwise it returns a new multiple value of discriminant DISCRM */ melt_ptr_t meltgc_sort_multiple(melt_ptr_t mult_p, melt_ptr_t clo_p, melt_ptr_t discrm_p); /* allocate a new box of given DISCR & content VAL */ melt_ptr_t meltgc_new_box (meltobject_ptr_t discr_p, melt_ptr_t val_p); /* return the content of a box */ static inline melt_ptr_t melt_box_content (meltbox_ptr_t box) { if (!box || box->discr->object_magic != OBMAG_BOX) return NULL; return box->val; } void meltgc_box_put (melt_ptr_t box, melt_ptr_t val); /* safely return the calue inside a container - instance of CLASS_CONTAINER */ melt_ptr_t melt_container_value (melt_ptr_t cont); void *meltgc_raw_new_mappointers (meltobject_ptr_t discr_p, unsigned len); void meltgc_raw_put_mappointers (void *mappointer_p, const void *attr, melt_ptr_t valu_p); melt_ptr_t melt_raw_get_mappointers (void *mappointer_p, const void *attr); melt_ptr_t meltgc_raw_remove_mappointers (void *mappointer_p, const void *attr); /* big macro to implement a mapFOOs */ #define MELT_DEFINE_MAPTR(Obmag,Ptyp,Mapstruct,Newf,Getf,Putf,Removef,Countf,Sizef,Nthattrf,Nthvalf) \ \ static inline melt_ptr_t \ Newf (meltobject_ptr_t discr, unsigned len) \ { \ if (melt_magic_discr ((melt_ptr_t) discr) != OBMAG_OBJECT) \ return NULL; \ if (discr->object_magic != Obmag) \ return NULL; \ return (melt_ptr_t) meltgc_raw_new_mappointers (discr, len); \ } \ \ static inline melt_ptr_t \ Getf (melt_ptr_t map_p, Ptyp attr) \ { \ if (melt_magic_discr ((melt_ptr_t) map_p) != Obmag || !attr) \ return NULL; \ return melt_raw_get_mappointers (map_p, attr); \ } \ \ static inline void \ Putf (struct Mapstruct *map_p, \ Ptyp attr, melt_ptr_t valu_p) \ { \ if (melt_magic_discr ((melt_ptr_t) map_p) != Obmag \ || !attr || !valu_p) \ return; \ meltgc_raw_put_mappointers (map_p, attr, valu_p); \ } \ \ static inline melt_ptr_t \ Removef (struct Mapstruct *map, Ptyp attr) \ { \ if (melt_magic_discr ((melt_ptr_t) map) != Obmag || !attr) \ return NULL; \ return meltgc_raw_remove_mappointers (map, attr); \ } \ \ static inline unsigned \ Countf (struct Mapstruct* map_p) \ { \ if (!map_p || map_p->discr->obj_num != Obmag) \ return 0; \ return map_p->count; \ } \ \ static inline int \ Sizef (struct Mapstruct* map_p) \ { \ if (!map_p || map_p->discr->obj_num != Obmag) \ return 0; \ return melt_primtab[map_p->lenix]; \ } \ \ static inline Ptyp \ Nthattrf(struct Mapstruct* map_p, int ix) \ { \ Ptyp at = 0; \ if (!map_p || map_p->discr->obj_num != Obmag) \ return 0; \ if (ix < 0 || ix >= melt_primtab[map_p->lenix]) \ return 0; \ at = map_p->entab[ix].e_at; \ if ((void *) at == (void *) HTAB_DELETED_ENTRY) \ return 0; \ return at; \ } \ \ static inline melt_ptr_t \ Nthvalf(struct Mapstruct* map_p, int ix) \ { \ Ptyp at = 0; \ if (!map_p || map_p->discr->obj_num != Obmag) \ return 0; \ if (ix < 0 || ix >= melt_primtab[map_p->lenix]) \ return 0; \ at = map_p->entab[ix].e_at; \ if (!at || (void *) at == (void *) HTAB_DELETED_ENTRY) \ return 0; \ return map_p->entab[ix].e_va; \ } /* end of MELT_DEFINE_MAPTR macro */ MELT_DEFINE_MAPTR(OBMAG_MAPTREES, tree, meltmaptrees_st, meltgc_new_maptrees, melt_get_maptrees, melt_put_maptrees, melt_remove_maptrees, melt_count_maptrees, melt_size_maptrees, melt_nthattr_maptrees, melt_nthval_maptrees) MELT_DEFINE_MAPTR(OBMAG_MAPGIMPLES, gimple, meltmapgimples_st, meltgc_new_mapgimples, melt_get_mapgimples, melt_put_mapgimples, melt_remove_mapgimples, melt_count_mapgimples, melt_size_mapgimples, melt_nthattr_mapgimples, melt_nthval_mapgimples) MELT_DEFINE_MAPTR(OBMAG_MAPGIMPLESEQS, gimple_seq, meltmapgimpleseqs_st, meltgc_new_mapgimpleseqs, melt_get_mapgimpleseqs, melt_put_mapgimpleseqs, melt_remove_mapgimpleseqs, melt_count_mapgimpleseqs, melt_size_mapgimpleseqs, melt_nthattr_mapgimpleseqs, melt_nthval_mapgimpleseqs) MELT_DEFINE_MAPTR(OBMAG_MAPEDGES, edge, meltmapedges_st, meltgc_new_mapedges, melt_get_mapedges, melt_put_mapedges, melt_remove_mapedges, melt_count_mapedges, melt_size_mapedges, melt_nthattr_mapedges, melt_nthval_mapedges) MELT_DEFINE_MAPTR(OBMAG_MAPBASICBLOCKS, basic_block, meltmapbasicblocks_st, meltgc_new_mapbasicblocks, melt_get_mapbasicblocks, melt_put_mapbasicblocks, melt_remove_mapbasicblocks, melt_count_mapbasicblocks, melt_size_mapbasicblocks, melt_nthattr_mapbasicblocks, melt_nthval_mapbasicblocks) /* do not use MELT_DEFINE_MAPTR elsewhere */ #undef MELT_DEFINE_MAPTR /* allocate a new boxed tree of given DISCR [DISCR_TREE if null] & content VAL */ melt_ptr_t meltgc_new_tree (meltobject_ptr_t discr_p, tree val); /* return the content of a boxed tree */ static inline tree melt_tree_content (melt_ptr_t box) { struct melttree_st* tr = (struct melttree_st*)box; if (!tr || tr->discr->object_magic != OBMAG_TREE) return NULL; return tr->val; } /* allocate a new boxed gimple of given DISCR [DISCR_GIMPLE if null] & content VAL */ melt_ptr_t meltgc_new_gimple (meltobject_ptr_t discr_p, gimple val); /* return the content of a boxed gimple */ static inline gimple melt_gimple_content (melt_ptr_t box) { struct meltgimple_st* g = (struct meltgimple_st*)box; if (!g || g->discr->object_magic != OBMAG_GIMPLE) return NULL; return g->val; } /* allocate a new boxed gimpleseq of given DISCR [DISCR_GIMPLESEQ if null] & content VAL */ melt_ptr_t meltgc_new_gimpleseq (meltobject_ptr_t discr_p, gimple_seq val); /* return the content of a boxed gimple */ static inline gimple_seq melt_gimpleseq_content (melt_ptr_t box) { struct meltgimpleseq_st* g = (struct meltgimpleseq_st*)box; if (!g || g->discr->object_magic != OBMAG_GIMPLESEQ) return NULL; return g->val; } /* allocate a new boxed basicblock of given DISCR [DISCR_BASICBLOCK if null] & content VAL */ melt_ptr_t meltgc_new_basicblock (meltobject_ptr_t discr_p, basic_block val); /* return the content of a boxed gimple */ static inline basic_block melt_basicblock_content (melt_ptr_t box) { struct meltbasicblock_st* b = (struct meltbasicblock_st*)box; if (!b || b->discr->object_magic != OBMAG_BASICBLOCK) return NULL; return b->val; } /* return the seq of a boxed basicblock */ static inline gimple_seq melt_basicblock_gimpleseq(melt_ptr_t box) { struct meltbasicblock_st* b = (struct meltbasicblock_st*)box; if (!b || b->discr->object_magic != OBMAG_BASICBLOCK || !b->val) return NULL; return bb_seq(b->val); } /* return the phinodes of a boxed basicblock */ static inline gimple_seq melt_basicblock_phinodes(melt_ptr_t box) { struct meltbasicblock_st* b = (struct meltbasicblock_st*)box; if (!b || b->discr->object_magic != OBMAG_BASICBLOCK || !b->val) return NULL; return phi_nodes(b->val); } /************************************************************* * young generation copying garbage collector * * the young generation is managed specifically by an additional * copying garbage collector, which copies melt_ptr_t data into the * GGC heap from a young region. This requires that every local * variable is known to our copying melt GC. For that purpose, * locals are copied (or used) inside a chain of callframe_melt_st * structures. Since our copying GC change pointers, every allocation * or call may change all the frames. Also stores inside data should * be explicitly managed in a store list * * the young allocation zone is typically of a few megabytes when it * is full, a minor garbage collection occur (and possibly a full GGC * collection afterwards) which changes all the locals *************************************************************/ /* start and end of young allocation zone */ extern void *melt_startalz; extern void *melt_endalz; /* current allocation pointer aligned */ extern char *melt_curalz; /* the store vector grows downward */ extern void **melt_storalz; /* list of specials in the allocation zone */ extern struct meltspecial_st *melt_newspeclist; /* list of specials in the heap */ extern struct meltspecial_st *melt_oldspeclist; /* kilowords allocated since last full collection */ extern unsigned long melt_kilowords_sincefull; /* number of full & any melt garbage collections */ extern unsigned long melt_nb_full_garbcoll; extern unsigned long melt_nb_garbcoll; extern bool melt_prohibit_garbcoll; /* the melt copying garbage collector routine - moves all locals on the stack! */ enum melt_gckind_en { MELT_ONLY_MINOR= 0, MELT_MINOR_OR_FULL = 1, MELT_NEED_FULL = 2}; void melt_garbcoll (size_t wanted, enum melt_gckind_en gckd); /* the alignment */ #if defined(__GNUC__) && !defined(__STRICT_ANSI__) #define MELT_ALIGN (__alignof__(union melt_un)) #define MELT_LIKELY(P) __builtin_expect((P),1) #define MELT_UNLIKELY(P) __builtin_expect((P),0) #else #define MELT_ALIGN (2*sizeof(void*)) #define MELT_LIKELY(P) (P) #define MELT_UNLIKELY(P) (P) #endif static inline bool melt_is_young (const void *const p) { return (const char * const) p >= (const char * const) melt_startalz && (const char * const) p < (const char * const) melt_endalz; } #if ENABLE_CHECKING /* to ease debugging we sometimes want to know when some pointer is allocated: set these variables in the debugger */ static void* tracedptr1; static void* tracedptr2; #endif /* the allocator routine allocates a zone of BASESZ with extra GAP */ static inline void * meltgc_allocate (size_t basesz, size_t gap) { size_t wanted; void *ptr; if (basesz < sizeof (struct meltforward_st)) basesz = sizeof (struct meltforward_st); if ((basesz % MELT_ALIGN) != 0) basesz += (MELT_ALIGN - (basesz % MELT_ALIGN)); if ((gap % MELT_ALIGN) != 0) gap += (MELT_ALIGN - (gap % MELT_ALIGN)); wanted = basesz + gap; gcc_assert (wanted >= sizeof (struct meltforward_st)); if (MELT_UNLIKELY (melt_curalz + wanted + 2 * MELT_ALIGN >= (char *) melt_storalz)) melt_garbcoll (wanted, MELT_MINOR_OR_FULL); ptr = melt_curalz; #if ENABLE_CHECKING if (ptr == tracedptr1) debugeprintf("allocated tracedptr1 %p", ptr); else if (ptr == tracedptr2) debugeprintf("allocated tracedptr2 %p", ptr); #endif melt_curalz += wanted; return ptr; } /* we need sometimes to reserve some wanted size in the allocation zone without actaully using it now; this is needed for the few melt data structures, e.g. meltstrbuf_st, which have some content (e.g. the buffer zone itself bufzn) which should be kept young if the datastructure is young, and should become old (ie. GGC allocated) when it becomes old */ static inline void meltgc_reserve(size_t wanted) { if (wanted < 100*sizeof(void*) + sizeof(struct meltforward_st)) wanted = 100*sizeof(void*) + sizeof(struct meltforward_st); if ((wanted % MELT_ALIGN) != 0) wanted += (MELT_ALIGN - (wanted % MELT_ALIGN)); if (MELT_UNLIKELY (melt_curalz + wanted + 2 * MELT_ALIGN >= (char *) melt_storalz)) melt_garbcoll (wanted, MELT_MINOR_OR_FULL); } /* we need a function to detect failure in reserved allocation; this melt_reserved_allocation_failure function should never be called; we do not want to use fatal_error which requires toplev.h inclusion; never call this function outside of melt_allocatereserved */ void melt_reserved_allocation_failure(long siz); /* allocates a previously reserved zone of BASESZ with extra GAP; this should never trigger the GC, because space was reserved earlier */ static inline void * melt_allocatereserved (size_t basesz, size_t gap) { size_t wanted; void *ptr; if (basesz < sizeof (struct meltforward_st)) basesz = sizeof (struct meltforward_st); if ((basesz % MELT_ALIGN) != 0) basesz += (MELT_ALIGN - (basesz % MELT_ALIGN)); if ((gap % MELT_ALIGN) != 0) gap += (MELT_ALIGN - (gap % MELT_ALIGN)); wanted = basesz + gap; gcc_assert (wanted >= sizeof (struct meltforward_st)); if (MELT_UNLIKELY (melt_curalz + wanted + 2 * MELT_ALIGN >= (char *) melt_storalz)) /* this should never happen */ melt_reserved_allocation_failure((long) wanted); ptr = melt_curalz; #if ENABLE_CHECKING if (ptr == tracedptr1) debugeprintf("allocated tracedptr1 %p", ptr); else if (ptr == tracedptr2) debugeprintf("allocated tracedptr2 %p", ptr); #endif melt_curalz += wanted; return ptr; } /* we maintain a small cache hasharray of touched values - the touched cache size should be a small prime */ #define MELT_TOUCHED_CACHE_SIZE 17 extern void *melt_touched_cache[MELT_TOUCHED_CACHE_SIZE]; /* the touching routine should be called on every melt value which has been touched (by mutating one of its internal pointers) - it may add the touched value to the store "array" and may trigger our melt copying garbage collector */ static inline void meltgc_touch (void *touchedptr) { /* we know that this may loose -eg on some 64bits hosts- some highend bits of the pointer but we don't care, since the 32 lowest bits are enough (as hash); we need a double cast to avoid a warning */ unsigned pad = (unsigned) (HOST_WIDE_INT) touchedptr; if ((char *) touchedptr >= (char *) melt_startalz && (char *) touchedptr <= (char *) melt_endalz) return; pad = pad % (unsigned) MELT_TOUCHED_CACHE_SIZE; if (melt_touched_cache[pad] == touchedptr) return; *melt_storalz = touchedptr; melt_storalz--; melt_touched_cache[pad] = touchedptr; if (MELT_UNLIKELY ((char *) ((void **) melt_storalz - 3) <= (char *) melt_curalz)) melt_garbcoll (1024 * sizeof (void *) + ((char *) melt_endalz - (char *) melt_storalz), MELT_MINOR_OR_FULL); } /* we can avoid the hassle of adding a touched pointer to the store list if we know that the newly added pointer inside does not point into the new allocation zone; TOUCHEDPTR is the mutated value and DSTPTR is the newly added pointer insided */ static inline void meltgc_touch_dest (void *touchedptr, void *destptr) { /* if we add an old pointer we don't care */ if (!melt_is_young(destptr)) return; meltgc_touch (touchedptr); } /* low level map routines */ /*** * allocation routines that may trigger a garbage collection * (their name starts with meltgc) ***/ /* allocate a boxed long integer (or null if bad DISCR) fillen with NUM */ melt_ptr_t meltgc_new_int (meltobject_ptr_t discr, long num); static inline long melt_get_int (melt_ptr_t v) { switch (melt_magic_discr (v)) { case OBMAG_INT: return ((struct meltint_st *) (v))->val; case OBMAG_MIXINT: return ((struct meltmixint_st *) (v))->intval; case OBMAG_MIXLOC: return ((struct meltmixloc_st *) (v))->intval; case OBMAG_OBJECT: return ((meltobject_ptr_t) (v))->obj_num; default: return 0; } } static inline long melt_obj_hash (melt_ptr_t v) { if (melt_magic_discr (v) == OBMAG_OBJECT) return ((meltobject_ptr_t) (v))->obj_hash; return 0; } static inline unsigned long melt_obj_serial (melt_ptr_t v) { #if ENABLE_CHECKING if (melt_magic_discr (v) == OBMAG_OBJECT) return ((meltobject_ptr_t) (v))->obj_serial; #endif return 0; } static inline long melt_obj_len (melt_ptr_t v) { if (melt_magic_discr (v) == OBMAG_OBJECT) return ((meltobject_ptr_t) (v))->obj_len; return 0; } static inline long melt_obj_num (melt_ptr_t v) { if (melt_magic_discr (v) == OBMAG_OBJECT) return ((meltobject_ptr_t) (v))->obj_num; return 0; } /* safe integer div & mod */ static inline long melt_idiv (long i, long j) { return (j != 0) ? (i / j) : 0; } static inline long melt_imod (long i, long j) { return (j != 0) ? (i % j) : 0; } /* allocate a boxed mixed integer & value) */ melt_ptr_t meltgc_new_mixint (meltobject_ptr_t discr_p, melt_ptr_t val_p, long num); /* allocate a boxed mixed location */ melt_ptr_t meltgc_new_mixloc (meltobject_ptr_t discr_p, melt_ptr_t val_p, long num, location_t loc); /* get the boxed value of a mixint */ static inline melt_ptr_t melt_val_mixint (melt_ptr_t mix) { struct meltmixint_st *smix = (struct meltmixint_st *) mix; if (melt_magic_discr (mix) == OBMAG_MIXINT) return smix->ptrval; return NULL; } /* get the boxed value of a mixbigint */ static inline melt_ptr_t melt_val_mixbigint (melt_ptr_t mix) { struct meltmixbigint_st *smix = (struct meltmixbigint_st *) mix; if (melt_magic_discr (mix) == OBMAG_MIXBIGINT) return smix->ptrval; return NULL; } static inline long melt_num_mixint (melt_ptr_t mix) { struct meltmixint_st *smix = (struct meltmixint_st *) mix; if (melt_magic_discr (mix) == OBMAG_MIXINT) return smix->intval; return 0; } static inline long melt_num_mixloc (melt_ptr_t mix) { struct meltmixloc_st *smix = (struct meltmixloc_st *) mix; if (melt_magic_discr (mix) == OBMAG_MIXLOC) return smix->intval; return 0; } static inline melt_ptr_t melt_val_mixloc (melt_ptr_t mix) { struct meltmixloc_st *smix = (struct meltmixloc_st *) mix; if (melt_magic_discr (mix) == OBMAG_MIXLOC) return smix->ptrval; return NULL; } static inline location_t melt_location_mixloc (melt_ptr_t mix) { struct meltmixloc_st *smix = (struct meltmixloc_st *) mix; if (melt_magic_discr (mix) == OBMAG_MIXLOC) return smix->locval; return (location_t)UNKNOWN_LOCATION; } /* allocate a mixbigint from a GMP biginteger */ melt_ptr_t meltgc_new_mixbigint_mpz (meltobject_ptr_t discr_p, melt_ptr_t val_p, mpz_t mp); /* fill an mpz from a mixbigint and return true iff ok */ static inline bool melt_fill_mpz_from_mixbigint(melt_ptr_t mix, mpz_t mp) { struct meltmixbigint_st *bmix = (struct meltmixbigint_st *) mix; if (!bmix || !mp || melt_magic_discr (mix) != OBMAG_MIXBIGINT) return false; mpz_import (mp, bmix->biglen, /*most significant word first*/ 1, sizeof(bmix->tabig[0]), /*native endian*/ 0, /*no nails bits*/0, bmix->tabig); return true; } /* get (safely) the nth (counting from 0) field of an object */ static inline melt_ptr_t melt_field_object (melt_ptr_t ob, unsigned off) { if (melt_magic_discr (ob) == OBMAG_OBJECT) { meltobject_ptr_t pob = (meltobject_ptr_t) ob; if (off < pob->obj_len) return pob->obj_vartab[off]; }; return NULL; } /* allocate a new raw object of given KLASS (unchecked) with LEN slots */ meltobject_ptr_t meltgc_new_raw_object (meltobject_ptr_t klass_p, unsigned len); /* melt diagnostic routine */ void melt_error_str(melt_ptr_t mixloc_p, const char* msg, melt_ptr_t str_p); void melt_warning_str(int opt, melt_ptr_t mixloc_p, const char* msg, melt_ptr_t str_p); void melt_inform_str(melt_ptr_t mixloc_p, const char* msg, melt_ptr_t str_p); int* melt_dynobjstruct_fieldoffset_at(const char*fldnam, const char*fil, int lin); int* melt_dynobjstruct_classlength_at(const char*clanam, const char* fil, int lin); #if MELTGCC_DYNAMIC_OBJSTRUCT static inline melt_ptr_t melt_dynobjstruct_getfield_object_at (melt_ptr_t ob, unsigned off, const char*fldnam, const char*fil, int lin, int**poff) { unsigned origoff = off; if (poff && !*poff) *poff = melt_dynobjstruct_fieldoffset_at(fldnam, fil, lin); if (melt_magic_discr (ob) == OBMAG_OBJECT) { meltobject_ptr_t pob = (meltobject_ptr_t) ob; if (poff && *poff) off = **poff; if (off < pob->obj_len) return pob->obj_vartab[off]; error ("checked dynamic field access failed (bad offset %d/%d/%d [%s:%d]) - %s", (int)off, (int)pob->obj_len, (int)origoff, fil, lin, fldnam?fldnam:"..."); return NULL; } error ("checked dynamic field access failed (not object [%s:%d]) - %s", fil, lin, fldnam?fldnam:"..."); return NULL; } #define melt_object_get_field_at(Slot,Obj,Off,Fldnam,Fil,Lin) do { \ static int *offptr_##Lin; \ Slot = \ melt_dynobjstruct_getfield_object_at((melt_ptr_t)(Obj), \ (Off),Fldnam,Fil,Lin, \ &offptr_##Lin); \ } while(0) #define melt_object_get_field(Slot,Obj,Off,Fldnam) \ melt_object_get_field_at(Slot,Obj,Off,Fldnam,__FILE__,__LINE__) #define melt_getfield_object(Obj,Off,Fldnam) \ melt_dynobjstruct_getfield_object_at((melt_ptr_t)(Obj), \ (Off),Fldnam,__FILE__, \ __LINE__, \ (int**)0) static inline void melt_dynobjstruct_putfield_object_at(melt_ptr_t ob, unsigned off, melt_ptr_t val, const char*fldnam, const char*fil, int lin, int**poff) { unsigned origoff = off; if (poff && !*poff) *poff = melt_dynobjstruct_fieldoffset_at(fldnam, fil, lin); if (melt_magic_discr (ob) == OBMAG_OBJECT) { meltobject_ptr_t pob = (meltobject_ptr_t) ob; if (poff && *poff) off = **poff; if (off < pob->obj_len) { pob->obj_vartab[off] = val; return; } error ("checked dynamic field put failed (bad offset %d/%d/%d [%s:%d]) - %s", (int)off, (int)pob->obj_len, (int)origoff, fil, lin, fldnam?fldnam:"..."); return; } error ("checked dynamic field put failed (not object [%s:%d]) - %s", fil, lin, fldnam?fldnam:"..."); } #define melt_putfield_object_at(Obj,Off,Val,Fldnam,Fil,Lin) do { \ static int* ptroff_##Lin; \ melt_dynobjstruct_putfield_object_at((melt_ptr_t)(Obj), \ (Off), \ (melt_ptr_t)(Val),Fldnam, \ Fil,Lin, \ &ptroff_##Lin); } while(0) #define melt_putfield_object(Obj,Off,Val,Fldnam) \ melt_putfield_object_at(Obj,Off,Val,Fldnam,__FILE__,__LINE__) static inline melt_ptr_t melt_dynobjstruct_make_raw_object(melt_ptr_t klas, int len, const char*clanam, const char*fil, int lin, int**pptr) { if (pptr && !*pptr) *pptr = melt_dynobjstruct_classlength_at(clanam,fil,lin); if (pptr && *pptr) len = **pptr; return (melt_ptr_t)meltgc_new_raw_object((meltobject_ptr_t)klas,len); } #define melt_raw_object_create_at(Newobj,Klas,Len,Clanam,Fil,Lin) do { \ static int* ptrlen_##Lin; \ Newobj = \ melt_dynobjstruct_make_raw_object((Klas),(Len), \ Clanam,Fil,Lin, \ &ptrlen_##Lin); } while(0) #define melt_raw_object_create(Newobj,Klas,Len,Clanam) \ melt_raw_object_create_at(Newobj,Klas,Len,Clanam,__FILE__,__LINE__) #define melt_make_raw_object(Klas,Len,Clanam) \ melt_dynobjstruct_make_raw_object((Klas),(Len), \ Clanam, __FILE__, __LINE__, \ (int**)0) #elif ENABLE_CHECKING static inline melt_ptr_t melt_getfield_object_at (melt_ptr_t ob, unsigned off, const char*msg, const char*fil, int lin) { unsigned origoff = off; if (melt_magic_discr (ob) == OBMAG_OBJECT) { meltobject_ptr_t pob = (meltobject_ptr_t) ob; if (off < pob->obj_len) return pob->obj_vartab[off]; error ("checked field access failed (bad offset %d/%d/%d [%s:%d]) - %s", (int)off, (int)pob->obj_len, (int)origoff, fil, lin, msg?msg:"..."); return NULL; } error ("checked field access failed (not object [%s:%d]) - %s", fil, lin, msg?msg:"..."); return NULL; } static inline void melt_putfield_object_at(melt_ptr_t ob, unsigned off, melt_ptr_t val, const char*msg, const char*fil, int lin) { if (melt_magic_discr (ob) == OBMAG_OBJECT) { meltobject_ptr_t pob = (meltobject_ptr_t) ob; if (off < pob->obj_len) { pob->obj_vartab[off] = val; return; } fatal_error("checked field put failed (bad offset %d/%d [%s:%d]) - %s", (int)off, (int)pob->obj_len, fil, lin, msg?msg:"..."); } fatal_error("checked field put failed (not object [%s:%d]) - %s", fil, lin, msg?msg:"..."); } static inline melt_ptr_t melt_make_raw_object(melt_ptr_t klas, int len, const char*clanam) { gcc_assert(clanam != NULL); return (melt_ptr_t)meltgc_new_raw_object((meltobject_ptr_t)klas,len); } #define melt_raw_object_create(Newobj,Klas,Len,Clanam) do { \ Newobj = melt_make_raw_object(Klas,Len,Clanam); } while(0) #define melt_getfield_object(Obj,Off,Fldnam) melt_getfield_object_at((melt_ptr_t)(Obj),(Off),(Fldnam),__FILE__,__LINE__) #define melt_object_get_field(Slot,Obj,Off,Fldnam) do { \ Slot = melt_getfield_object(Obj,Off,Fldnam);} while(0) #define melt_putfield_object(Obj,Off,Val,Fldnam) melt_putfield_object_at((melt_ptr_t)(Obj),(Off),(melt_ptr_t)(Val),(Fldnam),__FILE__,__LINE__) #else #define melt_getfield_object(Obj,Off,Fldnam) (((meltobject_ptr_t)(Obj))->obj_vartab[Off]) #define melt_object_get_field(Slot,Obj,Off,Fldnam) do { \ Slot = melt_getfield_object(Obj,Off,Fldnam);} while(0) #define melt_putfield_object(Obj,Off,Val,Fldnam) do { \ ((meltobject_ptr_t)(Obj))->obj_vartab[Off] = (melt_ptr_t)(Val); \ }while(0) #define melt_make_raw_object(Klas,Len) ((melt_ptr_t)meltgc_new_raw_object(Klas,Len)) #define melt_raw_object_create(Newobj,Klas,Len,Clanam) do { \ Newobj = melt_make_raw_object(Klas,Len,Clanam); } while(0) #endif /* get (safely) the length of an object */ static inline int melt_object_length (melt_ptr_t ob) { if (melt_magic_discr (ob) == OBMAG_OBJECT) { meltobject_ptr_t pob = (meltobject_ptr_t) ob; return pob->obj_len; } return 0; } /* get safely the nth field of an object or NULL */ static inline melt_ptr_t melt_object_nth_field(melt_ptr_t ob, int rk) { if (melt_magic_discr (ob) == OBMAG_OBJECT) { meltobject_ptr_t pob = (meltobject_ptr_t) ob; if (rk<0) rk += pob->obj_len; if (rk>=0 && rkobj_len) return (melt_ptr_t)(pob->obj_vartab[rk]); } return NULL; } /* allocate a new string (or null if bad DISCR or null STR) initialized from _static_ (non gc-ed) memory STR with len SLEN or strlen(STR) if <0 */ melt_ptr_t meltgc_new_string_raw_len (meltobject_ptr_t discr, const char *str, int slen); /* allocate a new string (or null if bad DISCR or null STR) initialized from _static_ (non gc-ed) memory STR */ melt_ptr_t meltgc_new_string (meltobject_ptr_t discr, const char *str); /* allocate a new string (or null if bad DISCR or null STR) initialized from a memory STR which is temporarily duplicated (so can be in gc-ed) */ melt_ptr_t meltgc_new_stringdup (meltobject_ptr_t discr, const char *str); /* get the naked basename of a path, ie from "/foo/bar.gyz" return "bar"; argument is duplicated */ melt_ptr_t meltgc_new_string_nakedbasename (meltobject_ptr_t discr, const char *str); /* get the basename of a path inside the temporary directory with an optional suffix */ melt_ptr_t meltgc_new_string_tempname_suffixed (meltobject_ptr_t discr, const char *namstr, const char*suffix); /* split a [raw] string into a list of strings using a seperator. */ melt_ptr_t meltgc_new_split_string (const char*str, int sep, melt_ptr_t discr); static inline const char * melt_string_str (melt_ptr_t v) { if (melt_magic_discr (v) == OBMAG_STRING) return ((struct meltstring_st *) v)->val; return 0; } static inline int melt_string_length (melt_ptr_t v) { if (melt_magic_discr (v) == OBMAG_STRING) return strlen(((struct meltstring_st *) v)->val); return 0; } static inline bool melt_string_same (melt_ptr_t v1, melt_ptr_t v2) { if (melt_magic_discr (v1) == OBMAG_STRING && melt_magic_discr (v2) == OBMAG_STRING) { return 0 == strcmp (((struct meltstring_st *) v1)->val, ((struct meltstring_st *) v2)->val); } return 0; } static inline bool melt_string_less (melt_ptr_t v1, melt_ptr_t v2) { if (melt_magic_discr (v1) == OBMAG_STRING && melt_magic_discr (v2) == OBMAG_STRING) { return strcmp (((struct meltstring_st *) v1)->val, ((struct meltstring_st *) v2)->val) < 0; } return 0; } static inline bool melt_is_string_const (melt_ptr_t v, const char *s) { if (s && melt_magic_discr (v) == OBMAG_STRING) return 0 == strcmp (((struct meltstring_st *) v)->val, s); return 0; } static inline const char * melt_strbuf_str (melt_ptr_t v) { if (melt_magic_discr (v) == OBMAG_STRBUF) { struct meltstrbuf_st *sb = (struct meltstrbuf_st*) v; if (sb->bufend >= sb->bufstart) return sb->bufzn + sb->bufstart; } return 0; } static inline int melt_strbuf_usedlength(melt_ptr_t v) { if (melt_magic_discr (v) == OBMAG_STRBUF) { struct meltstrbuf_st *sb = (struct meltstrbuf_st *) v; if (sb->bufend >= sb->bufstart) return sb->bufend - sb->bufstart; } return 0; } /* output an strbuf into a file */ void melt_output_strbuf_to_file (melt_ptr_t sbuf, const char*filnam); /* allocate a pair of given head and tail */ melt_ptr_t meltgc_new_pair (meltobject_ptr_t discr, void *head, void *tail); /* change the head of a pair */ void meltgc_pair_set_head(melt_ptr_t pair, void* head); /* allocate a new multiple of given DISCR & length LEN */ melt_ptr_t meltgc_new_multiple (meltobject_ptr_t discr_p, unsigned len); /* make a subsequence of a given multiple OLDMUL_P from STARTIX to ENDIX; if either index is negative, take it from last. return null if arguments are incorrect, or a fresh subsequence of same discriminant as source otherwise */ melt_ptr_t meltgc_new_subseq_multiple (melt_ptr_t oldmul_p, int startix, int endix); /* allocate a multiple of arity 1 */ melt_ptr_t meltgc_new_mult1 (meltobject_ptr_t discr_p, melt_ptr_t v0_p); /* allocate a multiple of arity 2 */ melt_ptr_t meltgc_new_mult2 (meltobject_ptr_t discr_p, melt_ptr_t v0_p, melt_ptr_t v1_p); /* allocate a multiple of arity 3 */ melt_ptr_t meltgc_new_mult3 (meltobject_ptr_t discr_p, melt_ptr_t v0_p, melt_ptr_t v1_p, melt_ptr_t v2_p); /* allocate a multiple of arity 4 */ melt_ptr_t meltgc_new_mult4 (meltobject_ptr_t discr_p, melt_ptr_t v0_p, melt_ptr_t v1_p, melt_ptr_t v2_p, melt_ptr_t v3_p); /* allocate a multiple of arity 5 */ melt_ptr_t meltgc_new_mult5 (meltobject_ptr_t discr_p, melt_ptr_t v0_p, melt_ptr_t v1_p, melt_ptr_t v2_p, melt_ptr_t v3_p, melt_ptr_t v4_p); /* allocate a multiple of arity 6 */ melt_ptr_t meltgc_new_mult6 (meltobject_ptr_t discr_p, melt_ptr_t v0_p, melt_ptr_t v1_p, melt_ptr_t v2_p, melt_ptr_t v3_p, melt_ptr_t v4_p, melt_ptr_t v5_p); /* allocate a multiple of arity 7 */ melt_ptr_t meltgc_new_mult7 (meltobject_ptr_t discr_p, melt_ptr_t v0_p, melt_ptr_t v1_p, melt_ptr_t v2_p, melt_ptr_t v3_p, melt_ptr_t v4_p, melt_ptr_t v5_p, melt_ptr_t v6_p); /* allocate a new (empty) list */ melt_ptr_t meltgc_new_list (meltobject_ptr_t discr_p); /* append to the tail of a list */ void meltgc_append_list (melt_ptr_t list_p, melt_ptr_t val_p); /* prepend to the head of a list */ void meltgc_prepend_list (melt_ptr_t list_p, melt_ptr_t val_p); /* pop from head of list (and remove) */ melt_ptr_t meltgc_popfirst_list (melt_ptr_t list_p); /* return the length of a list, 0 for nil, or -1 iff non list */ int melt_list_length (melt_ptr_t list_p); /* allocate e new empty mapobjects */ melt_ptr_t meltgc_new_mapobjects (meltobject_ptr_t discr_p, unsigned len); /* put into a mapobjects */ void meltgc_put_mapobjects (meltmapobjects_ptr_t mapobject_p, meltobject_ptr_t attrobject_p, melt_ptr_t valu_p); /* get from a mapobject */ melt_ptr_t melt_get_mapobjects (meltmapobjects_ptr_t mapobject_p, meltobject_ptr_t attrobject_p); /* remove from a mapobject (return the removed value) */ melt_ptr_t meltgc_remove_mapobjects (meltmapobjects_ptr_t mapobject_p, meltobject_ptr_t attrobject_p); static inline int melt_size_mapobjects (meltmapobjects_ptr_t mapobject_p) { if (!mapobject_p || mapobject_p->discr->obj_num != OBMAG_MAPOBJECTS) return 0; return melt_primtab[mapobject_p->lenix]; } static inline unsigned melt_count_mapobjects (meltmapobjects_ptr_t mapobject_p) { if (!mapobject_p || mapobject_p->discr->obj_num != OBMAG_MAPOBJECTS) return 0; return mapobject_p->count; } static inline meltobject_ptr_t melt_nthattr_mapobjects (meltmapobjects_ptr_t mapobject_p, int ix) { meltobject_ptr_t at = 0; if (!mapobject_p || mapobject_p->discr->obj_num != OBMAG_MAPOBJECTS) return 0; if (ix < 0 || ix >= melt_primtab[mapobject_p->lenix]) return 0; at = mapobject_p->entab[ix].e_at; if ((void *) at == (void *) HTAB_DELETED_ENTRY) return 0; return at; } static inline melt_ptr_t melt_nthval_mapobjects (meltmapobjects_ptr_t mapobject_p, int ix) { meltobject_ptr_t at = 0; if (!mapobject_p || mapobject_p->discr->obj_num != OBMAG_MAPOBJECTS) return 0; if (ix < 0 || ix >= melt_primtab[mapobject_p->lenix]) return 0; at = mapobject_p->entab[ix].e_at; if ((void *) at == (void *) HTAB_DELETED_ENTRY) return 0; return mapobject_p->entab[ix].e_va; } /* allocate a new empty mapstrings */ melt_ptr_t meltgc_new_mapstrings (meltobject_ptr_t discr_p, unsigned len); /* put into a mapstrings, the string is copied so can be in the gc-ed heap */ void meltgc_put_mapstrings (struct meltmapstrings_st *mapstring_p, const char *str, melt_ptr_t valu_p); /* get from a mapstring */ melt_ptr_t melt_get_mapstrings (struct meltmapstrings_st *mapstring_p, const char *attr); /* remove from a mapstring (return the removed value) */ melt_ptr_t meltgc_remove_mapstrings (struct meltmapstrings_st *mapstring_p, const char *str); static inline int melt_size_mapstrings (struct meltmapstrings_st *mapstring_p) { if (!mapstring_p || mapstring_p->discr->obj_num != OBMAG_MAPSTRINGS) return 0; return melt_primtab[mapstring_p->lenix]; } static inline unsigned melt_count_mapstrings (struct meltmapstrings_st *mapstring_p) { if (!mapstring_p || mapstring_p->discr->obj_num != OBMAG_MAPSTRINGS) return 0; return mapstring_p->count; } static inline const char * melt_nthattrraw_mapstrings (struct meltmapstrings_st *mapstring_p, int ix) { const char *at = 0; if (!mapstring_p || mapstring_p->discr->obj_num != OBMAG_MAPSTRINGS) return 0; if (ix < 0 || ix >= melt_primtab[mapstring_p->lenix]) return 0; at = mapstring_p->entab[ix].e_at; if ((const void *) at == (const void *) HTAB_DELETED_ENTRY) return 0; return at; } static inline melt_ptr_t melt_nthval_mapstrings (struct meltmapstrings_st *mapstring_p, int ix) { const char *at = 0; if (!mapstring_p || mapstring_p->discr->obj_num != OBMAG_MAPSTRINGS) return 0; if (ix < 0 || ix >= melt_primtab[mapstring_p->lenix]) return 0; at = mapstring_p->entab[ix].e_at; if ((const void *) at == (const void *) HTAB_DELETED_ENTRY) return 0; return mapstring_p->entab[ix].e_va; } /* allocate a new routine object of given DISCR and of length LEN, with a DESCR-iptive string a a PROC-edure */ meltroutine_ptr_t meltgc_new_routine (meltobject_ptr_t discr_p, unsigned len, const char *descr, meltroutfun_t * proc); void meltgc_set_routine_data(melt_ptr_t rout_p, melt_ptr_t data_p); static inline melt_ptr_t melt_routine_data(melt_ptr_t rout) { if (rout && ((meltroutine_ptr_t) rout)->discr->obj_num == OBMAG_ROUTINE) return ((meltroutine_ptr_t) rout)->routdata; return NULL; } static inline char * melt_routine_descrstr (melt_ptr_t rout) { if (rout && ((meltroutine_ptr_t) rout)->discr->obj_num == OBMAG_ROUTINE) return ((meltroutine_ptr_t) rout)->routdescr; return (char *) 0; } static inline int melt_routine_size (melt_ptr_t rout) { if (rout && ((meltroutine_ptr_t) rout)->discr->obj_num == OBMAG_ROUTINE) return ((meltroutine_ptr_t) rout)->nbval; return 0; } static inline melt_ptr_t melt_routine_nth (melt_ptr_t rout, int ix) { if (rout && ((meltroutine_ptr_t) rout)->discr->obj_num == OBMAG_ROUTINE) if (ix >= 0 && ix < (int) ((meltroutine_ptr_t) rout)->nbval) return ((meltroutine_ptr_t) rout)->tabval[ix]; return 0; } /*********/ /* allocate a new closure of given DISCR with a given ROUT, and of length LEN */ meltclosure_ptr_t meltgc_new_closure (meltobject_ptr_t discr_p, meltroutine_ptr_t rout_p, unsigned len); static inline int melt_closure_size (melt_ptr_t clo) { if (clo && ((meltclosure_ptr_t) clo)->discr->obj_num == OBMAG_CLOSURE) return ((meltclosure_ptr_t) clo)->nbval; return 0; } static inline melt_ptr_t melt_closure_routine (melt_ptr_t clo) { if (clo && ((meltclosure_ptr_t) clo)->discr->obj_num == OBMAG_CLOSURE) return (melt_ptr_t) (((meltclosure_ptr_t) clo)->rout); return 0; } static inline melt_ptr_t melt_closure_nth (melt_ptr_t clo, int ix) { if (clo && ((meltclosure_ptr_t) clo)->discr->obj_num == OBMAG_CLOSURE && ix >= 0 && ix < (int) (((meltclosure_ptr_t) clo)->nbval)) return (melt_ptr_t) (((meltclosure_ptr_t) clo)->tabval[ix]); return 0; } /***** list and pairs accessors ****/ /* safe pair head & tail accessors */ static inline melt_ptr_t melt_pair_head (melt_ptr_t pair) { if (pair && ((struct meltpair_st *) pair)->discr->obj_num == OBMAG_PAIR) return ((struct meltpair_st *) pair)->hd; return 0; } static inline melt_ptr_t melt_pair_tail (melt_ptr_t pair) { if (pair && ((struct meltpair_st *) pair)->discr->obj_num == OBMAG_PAIR) return (melt_ptr_t) (((struct meltpair_st *) pair)->tl); return 0; } /* compute the length of a pairlist */ static inline long melt_pair_listlength (melt_ptr_t pair) { long l = 0; while (pair && ((struct meltpair_st *) pair)->discr->obj_num == OBMAG_PAIR) { l++; pair = (melt_ptr_t) (((struct meltpair_st *) pair)->tl); }; return l; } static inline melt_ptr_t melt_list_first (melt_ptr_t lis) { if (lis && ((struct meltlist_st *) lis)->discr->obj_num == OBMAG_LIST) return (melt_ptr_t) (((struct meltlist_st *) lis)->first); return NULL; } static inline melt_ptr_t melt_list_last (melt_ptr_t lis) { if (lis && ((struct meltlist_st *) lis)->discr->obj_num == OBMAG_LIST) return (melt_ptr_t) (((struct meltlist_st *) lis)->last); return NULL; } /***** STRBUF ie string buffers *****/ /* allocate a new strbuf of given DISCR with initial content STR */ struct meltstrbuf_st *meltgc_new_strbuf (meltobject_ptr_t discr_p, const char *str); /**** Output routines can go into a boxed strbuf or a boxed file ****/ /* add into OUT (a boxed STRBUF or a boxed FILE) the static string STR (which is not in the melt heap) */ void meltgc_add_out_raw (melt_ptr_t outbuf_p, const char *str); #define meltgc_add_strbuf_raw(Out,Str) meltgc_add_out_raw((Out),(Str)) /* add into OUT (a boxed STRBUF or a boxed FILE) the static string STR (which is not in the melt heap) of length SLEN or strlen(STR) if SLEN<0 */ void meltgc_add_out_raw_len (melt_ptr_t outbuf_p, const char *str, int slen); #define meltgc_add_strbuf_raw_len(Out,Str,Len) meltgc_add_out_raw_len((Out),(Str),(Len)) /* add safely into OUTBUF the string STR (which is first copied, so can be in the melt heap) */ void meltgc_add_out (melt_ptr_t outbuf_p, const char *str); #define meltgc_add_strbuf(Out,Str) meltgc_add_out((Out),(Str)) /* add safely into OUTBUF the string STR encoded as a C string with backslash escapes */ void meltgc_add_out_cstr (melt_ptr_t outbuf_p, const char *str); #define meltgc_add_strbuf_cstr(Out,Str) meltgc_add_out_cstr(Out,Str) /* add safely into OUTBUF the string STR encoded as the interior of a C comment with slash star and star slash replaced by slash plus and plus slash */ void meltgc_add_out_ccomment (melt_ptr_t outbuf_p, const char *str); #define meltgc_add_strbuf_ccomment(Out,Str) meltgc_add_out_ccomment((Out),(Str)) /* add safely into OUTBUF the string STR (which is copied at first) encoded as a C identifier; ie non-alphanum begine encoded as an underscore */ void meltgc_add_out_cident (melt_ptr_t outbuf_p, const char *str); #define meltgc_add_strbuf_cident(Out,Str) meltgc_add_out_cident((Out),(Str)) /* add safely into OUTBUF the initial prefix of string STR (which is copied at first), with a length of at most PREFLEN encoded as a C identifier; ie non-alphanum begine encoded as an underscore */ void meltgc_add_out_cidentprefix (melt_ptr_t strbuf_p, const char *str, int preflen); #define meltgc_add_strbuf_cidentprefix(Out,Str,Pln) meltgc_add_out_cidentprefix((Out),(Str),(Pln)) /* add safely into OUTBUF the hex encoded number L */ void meltgc_add_out_hex (melt_ptr_t outbuf_p, unsigned long l); #define meltgc_add_strbuf_hex(Out,L) meltgc_add_out_hex((Out),(L)) /* add safely into OUTBUF the decimal encoded number L */ void meltgc_add_out_dec (melt_ptr_t outbuf_p, long l); #define meltgc_add_strbuf_dec(Out,L) meltgc_add_out_dec((Out),(L)) /* add safely into OUTBUF a printf like stuff with FMT */ void meltgc_out_printf (melt_ptr_t outbuf_p, const char *fmt, ...) ATTRIBUTE_PRINTF (2, 3); /* don't bother using CPP varargs */ #define meltgc_strbuf_printf meltgc_out_printf /* add safely into OUTBUF either a space or an indented newline if the current line is bigger than the threshold */ void meltgc_out_add_indent (melt_ptr_t strbuf_p, int indeptn, int linethresh); #define meltgc_strbuf_add_indent(Out,I,L) meltgc_out_add_indent ((Out),(I),(L)) /* pretty print into OUTBUF a gimple */ void meltgc_ppout_gimple(melt_ptr_t outbuf_p, int indentsp, gimple gstmt); #define meltgc_ppstrbuf_gimple(Out,I,G) meltgc_ppout_gimple ((Out), (I), (G)) /* pretty print into an OUTBUF a gimple seq */ void meltgc_ppout_gimple_seq(melt_ptr_t outbuf_p, int indentsp, gimple_seq gseq); #define meltgc_ppstrbuf_gimple_seq(Out,I,G) meltgc_ppout_gimple_seq ((Out), (I), (G)) /* pretty print into an OUTBUF a tree */ void meltgc_ppout_tree(melt_ptr_t outbuf_p, int indentsp, tree tr); #define meltgc_ppstrbuf_tree(Out,I,T) meltgc_ppout_tree ((Out), (I), (T)) /* pretty print into an outbuf a basic_block */ void meltgc_ppout_basicblock(melt_ptr_t out_p, int indentsp, basic_block bb); #define meltgc_ppstrbuf_basicblock(Out,I,BB) meltgc_ppout_basicblock ((Out),(I),(BB)) /* pretty print into an outbuf a multiprecision integer */ void meltgc_ppout_mpz(melt_ptr_t out_p, int indentsp, mpz_t mp); #define meltgc_ppstrbuf_mpz(O,I,M) meltgc_ppout_mpz((O), (I), (M)) /* pretty print into an outbuf the mpz of a MELT bigint; do nothing if big_p is not a MELT bigint */ void meltgc_ppout_mixbigint(melt_ptr_t out_p, int indentsp, melt_ptr_t big_p); #define meltgc_ppstrbuf_mixbigint(O,I,B) meltgc_ppout_mixbigint ((O), (I), (B)) /***************** PASS MANAGEMENT ****************/ /* register a Melt pass PASS; there is no way to unregister it, and the opt_pass and plugin_pass used internally are never deallocated. The POSITIONING is one of the strings "after" "before" "replace" The REFPASSNAME is the name of the existing reference pass The REFPASSNUMBER is the number of the reference pass or 0 for all. Non-simple IPA passes are not yet implemented! */ void meltgc_register_pass (melt_ptr_t pass_p, const char* positioning, const char*refpassname, int refpassnum); /*** allocate a boxed file ***/ melt_ptr_t meltgc_new_file(melt_ptr_t discr_p, FILE* fil); /***************** PARMA POLYHEDRA LIBRARY ****************/ enum { MELT_PPL_EMPTY_CONSTRAINT_SYSTEM=0, MELT_PPL_UNSATISFIABLE_CONSTRAINT_SYSTEM }; /* create a new boxed PPL constraint system */ melt_ptr_t meltgc_new_ppl_constraint_system(melt_ptr_t discr_p, bool unsatisfiable); /* box clone an existing PPL constraint system */ melt_ptr_t meltgc_clone_ppl_constraint_system (melt_ptr_t ppl_p); /* make a new boxed PPL linear expression */ melt_ptr_t meltgc_new_ppl_linear_expression(melt_ptr_t discr_p); /* clear any boxed special by appropriately deleting inside */ void melt_clear_special(melt_ptr_t val_p); /** pretty print into a strbuf SBUF_P with indentation INDENTSP the pplvalue PPL_P using the variable name tuple VARNAMVECT_P **/ void meltgc_ppstrbuf_ppl_varnamvect (melt_ptr_t sbuf_p, int indentsp, melt_ptr_t ppl_p, melt_ptr_t varnamvect_p); /* create a new PPL empty constraint system raw stuff */ static inline ppl_Constraint_System_t melt_raw_new_ppl_empty_constraint_system (void) { ppl_Constraint_System_t consys= NULL; if (ppl_new_Constraint_System(&consys)) fatal_error("melt_raw_new_ppl_empty_constraint_system failed"); return consys; } /* create a new PPL unsatisfiable constraint system raw stuff */ static inline ppl_Constraint_System_t melt_raw_new_ppl_unsatisfiable_constraint_system (void) { ppl_Constraint_System_t consys= NULL; if (ppl_new_Constraint_System_zero_dim_empty(&consys)) fatal_error("melt_raw_new_ppl_unsatisfiable_constraint_system failed"); return consys; } /* create a new PPL empty constraint system raw stuff */ static inline ppl_Constraint_System_t melt_raw_clone_ppl_consstraint_system (ppl_Constraint_System_t oldconsys) { ppl_Constraint_System_t consys= NULL; if (ppl_new_Constraint_System_from_Constraint_System(&consys, oldconsys)) fatal_error("melt_raw_clone_ppl_consstraint_system failed"); return consys; } /* utility to make a ppl_Coefficient_t out of a constant tree */ ppl_Coefficient_t melt_make_ppl_coefficient_from_tree (tree tr); /* utility to make a ppl_Coefficient_t from a long number */ ppl_Coefficient_t melt_make_ppl_coefficient_from_long (long l); /* utility to make a ppl_Linear_Expression_t */ ppl_Linear_Expression_t melt_make_ppl_linear_expression (void); /* utility to make a ppl_Constraint ; the constraint type is a string "==" or ">" "<" ">=" "<=" because we don't want enums in MELT... */ ppl_Constraint_t melt_make_ppl_constraint_cstrtype (ppl_Linear_Expression_t liex, const char*constyp); /* insert a raw PPL constraint into a boxed constraint system */ void melt_insert_ppl_constraint_in_boxed_system (ppl_Constraint_t cons, melt_ptr_t ppl_p); /* utility to make a NNC [=not necessarily closed] ppl_Polyhedron_t out of a constraint system */ ppl_Polyhedron_t melt_make_ppl_NNC_Polyhedron_from_Constraint_System (ppl_Constraint_System_t consys); /* make a new boxed PPL polyhedron; if cloned is true, the poly is copied otherwise taken as is */ melt_ptr_t meltgc_new_ppl_polyhedron (melt_ptr_t discr_p, ppl_Polyhedron_t poly, bool cloned); enum { SAME_PPL_POLHYEDRON=0, CLONED_PPL_POLHYEDRON=1 }; /* get the content of a boxed PPL coefficient */ static inline ppl_Coefficient_t melt_ppl_coefficient_content (melt_ptr_t ppl_p) { if (melt_magic_discr(ppl_p) != OBMAG_SPECPPL_COEFFICIENT) return NULL; return ((struct meltspecial_st *)ppl_p)->val.sp_coefficient; } /* put the content of a boxed PPL coefficient */ static inline void melt_ppl_coefficient_put_content(melt_ptr_t ppl_p, ppl_Coefficient_t coef) { if (melt_magic_discr(ppl_p) != OBMAG_SPECPPL_COEFFICIENT) return; ((struct meltspecial_st *)ppl_p)->val.sp_coefficient = coef; } /* get the content of a boxed PPL linear expression */ static inline ppl_Linear_Expression_t melt_ppl_linear_expression_content(melt_ptr_t ppl_p) { if (melt_magic_discr(ppl_p) != OBMAG_SPECPPL_LINEAR_EXPRESSION) return NULL; return ((struct meltspecial_st *)ppl_p)->val.sp_linear_expression; } /* put the content of a boxed PPL linear expression */ static inline void melt_ppl_linear_expression_put_content(melt_ptr_t ppl_p, ppl_Linear_Expression_t liex) { if (melt_magic_discr(ppl_p) != OBMAG_SPECPPL_LINEAR_EXPRESSION) return; ((struct meltspecial_st *)ppl_p)->val.sp_linear_expression = liex; } /* get the content of a boxed PPL constraint */ static inline ppl_Constraint_t melt_ppl_constraint_content(melt_ptr_t ppl_p) { if (melt_magic_discr(ppl_p) != OBMAG_SPECPPL_CONSTRAINT) return NULL; return ((struct meltspecial_st *)ppl_p)->val.sp_constraint; } /* putt the content of a boxed PPL constraint */ static inline void melt_ppl_constraint_put_content(melt_ptr_t ppl_p, ppl_Constraint_t cons) { if (melt_magic_discr(ppl_p) != OBMAG_SPECPPL_CONSTRAINT) return; ((struct meltspecial_st *)ppl_p)->val.sp_constraint = cons; } /* get the content of a boxed PPL constraint system */ static inline ppl_Constraint_System_t melt_ppl_constraint_system_content(melt_ptr_t ppl_p) { if (melt_magic_discr(ppl_p) != OBMAG_SPECPPL_CONSTRAINT_SYSTEM) return NULL; return ((struct meltspecial_st *)ppl_p)->val.sp_constraint_system; } /* put the content of a boxed PPL constraint system */ static inline void melt_ppl_constraint_system_put_content(melt_ptr_t ppl_p, ppl_Constraint_System_t consys) { if (melt_magic_discr(ppl_p) != OBMAG_SPECPPL_CONSTRAINT_SYSTEM) return; ((struct meltspecial_st *)ppl_p)->val.sp_constraint_system = consys; } /* get the content of a boxed PPL generator */ static inline ppl_Generator_t melt_ppl_generator_content(melt_ptr_t ppl_p) { if (melt_magic_discr(ppl_p) != OBMAG_SPECPPL_GENERATOR) return NULL; return ((struct meltspecial_st *)ppl_p)->val.sp_generator; } /* put the content of a boxed PPL generator */ static inline void melt_ppl_generator_put_content(melt_ptr_t ppl_p, ppl_Generator_t gen) { if (melt_magic_discr(ppl_p) != OBMAG_SPECPPL_GENERATOR) return; ((struct meltspecial_st *)ppl_p)->val.sp_generator = gen; } /* get the content of a boxed PPL generator system */ static inline ppl_Generator_System_t melt_ppl_generator_system_content(melt_ptr_t ppl_p) { if (melt_magic_discr(ppl_p) != OBMAG_SPECPPL_GENERATOR_SYSTEM) return NULL; return ((struct meltspecial_st *)ppl_p)->val.sp_generator_system; } /* put the content of a boxed PPL generator system */ static inline void melt_ppl_generator_system_put_content(melt_ptr_t ppl_p, ppl_Generator_System_t gensys) { if (melt_magic_discr(ppl_p) != OBMAG_SPECPPL_GENERATOR_SYSTEM) return; ((struct meltspecial_st *)ppl_p)->val.sp_generator_system = gensys; } /* get the content of a boxed PPL polyhedron */ static inline ppl_Polyhedron_t melt_ppl_polyhedron_content(melt_ptr_t ppl_p) { if (melt_magic_discr(ppl_p) != OBMAG_SPECPPL_POLYHEDRON) return NULL; return ((struct meltspecial_st *)ppl_p)->val.sp_polyhedron; } /* put the content of a boxed PPL polyhedron */ static inline void melt_ppl_polyhedron_put_content(melt_ptr_t ppl_p, ppl_Polyhedron_t poly) { if (melt_magic_discr(ppl_p) != OBMAG_SPECPPL_POLYHEDRON) return; ((struct meltspecial_st *)ppl_p)->val.sp_polyhedron = poly; } /**************************** misc *****************************/ /* a random generator */ static inline long melt_lrand (void) { /* we used to call lrand48_r using some randata filled at init time, but lrand48_r is less portable than lrand48 */ return lrand48(); } static inline unsigned melt_nonzerohash (void) { unsigned h; do { h = melt_lrand () & MELT_MAXHASH; } while (h == 0); return h; } /* initialize all - don't do anything when called more than once */ void melt_initialize (void); /* finalize all */ void melt_finalize (void); /* find a symbol in all the loaded modules */ void* melt_dlsym_all(const char*nam); /* returns malloc-ed path inside a temporary directory, with a given basename & suffix */ char* melt_tempdir_path(const char* basnam, const char* suffix); /*** Load a MELT module by its name, which is only made of letters, digit, underscores, and + or - chars. If the module does not exist in binary form (or if the binary form is not in sync with the C source code), find its C source and compile it. Then, load the module as a shared object and invoke its start_module_melt function with the given module data, usually an environment, which returns the new module environment. ***/ melt_ptr_t meltgc_load_melt_module (melt_ptr_t modata_p, const char *modulnam); /* generate a loadable module from a MELT generated C source file; the out is the dynloaded module without any *.so suffix */ void meltgc_generate_melt_module (melt_ptr_t src_p, melt_ptr_t out_p); /* load a list of modules from a file whose basename MODLISTBASE is given without its suffix '.modlis' */ melt_ptr_t meltgc_load_modulelist(melt_ptr_t modata_p, const char *modlistbase); /* first_module_melt is the function start_module_melt in first-melt.c */ melt_ptr_t first_module_melt (melt_ptr_t); /* get (or create) the symbol of a given name, using the INITIAL_SYSTEM_DATA global; the NAM string can be in the GC-allocated heap since it is copied */ enum { /* a meningful enum for the create flag below */ MELT_GET = 0, MELT_CREATE }; melt_ptr_t meltgc_named_symbol (const char *nam, int create); /* get (or create) the keyword of a given name (without the colon), using the INITIAL_SYSTEM_DATA global; the NAM string can be in the GC-allocated heap since it is copied */ melt_ptr_t meltgc_named_keyword (const char *nam, int create); /* intern a symbol, ie add it into the global name map; if the symbol is new, return it otherwise return the older homonymous symnol */ melt_ptr_t meltgc_intern_symbol (melt_ptr_t symb); /* intern a keyword, ie add it into the global name map; if the symbol is new, return it otherwise return the older homonymous symnol */ melt_ptr_t meltgc_intern_keyword (melt_ptr_t symb); /* read a list of sexpressions from a file; if the second argument is non-empty and non-null, it is used for locations; otherwise the basename of the filnam is used */ melt_ptr_t meltgc_read_file (const char *filnam, const char* locnam); /* read a list of sexpressions from a raw string [which should not be in the melt heap] using a raw location name and a location in source */ melt_ptr_t meltgc_read_from_rawstring(const char* rawstr, const char* rawlocnam, location_t loch); /* read a list of sexpressions from a string or strbuf value or named object; if the second argument is non-empty and non-null, it is used for locations */ melt_ptr_t meltgc_read_from_val(melt_ptr_t strv_p, melt_ptr_t locnam_p); /* called from c-common.c in handle_melt_attribute */ void melt_handle_melt_attribute(tree decl, tree name, const char* attrstr, location_t loch); /* Use melt_assert(MESSAGE,EXPR) to test invariants. The MESSAGE should be a constant string displayed when asserted EXPR is false */ #if ENABLE_ASSERT_CHECKING void melt_assert_failed (const char *msg, const char *filnam, int lineno, const char *fun) ATTRIBUTE_NORETURN; void melt_check_failed (const char *msg, const char *filnam, int lineno, const char *fun); enum { MELT_ANYWHERE=0, MELT_NOYOUNG }; void melt_check_call_frames_at(int youngflag, const char*msg, const char*filenam, int lineno); #define melt_assertmsg(MSG,EXPR) \ (!(EXPR)?(melt_assert_failed((MSG),__FILE__,__LINE__,__FUNCTION__), 0):0) #define melt_checkmsg(MSG,EXPR) \ (!(EXPR)?(melt_check_failed((MSG),__FILE__,__LINE__,__FUNCTION__), 0):0) #define melt_check_call_frames(YNG,MSG) \ ((void)(melt_check_call_frames_at((YNG),(MSG),__FILE__,__LINE__))) #else /* Include EXPR, so that unused variable warnings do not occur. */ #define melt_assertmsg(MSG,EXPR) ((void)(0 && (MSG) && (EXPR))) #define melt_assert_failed(MSG,FIL,LIN,FUN) ((void)(0 && (MSG))) #define melt_checkmsg(MSG,EXPR) ((void)(0 && (MSG) && (EXPR))) #define melt_check_failed(MSG,FIL,LIN,FUN) ((void)(0 && (MSG))) #define melt_check_call_frames(YNG,MSG) (void)(0) #endif /******************* method sending ************************/ melt_ptr_t meltgc_send (melt_ptr_t recv, melt_ptr_t sel, const char *xargdescr_, union meltparam_un *xargtab_, const char *xresdescr_, union meltparam_un *xrestab_); /**************************** globals **************************/ /* enumeration of predefined global object indexes inside melt_globvec; Most are wired predefined, in the sense that they are automagically allocated and partly filled before loading the melt file. Others are named, and are expected to be created by loading the melt files. */ enum melt_globalix_en { MELTGLOB__NONE, /************************* wired predefined */ #include "melt-predef.h" /**************************** placeholder for last wired */ MELTGLOB__LASTWIRED, MELTGLOB___SPARE1, MELTGLOB___SPARE2, MELTGLOB___SPARE3, MELTGLOB___SPARE4, /*****/ MELTGLOB__LASTGLOB }; #define BGLOB__LASTGLOB MELTGLOB__LASTGLOB /* *INDENT-OFF* */ /* the array of global values */ extern GTY (()) melt_ptr_t melt_globarr[MELTGLOB__LASTGLOB]; /* *INDENT-ON* */ /* fields inside container */ enum { FCONTAINER_VALUE = 0, FCONTAINER__LAST }; /* fields inside every proped object */ enum { FPROPED_PROP = 0, FPROPED__LAST }; /* fields inside every named object */ enum { FNAMED_NAME = FPROPED__LAST, FNAMED__LAST }; /* fields inside every discriminant */ enum { FDISC_METHODICT = FNAMED__LAST, /* a mapobjects for method mapping selectors to closures */ FDISC_SENDER, /* the closure doing the send if a selector is not in the method dict */ FDISC_SUPER, /* the "superclass" or "parent discrim" */ FDISC__LAST }; /* fields inside every class */ enum { FCLASS_ANCESTORS = FDISC__LAST, /* a multiple for the class ancestors (first being the CLASS:ROOT last being the immediate superclass) */ FCLASS_FIELDS, /* a multiple for the class fields */ FCLASS_DATA, /* class variables */ FCLASS__LAST }; /* fields inside each symbol */ enum { FSYMB_DATA = FNAMED__LAST, FSYMB__LAST }; /* fields inside a source expression (sexpr) */ enum { FSEXPR_LOCATION = FPROPED__LAST, FSEXPR_CONTENTS, /* the contents of the sexpression (as a list) */ FSEXPR__LAST }; /* fields inside the system data - keep in sync with the class_system_data definition in MELT file warmelt-first.melt; needed because the predefined are immutable objects, and cannot be varying objects or non objects */ enum { FSYSDAT_COMMAND_DICT = FNAMED__LAST, /* the stringdict of commands */ FSYSDAT_BOX_FRESH_ENV, /* closure to make a fresh environment box */ FSYSDAT_VALUE_EXPORTER, /* closure to export a value */ FSYSDAT_MACRO_EXPORTER, /* closure to export a macro */ FSYSDAT_SYMBOLDICT, /* stringmap for symbols */ FSYSDAT_KEYWDICT, /* stringmap for keywords */ FSYSDAT_ADDSYMBOL, /* closure to add a symbol of given name */ FSYSDAT_ADDKEYW, /* closure to add a keyword of given name */ FSYSDAT_INTERNSYMBOL, /* closure to intern a symbol */ FSYSDAT_INTERNKEYW, /* closure to intern a keyword */ FSYSDAT_VALUE_IMPORTER, /* closure to import a value */ FSYSDAT_PASS_DICT, /* dictionnary of passes */ FSYSDAT_EXIT_FINALIZER, /* closure to call at exit */ FSYSDAT_MELTATTR_DEFINER, /* closure for melt attributes */ FSYSDAT_PATMACRO_EXPORTER, /* closure to export patmacro */ FSYSDAT_DEBUGMSG, /* closure for debugmsg */ FSYSDAT_STDOUT, /* raw boxed file for stdout */ FSYSDAT_STDERR, /* raw boxed file for stderr */ FSYSDAT_DUMPFILE, /* raw boxed file for dump_file */ FSYSDAT_UNIT_STARTER, /* closure for start of compilation unit */ FSYSDAT_UNIT_FINISHER, /* closure for start of compilation unit */ FSYSDAT__LAST }; /* fields inside GCC passes */ enum { FGCCPASS_GATE = FNAMED__LAST, /* the gate closure */ FGCCPASS_EXEC, /* the execute closure */ FGCCPASS_DATA, /* extra data */ FGCCPASS_PROPERTIES_REQUIRED, FGCCPASS_PROPERTIES_PROVIDED, FGCCPASS_PROPERTIES_DESTROYED, FGCCPASS_TODO_FLAGS_START, FGCCPASS_TODO_FLAGS_FINISH, FGCCPASS__LAST }; /* fields inside MELT commands */ enum { FMELTCMD_HELP = FNAMED__LAST, /* the help string */ FMELTCMD_FUN, /* the command closure */ FMELTCMD_DATA, /* client data of command */ FMELTCMD__LAST }; /* currently each predefined is a GC root (so we have about two hundreds of them), scanned at every minor garbage collection. We might change that, e.g. by grouping the predefined set by 16 and scanning in minor GC only groups which have been changed */ static inline melt_ptr_t melt_fetch_predefined(int ix) { if (ix>0 && ix0 && ixu_discr; } bool melt_is_subclass_of (meltobject_ptr_t subclass_p, meltobject_ptr_t superclass_p); static inline bool melt_is_instance_of (melt_ptr_t inst_p, melt_ptr_t class_p) { unsigned mag_class = 0; unsigned mag_inst = 0; if (!inst_p) return FALSE; if (!class_p) return FALSE; gcc_assert(class_p->u_discr != NULL); gcc_assert(inst_p->u_discr != NULL); mag_class = class_p->u_discr->obj_num; mag_inst = inst_p->u_discr->obj_num; if (mag_class != OBMAG_OBJECT || !mag_inst) return FALSE; if (((meltobject_ptr_t) inst_p)->obj_class == (meltobject_ptr_t) class_p) return TRUE; if (mag_inst != ((meltobject_ptr_t) class_p)->object_magic) return FALSE; if (mag_inst == OBMAG_OBJECT) return melt_is_subclass_of (((meltobject_ptr_t) inst_p)->obj_class, ((meltobject_ptr_t) class_p)); /* the instance is not an object but something else and it has the good magic */ return TRUE; } /* since melt_put_int uses DISCR_CONSTINTEGER it should be here */ static inline bool melt_put_int (melt_ptr_t v, long x) { if (!v) return FALSE; switch (melt_magic_discr (v)) { case OBMAG_INT: if (v->u_discr == (meltobject_ptr_t)MELT_PREDEF(DISCR_CONSTINTEGER)) return FALSE; ((struct meltint_st *) (v))->val = x; return TRUE; case OBMAG_MIXINT: ((struct meltmixint_st *) (v))->intval = x; return TRUE; case OBMAG_MIXLOC: ((struct meltmixloc_st *) (v))->intval = x; return TRUE; case OBMAG_OBJECT: if (((meltobject_ptr_t) (v))->obj_num != 0) return FALSE; ((meltobject_ptr_t) (v))->obj_num = (unsigned short) x; return TRUE; default: return FALSE; } } /*** * CALL FRAMES ***/ /* call frames for our copying garbage collector cannot be GTY-ed because they are inside the C call stack; in reality, MELT call frames may also contain other GTY-ed data -like tree-s, gimple-s, ...-, and the MELT machinery generated code to mark each such frame. See http://gcc.gnu.org/wiki/memory%20management%20in%20MELT for more */ struct callframe_melt_st { unsigned nbvar; #if ENABLE_CHECKING const char* flocs; #endif struct meltclosure_st *clos; struct excepth_melt_st *exh; /* for our exceptions - not implemented yet */ struct callframe_melt_st *prev; melt_ptr_t varptr[FLEXIBLE_DIM]; }; /* maximal number of local variables per frame */ #define MELT_MAXNBLOCALVAR 16384 /* the topmost call frame */ extern struct callframe_melt_st *melt_topframe; static inline int melt_curframdepth(void) { int cnt = 0; struct callframe_melt_st* fr = melt_topframe; for (;fr;fr=fr->prev) cnt++; return cnt; } #if 0 /* the jmpbuf for our catch & throw */ extern jmp_buf *melt_jmpbuf; extern melt_ptr_t melt_jmpval; #endif /* declare the current callframe */ #if ENABLE_CHECKING #define MELT_DECLFRAME(NBVAR) struct { \ unsigned nbvar; \ const char* flocs; \ struct meltclosure_st* clos; \ struct excepth_melt_st* exh; \ struct callframe_melt_st* prev; \ void* /* a melt_ptr_t */ varptr[NBVAR]; \ } curfram__ /* initialize the current callframe and link it at top */ #define MELT_INITFRAME_AT(NBVAR,CLOS,FIL,LIN) do { \ static char locbuf_##LIN[64]; \ if (!locbuf_##LIN[0]) \ snprintf(locbuf_##LIN, sizeof(locbuf_##LIN)-1, "%s:%d", \ basename(FIL), (int)LIN); \ memset(&curfram__, 0, sizeof(curfram__)); \ curfram__.nbvar = (NBVAR); \ curfram__.flocs = locbuf_##LIN; \ curfram__.prev = (struct callframe_melt_st*) melt_topframe; \ curfram__.clos = (CLOS); \ melt_topframe = ((struct callframe_melt_st*)&curfram__); \ } while(0) #define MELT_INITFRAME(NBVAR,CLOS) MELT_INITFRAME_AT(NBVAR,CLOS,__FILE__,__LINE__) #define MELT_LOCATION(LOCS) do{curfram__.flocs= LOCS;}while(0) #define MELT_LOCATION_HERE_AT(FIL,LIN,MSG) do { \ static char locbuf_##LIN[72]; \ if (!locbuf_##LIN[0]) \ snprintf(locbuf_##LIN, sizeof(locbuf_##LIN)-1, "%s:%d <%s>", \ basename(FIL), (int)LIN, MSG); \ curfram__.flocs = locbuf_##LIN; \ } while(0) #define MELT_LOCATION_HERE(MSG) MELT_LOCATION_HERE_AT(__FILE__,__LINE__,MSG) #else #define MELT_DECLFRAME(NBVAR) struct { \ unsigned nbvar; \ struct meltclosure_st* clos; \ struct excepth_melt_st* exh; \ struct callframe_melt_st* prev; \ void* /* a melt_ptr_t */ varptr[NBVAR]; \ } curfram__ #define MELT_LOCATION(LOCS) do{}while(0) #define MELT_LOCATION_HERE(MSG) do{}while(0) /* initialize the current callframe and link it at top */ #define MELT_INITFRAME(NBVAR,CLOS) do { \ memset(&curfram__, 0, sizeof(curfram__)); \ curfram__.nbvar = (NBVAR); \ curfram__.prev = (struct callframe_melt_st*)melt_topframe; \ curfram__.clos = (CLOS); \ melt_topframe = ((void*)&curfram__); \ } while(0) #endif /* declare and initialize the current callframe */ #define MELT_ENTERFRAME(NBVAR,CLOS) \ MELT_DECLFRAME(NBVAR); MELT_INITFRAME(NBVAR,CLOS) /* exit the current frame and return */ #define MELT_EXITFRAME() do { \ melt_topframe = (struct callframe_melt_st*)(curfram__.prev); \ } while(0) /**** #define MELT_CATCH(Vcod,Vptr) do { jmp_buf __jbuf; int __jcod; jmp_buf* __prevj = melt_jmpbuf; memset(&__jbuf, 0, sizeof(jmp_buf)); melt_jmpbuf = &__jbuf; __jcod = setjmp(&__jbuf); Vcod = __jcod; if (__jcod) { melt_topframe = ((void*)&curfram__); Vptr = melt_jmpval; }; } while(0) #define MELT_THROW(Cod,Ptr) do { } while(0) ***/ /* ====== safer output routines ===== */ /* output a string */ static inline void melt_puts (FILE * f, const char *str) { if (f && str) fputs (str, f); } /* output a number with a prefix & suffix message */ static inline void melt_putnum(FILE* f, const char*pref, long l, const char*suff) { if (f) fprintf(f, "%s%ld%s", pref?pref:"", l, suff?suff:""); } /* safe flush */ static inline void melt_flush (FILE * f) { if (f) fflush (f); } /* safe newline and flush */ static inline void melt_newlineflush (FILE * f) { if (f) { putc ('\n', f); fflush (f); } } /* output a string value */ static inline void melt_putstr (FILE * f, melt_ptr_t sv) { if (f && sv && melt_magic_discr (sv) == OBMAG_STRING) fputs (((struct meltstring_st *) sv)->val, f); } /* output a string buffer */ static inline void melt_putstrbuf (FILE * f, melt_ptr_t sb) { struct meltstrbuf_st *sbuf = (struct meltstrbuf_st *) sb; if (f && sbuf && melt_magic_discr ((melt_ptr_t) sbuf) == OBMAG_STRBUF) { gcc_assert (sbuf->bufzn); if (!sbuf->bufzn || sbuf->bufend <= sbuf->bufstart) return; fwrite (sbuf->bufzn + sbuf->bufstart, sbuf->bufend - sbuf->bufstart, 1, f); } } /* output the declaration and implementation buffers of a generated file */ void melt_output_cfile_decl_impl(melt_ptr_t cfilnam, melt_ptr_t declbuf, melt_ptr_t implbuf); static inline void debugeputs_at (const char *fil, int lin, const char *msg) { debugeprintf_raw ("!@%s:%d:\n@! %s\n", basename (fil), lin, msg); } #define debugeputs(Msg) debugeputs_at(__FILE__,__LINE__,(Msg)) static inline void debugvalue_at (const char *fil, int lin, const char *msg, void *val) { if (flag_melt_debug) { fprintf (stderr, "!@%s:%d:\n@! %s @%p/%d= ", basename (fil), lin, (msg), val, melt_magic_discr ((melt_ptr_t)val)); melt_dbgeprint (val); fflush (stderr); } } #define debugvalue(Msg,Val) debugvalue_at(__FILE__, __LINE__, (Msg), (Val)) void meltgc_debugmsgval(void* val, const char*msg, long count); static inline void debugmsgval_at (const char*fil, int lin, const char* msg, void*val, long count) { if (flag_melt_debug) { fprintf (stderr, "!@%s:%d:\n", basename (fil), lin); meltgc_debugmsgval(val, msg, count); } } #define debugmsgval(Msg,Val,Count) do { \ debugmsgval_at(__FILE__,__LINE__,(Msg),(Val),(Count)); } while(0) static inline void debugbacktrace_at (const char *fil, int lin, const char *msg, int depth) { if (flag_melt_debug) { fprintf (stderr, "\n!@%s:%d: %s ** BACKTRACE** ", basename (fil), lin, msg); melt_dbgbacktrace (depth); fflush (stderr); } } #define debugbacktrace(Msg,Depth) debugbacktrace_at(__FILE__, __LINE__, (Msg), (Depth)) static inline void debugnum_at (const char *fil, int lin, const char *msg, long val) { debugeprintf_raw ("!@%s:%d: %s =#= %ld\n", basename (fil), lin, msg, val); } #define debugnum(Msg,Val) debugnum_at(__FILE__, __LINE__, (Msg), (Val)) void melt_dbgshortbacktrace(const char* msg, int maxdepth); #if ENABLE_CHECKING extern void* melt_checkedp_ptr1; extern void* melt_checkedp_ptr2; extern FILE* melt_dbgtracefile; void melt_caught_assign_at(void*ptr, const char*fil, int lin, const char*msg); #define melt_checked_assignmsg_at(Assign,Fil,Lin,Msg) ({ \ void* p_##Lin = (Assign); \ if (p_##Lin && !melt_discr(p_##Lin)) \ melt_assert_failed("bad checked assign (in runtime)",Fil,Lin,__FUNCTION__); \ if ( (p_##Lin == melt_checkedp_ptr1 && p_##Lin) \ || (p_##Lin == melt_checkedp_ptr2 && p_##Lin)) \ melt_caught_assign_at(p_##Lin,Fil,Lin,Msg); p_##Lin; }) #define melt_checked_assign(Assign) melt_checked_assignmsg_at((Assign),__FILE__,__LINE__,__FUNCTION__) #define melt_checked_assignmsg(Assign,Msg) melt_checked_assignmsg_at((Assign),__FILE__,__LINE__,Msg) void melt_cbreak_at(const char*msg, const char*fil, int lin); #define melt_cbreak(Msg) melt_cbreak_at((Msg),__FILE__,__LINE__) #define melt_trace_start(Msg,Cnt) do {if (melt_dbgtracefile) \ fprintf(melt_dbgtracefile, "+%s %ld\n", Msg, (long)(Cnt));} while(0) #define melt_trace_end(Msg,Cnt) do {if (melt_dbgtracefile) \ fprintf(melt_dbgtracefile, "-%s %ld\n", Msg, (long)(Cnt));} while(0) #else #define melt_checked_assign(Assign) Assign #define melt_checked_assignmsg(Assign,Msg) Assign #define melt_cbreak(Msg) ((void)(Msg)) #define melt_trace_start(Msg,Cnt) do{}while(0) #define melt_trace_end(Msg,Cnt) do{}while(0) #define debugmsgval(Msg,Val,Count) do {}while(0) #endif /*ENABLE_CHECKING*/ /** handling GDBM state store; if there is none, these routines do nothing (and return NULL if needed); the GDBM database is lazily opened at first needed call. pointer key & data can be string, strbuf, or named instances (in which case the string name is used) **/ /* true if there is a GDBM state; side effect, open it */ bool melt_has_gdbmstate(void); /* return a string value associated to a constant key, or null if none */ melt_ptr_t meltgc_fetch_gdbmstate_constr(const char*key); /* return a string value associated to a pointer key [string, strbuf, named] or null if none */ melt_ptr_t meltgc_fetch_gdbmstate (melt_ptr_t key_p); /* store or remove a constant key; if the value pointer is nil, remove it; if it s a string, strbuf, named, put it, eventually replacing the previous one; otherwise do nothing */ void meltgc_put_gdbmstate_constr (const char *key, melt_ptr_t data_p); /* store or remove a pointer key (string, strbuf, or named value); if the value pointer is nil, remove it; if it s a string, strbuf, named, put it, eventually replacing the previous one; otherwise do nothing */ void meltgc_put_gdbmstate (melt_ptr_t key_p, melt_ptr_t data_p); /* make a new boxed file - the discr should be for a file or a raw file */ melt_ptr_t meltgc_new_file(melt_ptr_t discr_p, FILE* fil); /* get a file from a boxed file, may return NULL */ static inline FILE* melt_get_file(melt_ptr_t file_p) { int magic; if (!file_p) return NULL; magic = melt_magic_discr (file_p); if (magic == OBMAG_SPEC_FILE || magic == OBMAG_SPEC_RAWFILE) return ((struct meltspecial_st*)file_p)->val.sp_file; return NULL; } #endif /*MELT_INCLUDED_ */ /* eof melt-runtime.h */