/** MELT header melt-runtime.h [[middle end lisp translator, see http://gcc.gnu.org/wiki/MELT or www.gcc-melt.org ]] Copyright (C) 2008, 2009, 2010, 2011 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_ /* In the generated gtype-desc.c, file diagnostic.h is not included, so we declare these functions explicitly! */ extern void error (const char *, ...); extern void fatal_error (const char *, ...); #if __GNUC__ >= 4 #define MELT_MODULE_VISIBILITY __attribute__ ((visibility ("hidden"))) #define MELT_PUBLIC_VISIBILITY __attribute__ ((visibility ("default"))) #else #define MELT_MODULE_VISIBILITY #define MELT_PUBLIC_VISIBILITY #endif /* 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" /* MELTGCC_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" extern const char melt_runtime_build_date[]; extern void melt_fatal_info (const char*filename, int lineno); #define melt_fatal_error(Fmt,...) do{ melt_fatal_info (__FILE__,__LINE__); \ fatal_error ((Fmt),##__VA_ARGS__); }while(0) #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; /* the version string of MELT */ #define MELT_VERSION_STRING "0.7.1" /* return a read only version string */ extern const char* melt_version_str(void); extern long melt_dbgcounter; extern long melt_debugskipcount; extern long melt_error_counter; #if ENABLE_GC_CHECKING /* memory is poisoned by an 0xa5a5a5a5a5a5a5a5... pointer in ggc-zone.c or ggc-page.c */ #if SIZEOF_VOID_P == 8 #define MELT_POISON_POINTER (void*)0xa5a5a5a5a5a5a5a5 #elif SIZEOF_VOID_P == 4 #define MELT_POISON_POINTER (void*)0xa5a5a5a5 #else #error cannot set MELT_POISON_POINTER #endif #endif /*ENABLE_GC_CHECKING*/ /* the MELT debug depth for debug_msg ... can be set with -fmelt-debug-depth= */ int melt_debug_depth(void); #ifdef MELT_IS_PLUGIN extern int flag_melt_debug; extern int flag_melt_bootstrapping; #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 */ union meltparam_un; /* declared in file meltrunsup.h */ /* used in file meltrunsup.h */ #ifndef melt_ptr_t_TYPEDEFINED typedef union melt_un* melt_ptr_t ; #define melt_ptr_t_TYPEDEFINED #endif /*melt_ptr_t_TYPEDEFINED*/ /* forward declaration, return the magic of the discriminant or 0 */ static inline int melt_magic_discr (melt_ptr_t p); /* the maximal length of name of melt routines descriptions */ #define MELT_ROUTDESCR_LEN 100 #ifndef meltobject_ptr_t_TYPEDEFINED typedef struct meltobject_st* meltobject_ptr_t ; #define meltobject_ptr_t_TYPEDEFINED #endif /*meltobject_ptr_t_TYPEDEFINED*/ struct /* entry of string maps */ GTY (()) entrystringsmelt_st { const char *GTY (()) e_at; melt_ptr_t e_va; }; struct /* entry of object maps*/ GTY (()) entryobjectsmelt_st { meltobject_ptr_t e_at; melt_ptr_t e_va; }; /* a union of special pointers which have to be explicitly deleted */ union melt_special_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; }; /* make a special value; return NULL if the discriminant is not special */ /* actually, all meltspecial*_st structures are similar */ #define meltspecial_st meltspecialfile_st struct meltspecial_st*meltgc_make_special (melt_ptr_t discr_p); /* 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; }; 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); #ifdef ENABLE_CHECKING extern int melt_debug_garbcoll; #define melt_debuggc_eprintf(Fmt,...) do {if (melt_debug_garbcoll > 0) \ fprintf (stderr, "%s:%d:@$*" Fmt "\n", \ lbasename(__FILE__), __LINE__, ##__VA_ARGS__);} while(0) #else #define melt_debuggc_eprintf(Fmt,...) do{}while(0) #endif /* also in generated meltrunsup.h */ #ifndef meltobject_ptr_t_TYPEDEFINED typedef struct meltobject_st* meltobject_ptr_t; #define meltobject_ptr_t_TYPEDEFINED #endif #ifndef melt_ptr_t_TYPEDEFINED typedef union melt_un* melt_ptr_t; #define melt_ptr_t_TYPEDEFINED #endif #ifndef meltroutine_ptr_t_TYPEDEFINED typedef struct meltroutine_st *meltroutine_ptr_t; #define meltroutine_ptr_t_TYPEDEFINED #endif /******************* 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)) /* functions needed to support the generated map accessing routines inside meltrunsup.h */ 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); /*** 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 argument descriptor string describing the extra arguments + the array of union meltparam_un for extra arguments + a (non null, can be empty) constant argument descriptor 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 */ /* Changing the argument descriptor format should be done with extreme care, and should be delicately kept in sync with warmelt-outobj.melt code generation, in particular with the generate of runtime support in meltrunsup.h generated file. The Argument descriptor cell type is those of elements in argument descriptor string. It should be char or wchar_t; changing it require also delicate changes inside warmelt-outobj.melt, in particular of the generate_runtypesupport_param function there. It should be kept in sync! */ typedef char melt_argdescr_cell_t; /* The maximal value of above scalar types */ #define MELT_ARGDESCR_MAX CHAR_MAX /* File meltrunsup.h is inside melt/generated/ */ #include "meltrunsup.h" /* 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 melt_argdescr_cell_t xargdescr_[], union meltparam_un *xargtab_, const melt_argdescr_cell_t xresdescr_[], union meltparam_un *xrestab_); /* Depth and counter of MELT applications are only significant when checking is enabled by ENABLE_CHECKING. */ extern long melt_application_count (void); extern long melt_application_depth (void); /* 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; /* Gives the constant string corresponding to a given object magic above. */ const char* melt_obmag_string(int i); /* 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 */ /* 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) */ /* return the magic of the discriminant or 0 */ static inline int melt_magic_discr (melt_ptr_t p) { if (!p) return 0; #if ENABLE_GC_CHECKING if ((void*) p == MELT_POISON_POINTER) { /* This should never happen, and if it happens it means that p was insided a poisoned freed data zone, so the memory is corrupted; a data zone has been freed and then dereferenced. */ melt_fatal_error ("corrupted memory retrieving magic discriminant of %p," " (= the poison pointer)", (void*) p); } #endif /*ENABLE_GC_CHECKING */ #if ENABLE_CHECKING if (!p->u_discr) { /* This should never happen, we are asking the discriminant of a not yet filled, since cleared, memory zone. */ melt_fatal_error ("corrupted memory heap retrieving magic discriminant of %p," "(= a cleeared memory zone)", (void*) p); } #endif /*ENABLE_CHECKING*/ #if ENABLE_GC_CHECKING if ((void*) (p->u_discr) == MELT_POISON_POINTER) { /* This should never happen, we are asking the discriminant of a zone which has been poisoned, that is has been freed! */ melt_fatal_error ("corrupted memory heap retrieving magic discriminant of %p," "(= a freed and poisoned memory zone)", (void*) p); } #endif /*ENABLE_GC_CHECKING*/ return p->u_discr->meltobj_magic; } /* likewise, but without testing for null */ static inline int melt_unsafe_magic_discr (melt_ptr_t p) { return p->u_discr->meltobj_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 == MELTOBMAG_STRBUF || d == MELTOBMAG_SPEC_FILE || d == MELTOBMAG_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 == MELTOBMAG_SPEC_FILE || d == MELTOBMAG_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->meltobj_magic != MELTOBMAG_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->meltobj_magic != MELTOBMAG_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->meltobj_magic != MELTOBMAG_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->meltobj_magic != MELTOBMAG_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 either return a boxed integer (0 for equality, <0 for less than, >0 for greater than), or return :true and a raw small long (0 for equality, <0 or >0) when applied to two values to compare. If the closure does not return a boxed integer or both :true and a raw 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->meltobj_magic != MELTOBMAG_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); /* 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->meltobj_magic != MELTOBMAG_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; extern bool melt_is_forwarding; #define MELT_FORWARDED_DISCR (meltobject_ptr_t)1 melt_ptr_t melt_forwarded_copy (melt_ptr_t); 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; } static inline void * melt_forwarded (void *ptr) { melt_ptr_t p = (melt_ptr_t) ptr; if (p && melt_is_young (p)) { if (p->u_discr == MELT_FORWARDED_DISCR) p = ((struct meltforward_st *) p)->forward; else p = melt_forwarded_copy (p); } return p; } #if GCC_VERSION > 4000 #define MELT_FORWARDED(P) do {if (P) { \ (P) = (__typeof__(P))melt_forwarded((void*)(P));} } while(0) #else #define MELT_FORWARDED(P) do {if (P) { \ (P) = (melt_ptr_t)melt_forwarded((melt_ptr_t)(P));} } while(0) #endif /*GCC_VERSION*/ /* the MELT copying garbage collector routine - moves all locals on the stack! Minor GC is only moving, Minor or Full chooses either minor or full appropriately, and Full GC is the minor one followed by GCC garbage collector Ggc. */ 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 #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); /* Retrieve an integer from a boxed integer or mixnumbers. */ static inline long melt_get_int (melt_ptr_t v) { switch (melt_magic_discr (v)) { case MELTOBMAG_INT: return ((struct meltint_st *) (v))->val; case MELTOBMAG_MIXINT: return ((struct meltmixint_st *) (v))->intval; case MELTOBMAG_MIXLOC: return ((struct meltmixloc_st *) (v))->intval; case MELTOBMAG_OBJECT: return ((meltobject_ptr_t) (v))->obj_num; default: return 0; } } /* Make a boxed real from a real value. If discr is NULL, use DISCR_REAL. */ melt_ptr_t meltgc_new_real(meltobject_ptr_t discr, REAL_VALUE_TYPE r); /* Unbox real value. It returns 0 if not a boxed real. */ static inline REAL_VALUE_TYPE melt_get_real (melt_ptr_t v) { if (melt_magic_discr (v) == MELTOBMAG_REAL) return ((struct meltreal_st*) v)->val; return dconst0; } static inline long melt_obj_hash (melt_ptr_t v) { if (melt_magic_discr (v) == MELTOBMAG_OBJECT) return ((meltobject_ptr_t) (v))->obj_hash; return 0; } /* obsolete function */ static inline unsigned long melt_obj_serial (melt_ptr_t v ATTRIBUTE_UNUSED) { return 0; } static inline long melt_obj_len (melt_ptr_t v) { if (melt_magic_discr (v) == MELTOBMAG_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) == MELTOBMAG_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) == MELTOBMAG_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) == MELTOBMAG_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) == MELTOBMAG_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) == MELTOBMAG_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) == MELTOBMAG_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) == MELTOBMAG_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) != MELTOBMAG_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) == MELTOBMAG_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) == MELTOBMAG_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) == MELTOBMAG_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, int*deflenptr) { if (pptr && !*pptr) *pptr = melt_dynobjstruct_classlength_at(clanam,fil,lin); if (pptr && *pptr) len = **pptr; if (pptr && !*pptr && deflenptr) { *deflenptr = len; *pptr = deflenptr; } 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; \ static int deflen_##Lin; \ Newobj = \ melt_dynobjstruct_make_raw_object \ ( (Klas),(Len), \ Clanam,Fil,Lin, \ &ptrlen_##Lin, \ &deflen_##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, (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) == MELTOBMAG_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/len %d/origoff %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) == MELTOBMAG_OBJECT) { meltobject_ptr_t pob = (meltobject_ptr_t) ob; if (off < pob->obj_len) { pob->obj_vartab[off] = val; return; } melt_fatal_error("checked field put failed (bad offset %d/%d [%s:%d]) - %s", (int)off, (int)pob->obj_len, fil, lin, msg?msg:"..."); } melt_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,Clanam) \ ((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) #endif /* get (safely) the length of an object */ static inline int melt_object_length (melt_ptr_t ob) { if (melt_magic_discr (ob) == MELTOBMAG_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) == MELTOBMAG_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); /* Return as string value the name of a generated C file; if dirname is given and non-empty, it is used as the directory name using the basename of basepath, otherwise basepath is used. Any .melt or .so or .c suffix is removed, and if the num is positive it is appended. The result string is dirpath/basename+num.c, eg /foo/dir/mybase+3.c if dirpath is /foo/dir and basepath is /bar/mybase.c or mybase.melt etc... and num is 3. If num is non-positive it is ignored. */ melt_ptr_t meltgc_new_string_generated_c_filename (meltobject_ptr_t discr_p, const char* basepath, const char* dirpath, int num); /* Return true if we don't want to generate several C files for a given MELT module */ bool melt_wants_single_c_file (void); /* 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) == MELTOBMAG_STRING) return ((struct meltstring_st *) v)->val; return 0; } static inline int melt_string_length (melt_ptr_t v) { if (melt_magic_discr (v) == MELTOBMAG_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) == MELTOBMAG_STRING && melt_magic_discr (v2) == MELTOBMAG_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) == MELTOBMAG_STRING && melt_magic_discr (v2) == MELTOBMAG_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) == MELTOBMAG_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) == MELTOBMAG_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) == MELTOBMAG_STRBUF) { struct meltstrbuf_st *sb = (struct meltstrbuf_st *) v; if (sb->bufend >= sb->bufstart) return sb->bufend - sb->bufstart; } return 0; } /* return the length of an output, i.e. the used length of strbuf or the current file position of a file */ long melt_output_length (melt_ptr_t out_p); /* 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 != MELTOBMAG_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 != MELTOBMAG_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 != MELTOBMAG_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 != MELTOBMAG_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 != MELTOBMAG_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 != MELTOBMAG_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 != MELTOBMAG_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 != MELTOBMAG_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 == MELTOBMAG_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 == MELTOBMAG_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 == MELTOBMAG_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 == MELTOBMAG_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 == MELTOBMAG_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 == MELTOBMAG_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 == MELTOBMAG_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 == MELTOBMAG_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 == MELTOBMAG_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 == MELTOBMAG_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 == MELTOBMAG_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 == MELTOBMAG_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 of length SLEN encoded as a C string with backslash escapes */ void meltgc_add_out_cstr_len (melt_ptr_t outbuf_p, const char *str, int slen); #define meltgc_add_strbuf_cstr_len(Out,Str,Slen) \ meltgc_add_out_cstr_len(Out,Str,Slen) /* add safely into OUTBUF the substring of STR starting at offset OFF of length SLEN encoded as a C string with backslash escapes */ void meltgc_add_out_csubstr_len (melt_ptr_t outbuf_p, const char *str, int off, int slen); #define meltgc_add_strbuf_csubstr_len(Out,Str,Slen) \ meltgc_add_out_csubstr_len(Out,Str,Slen) /* 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)) /* output print into an outbuf an edge */ void meltgc_out_edge(melt_ptr_t out_p, edge edg); /***************** 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; int err=0; if ((err=ppl_new_Constraint_System(&consys))!=0) melt_fatal_error("melt_raw_new_ppl_empty_constraint_system failed (%d)", err); 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; int err=0; if ((err=ppl_new_Constraint_System_zero_dim_empty(&consys))!=0) melt_fatal_error("melt_raw_new_ppl_unsatisfiable_constraint_system failed (%d)", err); 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; int err=0; if ((err=ppl_new_Constraint_System_from_Constraint_System(&consys, oldconsys))!=0) melt_fatal_error("melt_raw_clone_ppl_consstraint_system failed (%d)", err); 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) != MELTOBMAG_SPECPPL_COEFFICIENT) return NULL; return ((struct meltspecialpplcoefficient_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) != MELTOBMAG_SPECPPL_COEFFICIENT) return; ((struct meltspecialpplcoefficient_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) != MELTOBMAG_SPECPPL_LINEAR_EXPRESSION) return NULL; return ((struct meltspecialppllinearexpression_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) != MELTOBMAG_SPECPPL_LINEAR_EXPRESSION) return; ((struct meltspecialppllinearexpression_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) != MELTOBMAG_SPECPPL_CONSTRAINT) return NULL; return ((struct meltspecialpplconstraint_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) != MELTOBMAG_SPECPPL_CONSTRAINT) return; ((struct meltspecialpplconstraint_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) != MELTOBMAG_SPECPPL_CONSTRAINT_SYSTEM) return NULL; return ((struct meltspecialpplconstraintsystem_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) != MELTOBMAG_SPECPPL_CONSTRAINT_SYSTEM) return; ((struct meltspecialpplconstraintsystem_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) != MELTOBMAG_SPECPPL_GENERATOR) return NULL; return ((struct meltspecialpplgenerator_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) != MELTOBMAG_SPECPPL_GENERATOR) return; ((struct meltspecialpplgenerator_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) != MELTOBMAG_SPECPPL_GENERATOR_SYSTEM) return NULL; return ((struct meltspecialpplgeneratorsystem_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) != MELTOBMAG_SPECPPL_GENERATOR_SYSTEM) return; ((struct meltspecialpplgeneratorsystem_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) != MELTOBMAG_SPECPPL_POLYHEDRON) return NULL; return ((struct meltspecialpplpolyhedron_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) != MELTOBMAG_SPECPPL_POLYHEDRON) return; ((struct meltspecialpplpolyhedron_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, passing maketarget to the make utility. See file melt-module.mk for the acceptable maketargets, often "melt_module". 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_make_load_melt_module (melt_ptr_t modata_p, const char *modulnam, const char*maketarget, unsigned flags); enum { /* possible flags is an bitwise OR of */ MELTLOADFLAG_NONE=0, /* no flags is the default */ MELTLOADFLAG_CURDIR= (1 << 0), /* search the source and module in current directory */ MELTLOADFLAG_MASK= ~0 }; /* Generate a loadable module from a MELT generated C source file; the out is the dynloaded module without any *.so suffix. The maketarget is for melt-module.mk and by default is "melt_module". */ void meltgc_make_melt_module (melt_ptr_t src_p, melt_ptr_t out_p, const char*maketarget); /* 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, unsigned flags); /* 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); /***** low level routines for infix file parsing *****/ /* open an infix filepath */ void meltgc_open_infix_file (const char*filpath); /* close an infix file */ void meltgc_close_infix_file (void); /* get a lexeme, giving the location file name value and the delimiter hashtable */ melt_ptr_t meltgc_infix_lexeme (melt_ptr_t locnam_p, melt_ptr_t delimtab_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); #define melt_assertmsg(MSG,EXPR) do { if (MELT_UNLIKELY(!(EXPR))) \ melt_assert_failed ((MSG),__FILE__,__LINE__,__FUNCTION__); \ } while(0) #define melt_checkmsg(MSG,EXPR) do { if (MELT_UNLIKELY(!(EXPR))) \ melt_check_failed ((MSG),__FILE__,__LINE__,__FUNCTION__); \ } while(0) #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))) #endif /* MELT call frames checks are quite expensive and related to MELT's garbage collector. */ enum { MELT_ANYWHERE=0, MELT_NOYOUNG }; #if ENABLE_GC_CHECKING void melt_check_call_frames_at(int youngflag, const char*msg, const char*filenam, int lineno); #define melt_check_call_frames(YNG,MSG) \ ((void)(melt_check_call_frames_at((YNG),(MSG),__FILE__,__LINE__))) #else /* no ENABLE_GC_CHECKING */ #define melt_check_call_frames(YNG,MSG) (void)(0) #endif /* ENABLE_GC_CHECKING */ /******************* method sending ************************/ melt_ptr_t meltgc_send (melt_ptr_t recv, melt_ptr_t sel, const melt_argdescr_cell_t *xargdescr_, union meltparam_un *xargtab_, const melt_argdescr_cell_t *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 an infix lexeme */ enum { FSINFLEX_LOCATION = FSEXPR_LOCATION, FSINFLEX_DATA, FSINFLEX__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_MODE_DICT = FNAMED__LAST, /* the stringdict of modes */ 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_OPTION_SET, /* closure to set options */ FSYSDAT_PASSEXEC_HOOK, /* closure for PLUGIN_PASS_EXECUTION */ FSYSDAT__LAST }; /* fields inside GCC passes, i.e. class_gcc_pass */ 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, /* The above fields are for every GCC pass in MELT. */ FGCCPASS__LAST }; /* fields inside class_gcc_transform_ipa_pass */ enum { FGCCTRIPAPASS_STMT_FIXUP = FGCCPASS__LAST, FGCCTRIPAPASS_FUNCTION_TRANSFORM, FGCCTRIPAPASS_VARIABLE_TRANSFORM, FGCCTRIPAPASS__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 != MELTOBMAG_OBJECT || !mag_inst) return FALSE; if (((meltobject_ptr_t) inst_p)->meltobj_class == (meltobject_ptr_t) class_p) return TRUE; if (mag_inst != ((meltobject_ptr_t) class_p)->meltobj_magic) return FALSE; if (mag_inst == MELTOBMAG_OBJECT) return melt_is_subclass_of (((meltobject_ptr_t) inst_p)->meltobj_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_CONSTANT_INTEGER 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 MELTOBMAG_INT: if (v->u_discr == (meltobject_ptr_t)MELT_PREDEF(DISCR_CONSTANT_INTEGER)) return FALSE; ((struct meltint_st *) (v))->val = x; return TRUE; case MELTOBMAG_MIXINT: ((struct meltmixint_st *) (v))->intval = x; return TRUE; case MELTOBMAG_MIXLOC: ((struct meltmixloc_st *) (v))->intval = x; return TRUE; case MELTOBMAG_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 { /* When mcfr_nbvar is positive or zero, it is the number of pointers in mcfr_varptr; when it is negative, the mcfr_forwmarkrout should be used for forwarding or marking the frame's pointers. */ int mcfr_nbvar; #if ENABLE_CHECKING const char* mcfr_flocs; #endif union { struct meltclosure_st *mcfr_closp_; /* when mcfr_nbvar >= 0 */ void (*mcfr_forwmarkrout_) (struct callframe_melt_st*, int); /* when mcfr_nbvar < 0 */ } mcfr_un_; #define mcfr_closp mcfr_un_.mcfr_closp_ #define mcfr_forwmarkrout mcfr_un_.mcfr_forwmarkrout_ /* Interface: void mcfr_forwmarkrout (void* frame, int marking) */ struct excepth_melt_st *mcfr_exh; /* for our exceptions - not implemented yet */ struct callframe_melt_st *mcfr_prev; melt_ptr_t mcfr_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->mcfr_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 { \ int mcfr_nbvar; \ const char* mcfr_flocs; \ struct meltclosure_st* mcfr_clos; \ struct excepth_melt_st* mcfr_exh; \ struct callframe_melt_st* mcfr_prev; \ void* /* a melt_ptr_t */ mcfr_varptr[NBVAR]; \ } meltfram__ /* initialize the current callframe and link it at top */ #define MELT_INITFRAME_AT(NBVAR,CLOS,FIL,LIN) do { \ static char locbuf_##LIN[84]; \ if (!locbuf_##LIN[0]) \ snprintf(locbuf_##LIN, sizeof(locbuf_##LIN)-1, "%s:%d", \ basename(FIL), (int)LIN); \ memset(&meltfram__, 0, sizeof(meltfram__)); \ meltfram__.mcfr_nbvar = (NBVAR); \ meltfram__.mcfr_flocs = locbuf_##LIN; \ meltfram__.mcfr_prev = (struct callframe_melt_st*) melt_topframe; \ meltfram__.mcfr_clos = (CLOS); \ melt_topframe = ((struct callframe_melt_st*)&meltfram__); \ } while(0) #define MELT_INITFRAME(NBVAR,CLOS) MELT_INITFRAME_AT(NBVAR,CLOS,__FILE__,__LINE__) #define MELT_LOCATION(LOCS) do{meltfram__.mcfr_flocs= LOCS;}while(0) #define MELT_LOCATION_HERE_AT(FIL,LIN,MSG) do { \ static char locbuf_##LIN[88]; \ if (!locbuf_##LIN[0]) \ snprintf(locbuf_##LIN, sizeof(locbuf_##LIN)-1, "%s:%d <%s>", \ basename(FIL), (int)LIN, MSG); \ meltfram__.mcfr_flocs = locbuf_##LIN; \ } while(0) #define MELT_LOCATION_HERE(MSG) MELT_LOCATION_HERE_AT(__FILE__,__LINE__,MSG) #else #define MELT_DECLFRAME(NBVAR) struct { \ int mcfr_nbvar; \ struct meltclosure_st* mcfr_clos; \ struct excepth_melt_st* mcfr_exh; \ struct callframe_melt_st* mcfr_prev; \ void* /* a melt_ptr_t */ mcfr_varptr[NBVAR]; \ } meltfram__ #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(&meltfram__, 0, sizeof(meltfram__)); \ meltfram__.mcfr_nbvar = (NBVAR); \ meltfram__.mcfr_prev = (struct callframe_melt_st*)melt_topframe; \ meltfram__.mcfr_clos = (CLOS); \ melt_topframe = ((void*)&meltfram__); \ } 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*)(meltfram__.mcfr_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*)&meltfram__); Vptr = melt_jmpval; }; } while(0) #define MELT_THROW(Cod,Ptr) do { } while(0) ***/ /*Function to be called by MELT code when the :sysdata_passexec_hook is changed. */ void meltgc_notify_sysdata_passexec_hook (void); /* ====== 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) == MELTOBMAG_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) == MELTOBMAG_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 option, declaration and implementation buffers of a generated file with a secondary rank*/ void melt_output_cfile_decl_impl_secondary_option (melt_ptr_t cfilnam, melt_ptr_t declbuf, melt_ptr_t implbuf, melt_ptr_t optbuf, int filrank); static inline void melt_output_cfile_decl_impl_secondary (melt_ptr_t cfilnam, melt_ptr_t declbuf, melt_ptr_t implbuf, int filrank) { melt_output_cfile_decl_impl_secondary_option (cfilnam, declbuf, implbuf, (melt_ptr_t)0, filrank); } /* likewise, for the primary file */ static inline void melt_output_cfile_decl_impl(melt_ptr_t cfilnam, melt_ptr_t declbuf, melt_ptr_t implbuf) { melt_output_cfile_decl_impl_secondary_option (cfilnam, declbuf, implbuf, (melt_ptr_t)0, 0); } /* recursive function to output to a file. Handle boxed integers, lists, tuples, strings, strbufs, but don't handle objects! */ void meltgc_output_file (FILE* fil, melt_ptr_t val_p); #ifdef ENABLE_CHECKING 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)) #else #define debugeputs(Msg) ((void) 0) #endif /* ENABLE_CHECKING */ 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) #undef debugmsgval #define debugmsgval(Msg,Val,Count) do {}while(0) #endif /*ENABLE_CHECKING*/ /* 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 == MELTOBMAG_SPEC_FILE || magic == MELTOBMAG_SPEC_RAWFILE) return ((struct meltspecialfile_st*)file_p)->val.sp_file; return NULL; } #if ENABLE_CHECKING /* two useless routines in wich we can add a breakpoint from gdb. */ void melt_sparebreakpoint_1_at (const char*fil, int lin, void*ptr, const char*msg); void melt_sparebreakpoint_2_at (const char*fil, int lin, void*ptr, const char*msg); #define melt_sparebreakpoint_1(P,Msg) melt_sparebreakpoint_1_at(__FILE__,__LINE__,(void*)(P),(Msg)) #define melt_sparebreakpoint_2(P,Msg) melt_sparebreakpoint_2_at(__FILE__,__LINE__,(void*)(P),(Msg)) #else /*no ENABLE_CHECKING*/ #define melt_sparebreakpoint_1(P,Msg) do{(void)(0 && (P));}while(0) #define melt_sparebreakpoint_2(P,Msg) do{(void)(0 && (P));}while(0) #endif /*ENABLE_CHECKING*/ /* strangely, gcc/input.h don't define yet that macro. */ #define LOCATION_COLUMN(LOC) ((expand_location (LOC)).column) extern const char melt_run_preprocessed_md5[]; /* defined in generated file melt-run-md5.h */ #endif /*MELT_INCLUDED_ */ /* eof $Id$ */