/*** file melt-runtime.c Middle End Lisp Translator [MELT] runtime support. Copyright (C) 2008 - 2012 Free Software Foundation, Inc. Contributed by Basile Starynkevitch and Pierre Vittet and Romain Geissler and Jeremie Salvucci and Alexandre Lissy Indented with GNU indent. 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 . ***/ /* for debugging -fmelt-debug is useful */ /* To compile MELT as a plugin, try compiling with -DMELT_IS_PLUGIN. */ #ifdef MELT_IS_PLUGIN #include "gcc-plugin.h" const int melt_is_plugin = 1; #else #include "version.h" const int melt_is_plugin = 0; #endif /* MELT_IS_PLUGIN */ #include "bversion.h" #include "config.h" #include "system.h" #include "coretypes.h" #include "obstack.h" #include "tm.h" /* the file melt-run-md5.h is generated by a shell command wrapping md5sum of the preprocessed form of melt-run.h */ #include "melt-run-md5.h" /* some system or library headers needed to MELT */ #include #include #include /* meltgc_sort_multiple needs setjmp */ #include /* melt_start_probe needs wordexp */ #include #include "tree.h" #include "gimple.h" #include "intl.h" #include "filenames.h" #include "tree-pass.h" #include "tree-dump.h" #include "tree-flow.h" #include "tree-iterator.h" #include "tree-inline.h" #include "basic-block.h" #include "cfgloop.h" #include "timevar.h" #include "ggc.h" #include "cgraph.h" #include "flags.h" #include "toplev.h" #include "options.h" #include "params.h" #include "real.h" #include "prefix.h" #include "md5.h" #include "plugin.h" #include "cppdefault.h" #include "cpplib.h" #include "langhooks.h" /* Headers from c-family/ should be included directly with GCC4.6, but not with GCC 4.7 or when compiling with a C++ compiler. */ #if defined(GCCPLUGIN_VERSION) || MELT_GCC_VERSION>4006 || defined(__cplusplus) #include "c-family/c-pragma.h" #include "c-family/c-pretty-print.h" #else #include "c-pragma.h" #include "c-pretty-print.h" #endif /* Diagnostic related files need to be included after c-pretty-print.h! */ #include "diagnostic.h" /* the file "plugin-version.h" defines GCCPLUGIN_VERSION, but sadly also provide useless static constants like revision, datestamp, gcc_version, etc... and thru "configargs.h" static constants like configure_default_options etc.... */ #include "plugin-version.h" /* since 4.7, we have a GCCPLUGIN_VERSION in plugin-version.h. */ #if defined(GCCPLUGIN_VERSION) && (GCCPLUGIN_VERSION != MELT_GCC_VERSION) #error MELT Gcc version and GCC plugin version does not match #endif /*GCCPLUGIN_VERSION != MELT_GCC_VERSION */ /* the MELT branch has a BUILDING_GCC_VERSION. */ #if defined(BUILDING_GCC_VERSION) && (BUILDING_GCC_VERSION != MELT_GCC_VERSION) #MELT Gcc version and Building Gcc version does not match #endif /*BUILDING_GCC_VERSION != MELT_GCC_VERSION */ #if MELT_GCC_VERSION < 4006 #error MELT is for GCC 4.6 or newer #endif /* GCC 4.6 has realmpfr.h which includes */ #include "realmpfr.h" /* GCC 4.6 has it: */ #include "gimple-pretty-print.h" /* include a generated files of strings constants */ #include "melt-runtime-params-inc.c" #include "melt-runtime.h" #if defined(MELT_GCC_VERSION) && (MELT_GCC_VERSION > 0) const int melt_gcc_version = MELT_GCC_VERSION; #else #error should be given a MELT_GCC_VERSION #endif struct plugin_gcc_version *melt_plugin_gcc_version; #if defined (GCCPLUGIN_VERSION) const int melt_gccplugin_version = GCCPLUGIN_VERSION; #else const int melt_gccplugin_version = 0; #endif #if ENABLE_CHECKING /* For debugging purposes, used thru gdb. */ void *melt_alptr_1=NULL; void *melt_alptr_2=NULL; unsigned melt_objhash_1=0; unsigned melt_objhash_2=0; #endif /* ENABLE_CHECKING */ int melt_count_runtime_extensions; long melt_blocklevel_signals; volatile sig_atomic_t melt_signaled; volatile sig_atomic_t melt_got_sigio; volatile sig_atomic_t melt_got_sigalrm; volatile sig_atomic_t melt_got_sigchld; static struct timeval melt_start_time; #define MELT_DESC_FILESUFFIX "+meltdesc.c" #define MELT_TIME_FILESUFFIX "+melttime.h" #define MELT_DEFAULT_FLAVOR "optimized" /* our copying garbage collector needs a vector of melt_ptr_t to scan, a la Cheney. */ static GTY (()) VEC (melt_ptr_t, gc) * melt_bscanvec; /* the file gt-melt-runtime.h is generated by gengtype from melt-runtime.c & melt-runtime.h, and from MELT generated files melt/generated/meltrunsup.h and melt/generated/meltrunsup-inc.c. We need to include it here, because it could define our ggc_alloc_* macros. */ #include "gt-melt-runtime.h" const char melt_runtime_build_date[] = __DATE__; int melt_debug_garbcoll; /* Can be set in GDB, and is used by melt_debuggc_eprintf! */ static int melt_debugging_after_mode; /* the generating GGC marking routine */ extern void gt_ggc_mx_melt_un (void *); /* A nice buffer size for input or output. */ #define MELT_BUFSIZE 8192 #ifdef MELT_IS_PLUGIN int melt_flag_debug = 0; /* for MELT plugin */ int melt_flag_bootstrapping = 0; int melt_flag_generate_work_link = 0; /* In the MELT branch melt_flag_debug is #define-d in generated "options.h" as global_options.x_melt_flag_debug. */ /** NOTE: october 2009 libiberty is not fully available from a plugin. So we need to reproduce here some functions provided in libiberty.h **/ char * xstrndup (const char *s, size_t n) { char *result; size_t len = strlen (s); if (n < len) len = n; result = XNEWVEC (char, len + 1); result[len] = '\0'; return (char *) memcpy (result, s, len); } #endif /*MELT_IS_PLUGIN */ /* *INDENT-OFF* */ /* we use the plugin registration facilities, so this is the plugin name in use */ const char* melt_plugin_name; int melt_nb_modules; melt_ptr_t melt_globarr[MELTGLOB__LASTGLOB]= {0}; /* The start and end of the birth region. */ void* melt_startalz=NULL; void* melt_endalz=NULL; /* The current allocation pointer inside the birth region. Move upwards from start to end. */ char* melt_curalz=NULL; /* The current store pointer inside the birth region. Move downwards from end to start. */ void** melt_storalz=NULL; /* The initial store pointer. Don't change, but should be cleared outside of MELT. */ void** melt_initialstoralz = NULL; bool melt_is_forwarding=FALSE; long melt_forward_counter=0; static long melt_minorsizekilow = 0; static long melt_fullthresholdkilow = 0; static int melt_fullperiod = 0; /* File containing the generated C file list. Enabled by the -f[plugin-arg-]melt-generated-c-file-list= program option. */ static FILE* melt_generated_c_files_list_fil; /* Debugging file for tracing dlopen & dlsym calls for modules. Enabled by the GCCMELT_TRACE_MODULE environment variable. */ static FILE* melt_trace_module_fil; /* Debugging file for tracing source files related things. Enabled by the GCCMELT_TRACE_SOURCE environment variable. */ static FILE* melt_trace_source_fil; #if MELT_HAVE_DEBUG FILE* melt_loctrace_file; /* thru GCCMELT_TRACE_LOCATION env.var. */ #endif #define MELT_MODULE_MAGIC 0x5cc065cf /*1556112847*/ /* The start routine of every MELT module is named melt_start_this_module and gets its parent environment and returns the newly built current environment. */ typedef melt_ptr_t (melt_start_rout_t) (melt_ptr_t); typedef struct melt_module_info_st { unsigned mmi_magic; /* always MELT_MODULE_MAGIC */ void *mmi_dlh; /* dlopen handle */ char* mmi_modpath; /* strdup-ed file path passed to dlopen, ending with MELT_DYNLOADED_SUFFIX */ char* mmi_descrbase; /* strdup-ed file base path of the MELT descriptive file, without its +meltdesc.c suffix */ melt_start_rout_t *mmi_startrout; /* start routine */ } melt_module_info_t; DEF_VEC_O (melt_module_info_t); DEF_VEC_ALLOC_O (melt_module_info_t, heap); static VEC (melt_module_info_t, heap) *melt_modinfvec = 0; /* Extensions are dlopen-ed shared objects for direct evaluation */ #define MELT_EXTENSION_MAGIC 0x44b9cd8d /*0x44b9cd8d*/ typedef struct melt_extension_info_st { unsigned mmx_magic; /* always MELT_EXTENSION_MAGIC */ unsigned mmx_rank; /* the rank of this extension */ void *mmx_dlh; /* dlopen handle */ char* mmx_extpath; /* strdup-ed file path passed to dlopen, ending with MELT_DYNLOADED_SUFFIX */ char* mmx_descrbase; /* strdup-ed file base path of the MELT descriptive file, without its +meltdesc.c suffix */ /* no start routine is needed, since it is immediately called */ } melt_extension_info_t; DEF_VEC_O (melt_extension_info_t); DEF_VEC_ALLOC_O (melt_extension_info_t, heap); static VEC (melt_extension_info_t, heap) *melt_extinfvec =0; struct melt_callframe_st* melt_topframe =0; /* The start routine of every MELT extension (dynamically loaded shared object to evaluate at runtime some expressions in a given environment, e.g. used for read-eval-print-loop etc...) is named melt_start_run_extension, its parameters are a box containing the current environment to be extended and a tuple for literal values. It is returning the resulting value of the evaluation. */ typedef melt_ptr_t melt_start_runext_rout_t (melt_ptr_t /*boxcurenv*/, melt_ptr_t /*tuplitval*/); /** special values are linked in a list to permit their explicit deletion */ struct meltspecialdata_st* melt_newspecdatalist; struct meltspecialdata_st* melt_oldspecdatalist; unsigned long melt_kilowords_sincefull; /* number of full & any melt garbage collections */ unsigned long melt_nb_full_garbcoll; unsigned long melt_nb_garbcoll; void* melt_touched_cache[MELT_TOUCHED_CACHE_SIZE]; bool melt_prohibit_garbcoll; long melt_dbgcounter; long melt_debugskipcount; long melt_error_counter; /* File meltrunsup-inc.c is inside melt/generated/ */ #include "meltrunsup-inc.c" /* an strdup-ed version string of gcc */ char* melt_gccversionstr; int melt_last_global_ix = MELTGLOB__LASTGLOB; static void* proghandle; /* We have a melt prefix to minimize conflict with other code. */ typedef char *meltchar_p; DEF_VEC_P (meltchar_p); DEF_VEC_ALLOC_P (meltchar_p, heap); static VEC (meltchar_p, heap)* parsedmeltfilevect; /* to code case ALL_MELTOBMAG_SPECIAL_CASES: */ #define ALL_MELTOBMAG_SPECIAL_CASES \ MELTOBMAG_SPEC_FILE: \ case MELTOBMAG_SPEC_RAWFILE /* Obstack used for reading names */ static struct obstack melt_bname_obstack; const char* melt_version_str (void) { #ifndef MELT_REVISION #error MELT_REVISION not defined at command line compilation #endif /* MELT_REVISION is always a preprocessor constant string, because this file is compiled with something like -DMELT_REVISION='"foobar"' .... */ return MELT_VERSION_STRING " " MELT_REVISION; } #if ENABLE_CHECKING void melt_break_alptr_1_at (const char*msg, const char* fil, int line); void melt_break_alptr_2_at (const char*msg, const char* fil, int line); #define melt_break_alptr_1(Msg) melt_break_alptr_1_at((Msg),__FILE__,__LINE__) #define melt_break_alptr_2(Msg) melt_break_alptr_2_at((Msg),__FILE__,__LINE__) void melt_break_alptr_1_at (const char*msg, const char* fil, int line) { fprintf (stderr, "melt_break_alptr_1 %s:%d: %s alptr_1=%p\n", melt_basename(fil), line, msg, melt_alptr_1); fflush (stderr); } void melt_break_alptr_2_at (const char*msg, const char* fil, int line) { fprintf (stderr, "melt_break_alptr_2 %s:%d: %s alptr_2=%p\n", melt_basename(fil), line, msg, melt_alptr_2); fflush (stderr); } void melt_break_objhash_1_at (const char*msg, const char* fil, int line); void melt_break_objhash_2_at (const char*msg, const char* fil, int line); #define melt_break_objhash_1(Msg) melt_break_objhash_1_at((Msg),__FILE__,__LINE__) #define melt_break_objhash_2(Msg) melt_break_objhash_2_at((Msg),__FILE__,__LINE__) void melt_break_objhash_1_at (const char*msg, const char* fil, int line) { fprintf (stderr, "melt_break_objhash_1 %s:%d: %s objhash_1=%#x\n", melt_basename(fil), line, msg, melt_objhash_1); fflush (stderr); } void melt_break_objhash_2_at (const char*msg, const char* fil, int line) { fprintf (stderr, "melt_break_objhash_2 %s:%d: %s objhash_2=%#x\n", melt_basename(fil), line, msg, melt_objhash_2); fflush (stderr); } #endif /*ENABLE_CHECKING*/ /* The allocation & freeing of the young zone is a routine, for ease of debugging. */ static void melt_allocate_young_gc_zone (long wantedbytes) { if (wantedbytes & 0xffff) wantedbytes = (wantedbytes | 0xffff) + 1; melt_debuggc_eprintf("allocate #%ld young zone %ld [=%ldK] bytes", melt_nb_garbcoll, wantedbytes, wantedbytes >> 10); melt_startalz = melt_curalz = (char *) xcalloc (sizeof (void *), wantedbytes / sizeof (void *)); melt_endalz = (char *) melt_curalz + wantedbytes; melt_storalz = melt_initialstoralz = ((void **) melt_endalz) - 2; melt_debuggc_eprintf("allocated young zone %p-%p", (void*)melt_startalz, (void*)melt_endalz); /* You could put a breakpoint here under gdb! */ gcc_assert (melt_startalz != NULL); #if ENABLE_CHECKING if (melt_alptr_1 && (char*)melt_alptr_1 >= (char*)melt_startalz && (char*)melt_alptr_1 < (char*)melt_endalz) { fprintf (stderr, "melt_allocate_young_gc_zone zone %p-%p with alptr_1 %p", (void*)melt_startalz, (void*)melt_endalz, melt_alptr_1); fflush (stderr); melt_debuggc_eprintf("allocate #%ld young with alptr_1 %p", melt_nb_garbcoll, melt_alptr_1); melt_break_alptr_1 ("allocate with alptr_1"); }; if (melt_alptr_2 && (char*)melt_alptr_2 >= (char*)melt_startalz && (char*)melt_alptr_2 < (char*)melt_endalz) { fprintf (stderr, "melt_allocate_young_gc_zone zone %p-%p with alptr_2 %p", (void*)melt_startalz, (void*)melt_endalz, melt_alptr_2); fflush (stderr); melt_debuggc_eprintf("allocate #%ld young with alptr_2 %p", melt_nb_garbcoll, melt_alptr_2); melt_break_alptr_2 ("allocate with alptr_2"); }; #endif /*ENABLE_CHECKING*/ return; } static void melt_free_young_gc_zone (void) { gcc_assert (melt_startalz != NULL); melt_debuggc_eprintf("freeing #%ld young zone %p-%p", melt_nb_garbcoll, (void*)melt_startalz, (void*)melt_endalz); #if ENABLE_CHECKING if (melt_alptr_1 && (char*)melt_alptr_1 >= (char*)melt_startalz && (char*)melt_alptr_1 < (char*)melt_endalz) { fprintf (stderr, "melt_free_young_gc_zone zone %p-%p with alptr_1 %p", (void*)melt_startalz, (void*)melt_endalz, melt_alptr_1); fflush (stderr); melt_debuggc_eprintf("free #%ld young with alptr_1 %p", melt_nb_garbcoll, melt_alptr_1); melt_break_alptr_1 ("free with alptr_1"); }; if (melt_alptr_2 && (char*)melt_alptr_2 >= (char*)melt_startalz && (char*)melt_alptr_2 < (char*)melt_endalz) { fprintf (stderr, "melt_free_young_gc_zone zone %p-%p with alptr_2 %p", (void*)melt_startalz, (void*)melt_endalz, melt_alptr_2); fflush (stderr); melt_debuggc_eprintf("free #%ld young with alptr_2 %p", melt_nb_garbcoll, melt_alptr_2); melt_break_alptr_2("free with alptr_2"); }; #endif /*ENABLE_CHECKING*/ free (melt_startalz); melt_startalz = melt_endalz = melt_curalz = NULL; melt_storalz = melt_initialstoralz = NULL; /* You can put a gdb breakpoint here! */ gcc_assert (melt_nb_garbcoll > 0); return; } /* called from toplev.c function print_version */ void melt_print_version_info (FILE *fil, const char* indent) { if (!fil) return; if (!indent) indent="\t"; fprintf (fil, "%sMELT built-in source directory: %s\n", indent, melt_source_dir); fprintf (fil, "%sMELT built-in module directory: %s\n", indent, melt_module_dir); if (melt_is_plugin) { fprintf (fil, "%sUse -fplugin-arg-melt-source-path= or -fplugin-arg-melt-module-path= to override them with a colon-separated path.\n", indent); fprintf (fil, "%sMELT built-in module make command [-fplugin-arg-melt-module-make-command=] %s\n", indent, melt_module_make_command); fprintf (fil, "%sMELT built-in module makefile [-fplugin-arg-melt-module-makefile=] %s\n", indent, melt_module_makefile); fprintf (fil, "%sMELT built-in module cflags [-fplugin-arg-melt-module-cflags=] %s\n", indent, melt_module_cflags); fprintf (fil, "%sMELT built-in default module list [-fplugin-arg-melt-init=@]%s\n", indent, melt_default_modlis); } else { fprintf (fil, "%sUse -fmelt-source-path= or -fmelt-module-path= to override them with a colon-separated path.\n", indent); fprintf (fil, "%sMELT built-in module make command [-fmelt-module-make-command=] %s\n", indent, melt_module_make_command); fprintf (fil, "%sMELT built-in module makefile [-fmelt-module-makefile=] %s\n", indent, melt_module_makefile); fprintf (fil, "%sMELT built-in module cflags [-fmelt-module-cflags=] %s\n", indent, melt_module_cflags); fprintf (fil, "%sMELT built-in default module list [-fmelt-init=@]%s\n", indent, melt_default_modlis); } fflush (fil); } /* retrieve a MELT related program or plugin argument */ #ifdef MELT_IS_PLUGIN static int melt_plugin_argc; static struct plugin_argument* melt_plugin_argv; const char* melt_argument (const char* argname) { int argix=0; if (!argname || !argname[0]) return NULL; for (argix = 0; argix < melt_plugin_argc; argix ++) { if (!strcmp(argname, melt_plugin_argv[argix].key)) { char* val = melt_plugin_argv[argix].value; /* never return NULL if the argument is found; return an empty string if no value given */ if (!val) return ""; return val; } } return NULL; } #else /* builtin MELT, retrieve the MELT relevant program argument */ const char* melt_argument (const char* argname) { if (!argname || !argname[0]) return NULL; else if (!strcmp (argname, "mode")) { if (melt_mode_string && melt_mode_string[0]) { return melt_mode_string; } } else if (!strcmp (argname, "arg")) return melt_argument_string; else if (!strcmp (argname, "arglist")) return melt_arglist_string; else if (!strcmp (argname, "module-makefile")) return melt_module_makefile_string; else if (!strcmp (argname, "module-make-command")) return melt_module_make_command_string; else if (!strcmp (argname, "debug")) return melt_flag_debug?"yes":NULL; else if (!strcmp (argname, "debugging")) return melt_debugging_string; else if (!strcmp (argname, "inhibit-auto-build")) return melt_flag_inhibit_auto_build?"yes":NULL; else if (!strcmp (argname, "bootstrapping")) return melt_flag_bootstrapping?"yes":NULL; else if (!strcmp (argname, "generate-work-link")) return melt_flag_generate_work_link?"yes":NULL; else if (!strcmp (argname, "generated-c-file-list")) return melt_generated_c_file_list_string; else if (!strcmp (argname, "debugskip") || !strcmp (argname, "debug-skip")) return melt_count_debugskip_string; else if (!strcmp (argname, "debug-depth")) return melt_debug_depth_string; else if (!strcmp (argname, "module-path")) return melt_dynmodpath_string; else if (!strcmp (argname, "module-cflags")) return melt_module_cflags_string; else if (!strcmp (argname, "source-path")) return melt_srcpath_string; else if (!strcmp (argname, "init")) return melt_init_string; else if (!strcmp (argname, "extra")) return melt_extra_string; else if (!strcmp (argname, "output")) return melt_output_string; else if (!strcmp (argname, "coutput")) return melt_coutput_string; else if (!strcmp (argname, "option")) return melt_option_string; else if (!strcmp (argname, "probe")) return melt_probe_string; else if (!strcmp (argname, "secondarg")) return melt_secondargument_string; else if (!strcmp (argname, "tempdir")) return melt_tempdir_string; else if (!strcmp (argname, "workdir")) return melt_workdir_string; else if (!strcmp (argname, "print-settings")) return melt_print_settings_string; /* currently, minor-zone & full-threshold are parameters, so we make a string out of them */ else if (!strcmp (argname, "minor-zone")) { static char minzonstr[40]; if (!minzonstr[0]) snprintf(minzonstr, sizeof (minzonstr) - 1, "%d", PARAM_VALUE(PARAM_MELT_MINOR_ZONE)); return minzonstr; } else if (!strcmp (argname, "full-threshold")) { static char fullthrstr[40]; if (!fullthrstr[0]) snprintf(fullthrstr, sizeof (fullthrstr) - 1, "%d", PARAM_VALUE(PARAM_MELT_FULL_THRESHOLD)); return fullthrstr; } else if (!strcmp (argname, "full-period")) { static char fullperstr[40]; if (!fullperstr[0]) snprintf(fullperstr, sizeof (fullperstr) - 1, "%d", PARAM_VALUE(PARAM_MELT_FULL_PERIOD)); return fullperstr; } return NULL; } #endif /*MELT_IS_PLUGIN*/ #if defined(__GNUC__) && __GNUC__>3 /* condition to have pragma GCC poison */ /* in GCC 4.6, options are #define-ed macros! */ #ifdef melt_mode_string #undef melt_mode_string #else #pragma GCC poison melt_mode_string #endif /* melt_mode_string */ #ifdef melt_argument_string #undef melt_argument_string #else #pragma GCC poison melt_argument_string #endif #ifdef melt_arglist_string #undef melt_arglist_string #else #pragma GCC poison melt_arglist_string #endif /* don't poison melt_flag_debug or melt_flag_bootstrapping */ #ifdef melt_compile_script_string #undef melt_compile_script_string #else #pragma GCC poison melt_compile_script_string #endif #ifdef melt_count_debugskip_string #undef melt_count_debugskip_string #else #pragma GCC poison melt_count_debugskip_string #endif #ifdef melt_dynmodpath_string #undef melt_dynmodpath_string #else #pragma GCC poison melt_dynmodpath_string #endif #ifdef melt_srcpath_string #undef melt_srcpath_string #else #pragma GCC poison melt_srcpath_string #endif #ifdef melt_init_string #undef melt_init_string #else #pragma GCC poison melt_init_string #endif #ifdef melt_extra_string #undef melt_extra_string #else #pragma GCC poison melt_extra_string #endif #ifdef melt_secondargument_string #undef melt_secondargument_string #else #pragma GCC poison melt_secondargument_string #endif #ifdef melt_tempdir_string #undef melt_tempdir_string #else #pragma GCC poison melt_tempdir_string #endif #endif /* GCC >= 3 */ /* the debug depth for MELT debug_msg .... */ int melt_debug_depth (void) { #define MELT_DEFAULT_DEBUG_DEPTH 7 #define MELT_MINIMAL_DEBUG_DEPTH 2 #define MELT_MAXIMAL_DEBUG_DEPTH 25 static int d; if (MELT_UNLIKELY(!d)) { const char* dbgdepthstr = melt_argument ("debug-depth"); d = dbgdepthstr?(atoi (dbgdepthstr)):0; if (d == 0) { d = MELT_DEFAULT_DEBUG_DEPTH; warning (0, "MELT debug depth -f[plugin-arg-]melt-debug-depth= defaulted to %d", d); } if (d < MELT_MINIMAL_DEBUG_DEPTH) { warning (0, "MELT debug depth -f[plugin-arg-]melt-debug-depth= increased to %d but was %d ", MELT_MINIMAL_DEBUG_DEPTH, d); d = MELT_MINIMAL_DEBUG_DEPTH; } else if (d > MELT_MAXIMAL_DEBUG_DEPTH) { warning (0, "MELT debug depth -f[plugin-arg-]melt-debug-depth= decreased to %d but was %d ", MELT_MAXIMAL_DEBUG_DEPTH, d); d = MELT_MAXIMAL_DEBUG_DEPTH; } } return d; } #define MELTPYD_MAX_RANK 512 /* FIXME: should use a vector */ static struct melt_payload_descriptor_st* meltpyd_array[MELTPYD_MAX_RANK]; static inline void melt_delete_specialdata (struct meltspecialdata_st *msd) { unsigned kind = msd->meltspec_kind; struct melt_payload_descriptor_st* mpyd = NULL; if (kind != 0) { if (kind >= MELTPYD_MAX_RANK || (mpyd = meltpyd_array[kind]) == NULL) melt_fatal_error ("invalid kind %d of deleted special data @%p", kind, (void*)msd); if (mpyd->meltpyd_magic != MELT_PAYLOAD_DESCRIPTOR_MAGIC || (mpyd->meltpyd_rank > 0 && mpyd->meltpyd_rank != kind) || !mpyd->meltpyd_name) melt_fatal_error ("invalid payload descriptor of kind %d for deleted special data @%p", kind, (void*)msd); if (mpyd->meltpyd_destroy_rout) { melt_debuggc_eprintf ("delete_special destroying kind %d=%s data @%p", kind, mpyd->meltpyd_name, (void*)msd); (*mpyd->meltpyd_destroy_rout) (msd, mpyd); melt_debuggc_eprintf ("delete_special destroyed kind %d=%s data @%p", kind, mpyd->meltpyd_name, (void*)msd); }; } memset (msd, 0, sizeof(struct meltspecialdata_st)); } #ifdef ENABLE_CHECKING /* only for debugging, to be set from the debugger */ void *melt_checkedp_ptr1; void *melt_checkedp_ptr2; #endif /*ENABLE_CHECKING */ static void melt_scanning (melt_ptr_t); #if ENABLE_CHECKING /*** * check our call frames ***/ static inline void check_pointer_at (const char msg[], long count, melt_ptr_t * pptr, const char *filenam, int lineno) { unsigned magic = 0; melt_ptr_t ptr = *pptr; if (!ptr) return; if (!ptr->u_discr) melt_fatal_error ("<%s#%ld> corrupted pointer %p (at %p) without discr at %s:%d", msg, count, (void *) ptr, (void *) pptr, melt_basename (filenam), lineno); magic = ptr->u_discr->meltobj_magic; if (magic < MELTOBMAG__FIRST || magic >= MELTOBMAG__LAST) melt_fatal_error ("<%s#%ld> bad pointer %p (at %p) bad magic %d at %s:%d", msg, count, (void *) ptr, (void *) pptr, (int) ptr->u_discr->meltobj_magic, melt_basename (filenam), lineno); } #if ENABLE_GC_CHECKING static long meltnbcheckcallframes; static long meltthresholdcheckcallframes; void melt_check_call_frames_at (int noyoungflag, const char *msg, const char *filenam, int lineno) { /* Don't call melt_fatal_error here, because if the MELT stack is corrupted we can't show it! */ struct melt_callframe_st *cfram = NULL; int nbfram = 0, nbvar = 0; meltnbcheckcallframes++; if (!msg) msg = "/"; if (meltthresholdcheckcallframes > 0 && meltnbcheckcallframes > meltthresholdcheckcallframes) { debugeprintf ("start check_call_frames#%ld {%s} from %s:%d", meltnbcheckcallframes, msg, melt_basename (filenam), lineno); } for (cfram = melt_topframe; cfram != NULL; cfram = cfram->mcfr_prev) { int varix = 0; nbfram++; if (cfram->mcfr_closp != NULL && cfram->mcfr_nbvar >= 0) { if (noyoungflag && melt_is_young (cfram->mcfr_closp)) fatal_error ("bad MELT frame <%s#%ld> unexpected young closure %p in frame %p at %s:%d", msg, meltnbcheckcallframes, (void *) cfram->mcfr_closp, (void *) cfram, melt_basename (filenam), lineno); check_pointer_at (msg, meltnbcheckcallframes, (melt_ptr_t *) (void *) &cfram->mcfr_closp, filenam, lineno); if (cfram->mcfr_closp->discr->meltobj_magic != MELTOBMAG_CLOSURE) fatal_error ("bad MELT frame <%s#%ld> invalid closure %p in frame %p at %s:%d", msg, meltnbcheckcallframes, (void *) cfram->mcfr_closp, (void *) cfram, melt_basename (filenam), lineno); } for (varix = ((int) cfram->mcfr_nbvar) - 1; varix >= 0; varix--) { nbvar++; if (noyoungflag && cfram->mcfr_varptr[varix] != NULL && melt_is_young (cfram->mcfr_varptr[varix])) fatal_error ("bad MELT frame <%s#%ld> unexpected young pointer %p in frame %p at %s:%d", msg, meltnbcheckcallframes, (void *) cfram->mcfr_varptr[varix], (void *) cfram, melt_basename (filenam), lineno); check_pointer_at (msg, meltnbcheckcallframes, &cfram->mcfr_varptr[varix], filenam, lineno); } } if (meltthresholdcheckcallframes > 0 && meltnbcheckcallframes > meltthresholdcheckcallframes) debugeprintf ("end check_call_frames#%ld {%s} %d frames/%d vars %s:%d", meltnbcheckcallframes, msg, nbfram, nbvar, melt_basename (filenam), lineno); } #endif /*ENABLE_GC_CHECKING*/ void melt_caught_assign_at (void *ptr, const char *fil, int lin, const char *msg) { debugeprintf ("caught assign %p at %s:%d /// %s", ptr, melt_basename (fil), lin, msg); } static long nbcbreak; void melt_cbreak_at (const char *msg, const char *fil, int lin) { nbcbreak++; debugeprintf_raw ("%s:%d: CBREAK#%ld %s\n", melt_basename (fil), lin, nbcbreak, msg); } #endif /*ENABLE_CHECKING*/ /* make a special value; return NULL if the discriminant is not special */ struct meltspecial_st* meltgc_make_special (melt_ptr_t discr_p) { unsigned magic = 0; MELT_ENTERFRAME (2, NULL); #define discrv meltfram__.mcfr_varptr[0] #define specv meltfram__.mcfr_varptr[1] #define sp_specv ((struct meltspecial_st*)(specv)) #define spda_specv ((struct meltspecialdata_st*)(specv)) discrv = discr_p; if (!discrv || melt_magic_discr((melt_ptr_t)discrv) != MELTOBMAG_OBJECT) goto end; magic = ((meltobject_ptr_t)discrv)->meltobj_magic; switch (magic) { /* our new special data */ case MELTOBMAG_SPECIAL_DATA: { specv = meltgc_allocate (sizeof(struct meltspecialdata_st), 0); memset (specv, 0, sizeof(struct meltspecialdata_st)); spda_specv->discr = (meltobject_ptr_t) discrv; spda_specv->meltspec_mark = 0; spda_specv->meltspec_next = melt_newspecdatalist; melt_newspecdatalist = (struct meltspecialdata_st*)specv; melt_debuggc_eprintf ("make_special data %p discr %p magic %d %s", specv, discrv, magic, melt_obmag_string(magic)); #if ENABLE_CHECKING if (melt_alptr_1 && (void*)melt_alptr_1 == specv) { fprintf (stderr, "meltgc_make_special data alptr_1 %p mag %d %s\n", melt_alptr_1, magic, melt_obmag_string(magic)); fflush (stderr); melt_break_alptr_1 ("meltgc_make_special data alptr_1"); }; if (melt_alptr_2 && (void*)melt_alptr_2 == specv) { fprintf (stderr, "meltgc_make_special data alptr_2 %p mag %d %s\n", melt_alptr_2, magic, melt_obmag_string(magic)); fflush (stderr); melt_break_alptr_2 ("meltgc_make_special data alptr_2"); }; #endif /*ENABLE_CHECKING*/ } break; default: goto end; } end: MELT_EXITFRAME(); return sp_specv; #undef discrv #undef specv #undef sp_specv #undef spda_specv } /* make a special value; return NULL if the discriminant is not special data */ struct meltspecialdata_st* meltgc_make_specialdata (melt_ptr_t discr_p) { unsigned magic = 0; MELT_ENTERFRAME (2, NULL); #define discrv meltfram__.mcfr_varptr[0] #define specv meltfram__.mcfr_varptr[1] #define spda_specv ((struct meltspecialdata_st*)(specv)) discrv = discr_p; if (!discrv || melt_magic_discr((melt_ptr_t)discrv) != MELTOBMAG_OBJECT) goto end; magic = ((meltobject_ptr_t)discrv)->meltobj_magic; if (magic != MELTOBMAG_SPECIAL_DATA) goto end; specv = meltgc_allocate (sizeof(struct meltspecialdata_st), 0); memset (specv, 0, sizeof(struct meltspecialdata_st)); spda_specv->discr = (meltobject_ptr_t) discrv; spda_specv->meltspec_mark = 0; spda_specv->meltspec_next = melt_newspecdatalist; melt_newspecdatalist = (struct meltspecialdata_st*)specv; melt_debuggc_eprintf ("make_specialdata %p discr %p magic %d %s", specv, discrv, magic, melt_obmag_string(magic)); #if ENABLE_CHECKING if (melt_alptr_1 && (void*)melt_alptr_1 == specv) { fprintf (stderr, "meltgc_make_specialdata alptr_1 %p mag %d %s\n", melt_alptr_1, magic, melt_obmag_string(magic)); fflush (stderr); melt_break_alptr_1 ("meltgc_make_special data alptr_1"); }; if (melt_alptr_2 && (void*)melt_alptr_2 == specv) { fprintf (stderr, "meltgc_make_specialdata alptr_2 %p mag %d %s\n", melt_alptr_2, magic, melt_obmag_string(magic)); fflush (stderr); melt_break_alptr_2 ("meltgc_make_specialdata alptr_2"); }; #endif /*ENABLE_CHECKING*/ end: MELT_EXITFRAME(); return spda_specv; #undef discrv #undef specv #undef spda_specv } char* meltgc_specialdata_sprint (melt_ptr_t specd_p) { char *res = NULL; unsigned kind = 0; struct melt_payload_descriptor_st* mpyd = NULL; MELT_ENTERFRAME (1, NULL); #define specv meltfram__.mcfr_varptr[0] #define spda_specv ((struct meltspecialdata_st*)(specv)) specv = specd_p; if (melt_magic_discr ((melt_ptr_t) specv) != MELTOBMAG_SPECIAL_DATA) goto end; kind = spda_specv->meltspec_kind; if (kind > 0 && kind < MELTPYD_MAX_RANK && (mpyd = meltpyd_array[kind]) != NULL) { gcc_assert (mpyd->meltpyd_magic == MELT_PAYLOAD_DESCRIPTOR_MAGIC); gcc_assert (mpyd->meltpyd_rank == 0 || mpyd->meltpyd_rank == kind); if (mpyd->meltpyd_sprint_rout) res = (*mpyd->meltpyd_sprint_rout) (spda_specv, mpyd); if (!res) { char resbuf[80]; snprintf (resbuf, sizeof(resbuf), "special:%s@@%p.%#lx", mpyd->meltpyd_name, (void*) specv, (long) spda_specv->meltspec_payload.meltpayload_ptr1); res = xstrdup (resbuf); } } end: MELT_EXITFRAME (); return res; #undef specv #undef spda_specv } /*** * the marking routine is registered thru PLUGIN_GGC_MARKING * it makes GGC play nice with MELT. **/ static long meltmarkingcount; static void melt_marking_callback (void *gcc_data ATTRIBUTE_UNUSED, void* user_data ATTRIBUTE_UNUSED) { int ix = 0; melt_ptr_t *storp = NULL; struct melt_callframe_st *cf = 0; meltmarkingcount++; dbgprintf ("start of melt_marking_callback %ld", meltmarkingcount); /* Scan all the MELT call frames */ for (cf = (struct melt_callframe_st*) melt_topframe; cf != NULL; cf = cf->mcfr_prev) { dbgprintf ("melt_marking_callback %ld cf=%p", meltmarkingcount, (void*) cf); if (cf->mcfr_closp && cf->mcfr_nbvar >= 0) { /* Common case, we have a closure. */ meltroutfun_t*funp = 0; int ix = 0; gcc_assert(cf->mcfr_closp->rout); funp = cf->mcfr_closp->rout->routfunad; gcc_assert(funp); melt_debuggc_eprintf ("melt_marking_callback %ld marking*frame %p with closure & %d vars", meltmarkingcount, (void*) cf, cf->mcfr_nbvar); gt_ggc_mx_melt_un ((melt_ptr_t)(cf->mcfr_closp)); for (ix = ((int)(cf->mcfr_nbvar)) - 1; ix >= 0; ix --) gt_ggc_mx_melt_un ((melt_ptr_t)(cf->mcfr_varptr[ix])); /* call the function specially with the MARKGCC special parameter descriptor */ funp(cf->mcfr_closp, (melt_ptr_t)cf, MELTPAR_MARKGGC, (union meltparam_un*)0, (char*)0, (union meltparam_un*)0); } else if (cf->mcfr_nbvar < 0 && cf->mcfr_forwmarkrout) { /* Rare case, the frame is special and has its own marking routine. This happens in particular for the initial frame of generated MELT modules; their startup routine has a special marking routine. */ melt_debuggc_eprintf ("melt_marking_callback %ld marking*frame thru routine frame %p", meltmarkingcount, (void*) cf); cf->mcfr_forwmarkrout ((struct melt_callframe_st*)cf, 1); melt_debuggc_eprintf ("melt_marking_callback %ld called frame %p marking routine", meltmarkingcount, (void*)cf); } else { /* no closure, e.g. a frame manually set with MELT_ENTERFRAME. */ extern void gt_ggc_mx_melt_un (void *); melt_debuggc_eprintf ("melt_marking_callback %ld marking*frame no closure frame %p-%p of %d vars", meltmarkingcount, (void*)cf, (void*)(cf->mcfr_varptr + cf->mcfr_nbvar), cf->mcfr_nbvar); /* if no closure, mark the local pointers */ for (ix= 0; ix<(int) cf->mcfr_nbvar; ix++) if (cf->mcfr_varptr[ix]) gt_ggc_mx_melt_un ((melt_ptr_t)(cf->mcfr_varptr[ix])); } } /* mark the store list. */ if (melt_storalz) for (storp = (melt_ptr_t *) melt_storalz; (char *) storp < (char *) melt_endalz; storp++) { melt_ptr_t curstorp = (melt_ptr_t) *storp; if (curstorp) gt_ggc_mx_melt_un (curstorp); } dbgprintf("end of melt_marking_callback %ld", meltmarkingcount); } static void melt_delete_unmarked_new_specialdata (void) { struct meltspecialdata_st *specda = NULL; /* Delete every unmarked special data on the new list and clear it */ for (specda = melt_newspecdatalist; specda != NULL; specda = specda->meltspec_next) { gcc_assert (melt_is_young (specda)); melt_debuggc_eprintf ("melt_delete_unmarked_new_specialdata specda %p has mark %d", (void*) specda, specda->meltspec_mark); #if ENABLE_CHECKING if (melt_alptr_1 && (void*)melt_alptr_1 == (void*)specda) { unsigned mag = specda->discr->meltobj_magic; fprintf (stderr, "melt_delete_unmarked_new_specialdata new special alptr_1 %p mag %d\n", melt_alptr_1, mag); fflush (stderr); melt_debuggc_eprintf("melt_delete_unmarked_new_specialdata #%ld new special alptr_1 %p mag %d", melt_nb_garbcoll, melt_alptr_1, mag); melt_break_alptr_1 ("garbcoll new specialdata alptr_1"); } if (melt_alptr_2 && (void*)melt_alptr_2 == (void*)specda) { unsigned mag = specda->discr->meltobj_magic; fprintf (stderr, "melt_delete_unmarked_new_specialdata new special alptr_2 %p mag %d\n", melt_alptr_2, mag); fflush (stderr); melt_debuggc_eprintf("melt_delete_unmarked_new_specialdata #%ld new special alptr_2 %p mag %d", melt_nb_garbcoll, melt_alptr_2, mag); melt_break_alptr_2 ("garbcoll new specialdata alptr_2"); } #endif /*ENABLE_CHECKING*/ if (!specda->meltspec_mark) { melt_debuggc_eprintf ("melt_delete_unmarked_new_specialdata deleting newspec %p", (void*)specda); melt_delete_specialdata (specda); } } melt_newspecdatalist = NULL; } /* The minor MELT GC is a copying generational garbage collector whose old space is the GGC heap. */ static void melt_minor_copying_garbage_collector (size_t wanted) { struct melt_callframe_st *cfram = NULL; melt_ptr_t *storp = NULL; int ix = 0; melt_check_call_frames (MELT_ANYWHERE, "before garbage collection"); melt_debuggc_eprintf ("melt_minor_copying_garbage_collector %ld begin alz=%p-%p *****************\n", melt_nb_garbcoll, melt_startalz, melt_endalz); gcc_assert ((char *) melt_startalz < (char *) melt_endalz); gcc_assert ((char *) melt_curalz >= (char *) melt_startalz && (char *) melt_curalz < (char *) melt_storalz); gcc_assert ((char *) melt_storalz < (char *) melt_endalz); melt_bscanvec = VEC_alloc (melt_ptr_t, gc, 1024 + 32 * melt_minorsizekilow); wanted += wanted / 4 + melt_minorsizekilow * 1000; wanted |= 0x3fff; wanted++; if (wanted < melt_minorsizekilow * sizeof (void *) * 1024) wanted = melt_minorsizekilow * sizeof (void *) * 1024; melt_is_forwarding = TRUE; melt_forward_counter = 0; for (ix = 0; ix < MELTGLOB__LASTWIRED; ix++) MELT_FORWARDED (melt_globarr[ix]); for (ix = MELTGLOB__LASTWIRED; ix < MELTGLOB__LASTGLOB; ix++) melt_globarr[ix] = NULL; for (cfram = melt_topframe; cfram != NULL; cfram = cfram->mcfr_prev) { int varix = 0; if (cfram->mcfr_nbvar < 0 && cfram->mcfr_forwmarkrout) { melt_debuggc_eprintf ("melt_minor_copying_garbage_collector forwarding*frame %p thru routine", (void*) cfram); cfram->mcfr_forwmarkrout (cfram, 0); } else if (cfram->mcfr_nbvar >= 0) { melt_debuggc_eprintf ("melt_minor_copying_garbage_collector forwarding*frame %p-%p of %d nbvars", (void*) cfram, (void*) (cfram->mcfr_varptr + cfram->mcfr_nbvar), cfram->mcfr_nbvar); MELT_FORWARDED (cfram->mcfr_closp); for (varix = 0; varix < cfram->mcfr_nbvar; varix ++) MELT_FORWARDED (cfram->mcfr_varptr[varix]); }; melt_debuggc_eprintf ("melt_minor_copying_garbage_collector forwarding*frame %p done", (void*)cfram); }; melt_debuggc_eprintf ("melt_minor_copying_garbage_collector %ld done forwarding", melt_nb_garbcoll); melt_is_forwarding = FALSE; /* Scan the store list. */ for (storp = (melt_ptr_t *) melt_storalz; (char *) storp < (char *) melt_endalz; storp++) { if (*storp) melt_scanning (*storp); } melt_debuggc_eprintf ("melt_minor_copying_garbage_collector %ld scanned store list", melt_nb_garbcoll); memset (melt_touched_cache, 0, sizeof (melt_touched_cache)); /* Sort of Cheney loop; http://en.wikipedia.org/wiki/Cheney%27s_algorithm */ while (!VEC_empty (melt_ptr_t, melt_bscanvec)) { melt_ptr_t p = VEC_pop (melt_ptr_t, melt_bscanvec); if (!p) continue; melt_scanning (p); } VEC_free (melt_ptr_t, gc, melt_bscanvec); melt_bscanvec = NULL; melt_delete_unmarked_new_specialdata (); /* Free the previous young zone and allocate a new one. */ melt_debuggc_eprintf ("melt_minor_copying_garbage_collector %ld freeing alz=%p-%p", melt_nb_garbcoll, melt_startalz, melt_endalz); melt_free_young_gc_zone (); melt_kilowords_sincefull += wanted / (1024 * sizeof (void *)); melt_allocate_young_gc_zone (wanted); melt_debuggc_eprintf ("melt_minor_copying_garbage_collector ending %ld allocated alz=%p-%p", melt_nb_garbcoll, melt_startalz, melt_endalz); } /* Plugin callback started at beginning of GGC, to run a minor copying MELT GC. */ static void melt_ggcstart_callback (void *gcc_data ATTRIBUTE_UNUSED, void* user_data ATTRIBUTE_UNUSED) { /* Run the minor GC if the birth region has been used, or if its store part is non empty (this covers the rare case when no MELT values have been allocated, but some have been written into). */ if (melt_startalz != NULL && melt_curalz != NULL && melt_storalz != NULL && melt_initialstoralz != NULL && ((char *) melt_curalz > (char *) melt_startalz || melt_storalz < melt_initialstoralz)) { if (melt_prohibit_garbcoll) fatal_error ("melt minor garbage collection prohibited from GGC start callback"); melt_debuggc_eprintf ("melt_ggcstart_callback need a minor copying GC with %ld young Kilobytes\n", (((char *) melt_curalz - (char *) melt_startalz))>>10); melt_minor_copying_garbage_collector (0); } } static long melt_clear_old_specialdata (void) { long nboldspecdata = 0; struct meltspecialdata_st *specda = NULL; struct meltspecialdata_st *nextspecda = NULL; /* clear our mark fields on old special list before running Ggc. */ for (specda = melt_oldspecdatalist; specda != NULL; specda = nextspecda) { specda->meltspec_mark = 0; nextspecda = specda->meltspec_next; nboldspecdata++; #if ENABLE_CHECKING if (melt_alptr_1 && (void*)melt_alptr_1 == (void*)specda) { unsigned mag = specda->discr->meltobj_magic; fprintf (stderr, "melt_clear_old_specialdata oldmark special alptr_1 %p mag %d\n", melt_alptr_1, mag); fflush (stderr); melt_debuggc_eprintf("melt_clear_old_specialdata #%ld clear oldmark special alptr_1 %p mag %d", melt_nb_garbcoll, melt_alptr_1, mag); melt_break_alptr_1 ("melt_clear_old_specialdata oldmark special alptr_1"); } if (melt_alptr_2 && (void*)melt_alptr_2 == (void*)specda) { unsigned mag = specda->discr->meltobj_magic; fprintf (stderr, "melt_clear_old_specialdata oldmark special alptr_2 %p mag %d\n", melt_alptr_2, mag); fflush (stderr); melt_debuggc_eprintf("melt_clear_old_specialdata #%ld clear oldmark special alptr_2 %p mag %d", melt_nb_garbcoll, melt_alptr_2, mag); melt_break_alptr_2 ("melt_clear_old_specialdata oldmark special alptr_2"); } #endif /* ENABLE_CHECKING */ }; return nboldspecdata; } static void melt_delete_unmarked_old_specialdata (void) { struct meltspecialdata_st *specda = NULL; struct meltspecialdata_st *nextspecda = NULL; struct meltspecialdata_st **prevspecdaptr = NULL; /* Delete the unmarked specials. */ prevspecdaptr = &melt_oldspecdatalist; for (specda = melt_oldspecdatalist; specda != NULL; specda = nextspecda) { nextspecda = specda->meltspec_next; #if ENABLE_CHECKING if (melt_alptr_1 && (void*)melt_alptr_1 == (void*)specda) { int mag = specda->discr->meltobj_magic; fprintf (stderr, "melt_delete_unmarked_old_specialdata alptr_1 %p mag %d\n", melt_alptr_1, mag); fflush (stderr); melt_debuggc_eprintf("melt_delete_unmarked_old_specialdata #%ld old special alptr_1 %p mag %d", melt_nb_garbcoll, melt_alptr_1, mag); melt_break_alptr_1 ("melt_delete_unmarked_old_specialdata alptr_1"); } if (melt_alptr_2 && (void*)melt_alptr_2 == (void*)specda) { int mag = specda->discr->meltobj_magic; fprintf (stderr, "melt_delete_unmarked_old_specialdata alptr_2 %p mag %d\n", melt_alptr_2, mag); fflush (stderr); melt_debuggc_eprintf("melt_delete_unmarked_old_specialdata #%ld old special alptr_2 %p mag %d", melt_nb_garbcoll, melt_alptr_2, mag); melt_break_alptr_2 ("melt_delete_unmarked_old_specialdata alptr_2"); } #endif /*ENABLE_CHECKING*/ melt_debuggc_eprintf ("melt_delete_unmarked_old_specialdata deletespecloop old specp %p mark %d", (void*)specda, specda->meltspec_mark); /* We test both the mark field, if mark_hook is really working in gengtype, and the result of ggc_marked_p, for GCC versions where it is not working. mark_hook don't always work in GCC 4.7 and probably not even in 4.6. See http://gcc.gnu.org/ml/gcc-patches/2012-10/msg00164.html for a corrective patch to gengtype. */ if (specda->meltspec_mark || ggc_marked_p(specda)) { prevspecdaptr = &specda->meltspec_next; continue; } melt_debuggc_eprintf ("melt_delete_unmarked_old_specialdata deletespecloop deleting old specp %p", (void*)specda); melt_delete_specialdata (specda); memset (specda, 0, sizeof (*specda)); ggc_free (specda); *prevspecdaptr = nextspecda; }; } /*** * Our copying garbage collector, based upon GGC which does the full collection. ***/ void melt_garbcoll (size_t wanted, enum melt_gckind_en gckd) { bool needfull = FALSE; if (melt_prohibit_garbcoll) fatal_error ("MELT garbage collection prohibited"); melt_nb_garbcoll++; if (gckd == MELT_NEED_FULL) { melt_debuggc_eprintf ("melt_garbcoll explicitly needs full gckd#%d", (int) gckd); needfull = TRUE; } /* set some parameters if they are cleared. Should happen once. The default values (used in particular in plugin mode) are not the minimal ones. */ if (melt_minorsizekilow == 0) { const char* minzstr = melt_argument ("minor-zone"); melt_minorsizekilow = minzstr? (atol (minzstr)) : 1024; if (melt_minorsizekilow < 512) melt_minorsizekilow = 512; else if (melt_minorsizekilow > 16384) melt_minorsizekilow = 16384; } if (melt_fullthresholdkilow == 0) { const char* fullthstr = melt_argument ("full-threshold"); melt_fullthresholdkilow = fullthstr ? (atol (fullthstr)) : 2048; if (melt_fullthresholdkilow < 1024) melt_fullthresholdkilow = 1024; if (melt_fullthresholdkilow < 2*melt_minorsizekilow) melt_fullthresholdkilow = 2*melt_minorsizekilow; if (melt_fullthresholdkilow > 65536) melt_fullthresholdkilow =65536; } if (melt_fullperiod == 0) { const char* fullperstr = melt_argument ("full-period"); melt_fullperiod = fullperstr ? (atoi (fullperstr)) : 64; if (melt_fullperiod < 32) melt_fullperiod = 32; else if (melt_fullperiod > 256) melt_fullperiod = 256; } if (melt_nb_garbcoll % melt_fullperiod == 0) { melt_debuggc_eprintf ("melt_garbcoll peridically need full nbgarbcoll %ld fullperiod %d", melt_nb_garbcoll, melt_fullperiod); needfull = TRUE; } if (gckd > MELT_ONLY_MINOR && melt_kilowords_sincefull > (unsigned long) melt_fullthresholdkilow) { melt_debuggc_eprintf ("melt_garbcoll need full threshold melt_kilowords_sincefull %ld melt_fullthresholdkilow %ld", melt_kilowords_sincefull, melt_fullthresholdkilow); needfull = TRUE; } melt_minor_copying_garbage_collector (wanted); if (needfull) { long nboldspec = 0; melt_nb_full_garbcoll++; debugeprintf ("melt_garbcoll #%ld fullgarbcoll #%ld", melt_nb_garbcoll, melt_nb_full_garbcoll); melt_clear_old_specialdata (); debugeprintf ("melt_garbcoll calling gcc_collect #%ld after clearing %ld oldspecial marks", melt_nb_full_garbcoll, nboldspec); /* There is no need to force a GGC collection, just to run it, and Ggc may decide to skip it. */ ggc_collect (); debugeprintf ("melt_garbcoll after fullgarbcoll #%ld", melt_nb_full_garbcoll); melt_delete_unmarked_old_specialdata (); if (!quiet_flag) { /* when not quiet, the GGC collector displays data, so we can add a message and end the line! "*/ fprintf (stderr, " MELT full gc#%ld/%ld [%ld Kw]\n", melt_nb_full_garbcoll, melt_nb_garbcoll, melt_kilowords_sincefull); fflush (stderr); } melt_kilowords_sincefull = 0; /* end of MELT full garbage collection */ } melt_check_call_frames (MELT_NOYOUNG, "after garbage collection"); } static void meltpayload_file_destroy (struct meltspecialdata_st*, const struct melt_payload_descriptor_st*); static char* meltpayload_file_sprint (struct meltspecialdata_st*, const struct melt_payload_descriptor_st*); static struct melt_payload_descriptor_st meltpydescr_file = { /* .meltpyd_magic = */ MELT_PAYLOAD_DESCRIPTOR_MAGIC, /* .meltpyd_rank = */ meltpydkind_file, /* .meltpyd_name = */ "file", /* .meltpyd_data = */ NULL, /* .meltpyd_destroy_rout = */ meltpayload_file_destroy, /* .meltpyd_sprint_rout = */ meltpayload_file_sprint, /* .meltpyd_spare1 =*/ 0, /* .meltpyd_spare2 =*/ 0, /* .meltpyd_spare3 =*/ 0 }; static void meltpayload_rawfile_destroy (struct meltspecialdata_st*, const struct melt_payload_descriptor_st*); static char* meltpayload_rawfile_sprint (struct meltspecialdata_st*, const struct melt_payload_descriptor_st*); static struct melt_payload_descriptor_st meltpydescr_rawfile = { /* .meltpyd_magic = */ MELT_PAYLOAD_DESCRIPTOR_MAGIC, /* .meltpyd_rank = */ meltpydkind_rawfile, /* .meltpyd_name = */ "rawfile", /* .meltpyd_data = */ NULL, /* .meltpyd_destroy_rout = */ meltpayload_rawfile_destroy, /* .meltpyd_sprint_rout = */ meltpayload_rawfile_sprint, /* .meltpyd_spare1 = */ 0, /* .meltpyd_spare2 =*/ 0, /* .meltpyd_spare3 =*/ 0 }; static void melt_payload_initialize_static_descriptors (void) { meltpyd_array[meltpydkind_file] = &meltpydescr_file; meltpyd_array[meltpydkind_rawfile] = &meltpydescr_rawfile; } int melt_payload_register_descriptor (struct melt_payload_descriptor_st*mpd) { unsigned mrk = 0; if (!mpd) return 0; if (mpd->meltpyd_magic != MELT_PAYLOAD_DESCRIPTOR_MAGIC || !mpd->meltpyd_name) melt_fatal_error("MELT cannot register corrupted payload descriptor @%p", (void*) mpd); if (mpd->meltpyd_rank > 0 && mpd->meltpyd_rank < MELTPYD_MAX_RANK && meltpyd_array[mpd->meltpyd_rank] == mpd) return mpd->meltpyd_rank; if (mpd->meltpyd_rank != 0) melt_fatal_error("MELT cannot register payload descriptor @%p with bad rank %d", (void*) mpd, mpd->meltpyd_rank); { unsigned r = 0; for (r = meltpydkind__last; r < MELTPYD_MAX_RANK && !mrk; r++) if (!meltpyd_array[r]) mrk = r; } if (!mrk) melt_fatal_error("MELT cannot register payload descriptor @%p, table of %d is full", (void*)mpd, MELTPYD_MAX_RANK); mpd->meltpyd_rank = mrk; meltpyd_array[mrk] = mpd; return mrk; } static void meltpayload_file_destroy (struct meltspecialdata_st*, const struct melt_payload_descriptor_st*); static char* meltpayload_file_sprint (struct meltspecialdata_st*, const struct melt_payload_descriptor_st*); static void meltpayload_rawfile_destroy (struct meltspecialdata_st*sd, const struct melt_payload_descriptor_st*mpd ATTRIBUTE_UNUSED) { if (sd->meltspec_payload.meltpayload_file1) fflush (sd->meltspec_payload.meltpayload_file1); sd->meltspec_payload.meltpayload_file1 = NULL; } static char* meltpayload_rawfile_sprint (struct meltspecialdata_st*sd, const struct melt_payload_descriptor_st*mpd ATTRIBUTE_UNUSED) { char buf[64]; if (sd->meltspec_payload.meltpayload_file1) snprintf (buf, sizeof(buf), "raw:FILE@%p#%d", (void*)(sd->meltspec_payload.meltpayload_file1), fileno (sd->meltspec_payload.meltpayload_file1)); else strcpy (buf, "raw-NULL-FILE"); return xstrdup (buf); } static void meltpayload_file_destroy (struct meltspecialdata_st*sd, const struct melt_payload_descriptor_st*mpd ATTRIBUTE_UNUSED) { if (sd->meltspec_payload.meltpayload_file1) fclose (sd->meltspec_payload.meltpayload_file1); sd->meltspec_payload.meltpayload_file1 = NULL; } static char* meltpayload_file_sprint (struct meltspecialdata_st*sd, const struct melt_payload_descriptor_st*mpd ATTRIBUTE_UNUSED) { char buf[64]; if (sd->meltspec_payload.meltpayload_file1) snprintf (buf, sizeof(buf), "FILE@%p#%d", (void*)(sd->meltspec_payload.meltpayload_file1), fileno (sd->meltspec_payload.meltpayload_file1)); else strcpy (buf, "NULL-FILE"); return xstrdup (buf); } /* The inline function melt_allocatereserved is the only one calling this melt_reserved_allocation_failure function, which should never be called. If it is indeed called, you've been bitten by a severe bug. In principle melt_allocatereserved should have been called with a suitable previous call to meltgc_reserve such that all the reserved allocations fits into the reserved size */ void melt_reserved_allocation_failure (long siz) { /* this function should never really be called */ fatal_error ("memory corruption in MELT reserved allocation: " "requiring %ld bytes but only %ld available in young zone", siz, (long) ((char *) melt_storalz - (char *) melt_curalz)); } /** array of about 190 primes gotten by shell command /usr/games/primes 3 2000000000 | awk '($1>p+p/8){print $1, ","; p=$1}' **/ const long melt_primtab[256] = { 0, /* the first entry indexed #0 is 0 to never be used */ 3, 5, 7, 11, 13, 17, 23, 29, 37, 43, 53, 61, 71, 83, 97, 113, 131, 149, 173, 197, 223, 251, 283, 331, 373, 421, 479, 541, 613, 691, 787, 887, 1009, 1151, 1297, 1471, 1657, 1867, 2111, 2377, 2677, 3019, 3407, 3833, 4327, 4871, 5483, 6173, 6947, 7817, 8803, 9907, 11149, 12547, 14143, 15913, 17903, 20143, 22669, 25523, 28723, 32321, 36373, 40927, 46049, 51817, 58309, 65599, 73819, 83047, 93463, 105167, 118343, 133153, 149803, 168533, 189613, 213319, 239999, 270001, 303767, 341743, 384469, 432539, 486617, 547453, 615887, 692893, 779507, 876947, 986567, 1109891, 1248631, 1404721, 1580339, 1777891, 2000143, 2250163, 2531443, 2847893, 3203909, 3604417, 4054987, 4561877, 5132117, 5773679, 6495389, 7307323, 8220743, 9248339, 10404403, 11704963, 13168091, 14814103, 16665881, 18749123, 21092779, 23729411, 26695609, 30032573, 33786659, 38010019, 42761287, 48106453, 54119761, 60884741, 68495347, 77057297, 86689469, 97525661, 109716379, 123430961, 138859837, 156217333, 175744531, 197712607, 222426683, 250230023, 281508827, 316697431, 356284619, 400820209, 450922753, 507288107, 570699121, 642036517, 722291083, 812577517, 914149741, #if HOST_BITS_PER_LONG >= 64 1028418463, 1156970821, 1301592203, 1464291239, 1647327679, 1853243677, 2084899139, 2345511541, 2638700497, 2968538081, 3339605383, 3757056091, 4226688133, 4755024167, 5349402193, 6018077509, 6770337239, 7616629399, 8568708139, 9639796667, 10844771263, 12200367671, 13725413633, 15441090347, 17371226651, 19542629983, 21985458749, 24733641113, 27825346259, 31303514549, 35216453869, 39618510629, 44570824481, 50142177559, #endif 0, 0 }; /* index of entry to get or add an attribute in an mapobject (or -1 on error) */ static inline int unsafe_index_mapobject (struct entryobjectsmelt_st *tab, meltobject_ptr_t attr, int siz) { int da = 0, ix = 0, frix = -1; unsigned h = 0; if (!tab) return -1; da = attr->meltobj_class->meltobj_magic; if (da == MELTOBMAG_OBJECT) h = ((struct meltobject_st *) attr)->obj_hash; else return -1; h = h % siz; for (ix = h; ix < siz; ix++) { meltobject_ptr_t curat = tab[ix].e_at; if (curat == attr) return ix; else if (curat == (void *) HTAB_DELETED_ENTRY) { if (frix < 0) frix = ix; } else if (!curat) { if (frix < 0) frix = ix; return frix; } } for (ix = 0; ix < (int) h; ix++) { meltobject_ptr_t curat = tab[ix].e_at; if (curat == attr) return ix; else if (curat == (void *) HTAB_DELETED_ENTRY) { if (frix < 0) frix = ix; } else if (!curat) { if (frix < 0) frix = ix; return frix; } } if (frix >= 0) return frix; /* found some place in a table with deleted entries but no empty entries */ return -1; /* entirely full, should not happen */ } melt_ptr_t meltgc_new_int (meltobject_ptr_t discr_p, long num) { MELT_ENTERFRAME (2, NULL); #define newintv meltfram__.mcfr_varptr[0] #define discrv meltfram__.mcfr_varptr[1] #define object_discrv ((meltobject_ptr_t)(discrv)) #define int_newintv ((struct meltint_st*)(newintv)) discrv = (void *) discr_p; if (!discrv) discrv = (melt_ptr_t) MELT_PREDEF (DISCR_INTEGER); if (melt_magic_discr ((melt_ptr_t) (discrv)) != MELTOBMAG_OBJECT) goto end; if (object_discrv->meltobj_magic != MELTOBMAG_INT) goto end; newintv = meltgc_allocate (sizeof (struct meltint_st), 0); int_newintv->discr = object_discrv; int_newintv->val = num; end: MELT_EXITFRAME (); return (melt_ptr_t) newintv; #undef newintv #undef discrv #undef int_newintv #undef object_discrv } melt_ptr_t meltgc_new_mixint (meltobject_ptr_t discr_p, melt_ptr_t val_p, long num) { MELT_ENTERFRAME (3, NULL); #define newmix meltfram__.mcfr_varptr[0] #define discrv meltfram__.mcfr_varptr[1] #define valv meltfram__.mcfr_varptr[2] #define object_discrv ((meltobject_ptr_t)(discrv)) #define mix_newmix ((struct meltmixint_st*)(newmix)) newmix = NULL; discrv = (void *) discr_p; if (!discrv) discrv = (melt_ptr_t) MELT_PREDEF (DISCR_MIXED_INTEGER); valv = val_p; if (melt_magic_discr ((melt_ptr_t) (discrv)) != MELTOBMAG_OBJECT) goto end; if (object_discrv->meltobj_magic != MELTOBMAG_MIXINT) goto end; newmix = meltgc_allocate (sizeof (struct meltmixint_st), 0); mix_newmix->discr = object_discrv; mix_newmix->intval = num; mix_newmix->ptrval = (melt_ptr_t) valv; end: MELT_EXITFRAME (); return (melt_ptr_t) newmix; #undef newmix #undef valv #undef discrv #undef mix_newmix #undef object_discrv } melt_ptr_t meltgc_new_mixloc (meltobject_ptr_t discr_p, melt_ptr_t val_p, long num, location_t loc) { MELT_ENTERFRAME (3, NULL); #define newmix meltfram__.mcfr_varptr[0] #define discrv meltfram__.mcfr_varptr[1] #define valv meltfram__.mcfr_varptr[2] #define object_discrv ((meltobject_ptr_t)(discrv)) #define mix_newmix ((struct meltmixloc_st*)(newmix)) newmix = NULL; discrv = (void *) discr_p; valv = val_p; if (!discrv) discrv = (melt_ptr_t) MELT_PREDEF (DISCR_MIXED_LOCATION); if (melt_magic_discr ((melt_ptr_t) (discrv)) != MELTOBMAG_OBJECT) goto end; if (object_discrv->meltobj_magic != MELTOBMAG_MIXLOC) goto end; newmix = meltgc_allocate (sizeof (struct meltmixloc_st), 0); mix_newmix->discr = object_discrv; mix_newmix->intval = num; mix_newmix->ptrval = (melt_ptr_t) valv; mix_newmix->locval = loc; end: MELT_EXITFRAME (); return (melt_ptr_t) newmix; #undef newmix #undef valv #undef discrv #undef mix_newmix #undef object_discrv } melt_ptr_t meltgc_new_mixbigint_mpz (meltobject_ptr_t discr_p, melt_ptr_t val_p, mpz_t mp) { unsigned numb = 0, blen = 0; size_t wcnt = 0; MELT_ENTERFRAME (3, NULL); #define newbig meltfram__.mcfr_varptr[0] #define discrv meltfram__.mcfr_varptr[1] #define valv meltfram__.mcfr_varptr[2] #define object_discrv ((meltobject_ptr_t)(discrv)) #define mix_newbig ((struct meltmixbigint_st*)(newbig)) newbig = NULL; discrv = (void *) discr_p; if (!discrv) discrv = (meltobject_ptr_t) MELT_PREDEF (DISCR_MIXED_BIGINT); valv = val_p; if (melt_magic_discr ((melt_ptr_t) (discrv)) != MELTOBMAG_OBJECT) goto end; if (object_discrv->meltobj_magic != MELTOBMAG_MIXBIGINT) goto end; if (!mp) goto end; numb = 8*sizeof(mix_newbig->tabig[0]); blen = (mpz_sizeinbase (mp, 2) + numb-1) / numb; newbig = meltgc_allocate (sizeof (struct meltmixbigint_st), blen*sizeof(mix_newbig->tabig[0])); mix_newbig->discr = object_discrv; mix_newbig->ptrval = (melt_ptr_t) valv; mix_newbig->negative = (mpz_sgn (mp)<0); mix_newbig->biglen = blen; mpz_export (mix_newbig->tabig, &wcnt, /*most significant word first */ 1, sizeof(mix_newbig->tabig[0]), /*native endian*/ 0, /* no nails bits */ 0, mp); gcc_assert(wcnt <= blen); end: MELT_EXITFRAME (); return (melt_ptr_t) newbig; #undef newbig #undef valv #undef discrv #undef mix_newbig #undef object_discrv } melt_ptr_t meltgc_new_real (meltobject_ptr_t discr_p, REAL_VALUE_TYPE r) { MELT_ENTERFRAME (2, NULL); #define resv meltfram__.mcfr_varptr[0] #define discrv meltfram__.mcfr_varptr[1] #define object_discrv ((meltobject_ptr_t)(discrv)) #define real_resv ((struct meltreal_st*) resv) discrv = (void*) discr_p; if (!discrv) discrv = (meltobject_ptr_t) MELT_PREDEF (DISCR_REAL); if (object_discrv->meltobj_magic != MELTOBMAG_REAL) goto end; resv = meltgc_allocate (sizeof (struct meltreal_st), 0); real_resv->discr = object_discrv; real_resv->val = r; end: MELT_EXITFRAME (); return (melt_ptr_t) resv; #undef resv #undef discrv #undef object_discrv #undef real_resv } /* 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) { MELT_ENTERFRAME (2, NULL); #define newroutv meltfram__.mcfr_varptr[0] #define discrv meltfram__.mcfr_varptr[1] #define obj_discrv ((meltobject_ptr_t)(discrv)) #define rou_newroutv ((meltroutine_ptr_t)(newroutv)) newroutv = NULL; discrv = discr_p; if (melt_magic_discr ((melt_ptr_t) (discrv)) != MELTOBMAG_OBJECT || obj_discrv->meltobj_magic != MELTOBMAG_ROUTINE || !descr || !descr[0] || !proc || len > MELT_MAXLEN) goto end; newroutv = meltgc_allocate (sizeof (struct meltroutine_st), len * sizeof (void *)); rou_newroutv->discr = (meltobject_ptr_t) discrv; rou_newroutv->nbval = len; rou_newroutv->routfunad = proc; strncpy (rou_newroutv->routdescr, descr, MELT_ROUTDESCR_LEN - 1); rou_newroutv->routdescr[MELT_ROUTDESCR_LEN - 1] = (char) 0; end: MELT_EXITFRAME (); return (meltroutine_ptr_t) newroutv; #undef newroutv #undef discrv #undef obj_discrv #undef rou_newroutv } void meltgc_set_routine_data (melt_ptr_t rout_p, melt_ptr_t data_p) { MELT_ENTERFRAME (2, NULL); #define routv meltfram__.mcfr_varptr[0] #define datav meltfram__.mcfr_varptr[1] routv = rout_p; datav = data_p; if (melt_magic_discr ((melt_ptr_t) routv) == MELTOBMAG_ROUTINE) { ((meltroutine_ptr_t) routv)->routdata = (melt_ptr_t) datav; meltgc_touch_dest (routv, datav); } MELT_EXITFRAME (); #undef routv #undef datav } meltclosure_ptr_t meltgc_new_closure (meltobject_ptr_t discr_p, meltroutine_ptr_t rout_p, unsigned len) { MELT_ENTERFRAME (3, NULL); #define newclosv meltfram__.mcfr_varptr[0] #define discrv meltfram__.mcfr_varptr[1] #define routv meltfram__.mcfr_varptr[2] #define clo_newclosv ((meltclosure_ptr_t)(newclosv)) #define obj_discrv ((meltobject_ptr_t)(discrv)) #define rou_routv ((meltroutine_ptr_t)(routv)) discrv = discr_p; routv = rout_p; newclosv = NULL; if (melt_magic_discr ((melt_ptr_t) (discrv)) != MELTOBMAG_OBJECT || obj_discrv->meltobj_magic != MELTOBMAG_CLOSURE || melt_magic_discr ((melt_ptr_t) (routv)) != MELTOBMAG_ROUTINE || len > MELT_MAXLEN) goto end; newclosv = meltgc_allocate (sizeof (struct meltclosure_st), sizeof (void *) * len); clo_newclosv->discr = (meltobject_ptr_t) discrv; clo_newclosv->rout = (meltroutine_ptr_t) routv; clo_newclosv->nbval = len; end: MELT_EXITFRAME (); return (meltclosure_ptr_t) newclosv; #undef newclosv #undef discrv #undef routv #undef clo_newclosv #undef obj_discrv #undef rou_routv } struct meltstrbuf_st * meltgc_new_strbuf (meltobject_ptr_t discr_p, const char *str) { int slen = 0, blen = 0, ix = 0; MELT_ENTERFRAME (2, NULL); #define newbufv meltfram__.mcfr_varptr[0] #define discrv meltfram__.mcfr_varptr[1] #define buf_newbufv ((struct meltstrbuf_st*)(newbufv)) discrv = discr_p; newbufv = NULL; if (melt_magic_discr ((melt_ptr_t) (discrv)) != MELTOBMAG_OBJECT) goto end; if (((meltobject_ptr_t) (discrv))->meltobj_magic != MELTOBMAG_STRBUF) goto end; if (str) slen = strlen (str); gcc_assert (slen < MELT_MAXLEN); slen += slen / 5 + 40; for (ix = 2; (blen = melt_primtab[ix]) != 0 && blen < slen; ix++); gcc_assert (blen != 0); newbufv = meltgc_allocate (offsetof (struct meltstrbuf_st, buf_space), blen + 1); buf_newbufv->discr = (meltobject_ptr_t) discrv; buf_newbufv->bufzn = buf_newbufv->buf_space; buf_newbufv->buflenix = ix; buf_newbufv->bufstart = 0; if (str) { strcpy (buf_newbufv->bufzn, str); buf_newbufv->bufend = strlen (str); } else buf_newbufv->bufend = 0; end: MELT_EXITFRAME (); return (struct meltstrbuf_st *) newbufv; #undef newbufv #undef discrv #undef buf_newbufv } /* we need to be able to compute the length of the last line of a FILE* filled by MELT output primitives; very often this FILE* will be stdout or stderr; and we don't care that much if the computed length of the last [i.e. current] line is wrong. So we keep an array of positions in FILE*, indexed by their fileno, which we suppose is small */ #define MELTMAXFILE 512 static long lasteol[MELTMAXFILE]; long melt_output_length (melt_ptr_t out_p) { if (!out_p) return 0; switch (melt_magic_discr (out_p)) { case MELTOBMAG_STRBUF: { struct meltstrbuf_st *sb = (struct meltstrbuf_st *) out_p; if (sb->bufend >= sb->bufstart) return sb->bufend - sb->bufstart; } break; case MELTOBMAG_SPECIAL_DATA: { struct meltspecialdata_st* spd = (struct meltspecialdata_st*) out_p; if (spd->meltspec_kind == meltpydkind_file || spd->meltspec_kind == meltpydkind_rawfile) { FILE *fil = spd->meltspec_payload.meltpayload_file1; if (fil) { long off = ftell (fil); return off; } } } break; default: break; } return 0; } void meltgc_strbuf_reserve (melt_ptr_t outbuf_p, unsigned reslen) { unsigned blen = 0; unsigned slen = 0; MELT_ENTERFRAME (1, NULL); #define outbufv meltfram__.mcfr_varptr[0] #define buf_outbufv ((struct meltstrbuf_st*)(outbufv)) outbufv = outbuf_p; if (!outbufv || melt_magic_discr ((melt_ptr_t) (outbufv)) != MELTOBMAG_STRBUF) goto end; blen = melt_primtab[buf_outbufv->buflenix]; gcc_assert (blen > 0); gcc_assert (buf_outbufv->bufstart <= buf_outbufv->bufend && buf_outbufv->bufend < (unsigned) blen); if (buf_outbufv->bufend + reslen + 1 < blen) /* simplest case, there is enough space without changing the strbuf */ goto end; slen = buf_outbufv->bufend - buf_outbufv->bufstart; if (slen + reslen + 2 < blen) { /* the strbuf has enough space, but it needs to be moved... */ memmove (buf_outbufv->bufzn, buf_outbufv->bufzn + buf_outbufv->bufstart, slen); buf_outbufv->bufstart = 0; buf_outbufv->bufend = slen; memset (buf_outbufv->bufzn + slen, 0, blen-slen-1); } else { unsigned long newblen = 0; int newix = 0; unsigned long newsiz = slen + reslen + 10; bool wasyoung = FALSE; newsiz += newsiz/8; #if MELT_HAVE_DEBUG /* to help catching monster buffer overflow */ if (newsiz > MELT_BIGLEN) { static unsigned long sbufthreshold; if (newsiz > sbufthreshold && melt_flag_debug) { unsigned int shownsize = 0; long rnd = melt_lrand() & 0xffffff; sbufthreshold = ((newsiz + (sbufthreshold / 4)) | 0xff) + 1; shownsize = (int)(5000 + (sbufthreshold/(MELT_BIGLEN/16))); gcc_assert ((shownsize * 3L) < newsiz); /* we generate a quasirandom marker to ease searching */ debugeprintf_raw("\n\n##########%06lx##\n", rnd); debugeprintf ("MELT string buffer @%p of length %ld growing very big to %ld\n", outbufv, (long) (buf_outbufv->bufend - buf_outbufv->bufstart), newsiz); debugeprintf("MELT big string buffer starts with %d bytes:\n%.*s\n", shownsize, shownsize, buf_outbufv->bufzn + buf_outbufv->bufstart); debugeprintf_raw("##########%06lx##\n", rnd); debugeprintf("MELT big string buffer ends with %d bytes:\n%.*s\n", shownsize, shownsize, buf_outbufv->bufzn + buf_outbufv->bufend - shownsize); debugeprintf_raw("##########%06lx##\n", rnd); melt_dbgshortbacktrace ("MELT big string buffer", 20); } } #endif if (newsiz > MELT_MAXLEN) melt_fatal_error ("MELT string buffer overflow, needed %ld bytes = %ld Megabytes!", (long)newsiz, (long)newsiz>>20); for (newix = buf_outbufv->buflenix + 1; (newblen = melt_primtab[newix]) != 0 && newblen < newsiz; newix++) {}; gcc_assert (newblen != 0) /* Otherwise, the required buffer is too big. */; /* we need to allocate more memory for the buffer... */ if (melt_is_young (outbufv)) { wasyoung = TRUE; meltgc_reserve (8*sizeof(void*) + sizeof(struct meltstrbuf_st) + newblen); /* The previous reservation may have triggered a MELT minor collection and have copied outbufv out of the young zone, so we test again for youngness. */ } if (wasyoung && melt_is_young (outbufv)) { /* If the buffer is still young, we do have enough place in the young birth region. */ char* newb = NULL; gcc_assert (melt_is_young (buf_outbufv->bufzn)); newb = (char*) melt_allocatereserved (newblen + 1, 0); memcpy (newb, buf_outbufv->bufzn + buf_outbufv->bufstart, slen); newb[slen] = 0; buf_outbufv->buflenix = newix; buf_outbufv->bufzn = newb; buf_outbufv->bufstart = 0; buf_outbufv->bufend = slen; } else { /* The buffer is old, in Ggc heap. */ char* newzn = NULL; char* oldzn = buf_outbufv->bufzn; gcc_assert (!melt_is_young (oldzn)); #ifdef ggc_alloc_cleared_atomic /* GCC 4.6 or later */ newzn = (char*) ggc_alloc_cleared_atomic (newblen+1); #else newzn = (char *) ggc_alloc_cleared (newblen+1); #endif /* ggc_alloc_cleared_atomic */ memcpy (newzn, oldzn + buf_outbufv->bufstart, slen); newzn[slen] = 0; memset (oldzn, 0, slen<100?slen/2:50); buf_outbufv->buflenix = newix; buf_outbufv->bufzn = newzn; buf_outbufv->bufstart = 0; buf_outbufv->bufend = slen; ggc_free (oldzn); } meltgc_touch ((melt_ptr_t)outbufv); } end: MELT_EXITFRAME (); #undef outbufv #undef buf_outbufv } void meltgc_add_out_raw_len (melt_ptr_t outbuf_p, const char *str, int slen) { int blen = 0; MELT_ENTERFRAME (2, NULL); #define outbufv meltfram__.mcfr_varptr[0] #define buf_outbufv ((struct meltstrbuf_st*)(outbufv)) #define spec_outbufv ((struct meltspecial_st*)(outbufv)) #define spda_outbufv ((struct meltspecialdata_st*)(outbufv)) outbufv = outbuf_p; if (!str) goto end; if (slen<0) slen = strlen (str); if (slen<=0) goto end; switch (melt_magic_discr ((melt_ptr_t) (outbufv))) { case MELTOBMAG_SPECIAL_DATA: { if (spda_outbufv->meltspec_kind == meltpydkind_file || spda_outbufv->meltspec_kind == meltpydkind_rawfile) { FILE *f = spda_outbufv->meltspec_payload.meltpayload_file1; if (f) { int fno = fileno (f); const char* eol = NULL; long fp = ftell (f); (void) fwrite(str, (size_t)slen, (size_t)1, f); if (fno < MELTMAXFILE && fno >= 0 && (eol = strchr(str, '\n')) && eol-str < slen) lasteol[fno] = fp + (eol-str); } } } break; case MELTOBMAG_STRBUF: gcc_assert (!melt_is_young (str)); blen = melt_primtab[buf_outbufv->buflenix]; gcc_assert (blen > 0); gcc_assert (buf_outbufv->bufstart <= buf_outbufv->bufend && buf_outbufv->bufend < (unsigned) blen); if ((int) buf_outbufv->bufend + slen + 2 < blen) { /* simple case, just copy at end */ strncpy (buf_outbufv->bufzn + buf_outbufv->bufend, str, slen); buf_outbufv->bufend += slen; buf_outbufv->bufzn[buf_outbufv->bufend] = 0; } else if ((int) buf_outbufv->bufstart > (int) 0 && (int) buf_outbufv->bufend - (int) buf_outbufv->bufstart + (int) slen + 2 < (int) blen) { /* should move the buffer to fit */ int oldlen = buf_outbufv->bufend - buf_outbufv->bufstart; gcc_assert (oldlen >= 0); memmove (buf_outbufv->bufzn, buf_outbufv->bufzn + buf_outbufv->bufstart, oldlen); buf_outbufv->bufstart = 0; strncpy (buf_outbufv->bufzn + oldlen, str, slen); buf_outbufv->bufend = oldlen + slen; buf_outbufv->bufzn[buf_outbufv->bufend] = 0; } else { /* should grow the buffer to fit */ int oldlen = buf_outbufv->bufend - buf_outbufv->bufstart; gcc_assert (oldlen >= 0); meltgc_strbuf_reserve ((melt_ptr_t) outbufv, slen + (slen+oldlen)/8 + 30); strncpy (buf_outbufv->bufzn + buf_outbufv->bufend, str, slen); buf_outbufv->bufend += slen; buf_outbufv->bufzn[buf_outbufv->bufend] = 0; } break; default: goto end; } end: MELT_EXITFRAME (); #undef outbufv #undef buf_outbufv #undef spec_outbufv #undef spda_outbufv } void meltgc_add_out_raw (melt_ptr_t out_p, const char *str) { meltgc_add_out_raw_len(out_p, str, -1); } void meltgc_add_out (melt_ptr_t out_p, const char *str) { char sbuf[80]; char *cstr = NULL; int slen = 0; if (str) slen = strlen (str); if (slen <= 0) return; if (slen < (int) sizeof (sbuf) - 1) { memset (sbuf, 0, sizeof (sbuf)); strcpy (sbuf, str); meltgc_add_out_raw (out_p, sbuf); } else { cstr = xstrdup (str); meltgc_add_out_raw (out_p, cstr); free (cstr); } } void meltgc_add_out_cstr_len (melt_ptr_t outbuf_p, const char *str, int slen) { const char *ps = NULL; char *pd = NULL; char *lastnl = NULL; char *encstr = NULL; /* duplicate the given string either on stack in tinybuf or in xcalloc-ed buffer */ char *dupstr = NULL; int encsiz = 0; char tinybuf[80]; if (!str) return; if (slen<0) slen = strlen(str); if (slen<(int) sizeof(tinybuf)-3) { memset (tinybuf, 0, sizeof(tinybuf)); memcpy (tinybuf, str, slen); dupstr = tinybuf; } else { dupstr = (char*) xcalloc (slen + 2, 1); memcpy (dupstr, str, slen); } /* at most four characters e.g. \xAB per original character, but occasionally a backslashed newline for readability */ encsiz = slen+slen/16+8; encstr = (char *) xcalloc (encsiz+4, 1); pd = encstr; for (ps = dupstr; *ps; ps++) { int curlinoff = pd - (lastnl?lastnl:encstr); if (pd - encstr > encsiz - 8) { int newsiz = ((5*encsiz/4 + slen/8 + 5)|7); char *newstr = (char*)xcalloc (newsiz+1, 1); size_t curln = pd - encstr; memcpy (newstr, encstr, curln); free (encstr), encstr = newstr; encsiz = newsiz; pd = encstr + curln; } if (ps[1] && ps[2] && ps[3] && curlinoff > 65 && ps[4]) { if ((!ISALNUM(ps[0]) && ps[0] != '_') || ISSPACE(ps[0]) || curlinoff > 76) { strcpy (pd, "\\" "\n"); pd += 2; lastnl = pd; } } switch (*ps) { #define ADDS(S) strcpy(pd, S); pd += sizeof(S)-1; break case '\n': if (ps[1] && ps[2] && curlinoff > 32) { strcpy (pd, "\\" "\n"); pd += 2; lastnl = pd; } ADDS ("\\n"); case '\r': ADDS ("\\r"); case '\t': ADDS ("\\t"); case '\v': ADDS ("\\v"); case '\f': ADDS ("\\f"); case '\'': ADDS ("\\\'"); case '\"': ADDS ("\\\""); case '\\': ADDS ("\\\\"); #undef ADDS default: if (ISPRINT (*ps)) *(pd++) = *ps; else { sprintf (pd, "\\%03o", (*ps) & 0xff); pd += 4; } } }; if (dupstr && dupstr != tinybuf) free (dupstr); meltgc_add_out_raw (outbuf_p, encstr); free (encstr); } void meltgc_add_out_csubstr_len (melt_ptr_t outbuf_p, const char *str, int off, int slen) { if (!str) return; if (off < 0) off=0; if (slen < 0) slen = strlen(str+off); meltgc_add_out_cstr_len (outbuf_p, str+off, slen); } void meltgc_add_out_cstr (melt_ptr_t outbuf_p, const char *str) { meltgc_add_out_cstr_len (outbuf_p, str, -1); } void meltgc_add_out_ccomment (melt_ptr_t outbuf_p, const char *str) { int slen = str ? strlen (str) : 0; const char *ps = NULL; char *pd = NULL; char *cstr = NULL; if (!str || !str[0]) return; cstr = (char *) xcalloc (slen + 4, 4); pd = cstr; for (ps = str; *ps; ps++) { if (ps[0] == '/' && ps[1] == '*') { pd[0] = '/'; pd[1] = '+'; pd += 2; ps++; } else if (ps[0] == '*' && ps[1] == '/') { pd[0] = '+'; pd[1] = '/'; pd += 2; ps++; } else *(pd++) = *ps; }; meltgc_add_out_raw (outbuf_p, cstr); free (cstr); } void meltgc_add_out_cident (melt_ptr_t outbuf_p, const char *str) { int slen = str ? strlen (str) : 0; char *dupstr = 0; const char *ps = 0; char *pd = 0; char tinybuf[80]; if (!str || !str[0]) return; if (slen < (int) sizeof (tinybuf) - 2) { memset (tinybuf, 0, sizeof (tinybuf)); dupstr = tinybuf; } else dupstr = (char *) xcalloc (slen + 2, 1); if (str) for (ps = (const char *) str, pd = dupstr; *ps; ps++) { if (ISALNUM (*ps)) *(pd++) = *ps; else if (pd > dupstr && pd[-1] != '_') *(pd++) = '_'; else *pd = (char) 0; pd[1] = (char) 0; } meltgc_add_out_raw (outbuf_p, dupstr); if (dupstr && dupstr != tinybuf) free (dupstr); } void meltgc_add_out_cidentprefix (melt_ptr_t outbuf_p, const char *str, int preflen) { const char *ps = 0; char *pd = 0; char tinybuf[80]; if (str) { int lenst = strlen (str); if (lenst < preflen) preflen = lenst; } else return; /* we don't care to trim the C identifier in generated stuff */ if (preflen >= (int) sizeof (tinybuf) - 1) preflen = sizeof (tinybuf) - 2; if (preflen <= 0) return; memset (tinybuf, 0, sizeof (tinybuf)); for (pd = tinybuf, ps = str; ps < str + preflen && *ps; ps++) { if (ISALNUM (*ps)) *(pd++) = *ps; else if (pd > tinybuf && pd[-1] != '_') *(pd++) = '_'; } meltgc_add_out_raw (outbuf_p, tinybuf); } void meltgc_add_out_hex (melt_ptr_t outbuf_p, unsigned long l) { if (l == 0UL) meltgc_add_out_raw (outbuf_p, "0"); else { int ix = 0, j = 0; char revbuf[80], thebuf[80]; memset (revbuf, 0, sizeof (revbuf)); memset (thebuf, 0, sizeof (thebuf)); while (ix < (int) sizeof (revbuf) - 1 && l != 0UL) { unsigned h = l & 15; l >>= 4; revbuf[ix++] = "0123456789abcdef"[h]; } ix--; for (j = 0; j < (int) sizeof (thebuf) - 1 && ix >= 0; j++, ix--) thebuf[j] = revbuf[ix]; meltgc_add_out_raw (outbuf_p, thebuf); } } void meltgc_add_out_dec (melt_ptr_t outbuf_p, long l) { if (l == 0L) meltgc_add_out_raw (outbuf_p, "0"); else { int ix = 0, j = 0, neg = 0; char revbuf[96], thebuf[96]; memset (revbuf, 0, sizeof (revbuf)); memset (thebuf, 0, sizeof (thebuf)); if (l < 0) { l = -l; neg = 1; }; while (ix < (int) sizeof (revbuf) - 1 && l != 0UL) { unsigned h = l % 10; l = l / 10; revbuf[ix++] = "0123456789"[h]; } ix--; if (neg) { thebuf[0] = '-'; j = 1; }; for (; j < (int) sizeof (thebuf) - 1 && ix >= 0; j++, ix--) thebuf[j] = revbuf[ix]; meltgc_add_out_raw (outbuf_p, thebuf); } } void meltgc_out_printf (melt_ptr_t outbuf_p, const char *fmt, ...) { char *cstr = NULL; va_list ap; int l = 0; char tinybuf[120]; MELT_ENTERFRAME (2, NULL); #define outbufv meltfram__.mcfr_varptr[0] outbufv = outbuf_p; if (!melt_is_out ((melt_ptr_t) outbufv)) goto end; memset (tinybuf, 0, sizeof (tinybuf)); va_start (ap, fmt); l = vsnprintf (tinybuf, sizeof (tinybuf) - 1, fmt, ap); va_end (ap); if (l < (int) sizeof (tinybuf) - 3) { meltgc_add_strbuf_raw ((melt_ptr_t) outbufv, tinybuf); goto end; } va_start (ap, fmt); cstr = (char*) xcalloc ((l + 10)|7, 1); memset (cstr, 0, l+2); if (vsprintf (cstr, fmt, ap) > l) gcc_unreachable (); va_end (ap); meltgc_add_out_raw ((melt_ptr_t) outbufv, cstr); free (cstr); end: MELT_EXITFRAME (); #undef outbufv } /* 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 outbuf_p, int depth, int linethresh) { int llln = 0; /* last line length */ int outmagic = 0; /* the magic of outbuf */ MELT_ENTERFRAME (2, NULL); /* we need a frame, because we have more than one call to meltgc_add_outbuf_raw */ #define outbv meltfram__.mcfr_varptr[0] #define outbufv ((struct meltstrbuf_st*)(outbv)) #define spec_outv ((struct meltspecial_st*)(outbv)) #define spda_outv ((struct meltspecialdata_st*)(outbv)) outbv = outbuf_p; if (!outbv) goto end; outmagic = melt_magic_discr((melt_ptr_t) outbv); if (linethresh > 0 && linethresh < 40) linethresh = 40; /* compute the last line length llln */ if (outmagic == MELTOBMAG_STRBUF) { char *bs = 0, *be = 0, *nl = 0; bs = outbufv->bufzn + outbufv->bufstart; be = outbufv->bufzn + outbufv->bufend; for (nl = be - 1; nl > bs && *nl && *nl != '\n'; nl--); llln = be - nl; gcc_assert (llln >= 0); } else if (outmagic == MELTOBMAG_SPECIAL_DATA) { FILE *f = spda_outv->meltspec_payload.meltpayload_file1; int fn = f?fileno(f):-1; if (f && fn>=0 && fn<=MELTMAXFILE) llln = ftell(f) - lasteol[fn]; } if (linethresh > 0 && llln < linethresh) meltgc_add_out_raw ((melt_ptr_t) outbv, " "); else { int nbsp = depth; static const char spaces32[] = " "; meltgc_add_out_raw ((melt_ptr_t) outbv, "\n"); if (nbsp < 0) nbsp = 0; if (nbsp > 0 && nbsp % 32 != 0) meltgc_add_out_raw ((melt_ptr_t) outbv, spaces32 + (32 - nbsp % 32)); } end: MELT_EXITFRAME (); #undef outbufv #undef outbv #undef spec_outv #undef spda_outv } void melt_output_strbuf_to_file (melt_ptr_t sbuf, const char*filnam) { FILE* fil=0; char* namdot=0; char tmpsuffix[64]; time_t now = 0; /* we don't have any MELT garbage collection roots, because no allocation is done! */ if (!sbuf || melt_magic_discr (sbuf) != MELTOBMAG_STRBUF) return; if (!filnam || !filnam[0]) return; /* Use a unique temporary suffix to be more friendly when GCC MELT is invoked by a parallel make. */ memset (tmpsuffix, 0, sizeof(tmpsuffix)); time (&now); snprintf (tmpsuffix, sizeof(tmpsuffix)-1, ".%d-%d-%d.tmp", (int) getpid(), ((int) now) % 1000, (int) ((melt_lrand()) & 0xfffff)); namdot = concat(filnam, tmpsuffix, NULL); fil = fopen(namdot, "w"); if (!fil) melt_fatal_error ("failed to open MELT output file %s [%s]", namdot, xstrerror (errno)); if (fwrite (melt_strbuf_str (sbuf), (size_t) melt_strbuf_usedlength (sbuf), (size_t) 1, fil) <= 0) melt_fatal_error ("failed to write %d bytes into MELT output file %s [%s]", melt_strbuf_usedlength (sbuf), namdot, xstrerror (errno)); if (fclose (fil)) melt_fatal_error ("failed to close MELT output file %s [%s]", namdot, xstrerror (errno)); fil = NULL; if (rename (namdot, filnam)) melt_fatal_error ("failed to rename MELT output file from %s to %s [%s]", namdot, filnam, xstrerror (errno)); free (namdot); } /***************/ meltobject_ptr_t meltgc_new_raw_object (meltobject_ptr_t klass_p, unsigned len) { unsigned h = 0; MELT_ENTERFRAME (2, NULL); #define newobjv meltfram__.mcfr_varptr[0] #define klassv meltfram__.mcfr_varptr[1] #define obj_newobjv ((meltobject_ptr_t)(newobjv)) #define obj_klassv ((meltobject_ptr_t)(klassv)) newobjv = NULL; klassv = klass_p; if (melt_magic_discr ((melt_ptr_t) (klassv)) != MELTOBMAG_OBJECT || obj_klassv->meltobj_magic != MELTOBMAG_OBJECT || len >= SHRT_MAX) goto end; /* the sizeof below could be the offsetof obj__tabfields */ newobjv = meltgc_allocate (sizeof (struct meltobject_st), len * sizeof (void *)); obj_newobjv->meltobj_class = (meltobject_ptr_t) klassv; do { h = melt_lrand () & MELT_MAXHASH; } while (h == 0); obj_newobjv->obj_hash = h; obj_newobjv->obj_len = len; #if ENABLE_CHECKING if (melt_alptr_1 && (void*)melt_alptr_1 == (void*)newobjv) melt_break_alptr_1("newrawobj alptr_1"); if (melt_alptr_2 && (void*)melt_alptr_2 == (void*)newobjv) melt_break_alptr_2("newrawobj alptr_1"); if (melt_objhash_1 == h) melt_break_objhash_1("newrawobj objhash1"); if (melt_objhash_2 == h) melt_break_objhash_1("newrawobj objhash2"); #endif end: MELT_EXITFRAME (); return (meltobject_ptr_t) newobjv; #undef newobjv #undef klassv #undef obj_newobjv #undef obj_klassv } /* allocate a new multiple of given DISCR & length LEN */ melt_ptr_t meltgc_new_multiple (meltobject_ptr_t discr_p, unsigned len) { MELT_ENTERFRAME (2, NULL); #define newmul meltfram__.mcfr_varptr[0] #define discrv meltfram__.mcfr_varptr[1] #define object_discrv ((meltobject_ptr_t)(discrv)) #define mult_newmul ((struct meltmultiple_st*)(newmul)) discrv = (void *) discr_p; newmul = NULL; gcc_assert (len < MELT_MAXLEN); if (melt_magic_discr ((melt_ptr_t) (discrv)) != MELTOBMAG_OBJECT) goto end; if (object_discrv->meltobj_magic != MELTOBMAG_MULTIPLE) goto end; newmul = meltgc_allocate (sizeof (struct meltmultiple_st), sizeof (void *) * len); mult_newmul->discr = object_discrv; mult_newmul->nbval = len; end: MELT_EXITFRAME (); return (melt_ptr_t) newmul; #undef newmul #undef discr #undef mult_newmul #undef object_discrv } /* 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) { int oldlen=0, newlen=0, i=0; MELT_ENTERFRAME(3, NULL); #define oldmulv meltfram__.mcfr_varptr[0] #define newmulv meltfram__.mcfr_varptr[1] #define mult_oldmulv ((struct meltmultiple_st*)(oldmulv)) #define mult_newmulv ((struct meltmultiple_st*)(newmulv)) oldmulv = oldmul_p; newmulv = NULL; if (melt_magic_discr ((melt_ptr_t) (oldmulv)) != MELTOBMAG_MULTIPLE) goto end; oldlen = mult_oldmulv->nbval; if (startix < 0) startix += oldlen; if (endix < 0) endix += oldlen; if (startix < 0 || startix >= oldlen) goto end; if (endix < 0 || endix >= oldlen || endix < startix) goto end; newlen = endix - startix; newmulv = meltgc_allocate (sizeof (struct meltmultiple_st), sizeof (void *) * newlen); mult_newmulv->discr = mult_oldmulv->discr; mult_newmulv->nbval = newlen; for (i=0; itabval[i] = mult_oldmulv->tabval[startix+i]; end: MELT_EXITFRAME (); return (melt_ptr_t) newmulv; #undef oldmulv #undef newmulv #undef mult_oldmulv #undef mult_newmulv } void meltgc_multiple_put_nth (melt_ptr_t mul_p, int n, melt_ptr_t val_p) { int ln = 0; MELT_ENTERFRAME (2, NULL); #define mulv meltfram__.mcfr_varptr[0] #define mult_mulv ((struct meltmultiple_st*)(mulv)) #define valv meltfram__.mcfr_varptr[1] mulv = mul_p; valv = val_p; if (melt_magic_discr ((melt_ptr_t) (mulv)) != MELTOBMAG_MULTIPLE) goto end; ln = mult_mulv->nbval; if (n < 0) n += ln; if (n >= 0 && n < ln) { mult_mulv->tabval[n] = (melt_ptr_t) valv; meltgc_touch_dest (mulv, valv); } end: MELT_EXITFRAME (); #undef mulv #undef mult_mulv #undef valv } /*** sort a multiple with a compare closure which should return a number; if it does not, the sort return nil, by longjmp-ing out of qsort ***/ static jmp_buf mulsort_escapjmp; static melt_ptr_t *mulsort_mult_ad; static melt_ptr_t *mulsort_clos_ad; static int mulsort_cmp (const void *p1, const void *p2) { int ok = 0; int cmp = 0; int ix1 = -1, ix2 = -1; long cmplg = 0; union meltparam_un argtab[2]; union meltparam_un restab[2]; MELT_ENTERFRAME (5, NULL); #define rescmpv meltfram__.mcfr_varptr[0] #define val1v meltfram__.mcfr_varptr[1] #define val2v meltfram__.mcfr_varptr[2] #define clov meltfram__.mcfr_varptr[3] #define mulv meltfram__.mcfr_varptr[4] mulv = *mulsort_mult_ad; clov = *mulsort_clos_ad; ix1 = *(const int *) p1; ix2 = *(const int *) p2; val1v = melt_multiple_nth ((melt_ptr_t) mulv, ix1); val2v = melt_multiple_nth ((melt_ptr_t) mulv, ix2); if (val1v == val2v) { ok = 1; cmp = 0; goto end; } memset (argtab, 0, sizeof (argtab)); memset (restab, 0, sizeof (restab)); argtab[0].meltbp_aptr = (melt_ptr_t *) & val2v; restab[0].meltbp_longptr = & cmplg; MELT_LOCATION_HERE("multiple sort internal compare"); rescmpv = melt_apply ((meltclosure_ptr_t) clov, (melt_ptr_t) val1v, MELTBPARSTR_PTR, argtab, MELTBPARSTR_LONG, restab); if (melt_magic_discr ((melt_ptr_t) rescmpv) == MELTOBMAG_INT) { ok = 1; cmp = melt_get_int ((melt_ptr_t) rescmpv); } else if (rescmpv) { ok = 1; cmp = (int) cmplg; } end: MELT_EXITFRAME (); #undef rescmpv #undef val1v #undef val2v #undef clov if (!ok) { longjmp (mulsort_escapjmp, 1); } return cmp; } melt_ptr_t meltgc_sort_multiple (melt_ptr_t mult_p, melt_ptr_t clo_p, melt_ptr_t discrm_p) { int *ixtab = 0; int i = 0; unsigned mulen = 0; MELT_ENTERFRAME (5, NULL); #define multv meltfram__.mcfr_varptr[0] #define clov meltfram__.mcfr_varptr[1] #define discrmv meltfram__.mcfr_varptr[2] #define resv meltfram__.mcfr_varptr[3] multv = mult_p; clov = clo_p; discrmv = discrm_p; resv = NULL; if (melt_magic_discr ((melt_ptr_t) multv) != MELTOBMAG_MULTIPLE) goto end; if (melt_magic_discr ((melt_ptr_t) clov) != MELTOBMAG_CLOSURE) goto end; if (!discrmv) discrmv = (meltobject_ptr_t) MELT_PREDEF (DISCR_MULTIPLE); if (melt_magic_discr ((melt_ptr_t) discrmv) != MELTOBMAG_OBJECT) goto end; if (((meltobject_ptr_t) discrmv)->obj_num != MELTOBMAG_MULTIPLE) goto end; mulen = (int) (((meltmultiple_ptr_t) multv)->nbval); /* allocate and fill ixtab with indexes */ ixtab = (int *) xcalloc (mulen + 1, sizeof (ixtab[0])); for (i = 0; i < (int) mulen; i++) ixtab[i] = i; mulsort_mult_ad = (melt_ptr_t *) & multv; mulsort_clos_ad = (melt_ptr_t *) & clov; MELT_LOCATION_HERE("multiple sort before qsort"); if (!setjmp (mulsort_escapjmp)) { qsort (ixtab, (size_t) mulen, sizeof (ixtab[0]), mulsort_cmp); resv = meltgc_new_multiple ((meltobject_ptr_t) discrmv, (unsigned) mulen); for (i = 0; i < (int) mulen; i++) meltgc_multiple_put_nth ((melt_ptr_t) resv, i, melt_multiple_nth ((melt_ptr_t) multv, ixtab[i])); } else { resv = NULL; } end: if (ixtab) free (ixtab); memset (&mulsort_escapjmp, 0, sizeof (mulsort_escapjmp)); mulsort_mult_ad = 0; mulsort_clos_ad = 0; MELT_EXITFRAME (); return (melt_ptr_t) resv; #undef multv #undef clov #undef discrmv #undef resv } /* safely return the content of a reference - instance of CLASS_REFERENCE */ melt_ptr_t melt_reference_value (melt_ptr_t cont) { if (melt_magic_discr (cont) != MELTOBMAG_OBJECT || ((meltobject_ptr_t) cont)->obj_len < MELTLENGTH_CLASS_REFERENCE) return NULL; /* This case is so common that we handle it explicitly! */ if (((meltobject_ptr_t)cont)->discr == (meltobject_ptr_t)MELT_PREDEF (CLASS_REFERENCE)) return ((meltobject_ptr_t) cont)->obj_vartab[MELTFIELD_REFERENCED_VALUE]; if (!melt_is_instance_of ((melt_ptr_t) cont, (melt_ptr_t) MELT_PREDEF (CLASS_REFERENCE))) return NULL; return ((meltobject_ptr_t) cont)->obj_vartab[MELTFIELD_REFERENCED_VALUE]; } /* make a new reference */ melt_ptr_t meltgc_new_reference (melt_ptr_t val_p) { MELT_ENTERFRAME(3, NULL); #define valv meltfram__.mcfr_varptr[0] #define resv meltfram__.mcfr_varptr[1] #define classrefv meltfram__.mcfr_varptr[2] valv = val_p; classrefv = MELT_PREDEF (CLASS_REFERENCE); gcc_assert (melt_magic_discr ((melt_ptr_t)classrefv) == MELTOBMAG_OBJECT); /* we really need that references have one single field */ gcc_assert (MELTFIELD_REFERENCED_VALUE == 0); gcc_assert (MELTLENGTH_CLASS_REFERENCE == 1); resv = meltgc_new_raw_object ((meltobject_ptr_t) classrefv, MELTLENGTH_CLASS_REFERENCE); ((meltobject_ptr_t) (resv))->obj_vartab[MELTFIELD_REFERENCED_VALUE] = (melt_ptr_t) valv; MELT_EXITFRAME(); return (melt_ptr_t)resv; #undef valv #undef resv #undef classrefv } /* put inside a reference */ void meltgc_reference_put (melt_ptr_t ref_p, melt_ptr_t val_p) { MELT_ENTERFRAME(3, NULL); #define refv meltfram__.mcfr_varptr[0] #define valv meltfram__.mcfr_varptr[1] #define classrefv meltfram__.mcfr_varptr[2] refv = ref_p; valv = val_p; classrefv = MELT_PREDEF (CLASS_REFERENCE); gcc_assert (melt_magic_discr ((melt_ptr_t)classrefv) == MELTOBMAG_OBJECT); /* we really need that references have one single field */ gcc_assert (MELTFIELD_REFERENCED_VALUE == 0); if (melt_magic_discr((melt_ptr_t)refv) != MELTOBMAG_OBJECT) goto end; /* This case is so common that we handle it explicitly! */ if (((meltobject_ptr_t)refv)->discr != classrefv && !melt_is_instance_of ((melt_ptr_t) refv, (melt_ptr_t) classrefv)) goto end; ((meltobject_ptr_t) (refv))->obj_vartab[MELTFIELD_REFERENCED_VALUE] = (melt_ptr_t) valv; meltgc_touch_dest (refv, valv); end: MELT_EXITFRAME(); #undef valv #undef refv #undef classrefv } /****** MULTIPLES ******/ /* allocate a multiple of arity 1 */ melt_ptr_t meltgc_new_mult1 (meltobject_ptr_t discr_p, melt_ptr_t v0_p) { MELT_ENTERFRAME (3, NULL); #define newmul meltfram__.mcfr_varptr[0] #define discrv meltfram__.mcfr_varptr[1] #define v0 meltfram__.mcfr_varptr[2] #define object_discrv ((meltobject_ptr_t)(discrv)) #define mult_newmul ((struct meltmultiple_st*)(newmul)) discrv = (void *) discr_p; v0 = v0_p; newmul = NULL; if (melt_magic_discr ((melt_ptr_t) discrv) != MELTOBMAG_OBJECT) goto end; if (object_discrv->meltobj_magic != MELTOBMAG_MULTIPLE) goto end; newmul = meltgc_allocate (sizeof (struct meltmultiple_st), sizeof (void *) * 1); mult_newmul->discr = object_discrv; mult_newmul->nbval = 1; mult_newmul->tabval[0] = (melt_ptr_t) v0; end: MELT_EXITFRAME (); return (melt_ptr_t) newmul; #undef newmul #undef discr #undef v0 #undef mult_newmul #undef object_discrv } melt_ptr_t meltgc_new_mult2 (meltobject_ptr_t discr_p, melt_ptr_t v0_p, melt_ptr_t v1_p) { MELT_ENTERFRAME (4, NULL); #define newmul meltfram__.mcfr_varptr[0] #define discrv meltfram__.mcfr_varptr[1] #define v0 meltfram__.mcfr_varptr[2] #define v1 meltfram__.mcfr_varptr[3] #define object_discrv ((meltobject_ptr_t)(discrv)) #define mult_newmul ((struct meltmultiple_st*)(newmul)) discrv = (void *) discr_p; v0 = v0_p; v1 = v1_p; newmul = NULL; if (melt_magic_discr ((melt_ptr_t) discrv) != MELTOBMAG_OBJECT) goto end; if (object_discrv->meltobj_magic != MELTOBMAG_MULTIPLE) goto end; newmul = meltgc_allocate (sizeof (struct meltmultiple_st), sizeof (void *) * 2); mult_newmul->discr = object_discrv; mult_newmul->nbval = 2; mult_newmul->tabval[0] = (melt_ptr_t) v0; mult_newmul->tabval[1] = (melt_ptr_t) v1; end: MELT_EXITFRAME (); return (melt_ptr_t) newmul; #undef newmul #undef discr #undef v0 #undef v1 #undef mult_newmul #undef object_discrv } 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) { MELT_ENTERFRAME (5, NULL); #define newmul meltfram__.mcfr_varptr[0] #define discrv meltfram__.mcfr_varptr[1] #define v0 meltfram__.mcfr_varptr[2] #define v1 meltfram__.mcfr_varptr[3] #define v2 meltfram__.mcfr_varptr[4] #define object_discrv ((meltobject_ptr_t)(discrv)) #define mult_newmul ((struct meltmultiple_st*)(newmul)) discrv = (void *) discr_p; v0 = v0_p; v1 = v1_p; v2 = v2_p; newmul = NULL; if (melt_magic_discr ((melt_ptr_t) discrv) != MELTOBMAG_OBJECT) goto end; if (object_discrv->meltobj_magic != MELTOBMAG_MULTIPLE) goto end; newmul = meltgc_allocate (sizeof (struct meltmultiple_st), sizeof (void *) * 3); mult_newmul->discr = object_discrv; mult_newmul->nbval = 3; mult_newmul->tabval[0] = (melt_ptr_t) v0; mult_newmul->tabval[1] = (melt_ptr_t) v1; mult_newmul->tabval[2] = (melt_ptr_t) v2; end: MELT_EXITFRAME (); return (melt_ptr_t) newmul; #undef newmul #undef discrv #undef v0 #undef v1 #undef v2 #undef mult_newmul #undef object_discrv } 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) { MELT_ENTERFRAME (6, NULL); #define newmul meltfram__.mcfr_varptr[0] #define discrv meltfram__.mcfr_varptr[1] #define v0 meltfram__.mcfr_varptr[2] #define v1 meltfram__.mcfr_varptr[3] #define v2 meltfram__.mcfr_varptr[4] #define v3 meltfram__.mcfr_varptr[5] #define object_discrv ((meltobject_ptr_t)(discrv)) #define mult_newmul ((struct meltmultiple_st*)(newmul)) discrv = (void *) discr_p; v0 = v0_p; v1 = v1_p; v2 = v2_p; v3 = v3_p; newmul = NULL; if (melt_magic_discr ((melt_ptr_t) discrv) != MELTOBMAG_OBJECT) goto end; if (object_discrv->meltobj_magic != MELTOBMAG_MULTIPLE) goto end; newmul = meltgc_allocate (sizeof (struct meltmultiple_st), sizeof (void *) * 4); mult_newmul->discr = object_discrv; mult_newmul->nbval = 4; mult_newmul->tabval[0] = (melt_ptr_t) v0; mult_newmul->tabval[1] = (melt_ptr_t) v1; mult_newmul->tabval[2] = (melt_ptr_t) v2; mult_newmul->tabval[3] = (melt_ptr_t) v3; end: MELT_EXITFRAME (); return (melt_ptr_t) newmul; #undef newmul #undef discrv #undef v0 #undef v1 #undef v2 #undef v3 #undef mult_newmul #undef object_discrv } 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) { MELT_ENTERFRAME (7, NULL); #define newmul meltfram__.mcfr_varptr[0] #define discrv meltfram__.mcfr_varptr[1] #define v0 meltfram__.mcfr_varptr[2] #define v1 meltfram__.mcfr_varptr[3] #define v2 meltfram__.mcfr_varptr[4] #define v3 meltfram__.mcfr_varptr[5] #define v4 meltfram__.mcfr_varptr[6] #define object_discrv ((meltobject_ptr_t)(discrv)) #define mult_newmul ((struct meltmultiple_st*)(newmul)) discrv = (void *) discr_p; v0 = v0_p; v1 = v1_p; v2 = v2_p; v3 = v3_p; v4 = v4_p; newmul = NULL; if (melt_magic_discr ((melt_ptr_t) discrv) != MELTOBMAG_OBJECT) goto end; if (object_discrv->meltobj_magic != MELTOBMAG_MULTIPLE) goto end; newmul = meltgc_allocate (sizeof (struct meltmultiple_st), sizeof (void *) * 5); mult_newmul->discr = object_discrv; mult_newmul->nbval = 5; mult_newmul->tabval[0] = (melt_ptr_t) v0; mult_newmul->tabval[1] = (melt_ptr_t) v1; mult_newmul->tabval[2] = (melt_ptr_t) v2; mult_newmul->tabval[3] = (melt_ptr_t) v3; mult_newmul->tabval[4] = (melt_ptr_t) v4; end: MELT_EXITFRAME (); return (melt_ptr_t) newmul; #undef newmul #undef discrv #undef v0 #undef v1 #undef v2 #undef v3 #undef v4 #undef mult_newmul #undef object_discrv } 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) { MELT_ENTERFRAME (8, NULL); #define newmul meltfram__.mcfr_varptr[0] #define discrv meltfram__.mcfr_varptr[1] #define v0 meltfram__.mcfr_varptr[2] #define v1 meltfram__.mcfr_varptr[3] #define v2 meltfram__.mcfr_varptr[4] #define v3 meltfram__.mcfr_varptr[5] #define v4 meltfram__.mcfr_varptr[6] #define v5 meltfram__.mcfr_varptr[7] #define object_discrv ((meltobject_ptr_t)(discrv)) #define mult_newmul ((struct meltmultiple_st*)(newmul)) discrv = (void *) discr_p; v0 = v0_p; v1 = v1_p; v2 = v2_p; v3 = v3_p; v4 = v4_p; v5 = v5_p; newmul = NULL; if (melt_magic_discr ((melt_ptr_t) discrv) != MELTOBMAG_OBJECT) goto end; if (object_discrv->meltobj_magic != MELTOBMAG_MULTIPLE) goto end; newmul = meltgc_allocate (sizeof (struct meltmultiple_st), sizeof (void *) * 6); mult_newmul->discr = object_discrv; mult_newmul->nbval = 6; mult_newmul->tabval[0] = (melt_ptr_t) v0; mult_newmul->tabval[1] = (melt_ptr_t) v1; mult_newmul->tabval[2] = (melt_ptr_t) v2; mult_newmul->tabval[3] = (melt_ptr_t) v3; mult_newmul->tabval[4] = (melt_ptr_t) v4; mult_newmul->tabval[5] = (melt_ptr_t) v5; end: MELT_EXITFRAME (); return (melt_ptr_t) newmul; #undef newmul #undef discrv #undef v0 #undef v1 #undef v2 #undef v3 #undef v4 #undef v5 #undef mult_newmul #undef object_discrv } 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) { MELT_ENTERFRAME (9, NULL); #define newmul meltfram__.mcfr_varptr[0] #define discrv meltfram__.mcfr_varptr[1] #define v0 meltfram__.mcfr_varptr[2] #define v1 meltfram__.mcfr_varptr[3] #define v2 meltfram__.mcfr_varptr[4] #define v3 meltfram__.mcfr_varptr[5] #define v4 meltfram__.mcfr_varptr[6] #define v5 meltfram__.mcfr_varptr[7] #define v6 meltfram__.mcfr_varptr[8] #define object_discrv ((meltobject_ptr_t)(discrv)) #define mult_newmul ((struct meltmultiple_st*)(newmul)) discrv = (void *) discr_p; v0 = v0_p; v1 = v1_p; v2 = v2_p; v3 = v3_p; v4 = v4_p; v5 = v5_p; v6 = v6_p; newmul = NULL; if (melt_magic_discr ((melt_ptr_t) discrv) != MELTOBMAG_OBJECT) goto end; if (object_discrv->meltobj_magic != MELTOBMAG_MULTIPLE) goto end; newmul = meltgc_allocate (sizeof (struct meltmultiple_st), sizeof (void *) * 7); mult_newmul->discr = object_discrv; mult_newmul->nbval = 7; mult_newmul->tabval[0] = (melt_ptr_t) v0; mult_newmul->tabval[1] = (melt_ptr_t) v1; mult_newmul->tabval[2] = (melt_ptr_t) v2; mult_newmul->tabval[3] = (melt_ptr_t) v3; mult_newmul->tabval[4] = (melt_ptr_t) v4; mult_newmul->tabval[5] = (melt_ptr_t) v5; mult_newmul->tabval[6] = (melt_ptr_t) v6; end: MELT_EXITFRAME (); return (melt_ptr_t) newmul; #undef newmul #undef discrv #undef v0 #undef v1 #undef v2 #undef v3 #undef v4 #undef v5 #undef v6 #undef mult_newmul #undef object_discrv } melt_ptr_t meltgc_new_list (meltobject_ptr_t discr_p) { MELT_ENTERFRAME (2, NULL); #define discrv meltfram__.mcfr_varptr[0] #define newlist meltfram__.mcfr_varptr[1] #define object_discrv ((meltobject_ptr_t)(discrv)) #define list_newlist ((struct meltlist_st*)(newlist)) discrv = (void *) discr_p; newlist = NULL; if (melt_magic_discr ((melt_ptr_t) discrv) != MELTOBMAG_OBJECT) goto end; if (object_discrv->meltobj_magic != MELTOBMAG_LIST) goto end; newlist = meltgc_allocate (sizeof (struct meltlist_st), 0); list_newlist->discr = object_discrv; list_newlist->first = NULL; list_newlist->last = NULL; end: MELT_EXITFRAME (); return (melt_ptr_t) newlist; #undef newlist #undef discrv #undef list_newlist #undef object_discrv } /* allocate a pair of given head and tail */ melt_ptr_t meltgc_new_pair (meltobject_ptr_t discr_p, void *head_p, void *tail_p) { MELT_ENTERFRAME (4, NULL); #define pairv meltfram__.mcfr_varptr[0] #define discrv meltfram__.mcfr_varptr[1] #define headv meltfram__.mcfr_varptr[2] #define tailv meltfram__.mcfr_varptr[3] discrv = discr_p; headv = head_p; tailv = tail_p; if (melt_magic_discr ((melt_ptr_t) discrv) != MELTOBMAG_OBJECT || ((meltobject_ptr_t) (discrv))->meltobj_magic != MELTOBMAG_PAIR) goto end; if (melt_magic_discr ((melt_ptr_t) tailv) != MELTOBMAG_PAIR) tailv = NULL; pairv = meltgc_allocate (sizeof (struct meltpair_st), 0); ((struct meltpair_st *) (pairv))->discr = (meltobject_ptr_t) discrv; ((struct meltpair_st *) (pairv))->hd = (melt_ptr_t) headv; ((struct meltpair_st *) (pairv))->tl = (struct meltpair_st *) tailv; end: MELT_EXITFRAME (); return (melt_ptr_t) pairv; #undef pairv #undef headv #undef tailv #undef discrv } /* change the head of a pair */ void meltgc_pair_set_head (melt_ptr_t pair_p, void *head_p) { MELT_ENTERFRAME (2, NULL); #define pairv meltfram__.mcfr_varptr[0] #define headv meltfram__.mcfr_varptr[1] pairv = pair_p; headv = head_p; if (melt_magic_discr ((melt_ptr_t) pairv) != MELTOBMAG_PAIR) goto end; ((struct meltpair_st *) pairv)->hd = (melt_ptr_t) headv; meltgc_touch_dest (pairv, headv); end: MELT_EXITFRAME (); #undef pairv #undef headv } void meltgc_append_list (melt_ptr_t list_p, melt_ptr_t valu_p) { MELT_ENTERFRAME (4, NULL); #define list meltfram__.mcfr_varptr[0] #define valu meltfram__.mcfr_varptr[1] #define pairv meltfram__.mcfr_varptr[2] #define lastv meltfram__.mcfr_varptr[3] #define pai_pairv ((struct meltpair_st*)(pairv)) #define list_list ((struct meltlist_st*)(list)) list = list_p; valu = valu_p; if (melt_magic_discr ((melt_ptr_t) list) != MELTOBMAG_LIST || ! MELT_PREDEF (DISCR_PAIR)) goto end; pairv = meltgc_allocate (sizeof (struct meltpair_st), 0); pai_pairv->discr = (meltobject_ptr_t) MELT_PREDEF (DISCR_PAIR); pai_pairv->hd = (melt_ptr_t) valu; pai_pairv->tl = NULL; gcc_assert (melt_magic_discr ((melt_ptr_t) pairv) == MELTOBMAG_PAIR); lastv = list_list->last; if (melt_magic_discr ((melt_ptr_t) lastv) == MELTOBMAG_PAIR) { gcc_assert (((struct meltpair_st *) lastv)->tl == NULL); ((struct meltpair_st *) lastv)->tl = (struct meltpair_st *) pairv; meltgc_touch_dest (lastv, pairv); } else list_list->first = (struct meltpair_st *) pairv; list_list->last = (struct meltpair_st *) pairv; meltgc_touch_dest (list, pairv); end: MELT_EXITFRAME (); #undef list #undef valu #undef list_list #undef pairv #undef pai_pairv #undef lastv } void meltgc_prepend_list (melt_ptr_t list_p, melt_ptr_t valu_p) { MELT_ENTERFRAME (4, NULL); #define list meltfram__.mcfr_varptr[0] #define valu meltfram__.mcfr_varptr[1] #define pairv meltfram__.mcfr_varptr[2] #define firstv meltfram__.mcfr_varptr[3] #define pai_pairv ((struct meltpair_st*)(pairv)) #define list_list ((struct meltlist_st*)(list)) list = list_p; valu = valu_p; if (melt_magic_discr ((melt_ptr_t) list) != MELTOBMAG_LIST || ! MELT_PREDEF (DISCR_PAIR)) goto end; pairv = meltgc_allocate (sizeof (struct meltpair_st), 0); pai_pairv->discr = (meltobject_ptr_t) MELT_PREDEF (DISCR_PAIR); pai_pairv->hd = (melt_ptr_t) valu; pai_pairv->tl = NULL; gcc_assert (melt_magic_discr ((melt_ptr_t) pairv) == MELTOBMAG_PAIR); firstv = (melt_ptr_t) (list_list->first); if (melt_magic_discr ((melt_ptr_t) firstv) == MELTOBMAG_PAIR) { pai_pairv->tl = (struct meltpair_st *) firstv; meltgc_touch_dest (pairv, firstv); } else list_list->last = (struct meltpair_st *) pairv; list_list->first = (struct meltpair_st *) pairv; meltgc_touch_dest (list, pairv); end: MELT_EXITFRAME (); #undef list #undef valu #undef list_list #undef pairv #undef pai_pairv } melt_ptr_t meltgc_popfirst_list (melt_ptr_t list_p) { MELT_ENTERFRAME (3, NULL); #define list meltfram__.mcfr_varptr[0] #define valu meltfram__.mcfr_varptr[1] #define pairv meltfram__.mcfr_varptr[2] #define pai_pairv ((struct meltpair_st*)(pairv)) #define list_list ((struct meltlist_st*)(list)) list = list_p; if (melt_magic_discr ((melt_ptr_t) list) != MELTOBMAG_LIST) goto end; pairv = list_list->first; if (melt_magic_discr ((melt_ptr_t) pairv) != MELTOBMAG_PAIR) goto end; if (list_list->last == pairv) { valu = pai_pairv->hd; list_list->first = NULL; list_list->last = NULL; } else { valu = pai_pairv->hd; list_list->first = pai_pairv->tl; } meltgc_touch (list); end: MELT_EXITFRAME (); return (melt_ptr_t) valu; #undef list #undef value #undef list_list #undef pairv #undef pai_pairv } /* enf of popfirst */ /* return the length of a list or -1 iff non list */ int melt_list_length (melt_ptr_t list_p) { struct meltpair_st *pair = NULL; int ln = 0; if (!list_p) return 0; if (melt_magic_discr (list_p) != MELTOBMAG_LIST) return -1; for (pair = ((struct meltlist_st *) list_p)->first; melt_magic_discr ((melt_ptr_t) pair) == MELTOBMAG_PAIR; pair = (struct meltpair_st *) (pair->tl)) ln++; return ln; } /* allocate a new empty mapobjects */ melt_ptr_t meltgc_new_mapobjects (meltobject_ptr_t discr_p, unsigned len) { int maplen = 0; int lenix = 0, primlen = 0; MELT_ENTERFRAME (2, NULL); #define discrv meltfram__.mcfr_varptr[0] #define newmapv meltfram__.mcfr_varptr[1] #define object_discrv ((meltobject_ptr_t)(discrv)) #define mapobject_newmapv ((struct meltmapobjects_st*)(newmapv)) discrv = discr_p; if (!discrv || object_discrv->meltobj_class->meltobj_magic != MELTOBMAG_OBJECT) goto end; if (object_discrv->meltobj_magic != MELTOBMAG_MAPOBJECTS) goto end; if (len > 0) { gcc_assert (len < (unsigned) MELT_MAXLEN); for (lenix = 1; (primlen = (int) melt_primtab[lenix]) != 0 && primlen <= (int) len; lenix++); maplen = primlen; }; meltgc_reserve (sizeof(struct meltmapobjects_st) + maplen * sizeof (struct entryobjectsmelt_st) + 8 * sizeof(void*)); newmapv = meltgc_allocate (offsetof (struct meltmapobjects_st, map_space), maplen * sizeof (struct entryobjectsmelt_st)); mapobject_newmapv->discr = object_discrv; mapobject_newmapv->meltmap_aux = NULL; if (len > 0) { mapobject_newmapv->entab = mapobject_newmapv->map_space; mapobject_newmapv->lenix = lenix; }; end: MELT_EXITFRAME (); return (melt_ptr_t) newmapv; #undef discrv #undef newmapv #undef object_discrv #undef mapobject_newmapv } /* get from a mapobject */ melt_ptr_t melt_get_mapobjects (meltmapobjects_ptr_t mapobject_p, meltobject_ptr_t attrobject_p) { long ix, len; melt_ptr_t val = NULL; if (!mapobject_p || !attrobject_p || mapobject_p->discr->meltobj_magic != MELTOBMAG_MAPOBJECTS || !mapobject_p->entab || attrobject_p->meltobj_class->meltobj_magic != MELTOBMAG_OBJECT) return NULL; len = melt_primtab[mapobject_p->lenix]; if (len <= 0) return NULL; ix = unsafe_index_mapobject (mapobject_p->entab, attrobject_p, len); if (ix < 0) return NULL; if (mapobject_p->entab[ix].e_at == attrobject_p) val = mapobject_p->entab[ix].e_va; return val; } void meltgc_put_mapobjects (meltmapobjects_ptr_t mapobject_p, meltobject_ptr_t attrobject_p, melt_ptr_t valu_p) { long ix = 0, len = 0, cnt = 0; MELT_ENTERFRAME (4, NULL); #define discrv meltfram__.mcfr_varptr[0] #define mapobjectv meltfram__.mcfr_varptr[1] #define attrobjectv meltfram__.mcfr_varptr[2] #define valuv meltfram__.mcfr_varptr[3] #define object_discrv ((meltobject_ptr_t)(discrv)) #define object_attrobjectv ((meltobject_ptr_t)(attrobjectv)) #define map_mapobjectv ((meltmapobjects_ptr_t)(mapobjectv)) mapobjectv = mapobject_p; attrobjectv = attrobject_p; valuv = valu_p; if (!mapobjectv || !attrobjectv || !valuv) goto end; discrv = map_mapobjectv->discr; if (!discrv || object_discrv->meltobj_magic != MELTOBMAG_MAPOBJECTS) goto end; discrv = object_attrobjectv->meltobj_class; if (!discrv || object_discrv->meltobj_magic != MELTOBMAG_OBJECT) goto end; if (!map_mapobjectv->entab) { /* fresh map without any entab; allocate it minimally */ size_t lensiz = 0; len = melt_primtab[1]; /* i.e. 3 */ lensiz = len * sizeof (struct entryobjectsmelt_st); if (melt_is_young (mapobjectv)) { meltgc_reserve (lensiz + 20); if (!melt_is_young (mapobjectv)) goto alloc_old_smallmapobj; map_mapobjectv->entab = (struct entryobjectsmelt_st *) melt_allocatereserved (lensiz, 0); } else { alloc_old_smallmapobj: map_mapobjectv->entab = ggc_alloc_cleared_vec_entryobjectsmelt_st (len); } map_mapobjectv->lenix = 1; meltgc_touch (map_mapobjectv); } else if ((len = melt_primtab[map_mapobjectv->lenix]) <= (5 * (cnt = map_mapobjectv->count)) / 4 || (len <= 5 && cnt + 1 >= len)) { /* entab is nearly full so need to be resized */ int ix, newcnt = 0; int newlen = melt_primtab[map_mapobjectv->lenix + 1]; size_t newlensiz = 0; struct entryobjectsmelt_st *newtab = NULL; struct entryobjectsmelt_st *oldtab = NULL; newlensiz = newlen * sizeof (struct entryobjectsmelt_st); if (melt_is_young (map_mapobjectv->entab)) { meltgc_reserve (newlensiz + 100); if (!melt_is_young (map_mapobjectv)) goto alloc_old_mapobj; newtab = (struct entryobjectsmelt_st *) melt_allocatereserved (newlensiz, 0); } else { alloc_old_mapobj: newtab = ggc_alloc_cleared_vec_entryobjectsmelt_st (newlen); }; oldtab = map_mapobjectv->entab; for (ix = 0; ix < len; ix++) { meltobject_ptr_t curat = oldtab[ix].e_at; int newix; if (!curat || curat == (void *) HTAB_DELETED_ENTRY) continue; newix = unsafe_index_mapobject (newtab, curat, newlen); gcc_assert (newix >= 0); newtab[newix] = oldtab[ix]; newcnt++; } if (!melt_is_young (oldtab)) /* free oldtab since it is in old ggc space */ ggc_free (oldtab); map_mapobjectv->entab = newtab; map_mapobjectv->count = newcnt; map_mapobjectv->lenix++; meltgc_touch (map_mapobjectv); len = newlen; } ix = unsafe_index_mapobject (map_mapobjectv->entab, object_attrobjectv, len); gcc_assert (ix >= 0); if (map_mapobjectv->entab[ix].e_at != attrobjectv) { map_mapobjectv->entab[ix].e_at = (meltobject_ptr_t) attrobjectv; map_mapobjectv->count++; } map_mapobjectv->entab[ix].e_va = (melt_ptr_t) valuv; meltgc_touch_dest (map_mapobjectv, attrobjectv); meltgc_touch_dest (map_mapobjectv, valuv); end: MELT_EXITFRAME (); #undef discrv #undef mapobjectv #undef attrobjectv #undef valuv #undef object_discrv #undef object_attrobjectv #undef map_mapobjectv } melt_ptr_t meltgc_remove_mapobjects (meltmapobjects_ptr_t mapobject_p, meltobject_ptr_t attrobject_p) { long ix = 0, len = 0, cnt = 0; MELT_ENTERFRAME (4, NULL); #define discrv meltfram__.mcfr_varptr[0] #define mapobjectv meltfram__.mcfr_varptr[1] #define attrobjectv meltfram__.mcfr_varptr[2] #define valuv meltfram__.mcfr_varptr[3] #define object_discrv ((meltobject_ptr_t)(discrv)) #define object_attrobjectv ((meltobject_ptr_t)(attrobjectv)) #define map_mapobjectv ((meltmapobjects_ptr_t)(mapobjectv)) mapobjectv = mapobject_p; attrobjectv = attrobject_p; valuv = NULL; if (!mapobjectv || !attrobjectv) goto end; discrv = map_mapobjectv->discr; if (!discrv || object_discrv->meltobj_magic != MELTOBMAG_MAPOBJECTS) goto end; discrv = object_attrobjectv->meltobj_class; if (!discrv || object_discrv->meltobj_magic != MELTOBMAG_OBJECT) goto end; if (!map_mapobjectv->entab) goto end; len = melt_primtab[map_mapobjectv->lenix]; if (len <= 0) goto end; ix = unsafe_index_mapobject (map_mapobjectv->entab, attrobject_p, len); if (ix < 0 || map_mapobjectv->entab[ix].e_at != attrobjectv) goto end; map_mapobjectv->entab[ix].e_at = (meltobject_ptr_t) HTAB_DELETED_ENTRY; valuv = map_mapobjectv->entab[ix].e_va; map_mapobjectv->entab[ix].e_va = NULL; map_mapobjectv->count--; cnt = map_mapobjectv->count; if (len >= 7 && cnt < len / 2 - 2) { int newcnt = 0, newlen = 0, newlenix = 0; size_t newlensiz = 0; struct entryobjectsmelt_st *oldtab = NULL, *newtab = NULL; for (newlenix = map_mapobjectv->lenix; (newlen = melt_primtab[newlenix]) > 2 * cnt + 3; newlenix--); if (newlen >= len) goto end; newlensiz = newlen * sizeof (struct entryobjectsmelt_st); if (melt_is_young (map_mapobjectv->entab)) { /* reserve a zone; if a GC occurred, the mapobject & entab could become old */ meltgc_reserve (newlensiz + 10 * sizeof (void *)); if (!melt_is_young (map_mapobjectv)) goto alloc_old_entries; newtab = (struct entryobjectsmelt_st *) melt_allocatereserved (newlensiz, 0); } else { alloc_old_entries: newtab = ggc_alloc_cleared_vec_entryobjectsmelt_st (newlen); } oldtab = map_mapobjectv->entab; for (ix = 0; ix < len; ix++) { meltobject_ptr_t curat = oldtab[ix].e_at; int newix; if (!curat || curat == (void *) HTAB_DELETED_ENTRY) continue; newix = unsafe_index_mapobject (newtab, curat, newlen); gcc_assert (newix >= 0); newtab[newix] = oldtab[ix]; newcnt++; } if (!melt_is_young (oldtab)) /* free oldtab since it is in old ggc space */ ggc_free (oldtab); map_mapobjectv->entab = newtab; map_mapobjectv->count = newcnt; map_mapobjectv->lenix = newlenix; } meltgc_touch (map_mapobjectv); end: MELT_EXITFRAME (); return (melt_ptr_t) valuv; #undef discrv #undef mapobjectv #undef attrobjectv #undef valuv #undef object_discrv #undef object_attrobjectv #undef map_mapobjectv } /* index of entry to get or add an attribute in an mapstring (or -1 on error) */ static inline int unsafe_index_mapstring (struct entrystringsmelt_st *tab, const char *attr, int siz) { int ix = 0, frix = -1; unsigned h = 0; if (!tab || !attr || siz <= 0) return -1; h = (unsigned) htab_hash_string (attr) & MELT_MAXHASH; h = h % siz; for (ix = h; ix < siz; ix++) { const char *curat = tab[ix].e_at; if (curat == (void *) HTAB_DELETED_ENTRY) { if (frix < 0) frix = ix; } else if (!curat) { if (frix < 0) frix = ix; return frix; } else if (!strcmp (curat, attr)) return ix; } for (ix = 0; ix < (int) h; ix++) { const char *curat = tab[ix].e_at; if (curat == (void *) HTAB_DELETED_ENTRY) { if (frix < 0) frix = ix; } else if (!curat) { if (frix < 0) frix = ix; return frix; } else if (!strcmp (curat, attr)) return ix; } if (frix >= 0) /* found a place in a table with deleted entries */ return frix; return -1; /* entirely full, should not happen */ } /* allocate a new empty mapstrings */ melt_ptr_t meltgc_new_mapstrings (meltobject_ptr_t discr_p, unsigned len) { int lenix = -1, primlen = 0; MELT_ENTERFRAME (2, NULL); #define discrv meltfram__.mcfr_varptr[0] #define newmapv meltfram__.mcfr_varptr[1] #define object_discrv ((meltobject_ptr_t)(discrv)) #define mapstring_newmapv ((struct meltmapstrings_st*)(newmapv)) discrv = discr_p; if (!discrv || object_discrv->meltobj_class->meltobj_magic != MELTOBMAG_OBJECT) goto end; if (object_discrv->meltobj_magic != MELTOBMAG_MAPSTRINGS) goto end; if (len > 0) { gcc_assert (len < (unsigned) MELT_MAXLEN); for (lenix = 1; (primlen = (int) melt_primtab[lenix]) != 0 && primlen <= (int) len; lenix++); }; gcc_assert (primlen > (int) len); meltgc_reserve (sizeof (struct meltmapstrings_st) + primlen * sizeof (struct entrystringsmelt_st) + 8 * sizeof(void*)); newmapv = meltgc_allocate (sizeof (struct meltmapstrings_st), 0); mapstring_newmapv->discr = object_discrv; mapstring_newmapv->meltmap_aux = NULL; if (len > 0) { /* the newmapv is always young */ mapstring_newmapv->entab = (struct entrystringsmelt_st *) meltgc_allocate (primlen * sizeof (struct entrystringsmelt_st), 0); mapstring_newmapv->lenix = lenix; meltgc_touch_dest (newmapv, mapstring_newmapv->entab); } end: MELT_EXITFRAME (); return (melt_ptr_t) newmapv; #undef discrv #undef newmapv #undef object_discrv #undef mapstring_newmapv } void meltgc_put_mapstrings (struct meltmapstrings_st *mapstring_p, const char *attr, melt_ptr_t valu_p) { long ix = 0, len = 0, cnt = 0, atlen = 0; char *attrdup = 0; char tinybuf[130]; MELT_ENTERFRAME (3, NULL); #define discrv meltfram__.mcfr_varptr[0] #define mapstringv meltfram__.mcfr_varptr[1] #define valuv meltfram__.mcfr_varptr[2] #define object_discrv ((meltobject_ptr_t)(discrv)) #define map_mapstringv ((struct meltmapstrings_st*)(mapstringv)) mapstringv = mapstring_p; valuv = valu_p; if (!mapstringv || !attr || !attr[0] || !valuv) goto end; discrv = map_mapstringv->discr; if (!discrv || object_discrv->meltobj_magic != MELTOBMAG_MAPSTRINGS) goto end; atlen = strlen (attr); if (atlen < (int) sizeof (tinybuf) - 1) { memset (tinybuf, 0, sizeof (tinybuf)); attrdup = strcpy (tinybuf, attr); } else attrdup = strcpy ((char *) xcalloc (atlen + 1, 1), attr); if (!map_mapstringv->entab) { size_t lensiz = 0; len = melt_primtab[1]; /* i.e. 3 */ lensiz = len * sizeof (struct entrystringsmelt_st); if (melt_is_young (mapstringv)) { meltgc_reserve (lensiz + 16 * sizeof (void *)); if (!melt_is_young (mapstringv)) goto alloc_old_small_mapstring; map_mapstringv->entab = (struct entrystringsmelt_st *) melt_allocatereserved (lensiz, 0); } else { alloc_old_small_mapstring: map_mapstringv->entab = ggc_alloc_cleared_vec_entrystringsmelt_st (len); } map_mapstringv->lenix = 1; meltgc_touch (map_mapstringv); } else if ((len = melt_primtab[map_mapstringv->lenix]) <= (5 * (cnt = map_mapstringv->count)) / 4 || (len <= 5 && cnt + 1 >= len)) { int ix, newcnt = 0; int newlen = melt_primtab[map_mapstringv->lenix + 1]; struct entrystringsmelt_st *oldtab = NULL; struct entrystringsmelt_st *newtab = NULL; size_t newlensiz = newlen * sizeof (struct entrystringsmelt_st); if (melt_is_young (mapstringv)) { meltgc_reserve (newlensiz + 10 * sizeof (void *)); if (!melt_is_young (mapstringv)) goto alloc_old_mapstring; newtab = (struct entrystringsmelt_st *) melt_allocatereserved (newlensiz, 0); } else { alloc_old_mapstring: newtab = ggc_alloc_cleared_vec_entrystringsmelt_st (newlen); }; oldtab = map_mapstringv->entab; for (ix = 0; ix < len; ix++) { const char *curat = oldtab[ix].e_at; int newix; if (!curat || curat == (void *) HTAB_DELETED_ENTRY) continue; newix = unsafe_index_mapstring (newtab, curat, newlen); gcc_assert (newix >= 0); newtab[newix] = oldtab[ix]; newcnt++; } if (!melt_is_young (oldtab)) /* free oldtab since it is in old ggc space */ ggc_free (oldtab); map_mapstringv->entab = newtab; map_mapstringv->count = newcnt; map_mapstringv->lenix++; meltgc_touch (map_mapstringv); len = newlen; } ix = unsafe_index_mapstring (map_mapstringv->entab, attrdup, len); gcc_assert (ix >= 0); if (!map_mapstringv->entab[ix].e_at || map_mapstringv->entab[ix].e_at == HTAB_DELETED_ENTRY) { char *newat = (char *) meltgc_allocate (atlen + 1, 0); strcpy (newat, attrdup); map_mapstringv->entab[ix].e_at = newat; map_mapstringv->count++; } map_mapstringv->entab[ix].e_va = (melt_ptr_t) valuv; meltgc_touch_dest (map_mapstringv, valuv); end: if (attrdup && attrdup != tinybuf) free (attrdup); MELT_EXITFRAME (); #undef discrv #undef mapstringv #undef attrobjectv #undef valuv #undef object_discrv #undef object_attrobjectv #undef map_mapstringv } melt_ptr_t melt_get_mapstrings (struct meltmapstrings_st *mapstring_p, const char *attr) { long ix = 0, len = 0; const char *oldat = NULL; if (!mapstring_p || !attr) return NULL; if (mapstring_p->discr->meltobj_magic != MELTOBMAG_MAPSTRINGS) return NULL; if (!mapstring_p->entab) return NULL; len = melt_primtab[mapstring_p->lenix]; if (len <= 0) return NULL; ix = unsafe_index_mapstring (mapstring_p->entab, attr, len); if (ix < 0 || !(oldat = mapstring_p->entab[ix].e_at) || oldat == HTAB_DELETED_ENTRY) return NULL; return mapstring_p->entab[ix].e_va; } melt_ptr_t meltgc_remove_mapstrings (struct meltmapstrings_st * mapstring_p, const char *attr) { long ix = 0, len = 0, cnt = 0, atlen = 0; const char *oldat = NULL; char *attrdup = 0; char tinybuf[130]; MELT_ENTERFRAME (3, NULL); #define discrv meltfram__.mcfr_varptr[0] #define mapstringv meltfram__.mcfr_varptr[1] #define valuv meltfram__.mcfr_varptr[2] #define object_discrv ((meltobject_ptr_t)(discrv)) #define map_mapstringv ((struct meltmapstrings_st*)(mapstringv)) mapstringv = mapstring_p; valuv = NULL; if (!mapstringv || !attr || !valuv || !attr[0]) goto end; atlen = strlen (attr); discrv = map_mapstringv->discr; if (!discrv || object_discrv->meltobj_magic != MELTOBMAG_MAPSTRINGS) goto end; if (!map_mapstringv->entab) goto end; len = melt_primtab[map_mapstringv->lenix]; if (len <= 0) goto end; if (atlen < (int) sizeof (tinybuf) - 1) { memset (tinybuf, 0, sizeof (tinybuf)); attrdup = strcpy (tinybuf, attr); } else attrdup = strcpy ((char *) xcalloc (atlen + 1, 1), attr); ix = unsafe_index_mapstring (map_mapstringv->entab, attrdup, len); if (ix < 0 || !(oldat = map_mapstringv->entab[ix].e_at) || oldat == HTAB_DELETED_ENTRY) goto end; if (!melt_is_young (oldat)) ggc_free (CONST_CAST (char *, oldat)); map_mapstringv->entab[ix].e_at = (char *) HTAB_DELETED_ENTRY; valuv = map_mapstringv->entab[ix].e_va; map_mapstringv->entab[ix].e_va = NULL; map_mapstringv->count--; cnt = map_mapstringv->count; if (len > 7 && 2 * cnt + 2 < len) { int newcnt = 0, newlen = 0, newlenix = 0; size_t newlensiz = 0; struct entrystringsmelt_st *oldtab = NULL, *newtab = NULL; for (newlenix = map_mapstringv->lenix; (newlen = melt_primtab[newlenix]) > 2 * cnt + 3; newlenix--); if (newlen >= len) goto end; newlensiz = newlen * sizeof (struct entrystringsmelt_st); if (melt_is_young (mapstringv)) { meltgc_reserve (newlensiz + 10 * sizeof (void *)); if (!melt_is_young (mapstringv)) goto alloc_old_mapstring_newtab; newtab = (struct entrystringsmelt_st *) melt_allocatereserved (newlensiz, 0); } else { alloc_old_mapstring_newtab: newtab = ggc_alloc_cleared_vec_entrystringsmelt_st (newlen); } oldtab = map_mapstringv->entab; for (ix = 0; ix < len; ix++) { const char *curat = oldtab[ix].e_at; int newix; if (!curat || curat == (void *) HTAB_DELETED_ENTRY) continue; newix = unsafe_index_mapstring (newtab, curat, newlen); gcc_assert (newix >= 0); newtab[newix] = oldtab[ix]; newcnt++; } if (!melt_is_young (oldtab)) /* free oldtab since it is in olentab = newtab; map_mapstringv->count = newcnt; } meltgc_touch (map_mapstringv); end: if (attrdup && attrdup != tinybuf) free (attrdup); MELT_EXITFRAME (); return (melt_ptr_t) valuv; #undef discrv #undef mapstringv #undef valuv #undef object_discrv #undef map_mapstringv } /* index of entry to get or add an attribute in an mappointer (or -1 on error) */ struct GTY(()) entrypointermelt_st { const void * e_at; melt_ptr_t e_va; }; static inline int unsafe_index_mappointer (struct entrypointermelt_st *tab, const void *attr, int siz) { int ix = 0, frix = -1; unsigned h = 0; if (!tab || !attr || siz <= 0) return -1; h = ((unsigned) (((long) (attr)) >> 3)) & MELT_MAXHASH; h = h % siz; for (ix = h; ix < siz; ix++) { const void *curat = tab[ix].e_at; if (curat == (void *) HTAB_DELETED_ENTRY) { if (frix < 0) frix = ix; } else if (!curat) { if (frix < 0) frix = ix; return frix; } else if (curat == attr) return ix; } for (ix = 0; ix < (int) h; ix++) { const void *curat = tab[ix].e_at; if (curat == (void *) HTAB_DELETED_ENTRY) { if (frix < 0) frix = ix; } else if (!curat) { if (frix < 0) frix = ix; return frix; } else if (curat == attr) return ix; } if (frix >= 0) /* found some place in a table with deleted entries */ return frix; return -1; /* entirely full, should not happen */ } /* this should be the same as meltmaptrees_st, meltmapedges_st, meltmapbasicblocks_st, .... */ struct meltmappointers_st { meltobject_ptr_t discr; unsigned count; unsigned char lenix; melt_ptr_t meltmap_aux; struct entrypointermelt_st *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 */ struct entrypointermelt_st map_space[MELT_FLEXIBLE_DIM]; }; #ifndef ggc_alloc_cleared_vec_entrypointermelt_st /* When ggc_alloc_cleared_vec_entrypointermelt_st is not defined by gengtype generated files, we use the allocation of string entries suitably casted. This does not impact the GGC marking of struct meltmappointers_st since they are always casted & handled appropriately. */ #define ggc_alloc_cleared_vec_entrypointermelt_st(Siz) \ ((struct entrypointermelt_st*)(ggc_alloc_cleared_vec_entrystringsmelt_st(Siz))) #endif /*ggc_alloc_cleared_vec_entrystringsmelt_st*/ /* allocate a new empty mappointers without checks */ void * meltgc_raw_new_mappointers (meltobject_ptr_t discr_p, unsigned len) { int lenix = 0, primlen = 0; MELT_ENTERFRAME (2, NULL); #define discrv meltfram__.mcfr_varptr[0] #define newmapv meltfram__.mcfr_varptr[1] #define object_discrv ((meltobject_ptr_t)(discrv)) #define map_newmapv ((struct meltmappointers_st*)(newmapv)) discrv = discr_p; if (len > 0) { gcc_assert (len < (unsigned) MELT_MAXLEN); for (lenix = 1; (primlen = (int) melt_primtab[lenix]) != 0 && primlen <= (int) len; lenix++); }; gcc_assert (sizeof (struct entrypointermelt_st) == sizeof (struct entrytreemelt_st)); gcc_assert (sizeof (struct entrypointermelt_st) == sizeof (struct entrygimplemelt_st)); gcc_assert (sizeof (struct entrypointermelt_st) == sizeof (struct entryedgemelt_st)); gcc_assert (sizeof (struct entrypointermelt_st) == sizeof (struct entrybasicblockmelt_st)); meltgc_reserve (sizeof (struct meltmappointers_st) + primlen * sizeof (struct entrypointermelt_st) + 8 * sizeof(void*)); newmapv = meltgc_allocate (offsetof (struct meltmappointers_st, map_space), primlen * sizeof (struct entrypointermelt_st)); map_newmapv->discr = object_discrv; map_newmapv->meltmap_aux = NULL; map_newmapv->count = 0; map_newmapv->lenix = lenix; if (len > 0) map_newmapv->entab = map_newmapv->map_space; else map_newmapv->entab = NULL; MELT_EXITFRAME (); return newmapv; #undef discrv #undef newmapv #undef object_discrv #undef map_newmapv } void meltgc_raw_put_mappointers (void *mappointer_p, const void *attr, melt_ptr_t valu_p) { long ix = 0, len = 0, cnt = 0; size_t lensiz = 0; MELT_ENTERFRAME (2, NULL); #define mappointerv meltfram__.mcfr_varptr[0] #define valuv meltfram__.mcfr_varptr[1] #define map_mappointerv ((struct meltmappointers_st*)(mappointerv)) mappointerv = mappointer_p; valuv = valu_p; if (!map_mappointerv->entab) { len = melt_primtab[1]; /* i.e. 3 */ lensiz = len * sizeof (struct entrypointermelt_st); if (melt_is_young (mappointerv)) { meltgc_reserve (lensiz + 10 * sizeof (void *)); if (!melt_is_young (mappointerv)) goto alloc_old_mappointer_small_entab; map_mappointerv->entab = (struct entrypointermelt_st *) melt_allocatereserved (lensiz, 0); } else { alloc_old_mappointer_small_entab: map_mappointerv->entab = ggc_alloc_cleared_vec_entrypointermelt_st (len); } map_mappointerv->lenix = 1; meltgc_touch (map_mappointerv); } else if ((len = melt_primtab[map_mappointerv->lenix]) <= (5 * (cnt = map_mappointerv->count)) / 4 || (len <= 5 && cnt + 1 >= len)) { int ix, newcnt = 0; int newlen = melt_primtab[map_mappointerv->lenix + 1]; struct entrypointermelt_st *oldtab = NULL; struct entrypointermelt_st *newtab = NULL; size_t newlensiz = newlen * sizeof (struct entrypointermelt_st); if (melt_is_young (mappointerv)) { meltgc_reserve (newlensiz + 10 * sizeof (void *)); if (!melt_is_young (mappointerv)) goto alloc_old_mappointer_entab; newtab = (struct entrypointermelt_st *) melt_allocatereserved (newlensiz, 0); } else { alloc_old_mappointer_entab: newtab = ggc_alloc_cleared_vec_entrypointermelt_st (newlen); } oldtab = map_mappointerv->entab; for (ix = 0; ix < len; ix++) { const void *curat = oldtab[ix].e_at; int newix; if (!curat || curat == (void *) HTAB_DELETED_ENTRY) continue; newix = unsafe_index_mappointer (newtab, curat, newlen); gcc_assert (newix >= 0); newtab[newix] = oldtab[ix]; newcnt++; } if (!melt_is_young (oldtab)) /* free oldtab since it is in old ggc space */ ggc_free (oldtab); map_mappointerv->entab = newtab; map_mappointerv->count = newcnt; map_mappointerv->lenix++; meltgc_touch (map_mappointerv); len = newlen; } ix = unsafe_index_mappointer (map_mappointerv->entab, attr, len); gcc_assert (ix >= 0); if (!map_mappointerv->entab[ix].e_at || map_mappointerv->entab[ix].e_at == HTAB_DELETED_ENTRY) { map_mappointerv->entab[ix].e_at = attr; map_mappointerv->count++; } map_mappointerv->entab[ix].e_va = (melt_ptr_t) valuv; meltgc_touch_dest (map_mappointerv, valuv); MELT_EXITFRAME (); #undef discrv #undef mappointerv #undef valuv #undef object_discrv #undef map_mappointerv } melt_ptr_t melt_raw_get_mappointers (void *map, const void *attr) { long ix = 0, len = 0; const void *oldat = NULL; struct meltmappointers_st *mappointer_p = (struct meltmappointers_st *) map; if (!mappointer_p->entab) return NULL; len = melt_primtab[mappointer_p->lenix]; if (len <= 0) return NULL; ix = unsafe_index_mappointer (mappointer_p->entab, attr, len); if (ix < 0 || !(oldat = mappointer_p->entab[ix].e_at) || oldat == HTAB_DELETED_ENTRY) return NULL; return mappointer_p->entab[ix].e_va; } melt_ptr_t meltgc_raw_remove_mappointers (void *mappointer_p, const void *attr) { long ix = 0, len = 0, cnt = 0; const char *oldat = NULL; MELT_ENTERFRAME (2, NULL); #define mappointerv meltfram__.mcfr_varptr[0] #define valuv meltfram__.mcfr_varptr[1] #define map_mappointerv ((struct meltmappointers_st*)(mappointerv)) mappointerv = mappointer_p; valuv = NULL; if (!map_mappointerv->entab) goto end; len = melt_primtab[map_mappointerv->lenix]; if (len <= 0) goto end; ix = unsafe_index_mappointer (map_mappointerv->entab, attr, len); if (ix < 0 || !(oldat = (const char *) map_mappointerv->entab[ix].e_at) || oldat == HTAB_DELETED_ENTRY) goto end; map_mappointerv->entab[ix].e_at = (void *) HTAB_DELETED_ENTRY; valuv = map_mappointerv->entab[ix].e_va; map_mappointerv->entab[ix].e_va = NULL; map_mappointerv->count--; cnt = map_mappointerv->count; if (len > 7 && 2 * cnt + 2 < len) { int newcnt = 0, newlen = 0, newlenix = 0; struct entrypointermelt_st *oldtab = NULL, *newtab = NULL; size_t newlensiz = 0; for (newlenix = map_mappointerv->lenix; (newlen = melt_primtab[newlenix]) > 2 * cnt + 3; newlenix--); if (newlen >= len) goto end; newlensiz = newlen * sizeof (struct entrypointermelt_st); if (melt_is_young (mappointerv)) { meltgc_reserve (newlensiz + 10 * sizeof (void *)); if (!melt_is_young (mappointerv)) goto allocate_old_newtab_mappointer; newtab = (struct entrypointermelt_st *) melt_allocatereserved (newlensiz, 0); } else { allocate_old_newtab_mappointer: newtab = ggc_alloc_cleared_vec_entrypointermelt_st (newlen); }; oldtab = map_mappointerv->entab; for (ix = 0; ix < len; ix++) { const void *curat = oldtab[ix].e_at; int newix; if (!curat || curat == (void *) HTAB_DELETED_ENTRY) continue; newix = unsafe_index_mappointer (newtab, curat, newlen); gcc_assert (newix >= 0); newtab[newix] = oldtab[ix]; newcnt++; } if (!melt_is_young (oldtab)) /* free oldtab since it is in old ggc space */ ggc_free (oldtab); map_mappointerv->entab = newtab; map_mappointerv->count = newcnt; } meltgc_touch (map_mappointerv); end: MELT_EXITFRAME (); return (melt_ptr_t) valuv; #undef mappointerv #undef valuv #undef map_mappointerv } /***************** objvlisp test of strict subclassing */ bool melt_is_subclass_of (meltobject_ptr_t subclass_p, meltobject_ptr_t superclass_p) { struct meltmultiple_st *subanc = NULL; struct meltmultiple_st *superanc = NULL; unsigned subdepth = 0, superdepth = 0; if (melt_magic_discr ((melt_ptr_t) subclass_p) != MELTOBMAG_OBJECT || subclass_p->meltobj_magic != MELTOBMAG_OBJECT || melt_magic_discr ((melt_ptr_t) superclass_p) != MELTOBMAG_OBJECT || superclass_p->meltobj_magic != MELTOBMAG_OBJECT) { return FALSE; } if (subclass_p->obj_len < MELTLENGTH_CLASS_CLASS || !subclass_p->obj_vartab || superclass_p->obj_len < MELTLENGTH_CLASS_CLASS || !superclass_p->obj_vartab) { return FALSE; } if (superclass_p == (meltobject_ptr_t) MELT_PREDEF (CLASS_ROOT)) return TRUE; subanc = (struct meltmultiple_st *) subclass_p->obj_vartab[MELTFIELD_CLASS_ANCESTORS]; superanc = (struct meltmultiple_st *) superclass_p->obj_vartab[MELTFIELD_CLASS_ANCESTORS]; if (melt_magic_discr ((melt_ptr_t) subanc) != MELTOBMAG_MULTIPLE || subanc->discr != (meltobject_ptr_t) MELT_PREDEF (DISCR_CLASS_SEQUENCE)) { return FALSE; } if (melt_magic_discr ((melt_ptr_t) superanc) != MELTOBMAG_MULTIPLE || superanc->discr != (meltobject_ptr_t) MELT_PREDEF (DISCR_CLASS_SEQUENCE)) { return FALSE; } subdepth = subanc->nbval; superdepth = superanc->nbval; if (subdepth <= superdepth) return FALSE; if ((melt_ptr_t) subanc->tabval[superdepth] == (melt_ptr_t) superclass_p) return TRUE; return FALSE; } melt_ptr_t meltgc_new_string_raw_len (meltobject_ptr_t discr_p, const char *str, int slen) { MELT_ENTERFRAME (2, NULL); #define discrv meltfram__.mcfr_varptr[0] #define strv meltfram__.mcfr_varptr[1] #define obj_discrv ((struct meltobject_st*)(discrv)) #define str_strv ((struct meltstring_st*)(strv)) strv = 0; if (!str) goto end; if (slen<0) slen = strlen (str); discrv = discr_p; if (!discrv) discrv = MELT_PREDEF (DISCR_STRING); if (melt_magic_discr ((melt_ptr_t) discrv) != MELTOBMAG_OBJECT) goto end; if (obj_discrv->meltobj_magic != MELTOBMAG_STRING) goto end; strv = meltgc_allocate (sizeof (struct meltstring_st), slen + 1); str_strv->discr = obj_discrv; memcpy (str_strv->val, str, slen); str_strv->val[slen] = (char)0; str_strv->slen = slen; end: MELT_EXITFRAME (); return (melt_ptr_t) strv; #undef discrv #undef strv #undef obj_discrv #undef str_strv } melt_ptr_t meltgc_new_string (meltobject_ptr_t discr_p, const char *str) { return meltgc_new_string_raw_len(discr_p, str, -1); } melt_ptr_t meltgc_new_stringdup (meltobject_ptr_t discr_p, const char *str) { int slen = 0; char tinybuf[80]; char *strcop = 0; MELT_ENTERFRAME (2, NULL); #define discrv meltfram__.mcfr_varptr[0] #define strv meltfram__.mcfr_varptr[1] #define obj_discrv ((struct meltobject_st*)(discrv)) #define str_strv ((struct meltstring_st*)(strv)) strv = 0; if (!str) goto end; discrv = discr_p; if (!discrv) discrv = MELT_PREDEF (DISCR_STRING); if (melt_magic_discr ((melt_ptr_t) discrv) != MELTOBMAG_OBJECT) goto end; if (obj_discrv->meltobj_magic != MELTOBMAG_STRING) goto end; slen = strlen (str); if (slen < (int) sizeof (tinybuf) - 1) { memset (tinybuf, 0, sizeof (tinybuf)); strcop = strcpy (tinybuf, str); } else strcop = strcpy ((char *) xcalloc (1, slen + 1), str); strv = meltgc_new_string_raw_len (obj_discrv, strcop, slen); end: if (strcop && strcop != tinybuf) free (strcop); memset (tinybuf, 0, sizeof (tinybuf)); MELT_EXITFRAME (); return (melt_ptr_t) strv; #undef discrv #undef strv #undef obj_discrv #undef str_strv } /* Return a new string of given discriminant, with the original STR amputed of a given SUFFIX if appropriate, or else a copy of STR. */ melt_ptr_t meltgc_new_string_without_suffix (meltobject_ptr_t discr_p, const char* str, const char* suffix) { char tinybuf[120]; char *buf = NULL; int slen = 0; int suflen = 0; MELT_ENTERFRAME (2, NULL); #define discrv meltfram__.mcfr_varptr[0] #define strv meltfram__.mcfr_varptr[1] #define obj_discrv ((struct meltobject_st*)(discrv)) #define str_strv ((struct meltstring_st*)(strv)) memset (tinybuf, 0, sizeof(tinybuf)); discrv = discr_p; if (!discrv) discrv = MELT_PREDEF (DISCR_STRING); if (obj_discrv->meltobj_magic != MELTOBMAG_STRING) goto end; if (!str) goto end; debugeprintf ("meltgc_new_string_without_suffix str '%s' suffix '%s'", str, suffix); slen = strlen (str); if (slen < (int) sizeof(tinybuf) - 1) { strcpy (tinybuf, str); buf = tinybuf; } else buf = xstrdup (str); if (!suffix) { suflen = 0; suffix = ""; } else suflen = strlen (suffix); if (suflen <= slen && !strcmp (buf + slen - suflen, suffix)) { buf[slen-suflen] = (char)0; strv = meltgc_new_string_raw_len (obj_discrv, buf, slen - suflen); } else { strv = meltgc_new_string_raw_len (obj_discrv, buf, slen); } end: if (buf && buf != tinybuf) free (buf), buf = NULL; MELT_EXITFRAME (); return (melt_ptr_t) strv; #undef discrv #undef strv #undef obj_discrv #undef str_strv } melt_ptr_t meltgc_new_string_generated_c_filename (meltobject_ptr_t discr_p, const char* basepath, const char* dirpath, int num) { int slen = 0; int spos = 0; char *strcop = NULL; char numbuf[16]; char tinybuf[120]; MELT_ENTERFRAME (2, NULL); #define discrv meltfram__.mcfr_varptr[0] #define strv meltfram__.mcfr_varptr[1] #define obj_discrv ((struct meltobject_st*)(discrv)) #define str_strv ((struct meltstring_st*)(strv)) memset (numbuf, 0, sizeof(numbuf)); memset (tinybuf, 0, sizeof(tinybuf)); discrv = discr_p; if (!basepath || !basepath[0]) goto end; if (num > 0) snprintf (numbuf, sizeof(numbuf)-1, "+%02d", num); if (!discrv) discrv = MELT_PREDEF (DISCR_STRING); if (melt_magic_discr ((melt_ptr_t) discrv) != MELTOBMAG_OBJECT) goto end; if (obj_discrv->meltobj_magic != MELTOBMAG_STRING) goto end; slen += strlen (basepath); if (dirpath) slen += strlen (dirpath); slen += strlen (numbuf); slen += 6; /* slen is now an over-approximation of the needed space */ if (slen < (int) sizeof(tinybuf)-1) strcop = tinybuf; else strcop = (char*) xcalloc (slen+1, 1); if (dirpath) { /* add the dirpath with a trailing slash if needed */ strcpy (strcop, dirpath); spos = strlen (strcop); if (spos>0 && strcop[spos-1] != '/') strcop[spos++] = '/'; /* add the basename of the basepath */ strcpy (strcop + spos, melt_basename (basepath)); } else { /* no dirpath, add the entire basepath */ strcpy (strcop, basepath); }; spos = strlen (strcop); /* if strcop ends with .c, remove that suffix */ if (spos>2 && strcop[spos-1] == 'c' && strcop[spos-2] == '.') { strcop[spos-2] = strcop[spos-1] = (char)0; spos -= 2; } /* remove the MELT_DYNLOADED_SUFFIX suffix [often .so] if given */ else if (spos >= (int) sizeof(MELT_DYNLOADED_SUFFIX) && !strcmp (strcop+spos-(sizeof(MELT_DYNLOADED_SUFFIX)-1), MELT_DYNLOADED_SUFFIX)) { memset (strcop + spos - (sizeof(MELT_DYNLOADED_SUFFIX)-1), 0, sizeof(MELT_DYNLOADED_SUFFIX)-1); spos -= sizeof(MELT_DYNLOADED_SUFFIX)-1; } /* remove the .melt suffix if given */ else if (spos>5 && !strcmp (strcop+spos-5, ".melt")) { memset(strcop+spos, 0, strlen(".melt")); spos -= strlen(".melt"); } strcpy (strcop + spos, numbuf); strcat (strcop + spos, ".c"); spos = strlen (strcop); gcc_assert (spos < slen-1); strv = meltgc_new_string_raw_len (obj_discrv, strcop, spos); end: if (strcop && strcop != tinybuf) free (strcop); memset (tinybuf, 0, sizeof (tinybuf)); MELT_EXITFRAME (); return (melt_ptr_t) strv; #undef discrv #undef strv #undef obj_discrv #undef str_strv } melt_ptr_t meltgc_new_string_nakedbasename (meltobject_ptr_t discr_p, const char *str) { int slen = 0; char tinybuf[120]; char *strcop = 0; const char *basestr = 0; char *dot = 0; MELT_ENTERFRAME (2, NULL); #define discrv meltfram__.mcfr_varptr[0] #define strv meltfram__.mcfr_varptr[1] #define obj_discrv ((struct meltobject_st*)(discrv)) #define str_strv ((struct meltstring_st*)(strv)) strv = 0; discrv = discr_p; debugeprintf ("meltgc_new_string_nakedbasename start str '%s'", str); if (!str) goto end; if (!discrv) discrv = MELT_PREDEF (DISCR_STRING); if (melt_magic_discr ((melt_ptr_t) discrv) != MELTOBMAG_OBJECT) goto end; if (obj_discrv->meltobj_magic != MELTOBMAG_STRING) goto end; slen = strlen (str); if (slen < (int) sizeof (tinybuf) - 1) { memset (tinybuf, 0, sizeof (tinybuf)); strcop = strcpy (tinybuf, str); } else strcop = strcpy ((char *) xcalloc (1, slen + 1), str); basestr = (const char *) melt_basename (strcop); dot = CONST_CAST (char*, strrchr (basestr, '.')); if (dot) *dot = 0; slen = strlen (basestr); strv = meltgc_new_string_raw_len (obj_discrv, basestr, slen); end: if (strcop && strcop != tinybuf) free (strcop); memset (tinybuf, 0, sizeof (tinybuf)); MELT_EXITFRAME (); return (melt_ptr_t) strv; #undef discrv #undef strv #undef obj_discrv #undef str_strv } melt_ptr_t meltgc_new_string_tempname_suffixed (meltobject_ptr_t discr_p, const char *namstr, const char *suffstr) { int slen = 0; char suffix[16]; const char *basestr = xstrdup (melt_basename (namstr)); const char* tempnampath = 0; char *dot = 0; MELT_ENTERFRAME (2, NULL); #define discrv meltfram__.mcfr_varptr[0] #define strv meltfram__.mcfr_varptr[1] #define obj_discrv ((struct meltobject_st*)(discrv)) #define str_strv ((struct meltstring_st*)(strv)) memset(suffix, 0, sizeof(suffix)); if (suffstr) strncpy(suffix, suffstr, sizeof(suffix)-1); if (basestr) dot = CONST_CAST (char*, strrchr(basestr, '.')); if (dot) *dot=0; tempnampath = melt_tempdir_path (basestr, suffix); dbgprintf ("new_string_tempbasename basestr='%s' tempnampath='%s'", basestr, tempnampath); free(CONST_CAST(char*,basestr)); basestr = 0; strv = 0; if (!tempnampath) goto end; discrv = discr_p; if (!discrv) discrv = MELT_PREDEF (DISCR_STRING); if (melt_magic_discr ((melt_ptr_t) discrv) != MELTOBMAG_OBJECT) goto end; if (obj_discrv->meltobj_magic != MELTOBMAG_STRING) goto end; slen = strlen (tempnampath); strv = meltgc_new_string_raw_len (obj_discrv, tempnampath, slen); end: if (tempnampath) free (CONST_CAST (char*,tempnampath)); MELT_EXITFRAME (); return (melt_ptr_t) strv; #undef discrv #undef strv #undef obj_discrv #undef str_strv } /* Return as a cached MELT string, using the :sysdata_src_loc_file_dict dictonnary for memoization, the file path of a location, or else NULL. */ melt_ptr_t meltgc_cached_string_path_of_source_location (source_location loc) { const char* filepath = NULL; MELT_ENTERFRAME (2, NULL); #define dictv meltfram__.mcfr_varptr[0] #define strv meltfram__.mcfr_varptr[1] strv = NULL; if (loc == UNKNOWN_LOCATION) goto end; filepath = LOCATION_FILE (loc); if (!filepath) goto end; dictv = melt_get_inisysdata (MELTFIELD_SYSDATA_SRC_LOC_FILE_DICT); if (melt_magic_discr ((melt_ptr_t) dictv) == MELTOBMAG_MAPSTRINGS) { strv = melt_get_mapstrings ((struct meltmapstrings_st *) dictv, filepath); if (!strv) { strv = meltgc_new_stringdup ((meltobject_ptr_t) MELT_PREDEF(DISCR_STRING), filepath); meltgc_put_mapstrings ((struct meltmapstrings_st*) dictv, filepath, (melt_ptr_t) strv); } } end: MELT_EXITFRAME (); return (melt_ptr_t) strv; #undef dictv #undef strv } /* Split a string into a list of string value using sep as separating character. */ melt_ptr_t meltgc_new_split_string (const char*str, int sep, melt_ptr_t discr_p) { char* dupstr = 0; char *cursep = 0; char *pc = 0; MELT_ENTERFRAME (4, NULL); #define discrv meltfram__.mcfr_varptr[0] #define strv meltfram__.mcfr_varptr[1] #define lisv meltfram__.mcfr_varptr[2] #define obj_discrv ((struct meltobject_st*)(discrv)) #define str_strv ((struct meltstring_st*)(strv)) discrv = discr_p; if (!str) goto end; if (!discrv) discrv = MELT_PREDEF (DISCR_STRING); if (melt_magic_discr ((melt_ptr_t) discrv) != MELTOBMAG_OBJECT) goto end; if (obj_discrv->meltobj_magic != MELTOBMAG_STRING) goto end; dupstr = xstrdup (str); if (sep<0) sep=','; else if (sep==0) sep=' '; if (sep<0 || sep>CHAR_MAX) goto end; lisv = meltgc_new_list ((meltobject_ptr_t) MELT_PREDEF (DISCR_LIST)); for (pc = dupstr; pc && *pc; pc = cursep?(cursep+1):0) { cursep = NULL; strv = NULL; /* avoid errors when we have str which starts with the separator or when we have a separator immediatly followed by another one (like 'first::second'). */ while (*pc == sep) pc++; if (ISSPACE (sep)) for (cursep=pc; *cursep && !ISSPACE (*cursep); cursep++); else for (cursep=pc; *cursep && *cursep != sep; cursep++); if (cursep && cursep>pc) strv = meltgc_new_string_raw_len (obj_discrv, pc, cursep-pc); else strv = meltgc_new_string_raw_len (obj_discrv, pc, strlen (pc)); meltgc_append_list ((melt_ptr_t) lisv, (melt_ptr_t) strv); if (cursep && *cursep == 0) break; } end: MELT_EXITFRAME (); free (dupstr); return (melt_ptr_t)lisv; #undef discrv #undef strv #undef lisv #undef str_strv #undef obj_discrv } /* Return a string of a given discriminant (default DISCR_STRING), for the real path of a filepath which is an accessible file [perhaps a directory, etc...], or else NULL */ melt_ptr_t meltgc_new_real_accessible_path_string (meltobject_ptr_t discr_p, const char *str) { char *rpstr = NULL; MELT_ENTERFRAME (2, NULL); #define discrv meltfram__.mcfr_varptr[0] #define strv meltfram__.mcfr_varptr[1] discrv = (melt_ptr_t) discr_p; if (!discrv) discrv = MELT_PREDEF (DISCR_STRING); if (melt_magic_discr ((melt_ptr_t) discrv) != MELTOBMAG_OBJECT) goto end; if (((meltobject_ptr_t) discrv)->meltobj_magic != MELTOBMAG_STRING) goto end; if (!str || !str[0] || access (str, F_OK)) goto end; rpstr = lrealpath (str); if (!rpstr || !rpstr[0]) goto end; strv = meltgc_new_string_raw_len ((meltobject_ptr_t)discrv, rpstr, strlen (rpstr)); end: free (rpstr); MELT_EXITFRAME (); return (melt_ptr_t) strv; #undef discrv #undef strv } #if MELT_HAVE_DEBUG static long applcount_melt; static int appldepth_melt; #define MAXDEPTH_APPLY_MELT 256 long melt_application_count (void) { return (long) applcount_melt; } long melt_application_depth (void) { return (long) appldepth_melt; } #else long melt_application_count (void) { return 0L; } long melt_application_depth (void) { return 0L; } #endif /*************** closure application ********************/ /* the argument description string are currently char* strings; this could be changed to wchar_t* strings when the number of generated ctypes and MELBPAR__LAST is becoming large. Also update the generate_runtypesupport_param function of warmelt-outobj.melt. So the test at end of generate_runtypesupport_param should be kept in sync with the maximal value. See comments around melt_argdescr_cell_t and MELT_ARGDESCR_MAX in melt-runtime.h and keep delicately in sync with warmelt-outobj.melt code. */ melt_ptr_t melt_apply (meltclosure_ptr_t clos_p, melt_ptr_t arg1_p, const melt_argdescr_cell_t *xargdescr_, union meltparam_un *xargtab_, const melt_argdescr_cell_t *xresdescr_, union meltparam_un *xrestab_) { melt_ptr_t res = NULL; meltroutfun_t*routfun = 0; #if MELT_HAVE_DEBUG applcount_melt++; appldepth_melt++; if (appldepth_melt > MAXDEPTH_APPLY_MELT) { melt_dbgshortbacktrace ("too deep applications", 260); /* Don't call melt_fatal_error, since the backtrace is already shown. */ fatal_error ("too deep (%d) MELT applications", appldepth_melt); } if ((int) MELTBPAR__LAST >= (int) MELT_ARGDESCR_MAX - 2) melt_fatal_error ("too many different MELT ctypes since MELTBPAR__LAST= %d", (int) MELTBPAR__LAST); #endif if (melt_magic_discr ((melt_ptr_t) clos_p) != MELTOBMAG_CLOSURE) goto end; { int routmag = melt_magic_discr ((melt_ptr_t) (clos_p->rout)); if (routmag != MELTOBMAG_ROUTINE) { melt_fatal_error ("MELT corrupted closure %p with routine value %p of bad magic %d (expecting MELTOBMAG_ROUTINE=%d)", (void*) clos_p, (void*) clos_p->rout, routmag, MELTOBMAG_ROUTINE); goto end; } } if (!(routfun = clos_p->rout->routfunad)) { melt_fatal_error ("MELT closure %p with corrupted routine value %p <%s> without function", (void*) clos_p, (void*) clos_p->rout, clos_p->rout->routdescr); goto end; } res = (*routfun) (clos_p, arg1_p, xargdescr_, xargtab_, xresdescr_, xrestab_); end: #if MELT_HAVE_DEBUG appldepth_melt--; #endif return res; } /************** method sending ***************/ melt_ptr_t meltgc_send (melt_ptr_t recv_p, melt_ptr_t sel_p, const melt_argdescr_cell_t *xargdescr_, union meltparam_un * xargtab_, const melt_argdescr_cell_t *xresdescr_, union meltparam_un * xrestab_) { /* NAUGHTY TRICK here: message sending is very common, and we want to avoid having the current frame (the frame declared by the MELT_ENTERFRAME macro call below) to be active when the application for the sending is performed. This should make our call frames' linked list shorter. To do so, we put the closure to apply and the receiver in the two variables below. Yes this is dirty, but it works! We should be very careful when modifying this routine */ /* never assign to these if a GC could happen */ meltclosure_ptr_t closure_dirtyptr = NULL; melt_ptr_t recv_dirtyptr = NULL; MELT_ENTERFRAME (7, NULL); #define recv meltfram__.mcfr_varptr[0] #define selv meltfram__.mcfr_varptr[1] #define closv meltfram__.mcfr_varptr[2] #define discrv meltfram__.mcfr_varptr[3] #define mapv meltfram__.mcfr_varptr[4] #define resv meltfram__.mcfr_varptr[5] #define ancv meltfram__.mcfr_varptr[6] #define obj_discrv ((meltobject_ptr_t)(discrv)) #define obj_selv ((meltobject_ptr_t)(selv)) #define clo_closv ((meltclosure_ptr_t)(closv)) #define mul_ancv ((struct meltmultiple_st*)(ancv)) recv = recv_p; selv = sel_p; /* the receiver can be null, using DISCR_NULL_RECEIVER */ if (melt_magic_discr ((melt_ptr_t) selv) != MELTOBMAG_OBJECT) goto end; if (!melt_is_instance_of ((melt_ptr_t) selv, (melt_ptr_t) MELT_PREDEF (CLASS_SELECTOR))) goto end; if (recv != NULL) { discrv = ((melt_ptr_t) recv)->u_discr; gcc_assert (discrv != NULL); } else { discrv = ((meltobject_ptr_t) MELT_PREDEF (DISCR_NULL_RECEIVER)); gcc_assert (discrv != NULL); }; while (discrv) { gcc_assert (melt_magic_discr ((melt_ptr_t) discrv) == MELTOBMAG_OBJECT); gcc_assert (obj_discrv->obj_len >= MELTLENGTH_CLASS_DISCRIMINANT); mapv = obj_discrv->obj_vartab[MELTFIELD_DISC_METHODICT]; if (melt_magic_discr ((melt_ptr_t) mapv) == MELTOBMAG_MAPOBJECTS) { closv = (melt_ptr_t) melt_get_mapobjects ((meltmapobjects_ptr_t) mapv, (meltobject_ptr_t) selv); } else { closv = obj_discrv->obj_vartab[MELTFIELD_DISC_SENDER]; if (melt_magic_discr ((melt_ptr_t) closv) == MELTOBMAG_CLOSURE) { union meltparam_un pararg[1]; pararg[0].meltbp_aptr = (melt_ptr_t *) & selv; resv = melt_apply ((meltclosure_ptr_t) closv, (melt_ptr_t) recv, MELTBPARSTR_PTR, pararg, "", NULL); closv = resv; } } if (melt_magic_discr ((melt_ptr_t) closv) == MELTOBMAG_CLOSURE) { /* NAUGHTY TRICK: assign to dirty (see comments near start of function) */ closure_dirtyptr = (meltclosure_ptr_t) closv; recv_dirtyptr = (melt_ptr_t) recv; /*** OLD CODE: resv = melt_apply (closv, recv, xargdescr_, xargtab_, xresdescr_, xrestab_); ***/ goto end; } discrv = obj_discrv->obj_vartab[MELTFIELD_DISC_SUPER]; } /* end while discrv */ resv = NULL; end: MELT_EXITFRAME (); /* NAUGHTY TRICK (see comments near start of function) */ if (closure_dirtyptr) return melt_apply (closure_dirtyptr, recv_dirtyptr, xargdescr_, xargtab_, xresdescr_, xrestab_); return (melt_ptr_t) resv; #undef recv #undef selv #undef closv #undef discrv #undef mapv #undef resv #undef ancv #undef obj_discrv #undef obj_selv #undef clo_closv } /* Clear a slot inside the INITIAL_SYSTEM_DATA. */ static inline void melt_clear_inisysdata(int off) { meltobject_ptr_t inisys = (meltobject_ptr_t) MELT_PREDEF(INITIAL_SYSTEM_DATA); if (melt_magic_discr ((melt_ptr_t) inisys) == MELTOBMAG_OBJECT) { int leninisys = inisys->obj_len; gcc_assert(melt_is_instance_of ((melt_ptr_t) inisys, (melt_ptr_t) MELT_PREDEF (CLASS_SYSTEM_DATA))); if (off>=0 && offobj_vartab[off] = NULL; } } } /* our temporary directory */ /* maybe it should not be static, or have a bigger length */ static char tempdir_melt[1024]; static bool made_tempdir_melt; /* returns malloc-ed path inside a temporary directory, with a given basename */ char * melt_tempdir_path (const char *srcnam, const char* suffix) { int loopcnt = 0; int mkdirdone = 0; const char *basnam = 0; static const char* tmpdirstr = 0; time_t nowt = 0; int maymkdir = srcnam != NULL; basnam = srcnam?melt_basename (CONST_CAST (char*,srcnam)):0; debugeprintf ("melt_tempdir_path srcnam '%s' basnam '%s' suffix '%s'", srcnam, basnam, suffix); if (!tmpdirstr) tmpdirstr = melt_argument ("tempdir"); gcc_assert (!basnam || (ISALNUM (basnam[0]) || basnam[0] == '_')); if (tmpdirstr && tmpdirstr[0]) { if (maymkdir && access (tmpdirstr, F_OK)) { if (mkdir (tmpdirstr, 0700)) melt_fatal_error ("failed to mkdir melt_tempdir %s - %m", tmpdirstr); made_tempdir_melt = true; } return concat (tmpdirstr, "/", basnam, suffix, NULL); } if (!tempdir_melt[0]) { if (!maymkdir) return NULL; time (&nowt); /* Usually this loop runs only once! */ for (loopcnt = 0; loopcnt < 1000; loopcnt++) { int n = (melt_lrand () & 0x1fffffff) ^ (nowt & 0xffffff); n += (int)getpid (); memset(tempdir_melt, 0, sizeof(tempdir_melt)); snprintf (tempdir_melt, sizeof(tempdir_melt)-1, "%s-GccMeltTmp-%x", tmpnam(NULL), n); if (!mkdir (tempdir_melt, 0700)) { made_tempdir_melt = true; mkdirdone = 1; break; }; } if (!mkdirdone) melt_fatal_error ("failed to create temporary directory for MELT, last try was %s - %m", tempdir_melt); }; return concat (tempdir_melt, "/", basnam, suffix, NULL); } /* utility to add an escaped file path into an obstack. Returns true if characters have been escaped */ static bool obstack_add_escaped_path (struct obstack* obs, const char* path) { bool warn = false; const char* pc; for (pc = path; *pc; pc++) { const char c = *pc; /* Accept ordinary characters as is. */ if (ISALNUM(c) || c == '/' || c == '.' || c == '_' || c == '-' || c == '+') { obstack_1grow (obs, c); continue; } /* Accept characters as is if they are not first or last. */ if (pc > path && pc[1] && (c == '=' || c == ':')) { obstack_1grow (obs, c); continue; } /* Escape other characters. FIXME: this could be not enough with UTF8 special characters! */ warn = true; obstack_1grow (obs, '\\'); obstack_1grow (obs, c); }; return warn; } /* the name of the source module argument to 'make' without any .c suffix. */ #define MODULE_SOURCEBASE_ARG "GCCMELT_MODULE_SOURCEBASE=" /* the name of the binary base argument to 'make'. No dots in the basename here... */ #define MODULE_BINARYBASE_ARG "GCCMELT_MODULE_BINARYBASE=" /* the name of the workspace directory */ #define WORKSPACE_ARG "GCCMELT_MODULE_WORKSPACE=" /* flavor of the binary module */ #define FLAVOR_ARG "GCCMELT_MODULE_FLAVOR=" /* do we build with C++ the generated C modules */ #define BUILD_WITH_CXX_ARG "MELTGCC_BUILD_WITH_CXX=" /* the additional C flags */ #define CFLAGS_ARG "GCCMELT_CFLAGS=" /* the flag to change directory for make */ /* See also file melt-module.mk which expects the module binary to be without its MELT_DYNLOADED_SUFFIX. */ #define MAKECHDIR_ARG "-C" /* the make target */ #define MAKE_TARGET "melt_module" #if MELT_IS_PLUGIN static void melt_run_make_for_plugin (const char*ourmakecommand, const char*ourmakefile, const char*ourcflags, const char*flavor, const char*srcbase, const char*binbase, const char*workdir) { /* In plugin mode, we sadly don't have the pex_run function available, because libiberty is statically linked into cc1 which don't need pex_run. See http://gcc.gnu.org/ml/gcc-patches/2009-11/msg01419.html etc. So we unfortunately have to use system(3), using an obstack for the command string. */ int err = 0; bool warnescapedchar = false; char *cmdstr = NULL; const char*mycwd = getpwd (); struct obstack cmd_obstack; memset (&cmd_obstack, 0, sizeof(cmd_obstack)); obstack_init (&cmd_obstack); debugeprintf ("starting melt_run_make_for_plugin ourmakecommand=%s ourmakefile=%s ourcflags=%s", ourmakecommand, ourmakefile, ourcflags); debugeprintf ("starting melt_run_make_for_plugin flavor=%s srcbase=%s binbase=%s workdir=%s pwd=%s", flavor, srcbase, binbase, workdir, mycwd); if (!flavor) flavor = MELT_DEFAULT_FLAVOR; /* add ourmakecommand without any quoting trickery! */ obstack_grow (&cmd_obstack, ourmakecommand, strlen(ourmakecommand)); obstack_1grow (&cmd_obstack, ' '); /* silent make if not debugging */ if (!melt_flag_debug) obstack_grow (&cmd_obstack, "-s ", 3); /* add -f with spaces */ obstack_grow (&cmd_obstack, "-f ", 3); /* add ourmakefile and escape with backslash every escaped chararacter */ warnescapedchar = obstack_add_escaped_path (&cmd_obstack, ourmakefile); if (warnescapedchar) warning (0, "escaped character[s] in MELT module makefile %s", ourmakefile); obstack_1grow (&cmd_obstack, ' '); /* add the source argument */ obstack_grow (&cmd_obstack, MODULE_SOURCEBASE_ARG, strlen (MODULE_SOURCEBASE_ARG)); if (!IS_ABSOLUTE_PATH(srcbase)) { (void) obstack_add_escaped_path (&cmd_obstack, mycwd); obstack_1grow (&cmd_obstack, '/'); } warnescapedchar = obstack_add_escaped_path (&cmd_obstack, srcbase); if (warnescapedchar) warning (0, "escaped character[s] in MELT source base %s", srcbase); obstack_1grow (&cmd_obstack, ' '); /* add the binary argument */ obstack_grow (&cmd_obstack, MODULE_BINARYBASE_ARG, strlen (MODULE_BINARYBASE_ARG)); if (!IS_ABSOLUTE_PATH (binbase)) { (void) obstack_add_escaped_path (&cmd_obstack, mycwd); obstack_1grow (&cmd_obstack, '/'); } warnescapedchar = obstack_add_escaped_path (&cmd_obstack, binbase); if (warnescapedchar) warning (0, "escaped character[s] in MELT binary module %s", binbase); obstack_1grow (&cmd_obstack, ' '); /* add the built with C++ argument if needed */ #if defined(ENABLE_BUILD_WITH_CXX) || MELT_GCC_VERSION >= 4008 || defined(__cplusplus) { obstack_1grow (&cmd_obstack, ' '); obstack_grow (&cmd_obstack, BUILD_WITH_CXX_ARG "YesPlugin", strlen (BUILD_WITH_CXX_ARG "YesPlugin")); } #endif /* add the cflag argument if needed */ if (ourcflags && ourcflags[0]) { debugeprintf ("melt_run_make_for_plugin ourcflags=%s", ourcflags); obstack_1grow (&cmd_obstack, ' '); /* don't warn about escapes for cflags, they contain spaces...*/ debugeprintf ("melt_run_make_for_plugin CFLAGS_ARG=%s", CFLAGS_ARG); obstack_grow (&cmd_obstack, CFLAGS_ARG, strlen (CFLAGS_ARG)); obstack_add_escaped_path (&cmd_obstack, ourcflags); obstack_1grow (&cmd_obstack, ' '); obstack_1grow (&cmd_obstack, ' '); }; /* add the workspace argument if needed, that is if workdir is provided not as '.' */ if (workdir && workdir[0] && strcmp(workdir,".") && strcmp(workdir, mycwd)) { struct stat workstat; memset (&workstat, 0, sizeof(workstat)); debugeprintf ("melt_run_make_for_plugin handling workdir %s", workdir); if (stat (workdir, &workstat)) melt_fatal_error ("bad MELT module workspace directory %s - stat failed %m", workdir); if (!S_ISDIR(workstat.st_mode)) melt_fatal_error ("MELT module workspace %s not directory", workdir); obstack_grow (&cmd_obstack, WORKSPACE_ARG, strlen (WORKSPACE_ARG)); if (!IS_ABSOLUTE_PATH(workdir)) { (void) obstack_add_escaped_path (&cmd_obstack, mycwd); obstack_1grow (&cmd_obstack, '/'); }; warnescapedchar = obstack_add_escaped_path (&cmd_obstack, workdir); if (warnescapedchar) warning (0, "escaped character[s] in MELT workspace directory %s", workdir); obstack_1grow (&cmd_obstack, ' '); } /* Add the flavor and the constant make target*/ obstack_grow (&cmd_obstack, FLAVOR_ARG, strlen (FLAVOR_ARG)); warnescapedchar = obstack_add_escaped_path (&cmd_obstack, flavor); if (warnescapedchar) warning (0, "escaped character[s] in MELT flavor %s", flavor); obstack_1grow (&cmd_obstack, ' '); obstack_grow (&cmd_obstack, MAKE_TARGET, strlen (MAKE_TARGET)); obstack_1grow (&cmd_obstack, (char) 0); cmdstr = XOBFINISH (&cmd_obstack, char *); debugeprintf("melt_run_make_for_plugin cmdstr= %s", cmdstr); if (!quiet_flag || melt_flag_bootstrapping) printf ("MELT plugin running: %s\n", cmdstr); fflush (NULL); err = system (cmdstr); debugeprintf("melt_run_make_for_plugin command got %d", err); if (err) melt_fatal_error ("MELT plugin module compilation failed (%d) in %s for command %s", err, getpwd (), cmdstr); cmdstr = NULL; obstack_free (&cmd_obstack, NULL); /* free all the cmd_obstack */ debugeprintf ("melt_run_make_for_plugin meltplugin did built binbase %s flavor %s in workdir %s", binbase, flavor, workdir); if (IS_ABSOLUTE_PATH (binbase)) inform (UNKNOWN_LOCATION, "MELT plugin has built module %s flavor %s", binbase, flavor); else inform (UNKNOWN_LOCATION, "MELT plugin has built module %s flavor %s in %s", binbase, flavor, mycwd); return; } #else static void melt_run_make_for_branch (const char*ourmakecommand, const char*ourmakefile, const char*ourcflags, const char*flavor, const char*srcbase, const char*binbase, const char*workdir) { int argc = 0; int err = 0; int cstatus = 0; const char *argv[25] = { NULL }; const char *errmsg = NULL; char* srcarg = NULL; char* binarg = NULL; char* cflagsarg = NULL; char* workarg = NULL; char* flavorarg = NULL; char* mycwd = NULL; struct pex_obj* pex = NULL; struct pex_time ptime; double mysystime = 0.0, myusrtime = 0.0; char cputimebuf[32]; memset (&ptime, 0, sizeof (ptime)); memset (cputimebuf, 0, sizeof (cputimebuf)); memset (argv, 0, sizeof(argv)); mycwd = getpwd (); /* compute the ourmakecommand */ pex = pex_init (PEX_RECORD_TIMES, ourmakecommand, NULL); argv[argc++] = ourmakecommand; debugeprintf("melt_run_make_for_branch arg ourmakecommand %s", ourmakecommand); /* silent make if not debugging */ if (!melt_flag_debug && quiet_flag) argv[argc++] = "-s"; /* the -f argument, and then the makefile */ argv[argc++] = "-f"; argv[argc++] = ourmakefile; debugeprintf("melt_run_make_for_branch arg ourmakefile %s", ourmakefile); /* the source base argument */ if (IS_ABSOLUTE_PATH(srcbase)) srcarg = concat (MODULE_SOURCEBASE_ARG, srcbase, NULL); else srcarg = concat (MODULE_SOURCEBASE_ARG, mycwd, "/", srcbase, NULL); argv[argc++] = srcarg; debugeprintf ("melt_run_make_for_branch arg srcarg %s", srcarg); /* add the built with C++ argument if needed */ #if defined(ENABLE_BUILD_WITH_CXX) || MELT_GCC_VERSION >= 4008 || defined(__cplusplus) { const char*cplusarg = BUILD_WITH_CXX_ARG "YesBranch"; argv[argc++] = cplusarg; debugeprintf ("melt_run_make_for_branch arg with C++: %s", cplusarg); } #endif /* endif */ /* the binary base argument */ if (IS_ABSOLUTE_PATH(binbase)) binarg = concat (MODULE_BINARYBASE_ARG, binbase, NULL); else binarg = concat (MODULE_BINARYBASE_ARG, mycwd, "/", binbase, NULL); argv[argc++] = binarg; debugeprintf("melt_run_make_for_branch arg binarg %s", binarg); if (ourcflags && ourcflags[0]) { cflagsarg = concat (CFLAGS_ARG, ourcflags, NULL); debugeprintf("melt_run_make_for_branch arg cflagsarg %s", cflagsarg); argv[argc++] = cflagsarg; } /* add the workspace argument if needed, that is if workdir is provided not as '.' */ if (workdir && workdir[0] && (workdir[0] != '.' || workdir[1])) { struct stat workstat; debugeprintf ("melt_run_make_for_branch handling workdir %s", workdir); memset (&workstat, 0, sizeof(workstat)); if (stat (workdir, &workstat) || (!S_ISDIR (workstat.st_mode) && (errno = ENOTDIR) != 0)) melt_fatal_error ("invalid MELT module workspace directory %s - %m", workdir); workarg = concat (WORKSPACE_ARG, workdir, NULL); argv[argc++] = workarg; debugeprintf ("melt_run_make_for_branch arg workarg %s", workarg); } if (flavor && flavor[0]) { flavorarg = concat (FLAVOR_ARG, flavor, NULL); argv[argc++] = flavorarg; debugeprintf ("melt_run_make_for_branch arg flavorarg %s", flavorarg); } /* at last the target */ argv[argc++] = MAKE_TARGET; /* terminate by null */ argv[argc] = NULL; gcc_assert ((int) argc < (int) (sizeof(argv)/sizeof(*argv))); if (melt_flag_debug) { int i; debugeprintf("melt_run_make_for_branch before pex_run argc=%d", argc); for (i=0; i0) obstack_1grow (&cmd_obstack, ' '); obstack_add_escaped_path (&cmd_obstack, argv[i]); } obstack_1grow(&cmd_obstack, (char)0); cmdbuf = XOBFINISH (&cmd_obstack, char *); printf ("MELT branch running: %s\n", cmdbuf); } debugeprintf("melt_run_make_for_branch before pex_run ourmakecommand='%s'", ourmakecommand); fflush (NULL); errmsg = pex_run (pex, PEX_LAST | PEX_SEARCH, ourmakecommand, CONST_CAST (char**, argv), NULL, NULL, &err); if (errmsg) melt_fatal_error ("MELT run make failed %s with source argument %s & binary argument %s : %s", ourmakecommand, srcarg, binarg, errmsg); if (!pex_get_status (pex, 1, &cstatus)) melt_fatal_error ("failed to get status of MELT run %s with source argument %s & binary argument %s- %m", ourmakecommand, srcarg, binarg); if (!pex_get_times (pex, 1, &ptime)) melt_fatal_error ("failed to get time of MELT run %s with source argument %s & binary argument %s - %m", ourmakecommand, srcarg, binarg); if (cstatus) { int i = 0; char* cmdbuf = 0; struct obstack cmd_obstack; memset (&cmd_obstack, 0, sizeof(cmd_obstack)); obstack_init (&cmd_obstack); for (i=0; i0) obstack_1grow (&cmd_obstack, ' '); obstack_add_escaped_path (&cmd_obstack, argv[i]); } obstack_1grow(&cmd_obstack, (char)0); cmdbuf = XOBFINISH (&cmd_obstack, char *); error ("MELT failed command: %s", cmdbuf); melt_fatal_error ("MELT branch failed (%s %d) to build module using %s -f %s, source %s, binary %s, flavor %s", WIFEXITED (cstatus)?"exit" : WIFSIGNALED(cstatus)? "got signal" : WIFSTOPPED(cstatus)?"stopped" : "crashed", WIFEXITED (cstatus) ? WEXITSTATUS(cstatus) : WIFSIGNALED(cstatus) ? WTERMSIG(cstatus) : cstatus, ourmakecommand, ourmakefile, srcarg, binarg, flavorarg); } pex_free (pex); myusrtime = (double) ptime.user_seconds + 1.0e-6*ptime.user_microseconds; mysystime = (double) ptime.system_seconds + 1.0e-6*ptime.system_microseconds; debugeprintf("melt_run_make_for_branch melt did built binfile %s in %.3f usrtime + %.3f systime", binarg, myusrtime, mysystime); snprintf (cputimebuf, sizeof(cputimebuf)-1, "%.3f", myusrtime + mysystime); if (IS_ABSOLUTE_PATH(binbase)) inform (UNKNOWN_LOCATION, "MELT has built module %s in %s sec.", binbase, cputimebuf); else inform (UNKNOWN_LOCATION, "MELT has built module %s inside %s in %s sec.", binbase, mycwd, cputimebuf); debugeprintf ("melt_run_make_for_branch done srcarg %s binarg %s flavorarg %s workarg %s", srcarg, binarg, flavorarg, workarg); free (srcarg); free (binarg); free (flavorarg); free (workarg); } #endif /*MELT_IS_PLUGIN*/ static pid_t melt_probe_pid; /* process id of the probe */ static int melt_probe_reqfrom_fd = -1; /* file descriptor for requests from probe to GCC */ static int melt_probe_cmdto_fd = -1; /* file descriptor for commands to probe from GCC. */ /* return 0 if the wait was sucessful. */ int melt_wait_for_probe (int waitopt) { pid_t wpid = 0; int probstatus = 0; if (!melt_probe_pid) return 1; errno = 0; wpid = waitpid (melt_probe_pid, &probstatus, waitopt); debugeprintf ("melt_wait_for_probe pid %d wpid %d probstatus %d - %s", (int)melt_probe_pid, (int) wpid, probstatus, xstrerror(errno)); if (wpid == melt_probe_pid) { inform(UNKNOWN_LOCATION, "MELT probe (pid %d) ended", (int) melt_probe_pid); if (WIFEXITED(probstatus)) { if (WEXITSTATUS(probstatus)) warning(0, "MELT probe exited with exit code %d", WEXITSTATUS(probstatus)); } else if (WIFSIGNALED(probstatus)) { warning (0, "MELT probe terminated with signal %d = %s", WTERMSIG(probstatus), strsignal(WTERMSIG(probstatus))); } melt_probe_pid = 0; close (melt_probe_reqfrom_fd); melt_probe_reqfrom_fd = -1; close (melt_probe_cmdto_fd); melt_probe_cmdto_fd = -1; return 0; } return 1; } void melt_probe_stop (void) { pid_t pid = melt_probe_pid; int trynum = 0; if (!pid) return; debugeprintf("melt_stop_probe with melt_probe_pid %d", (int) melt_probe_pid); if (!melt_wait_for_probe (WNOHANG)) { debugeprintf("melt_stop_probe waited ok pid %d", (int) pid); return; } usleep (5000); #define MELT_PROBE_QUIT_COMMAND "\nQUIT_PCD 50\n\n" if (melt_probe_cmdto_fd > 0) { debugeprintf("melt_stop_probe sending quit command: %s", MELT_PROBE_QUIT_COMMAND); if (write (melt_probe_cmdto_fd, MELT_PROBE_QUIT_COMMAND, strlen(MELT_PROBE_QUIT_COMMAND)) < 0) warning (0, "MELT failed to write last quit command to probe - %s", xstrerror (errno)); usleep (60000); } for (trynum = 1; trynum < 3; trynum++) { if (!melt_wait_for_probe(WNOHANG)) { debugeprintf("melt_stop_probe waited ok after quit command pid %d", (int) pid); return; } usleep (10000 + trynum * 20000); } /* try 8 times to send a SIGTERM */ for (trynum = 1; trynum<=8; trynum++) { if (kill (SIGTERM, pid)) warning (0, "MELT failed to kill with SIGTERM pid %d try #%d - %s", (int) pid, trynum, xstrerror (errno)); debugeprintf("melt_stop_probe sent SIGTERM %d to pid %d try #%d", SIGTERM, (int) pid, trynum); usleep (20000 + trynum * 5000); if (!melt_wait_for_probe(WNOHANG)) { debugeprintf("melt_stop_probe waited ok after SIGTERM try #%d pid %d", trynum, (int) pid); return; } } /* try 3 times to send a SIGQUIT */ for (trynum = 1; trynum<=3; trynum++) { if (kill (SIGQUIT, pid)) warning (0, "MELT failed to kill with SIGQUIT pid %d try #%d - %s", (int) pid, trynum, xstrerror(errno)); debugeprintf("melt_stop_probe sent SIGQUIT %d to pid %d try #%d", SIGQUIT, (int) pid, trynum); usleep (20000 + trynum * 5000); if (!melt_wait_for_probe(WNOHANG)) { debugeprintf("melt_stop_probe waited ok after SIGQUIT try #%d pid %d", trynum, (int) pid); return; } } /* try 3 times a SIGKILL */ for (trynum = 1; trynum <= 3; trynum++) { if (kill (SIGKILL, pid)) warning (0, "MELT failed to kill with SIGKILL pid %d try #%d - %s", (int) pid, trynum, xstrerror(errno)); debugeprintf("melt_stop_probe sent SIGKILL %d to pid %d try #%d", SIGKILL, (int) pid, trynum); usleep (40000 + trynum * 5000); if (!melt_wait_for_probe(WNOHANG)) { debugeprintf("melt_stop_probe waited ok after SIGKILL try #%d pid %d", trynum, (int) pid); return; } } debugeprintf("melt_stop_probe wait indefinitely for pid %d", (int) pid); /* I would be surprized if the below *blocking* wait is ever reached in practice! */ if (!melt_wait_for_probe(0)) { debugeprintf("melt_stop_probe waited ok pid %d", (int) pid); return; } fatal_error ("MELT failed to stop probe process %d", (int) pid); } long melt_probe_start (const char* probecmd, int*toprobefdptr, int *fromprobefdptr) { long respid = 0; /* requests are from probe to MELT, commands are from MELT to probe */ #define MELTPROBE_COMMAND_ARG "--command-from-MELT" #define MELTPROBE_REQUEST_ARG "--request-to-MELT" enum {MELTPIPE_READ=0, MELTPIPE_WRITE=1}; /* for readability of pipe(2) pairs */ /* commands written by MELT and received by the probe. */ int cmdwrittenbymeltfd = -1, cmdreceivedbyprobefd = -1; /* requests sent by the probe and read by MELT. */ int reqsentbyprobefd = -1, reqreadbymeltfd = -1; /* strings passed as arguments of probe program. */ char **probeargv = NULL; /* calloced array; most strings are inside wexp. */ int probeargc = 0; char cmdprobestrfd[16]; char reqprobestrfd[16]; wordexp_t wexp; if (melt_probe_pid) melt_fatal_error("melt_probe_start probe already started pid %d", (int) melt_probe_pid); /** * Find the command string for the probe. **/ { debugeprintf("melt_probe_start probecmd: %s", probecmd); /* if no probecmd given, try to guess one... */ if (!probecmd || !probecmd[0]) { /* guess from program or plugin argument */ probecmd = melt_argument ("probe"); debugeprintf("melt_probe_start command from argument: %s", probecmd); } if (!probecmd || !probecmd[0]) { /* guess from environment variable */ probecmd = getenv ("GCCMELT_PROBE"); debugeprintf("melt_probe_start command from GCCMELT_PROBE: %s", probecmd); } if (!probecmd || !probecmd[0]) { probecmd = melt_default_probe; debugeprintf("melt_probe_start command from melt_default_probe: %s", probecmd); } if (!probecmd || !probecmd[0]) melt_fatal_error ("melt_probe_start without command %s", probecmd); } /** * Create the command and request pipes. Fill the probe arguments. **/ { int pipecmd[2] = { -1, -1 }; int pipereq[2] = { -1, -1 }; if (pipe(pipecmd) < 0 || pipe(pipereq) < 0) melt_fatal_error("melt_probe_start failed to create request and command pipes - %s", xstrerror (errno)); cmdwrittenbymeltfd = pipecmd[MELTPIPE_WRITE]; cmdreceivedbyprobefd = pipecmd[MELTPIPE_READ]; snprintf (cmdprobestrfd, sizeof (cmdprobestrfd), "%d", cmdreceivedbyprobefd); debugeprintf("melt_probe_start cmdwrittenbymeltfd=%d cmdreceivedbyprobefd=%d cmdprobestrfd=%s", cmdwrittenbymeltfd, cmdreceivedbyprobefd, cmdprobestrfd); reqreadbymeltfd = pipereq[MELTPIPE_READ]; reqsentbyprobefd = pipereq[MELTPIPE_WRITE]; snprintf (reqprobestrfd, sizeof (reqprobestrfd), "%d", reqsentbyprobefd); debugeprintf("melt_probe_start reqreadbymeltfd=%d reqsentbyprobefd=%d reqprobestrfd=%s", reqreadbymeltfd, reqsentbyprobefd, reqprobestrfd); } /** * Expand the probecmd using wordexp. Allocate and fill probeargv, probeargc. **/ { int werr = 0; int wix = 0; memset (&wexp, 0, sizeof(wexp)); if (getenv("IFS") != NULL) melt_fatal_error("melt_probe_start cannot start with IFS=%s because of security risks", getenv("IFS")); werr = wordexp (probecmd, &wexp, WRDE_SHOWERR|WRDE_UNDEF); if (werr) melt_fatal_error ("melt_probe_start failed to expand probe command %s - %d [%s]", probecmd, werr, (werr == WRDE_BADCHAR)?"bad char": (werr == WRDE_BADVAL)?"bad value": (werr == WRDE_CMDSUB)?"command subst": (werr == WRDE_NOSPACE)?"no memory space": (werr == WRDE_SYNTAX)?"syntax error": "??"); debugeprintf("melt_probe_start wexp.we_wordc=%d", (int) wexp.we_wordc); probeargc = wexp.we_wordc + 4; probeargv = (char**) xcalloc (probeargc+1, sizeof(char*)); for (wix = 0; wix < (int) wexp.we_wordc; wix++) { probeargv[wix] = wexp.we_wordv[wix]; debugeprintf("melt_probe_start probeargv[%d]=%s", wix, probeargv[wix]); } probeargv[wix] = CONST_CAST(char*, MELTPROBE_COMMAND_ARG), probeargv[wix+1] = cmdprobestrfd; debugeprintf("melt_probe_start command probeargv[%d,%d]= %s %s", wix, wix+1, probeargv[wix], probeargv[wix+1]); wix += 2; probeargv[wix] = CONST_CAST(char*, MELTPROBE_REQUEST_ARG), probeargv[wix+1] = reqprobestrfd; debugeprintf("melt_probe_start request probeargv[%d,%d]= %s %s", wix, wix+1, probeargv[wix], probeargv[wix+1]); wix += 2; } /** * fork the probe and close the irrelevant pipes sides. **/ { pid_t pid = -1; fflush (NULL); pid = fork(); if (pid < 0) melt_fatal_error ("melt_probe_start failed to fork; %m for command %s", probecmd); else if (pid == 0) { /* Child process, exec the probe after closing some useless fds */ int cfd; for (cfd = 3; cfd < 64; cfd++) { if (cfd == cmdreceivedbyprobefd || cfd == reqsentbyprobefd) continue; (void) close (cfd); } if (execvp (probeargv[0], probeargv)) { static char errmsg[100]; snprintf (errmsg, sizeof(errmsg), "execvp %s", probeargv[0]); perror(errmsg); _exit(127); }; } else { /* Parent process. */ close (cmdreceivedbyprobefd); close (reqsentbyprobefd); usleep (30000); /* give the probe a chance to start... */ }; melt_probe_pid = pid; respid = (long) pid; melt_probe_cmdto_fd = cmdwrittenbymeltfd; melt_probe_reqfrom_fd = reqreadbymeltfd; inform (UNKNOWN_LOCATION, "MELT probe started: pid %d, command fd to probe %d, request fd from probe %d", (int) melt_probe_pid, melt_probe_cmdto_fd, melt_probe_reqfrom_fd); } /** * Set at exit handler and release resources. **/ { atexit (melt_probe_stop); free (probeargv), probeargv = NULL; probeargc = 0; wordfree (&wexp); } /* check that the probe process is still running... */ usleep (10000); errno = 0; if (!melt_wait_for_probe (WNOHANG)) melt_fatal_error ("MELT probe exited as soon as started %s", probecmd); /* all seems ok... */ debugeprintf("melt_start_probe ended melt_probe_pid=%d melt_probe_cmdto_fd=%d melt_probe_reqfrom_fd=%d", melt_probe_pid, melt_probe_cmdto_fd, melt_probe_reqfrom_fd); if (toprobefdptr) *toprobefdptr = melt_probe_cmdto_fd; if (fromprobefdptr) *fromprobefdptr = melt_probe_reqfrom_fd; return respid; } void melt_send_command_strbuf_to_probe (melt_ptr_t buf) { long buflen = 0; long bufpos = 0; char *bufstr = NULL; if (melt_magic_discr (buf) != MELTOBMAG_STRBUF) return; if (!melt_probe_pid || melt_probe_cmdto_fd < 0) return; buflen = melt_output_length (buf); bufstr = CONST_CAST (char*, melt_strbuf_str (buf)); debugeprintf ("melt_send_command_strbuf_to_probe buflen %ld, bufstr:\n\t%s", buflen, bufstr); if (buflen<3 || !bufstr) return; gcc_assert (bufstr[buflen-2] == '\n'); gcc_assert (bufstr[buflen-1] == '\n'); bufpos = 0; /* Test that the probe process is still existing. */ errno = 0; if (kill (melt_probe_pid, 0)) melt_fatal_error ("MELT probe pid %d process not existing anymore [%s]", (int) melt_probe_pid, xstrerror(errno)); for (;;) { long wlen, wcnt; wlen = buflen - bufpos; if (wlen <= 0) break; errno = 0; wcnt = write (melt_probe_cmdto_fd, bufstr+bufpos, wlen); if (wcnt < 0 && errno == EINTR) continue; if (wcnt < 0) { warning (0, "MELT failed to send command %s to probe on fd#%d - %s", bufstr, melt_probe_cmdto_fd, xstrerror (errno)); break; } bufpos += wcnt; } debugeprintf ("melt_send_command_strbuf_to_probe final bufpos %ld, buflen %ld", bufpos, buflen); } /* the srcbase is a generated primary .c file without its .c suffix, such as /some/path/foo which also means the MELT descriptor file /some/path/foo+meltdesc.c and the MELT timestamp file /some/path/foo+melttime.h and possibly secondary files like /some/path/foo+01.c /some/path/foo+02.c in addition of the primary file /some/path/foo.c ; the binbase should have no MELT_DYNLOADED_SUFFIX. The module build is done thru the melt-module.mk file [with the 'make' utility]. */ void melt_compile_source (const char *srcbase, const char *binbase, const char*workdir, const char*flavor) { /* The generated dynamic library should have the following constant strings: const char melt_compiled_timestamp[]; const char melt_md5[]; The melt_compiled_timestamp should contain a human readable timestamp the melt_md5 should contain the hexadecimal md5 digest, followed by the source file name (i.e. the single line output by the command: md5sum $Csourcefile; where $Csourcefile is replaced by the source file path) */ char* srcdescrpath = NULL; const char* ourmakecommand = NULL; const char* ourmakefile = NULL; const char* ourcflags = NULL; const char* mycwd = NULL; #if MELT_HAVE_DEBUG char curlocbuf[250]; #endif /* we want a MELT frame for MELT_LOCATION here */ MELT_ENTEREMPTYFRAME(NULL); mycwd = getpwd (); if (!flavor) flavor = MELT_DEFAULT_FLAVOR; debugeprintf ("melt_compile_source start srcbase %s binbase %s flavor %s", srcbase, binbase, flavor); debugeprintf ("melt_compile_source start workdir %s", workdir); debugeprintf ("melt_compile_source start mycwd %s", mycwd); MELT_LOCATION_HERE_PRINTF (curlocbuf, "melt_compile_source srcbase %s binbase %s flavor %s", srcbase?(srcbase[0]?srcbase:"*empty*"):"*null*", binbase?(binbase[0]?binbase:"*empty*"):"*null*", flavor?(flavor[0]?flavor:"*empty*"):"*null*"); if (getenv ("IFS")) /* Having an IFS is a huge security risk for shells. */ melt_fatal_error ("MELT cannot compile source base %s of flavor %s with an $IFS (probable security risk)", srcbase, flavor); if (!srcbase || !srcbase[0]) { melt_fatal_error ("no source base given to compile for MELT (%p)", srcbase); } if (!binbase || !binbase[0]) { melt_fatal_error ("no binary base given to compile %s for MELT", srcbase); } if (!workdir || !workdir[0]) { workdir = melt_argument("workdir"); if (!workdir) workdir = melt_tempdir_path (NULL, NULL); } srcdescrpath = concat (srcbase, MELT_DESC_FILESUFFIX, NULL); if (access (srcdescrpath, R_OK)) melt_fatal_error ("Cannot access MELT descriptive file %s to compile - %m", srcdescrpath); { char*timefpath = concat (srcbase, MELT_TIME_FILESUFFIX, NULL); if (access (timefpath, R_OK)) warning(0, "MELT timestamp file %s missing", timefpath); free (timefpath); } if (strchr(melt_basename (binbase), '.')) melt_fatal_error ("MELT binary base %s to compile %s should not have dots", binbase, srcbase); if (strcmp(flavor, "quicklybuilt") && strcmp(flavor, "optimized") && strcmp(flavor, "debugnoline") && strcmp(flavor, "runextend")) melt_fatal_error ("invalid flavor %s to compile %s - expecting {quicklybuilt,optimized,debugnoline,runextend}", flavor, srcbase); ourmakecommand = melt_argument ("module-make-command"); if (!ourmakecommand || !ourmakecommand[0]) ourmakecommand = melt_module_make_command; debugeprintf ("melt_compile_source ourmakecommand='%s'", ourmakecommand); gcc_assert (ourmakecommand[0]); ourmakefile = melt_argument ("module-makefile"); if (!ourmakefile || !ourmakefile[0]) ourmakefile = melt_module_makefile; debugeprintf ("melt_compile_source ourmakefile: %s", ourmakefile); gcc_assert (ourmakefile[0]); ourcflags = melt_argument ("module-cflags"); if (!ourcflags || !ourcflags[0]) ourcflags = melt_flag_bootstrapping?NULL :(getenv ("GCCMELT_MODULE_CFLAGS")); if (!ourcflags || !ourcflags[0]) ourcflags = melt_module_cflags; debugeprintf ("melt_compile_source ourcflags: %s", ourcflags); debugeprintf ("melt_compile_source binbase='%s' srcbase='%s' flavor='%s'", binbase, srcbase, flavor); gcc_assert (binbase != NULL && binbase[0] != (char)0); gcc_assert (srcbase != NULL && srcbase[0] != (char)0); gcc_assert (flavor != NULL && flavor[0] != (char)0); /* We use printf, not inform, because we are not sure that diagnostic buffers are flushed. */ printf ("\nMELT is building binary %s from source %s with flavor %s\n", binbase, srcbase, flavor); fflush (stdout); fflush (stderr); #ifdef MELT_IS_PLUGIN melt_run_make_for_plugin (ourmakecommand, ourmakefile, ourcflags, flavor, srcbase, binbase, workdir); #else /* not MELT_IS_PLUGIN */ melt_run_make_for_branch (ourmakecommand, ourmakefile, ourcflags, flavor, srcbase, binbase, workdir); #endif /*MELT_IS_PLUGIN*/ goto end; end: debugeprintf ("melt_compile_source end srcbase %s binbase %s flavor %s", srcbase, binbase, flavor); MELT_EXITFRAME (); } /* compute the hexadecimal encoded md5sum string of a file into a given md5 hexbuf*/ static void melt_string_hex_md5sum_file_to_hexbuf (const char* path, char md5hex[32]) { int ix = 0; char md5srctab[16]; FILE *fil = NULL; memset (md5srctab, 0, sizeof (md5srctab)); memset (md5hex, 0, sizeof(md5hex)); if (!path || !path[0]) return; fil = fopen(path, "r"); if (!fil) return; if (md5_stream (fil, &md5srctab)) melt_fatal_error ("failed to compute md5sum of file %s - %m", path); fclose (fil); fil = NULL; memset (md5hex, 0, sizeof(md5hex)); for (ix=0; ix<16; ix++) { char hexb[4] = {0,0,0,0}; int curbyt = md5srctab[ix] & 0xff; snprintf (hexb, sizeof(hexb)-1, "%02x", curbyt); md5hex[2*ix] = hexb[0]; md5hex[2*ix+1] = hexb[1]; } } melt_ptr_t meltgc_string_hex_md5sum_file (const char* path) { char hexbuf[48]; /* a bit longer than needed, to ensure null termination */ MELT_ENTERFRAME(1, NULL); #define resv meltfram__.mcfr_varptr[0] if (!path || !path[0]) goto end; MELT_LOCATION_HERE("meltgc_string_hex_md5sum_file"); memset (hexbuf, 0, sizeof(hexbuf)); melt_string_hex_md5sum_file_to_hexbuf (path, hexbuf); if (!hexbuf[0]) goto end; resv = meltgc_new_string ((meltobject_ptr_t) MELT_PREDEF(DISCR_STRING), hexbuf); end: MELT_EXITFRAME(); return (melt_ptr_t)resv; #undef resv } /* compute the hexadecimal encoded md5sum string of a tuple of file paths, or NULL on failure. When we finish to proceed a file, we immediatly add the beginning of the following file to bufblock to keep a size of a multiple of 64. This permit to call md5_process_block. We only call md5_process_bytes for the last data. */ melt_ptr_t meltgc_string_hex_md5sum_file_sequence (melt_ptr_t pathtup_p) { int ix = 0; char md5srctab[16]; char md5hex[50]; char bufblock[1024]; /* size should be multiple of 64 for md5_process_block */ FILE *fil = NULL; int nbtup = 0; int cnt = 0; int new_file_cnt = 0; struct md5_ctx ctx; MELT_ENTERFRAME(3, NULL); #define resv meltfram__.mcfr_varptr[0] #define pathtupv meltfram__.mcfr_varptr[1] #define pathv meltfram__.mcfr_varptr[2] pathtupv = pathtup_p; memset (&ctx, 0, sizeof(ctx)); memset (md5srctab, 0, sizeof (md5srctab)); memset (md5hex, 0, sizeof (md5hex)); if (melt_magic_discr ((melt_ptr_t)pathtupv) != MELTOBMAG_MULTIPLE) goto end; md5_init_ctx (&ctx); nbtup = melt_multiple_length ((melt_ptr_t)pathtupv); /* this loop does not garbage collect! */ memset (bufblock, 0, sizeof (bufblock)); for (ix=0; ix < nbtup; ix++) { const char *curpath = NULL; pathv = melt_multiple_nth ((melt_ptr_t)pathtupv, ix); if (melt_magic_discr ((melt_ptr_t)pathv) != MELTOBMAG_STRING) goto end; curpath = melt_string_str ((melt_ptr_t) pathv); if (!curpath || !curpath[0]) goto end; fil = fopen(curpath, "r"); if (!fil) goto end; while (!feof (fil)) { if (cnt != 0) /*means that we havent process bufblock from previous file.*/ { new_file_cnt =fread (bufblock+cnt, sizeof(char),sizeof(bufblock)-cnt, fil); cnt = cnt + new_file_cnt; } else { cnt = fread (bufblock, sizeof(char), sizeof(bufblock), fil); } if (cnt ==sizeof(bufblock)) { /* an entire block has been read. */ md5_process_block (bufblock, sizeof(bufblock), &ctx); memset (bufblock, '\0', sizeof (bufblock)); cnt = 0; } } fclose (fil); fil = NULL; curpath = NULL; } if (cnt !=0) { /*We still have some data in the buffer*/ md5_process_bytes (bufblock, (size_t) cnt, &ctx); } md5_finish_ctx (&ctx, md5srctab); memset (md5hex, 0, sizeof(md5hex)); for (ix=0; ix<16; ix++) { char hexb[4] = {0,0,0,0}; int curbyt = md5srctab[ix] & 0xff; snprintf (hexb, sizeof(hexb)-1, "%02x", curbyt); md5hex[2*ix] = hexb[0]; md5hex[2*ix+1] = hexb[1]; } resv = meltgc_new_string ((meltobject_ptr_t) MELT_PREDEF(DISCR_STRING), md5hex); end: MELT_EXITFRAME(); return (melt_ptr_t)resv; #undef resv #undef pathtupv #undef pathv } /* following code and comment is taken from the gcc/plugin.c file of the plugins branch */ /* We need a union to cast dlsym return value to a function pointer as ISO C forbids assignment between function pointer and 'void *'. Use explicit union instead of __extension__() for portability. */ #define PTR_UNION_TYPE(TOTYPE) union { void *_q; TOTYPE _nq; } #define PTR_UNION_AS_VOID_PTR(NAME) (NAME._q) #define PTR_UNION_AS_CAST_PTR(NAME) (NAME._nq) void * melt_dlsym_all (const char *nam) { int ix = 0; melt_module_info_t *mi = 0; /* Index 0 is unused in melt_modinfvec! */ for (ix = 1; VEC_iterate (melt_module_info_t, melt_modinfvec, ix, mi); ix++) { void *p = NULL; gcc_assert (mi->mmi_magic == MELT_MODULE_MAGIC); p = (void *) dlsym ((void *) mi->mmi_dlh, nam); if (p) return p; }; /* Index 0 is unused in melt_extinfvec! */ if (melt_extinfvec) { melt_extension_info_t *mx = 0; for (ix = 1; VEC_iterate (melt_extension_info_t, melt_extinfvec, ix, mx); ix++) { void *p = NULL; gcc_assert (mx->mmx_magic == MELT_MODULE_MAGIC); p = (void *) dlsym ((void *) mx->mmx_dlh, nam); if (p) return p; }; }; return (void *) dlsym (proghandle, nam); } /* Find a file path using either directories or colon-seperated paths, return a malloc-ed string or null. */ static char*melt_find_file_at (int line, const char*path, ...) ATTRIBUTE_SENTINEL; #define MELT_FIND_FILE(PATH,...) melt_find_file_at (__LINE__,(PATH),__VA_ARGS__,NULL) /* Option to find a file in a directory. */ #define MELT_FILE_IN_DIRECTORY "directory" /* Option to find a file in a colon-separated path. */ #define MELT_FILE_IN_PATH "path" /* Option to find a file in a colon-seperated path given by an environment variable. */ #define MELT_FILE_IN_ENVIRON_PATH "envpath" /* Option to log to some tracing file the findings of a file, should be first option to MELT_FIND_FILE. */ #define MELT_FILE_LOG "log" /* Called thru the MELT_FIND_FILE macro, returns a malloced string. */ static char* melt_find_file_at (int lin, const char*path, ...) { char* mode = NULL; FILE *logf = NULL; va_list args; if (!path) return NULL; va_start (args, path); while ((mode=va_arg (args, char*)) != NULL) { if (!strcmp(mode, MELT_FILE_IN_DIRECTORY)) { char* fipath = NULL; char* indir = va_arg (args, char*); if (!indir || !indir[0]) continue; fipath = concat (indir, "/", path, NULL); if (!access(fipath, R_OK)) { if (logf) { fprintf (logf, "found %s in directory %s\n", fipath, indir); fflush (logf); } debugeprintf ("found file %s in directory %s [%s:%d]", fipath, indir, melt_basename(__FILE__), lin); return fipath; } else if (logf && indir && indir[0]) fprintf (logf, "not found in directory %s\n", indir); free (fipath); } else if (!strcmp(mode, MELT_FILE_IN_PATH)) { char* inpath = va_arg(args, char*); char* dupinpath = NULL; char* pc = NULL; char* nextpc = NULL; char* col = NULL; char* fipath = NULL; if (!inpath || !inpath[0]) continue; dupinpath = xstrdup (inpath); pc = dupinpath; for (pc = dupinpath; pc && *pc; pc = nextpc) { nextpc = NULL; col = strchr(pc, ':'); if (col) { *col = (char)0; nextpc = col+1; } else col = pc + strlen(pc); fipath = concat (pc, "/", path, NULL); if (!access (fipath, R_OK)) { if (logf) { fprintf (logf, "found %s in colon path %s\n", fipath, inpath); fflush (logf); } debugeprintf ("found file %s in colon path %s [%s:%d]", fipath, inpath, melt_basename(__FILE__), lin); free (dupinpath), dupinpath = NULL; return fipath; } }; if (logf) fprintf (logf, "not found in colon path %s\n", inpath); free (dupinpath), dupinpath = NULL; } else if (!strcmp(mode, MELT_FILE_IN_ENVIRON_PATH)) { char* inenv = va_arg(args, char*); char* dupinpath = NULL; char* inpath = NULL; char* pc = NULL; char* nextpc = NULL; char* col = NULL; char* fipath = NULL; if (!inenv || !inenv[0]) continue; inpath = getenv (inenv); if (!inpath || !inpath[0]) { if (logf) fprintf (logf, "not found in path from unset environment variable %s\n", inenv); continue; }; dupinpath = xstrdup (inpath); pc = dupinpath; for (pc = dupinpath; pc && *pc; pc = nextpc) { nextpc = NULL; col = strchr(pc, ':'); if (col) { *col = (char)0; nextpc = col+1; } else col = pc + strlen(pc); fipath = concat (pc, "/", path, NULL); if (!access (fipath, R_OK)) { if (logf) { fprintf (logf, "found %s from environ %s in colon path %s\n", fipath, inenv, inpath); fflush (logf); } debugeprintf ("found file %s from environ %s in colon path %s [%s:%d]", fipath, inenv, inpath, melt_basename(__FILE__), lin); free (dupinpath), dupinpath = NULL; return fipath; } }; if (logf) fprintf (logf, "not found from environ %s in colon path %s\n", inenv, inpath); free (dupinpath), dupinpath = NULL; } else if (!strcmp(mode, MELT_FILE_LOG)) { logf = va_arg (args, FILE*); if (logf) fprintf (logf, "finding file %s [from %s:%d]\n", path, melt_basename(__FILE__), lin); continue; } else fatal_error ("MELT_FIND_FILE %s: bad mode %s [%s:%d]", path, mode, melt_basename(__FILE__), lin); } va_end (args); if (logf) { fprintf (logf, "not found file %s [from %s:%d]\n", path, melt_basename(__FILE__), lin); fflush (logf); } debugeprintf ("not found file %s [%s:%d]", path, melt_basename(__FILE__), lin); return NULL; } /*************** initial load machinery *******************/ #define MELT_READING_MAGIC 0xdeb73d1 /* 233534417 */ struct melt_reading_st { unsigned readmagic; /* always MELT_READING_MAGIC */ FILE *rfil; const char *rpath; char *rcurlin; /* current line mallocated buffer */ int rlineno; /* current line number */ int rcol; /* current column */ source_location rsrcloc; /* current source location */ melt_ptr_t *rpfilnam; /* pointer to location of file name string */ bool rhas_file_location; /* true iff the string comes from a file */ jmp_buf readjmpbuf; /* for setjmp on read errors */ }; #define MELT_READ_TABULATION_FACTOR 8 /* Obstack used for reading strings */ static struct obstack melt_bstring_obstack; #define rdback() (rd->rcol--) #define rdnext() (rd->rcol++) #define rdcurc() rd->rcurlin[rd->rcol] #define rdfollowc(Rk) rd->rcurlin[rd->rcol + (Rk)] #define rdeof() ((rd->rfil?feof(rd->rfil):1) && rd->rcurlin[rd->rcol]==0) static void melt_linemap_compute_current_location (struct melt_reading_st *rd); static void melt_read_got_error_at (struct melt_reading_st*rd, const char* file, int line) ATTRIBUTE_NORETURN; #define MELT_READ_ERROR(Fmt,...) do { \ melt_linemap_compute_current_location (rd); \ error_at(rd->rsrcloc, Fmt, ##__VA_ARGS__); \ melt_read_got_error_at(rd, melt_basename(__FILE__), __LINE__); } while(0) #define MELT_READ_WARNING(Fmt,...) do { \ melt_linemap_compute_current_location (rd); \ warning_at (rd->rsrcloc, 0, "MELT read warning: " Fmt, \ ##__VA_ARGS__); \ } while(0) /* meltgc_readval returns the read value and sets *PGOT to true if something was read */ static melt_ptr_t meltgc_readval (struct melt_reading_st *rd, bool * pgot); static void melt_linemap_compute_current_location (struct melt_reading_st* rd) { int colnum = 1; int cix = 0; if (!rd || !rd->rcurlin || !rd->rhas_file_location) return; gcc_assert (rd->readmagic == MELT_READING_MAGIC); for (cix=0; cixrcol; cix++) { char c = rd->rcurlin[cix]; if (!c) break; else if (c == '\t') { while (colnum % MELT_READ_TABULATION_FACTOR != 0) colnum++; } else colnum++; } #if MELT_GCC_VERSION <= 4006 /* GCC 4.6 */ LINEMAP_POSITION_FOR_COLUMN(rd->rsrcloc, line_table, colnum); #else /* GCC 4.7 or newer */ rd->rsrcloc = linemap_position_for_column (line_table, colnum); #endif /*MELT_GCC_VERSION*/ } static void melt_read_got_error_at (struct melt_reading_st*rd, const char* file, int line) { gcc_assert (rd && rd->readmagic == MELT_READING_MAGIC); error ("MELT read error from %s:%d [MELT built %s, version %s]", file, line, melt_runtime_build_date, melt_version_str ()); if (rd->rpath && rd->rlineno && rd->rcol) error ("MELT read error while reading %s line %d column %d", rd->rpath, rd->rlineno, rd->rcol); fflush(NULL); #if MELT_HAVE_DEBUG melt_dbgshortbacktrace ("MELT read error", 100); #endif longjmp (rd->readjmpbuf, 1); } static melt_ptr_t meltgc_readstring (struct melt_reading_st *rd); static melt_ptr_t meltgc_readmacrostringsequence (struct melt_reading_st *rd); enum commenthandling_en { COMMENT_SKIP, COMMENT_NO }; static int melt_skipspace_getc (struct melt_reading_st *rd, enum commenthandling_en comh) { int c = 0; int incomm = 0; gcc_assert (rd && rd->readmagic == MELT_READING_MAGIC); readagain: if (rdeof ()) return EOF; if (!rd->rcurlin) goto readline; c = rdcurc (); if ((c == '\n' && !rdfollowc (1)) || c == 0) readline: { /* we expect most lines to fit into linbuf, so we don't handle efficiently long lines */ static char linbuf[400]; char *mlin = 0; /* partial mallocated line buffer when not fitting into linbuf */ char *eol = 0; if (!rd->rfil) { /* reading from a buffer: */ if (c) rdnext (); /* Skip terminating newline. */ return EOF; } if (rd->rcurlin) free ((void *) rd->rcurlin); rd->rcurlin = NULL; /* we really want getline here .... */ for (;;) { memset (linbuf, 0, sizeof (linbuf)); eol = NULL; if (!fgets (linbuf, sizeof (linbuf) - 2, rd->rfil)) { /* reached eof, so either give mlin or duplicate an empty line */ if (mlin) rd->rcurlin = mlin; else rd->rcurlin = xstrdup (""); break; } else eol = strchr (linbuf, '\n'); if (eol) { if (rd->rcurlin) free ((void *) rd->rcurlin); if (!mlin) rd->rcurlin = xstrdup (linbuf); else { rd->rcurlin = concat (mlin, linbuf, NULL); free (mlin); } break; } else { /* read partly a long line without reaching the end of line */ if (mlin) { char *newmlin = concat (mlin, linbuf, NULL); free (mlin); mlin = newmlin; } else mlin = xstrdup (linbuf); } }; rd->rlineno++; rd->rsrcloc = linemap_line_start (line_table, rd->rlineno, strlen (linbuf) + 1); rd->rcol = 0; if (comh == COMMENT_NO) return rdcurc(); goto readagain; } /** The comment ;;## [] is handled like #line, inspired by _cpp_do_file_change in libcpp/directives.c */ else if (c == ';' && rdfollowc (1) == ';' && rdfollowc (2) == '#' && rdfollowc (3) == '#' && comh == COMMENT_SKIP) { char *endp = 0; char *newpath = 0; char* newpathdup = 0; long newlineno = strtol (&rdfollowc (4), &endp, 10); /* take as filename from the first non-space to the last non-space */ while (endp && *endp && ISSPACE(*endp)) endp++; if (endp && *endp) newpath=endp; if (endp && newpath) endp += strlen(endp) - 1; while (newpath && ISSPACE(*endp)) endp--; debugeprintf (";;## directive for line newlineno=%ld newpath=%s", newlineno, newpath); if (newlineno>0 && newpath) { int ix= 0; char *curpath=0; /* find the newpath in the parsedmeltfilevect or push it there */ for (ix = 0; VEC_iterate (meltchar_p, parsedmeltfilevect, ix, curpath); ix++) { if (curpath && !strcmp(newpath, curpath)) newpathdup = curpath; } if (!newpathdup) { newpathdup = xstrdup (newpath); VEC_safe_push (meltchar_p, heap, parsedmeltfilevect, newpathdup); } (void) linemap_add (line_table, LC_RENAME_VERBATIM, false, newpathdup, newlineno); } else if (newlineno>0) { } goto readline; } else if (c == ';' && comh == COMMENT_SKIP) goto readline; else if (c == '#' && comh == COMMENT_SKIP && rdfollowc (1) == '|') { incomm = 1; rdnext (); c = rdcurc (); goto readagain; } else if (incomm && comh == COMMENT_SKIP && c == '|' && rdfollowc (1) == '#') { incomm = 0; rdnext (); rdnext (); c = rdcurc (); goto readagain; } else if (ISSPACE (c) || incomm) { rdnext (); c = rdcurc (); goto readagain; } else return c; } #define EXTRANAMECHARS "_+-*/<>=!?:%~&@$|" /* read a simple name on the melt_bname_obstack */ static char * melt_readsimplename (struct melt_reading_st *rd) { int c = 0; gcc_assert (rd && rd->readmagic == MELT_READING_MAGIC); while (!rdeof () && (c = rdcurc ()) > 0 && (ISALNUM (c) || strchr (EXTRANAMECHARS, c) != NULL)) { obstack_1grow (&melt_bname_obstack, (char) c); rdnext (); } obstack_1grow (&melt_bname_obstack, (char) 0); return XOBFINISH (&melt_bname_obstack, char *); } /* read an integer, like +123, which may also be +%numbername */ static long melt_readsimplelong (struct melt_reading_st *rd) { int c = 0; long r = 0; char *endp = 0; char *nam = 0; bool neg = FALSE; gcc_assert (rd && rd->readmagic == MELT_READING_MAGIC); /* we do not need any GC locals ie MELT_ENTERFRAME because no garbage collection occurs here */ c = rdcurc (); if (((c == '+' || c == '-') && ISDIGIT (rdfollowc (1))) || ISDIGIT (c)) { /* R5RS and R6RS require decimal notation -since the binary and hex numbers are hash-prefixed but for convenience we accept them thru strtol */ r = strtol (&rdcurc (), &endp, 0); if (r == 0 && endp <= &rdcurc ()) MELT_READ_ERROR ("MELT: failed to read number %.20s", &rdcurc ()); rd->rcol += endp - &rdcurc (); return r; } else if ((c == '+' || c == '-') && rdfollowc (1) == '%') { neg = (c == '-'); rdnext (); rdnext (); nam = melt_readsimplename (rd); r = -1; /* the +%magicname notation is seldom used, we don't care to do many needless strcmp-s in that case, to be able to define the below simple macro */ if (!nam) MELT_READ_ERROR ("MELT: magic number name expected after +%% or -%% for magic %s", nam); #define NUMNAM(N) else if (!strcmp(nam,#N)) r = (N) NUMNAM (MELTOBMAG_OBJECT); NUMNAM (MELTOBMAG_MULTIPLE); NUMNAM (MELTOBMAG_CLOSURE); NUMNAM (MELTOBMAG_ROUTINE); NUMNAM (MELTOBMAG_LIST); NUMNAM (MELTOBMAG_PAIR); NUMNAM (MELTOBMAG_INT); NUMNAM (MELTOBMAG_MIXINT); NUMNAM (MELTOBMAG_MIXLOC); NUMNAM (MELTOBMAG_REAL); NUMNAM (MELTOBMAG_STRING); NUMNAM (MELTOBMAG_STRBUF); NUMNAM (MELTOBMAG_TREE); NUMNAM (MELTOBMAG_GIMPLE); NUMNAM (MELTOBMAG_GIMPLESEQ); NUMNAM (MELTOBMAG_BASICBLOCK); NUMNAM (MELTOBMAG_EDGE); NUMNAM (MELTOBMAG_MAPOBJECTS); NUMNAM (MELTOBMAG_MAPSTRINGS); NUMNAM (MELTOBMAG_MAPTREES); NUMNAM (MELTOBMAG_MAPGIMPLES); NUMNAM (MELTOBMAG_MAPGIMPLESEQS); NUMNAM (MELTOBMAG_MAPBASICBLOCKS); NUMNAM (MELTOBMAG_MAPEDGES); NUMNAM (MELTOBMAG_DECAY); NUMNAM (MELTOBMAG_SPECIAL_DATA); /** the fields' ranks of melt.h have been removed in rev126278 */ #undef NUMNAM if (r < 0) MELT_READ_ERROR ("MELT: bad magic number name %s", nam); obstack_free (&melt_bname_obstack, nam); return neg ? -r : r; } else MELT_READ_ERROR ("MELT: invalid number %.20s", &rdcurc ()); return 0; } static melt_ptr_t meltgc_readseqlist (struct melt_reading_st *rd, int endc) { int c = 0; int nbcomp = 0; int startlin = rd->rlineno; bool got = FALSE; MELT_ENTERFRAME (4, NULL); #define seqv meltfram__.mcfr_varptr[0] #define compv meltfram__.mcfr_varptr[1] #define listv meltfram__.mcfr_varptr[2] #define pairv meltfram__.mcfr_varptr[3] gcc_assert (rd && rd->readmagic == MELT_READING_MAGIC); seqv = meltgc_new_list ((meltobject_ptr_t) MELT_PREDEF (DISCR_LIST)); readagain: compv = NULL; c = melt_skipspace_getc (rd, COMMENT_SKIP); if (c == endc) { rdnext (); goto end; } else if (c == '}' && rdfollowc(1) == '#') { MELT_READ_ERROR ("MELT: unexpected }# in s-expr sequence %.30s ... started line %d", &rdcurc (), startlin); } /* The lexing ##{ ... }# is to insert a macrostring inside the current sequence. */ else if (c == '#' && rdfollowc(1) == '#' && rdfollowc(2) == '{') { rdnext (); rdnext (); rdnext (); got = FALSE; compv = meltgc_readmacrostringsequence (rd); if (melt_is_instance_of ((melt_ptr_t) compv, MELT_PREDEF (CLASS_SEXPR))) { got = TRUE; listv = melt_field_object ((melt_ptr_t)compv, MELTFIELD_SEXP_CONTENTS); if (melt_magic_discr ((melt_ptr_t)listv) == MELTOBMAG_LIST) { compv = NULL; for (pairv = ((struct meltlist_st*)(listv))->first; pairv && melt_magic_discr((melt_ptr_t)pairv) == MELTOBMAG_PAIR; pairv = ((struct meltpair_st*)(pairv))->tl) { compv = ((struct meltpair_st*)(pairv))->hd; if (compv) { meltgc_append_list ((melt_ptr_t) seqv, (melt_ptr_t) compv); nbcomp++; } } } } if (!got) MELT_READ_ERROR ("MELT: unexpected stuff in macrostring seq %.20s ... started line %d", &rdcurc (), startlin); goto readagain; } got = FALSE; compv = meltgc_readval (rd, &got); if (!compv && !got) MELT_READ_ERROR ("MELT: unexpected stuff in seq %.20s ... started line %d", &rdcurc (), startlin); meltgc_append_list ((melt_ptr_t) seqv, (melt_ptr_t) compv); nbcomp++; goto readagain; end: MELT_EXITFRAME (); return (melt_ptr_t) seqv; #undef compv #undef seqv #undef listv #undef pairv } enum melt_macrostring_en { MELT_MACSTR_PLAIN=0, MELT_MACSTR_MACRO }; static melt_ptr_t meltgc_makesexpr (struct melt_reading_st *rd, int lineno, melt_ptr_t contents_p, location_t loc, enum melt_macrostring_en ismacrostring) { MELT_ENTERFRAME (4, NULL); #define sexprv meltfram__.mcfr_varptr[0] #define contsv meltfram__.mcfr_varptr[1] #define locmixv meltfram__.mcfr_varptr[2] #define sexpclassv meltfram__.mcfr_varptr[3] gcc_assert (rd && rd->readmagic == MELT_READING_MAGIC); contsv = contents_p; gcc_assert (melt_magic_discr ((melt_ptr_t) contsv) == MELTOBMAG_LIST); if (loc == 0) locmixv = meltgc_new_mixint ((meltobject_ptr_t) MELT_PREDEF (DISCR_MIXED_INTEGER), *rd->rpfilnam, (long) lineno); else locmixv = meltgc_new_mixloc ((meltobject_ptr_t) MELT_PREDEF (DISCR_MIXED_LOCATION), *rd->rpfilnam, (long) lineno, loc); if (ismacrostring == MELT_MACSTR_MACRO && (MELT_PREDEF (CLASS_SEXPR_MACROSTRING))) sexpclassv = MELT_PREDEF (CLASS_SEXPR_MACROSTRING); else sexpclassv = MELT_PREDEF (CLASS_SEXPR); sexprv = meltgc_new_raw_object ((meltobject_ptr_t) (sexpclassv), MELTLENGTH_CLASS_SEXPR); ((meltobject_ptr_t) (sexprv))->obj_vartab[MELTFIELD_LOCA_LOCATION] = (melt_ptr_t) locmixv; ((meltobject_ptr_t) (sexprv))->obj_vartab[MELTFIELD_SEXP_CONTENTS] = (melt_ptr_t) contsv; meltgc_touch (sexprv); MELT_EXITFRAME (); return (melt_ptr_t) sexprv; #undef sexprv #undef contsv #undef locmixv #undef sexpclassv } melt_ptr_t meltgc_named_symbol (const char *nam, int create) { int namlen = 0, ix = 0; char *namdup = 0; char tinybuf[130]; MELT_ENTERFRAME (4, NULL); #define symbv meltfram__.mcfr_varptr[0] #define dictv meltfram__.mcfr_varptr[1] #define closv meltfram__.mcfr_varptr[2] #define nstrv meltfram__.mcfr_varptr[3] symbv = NULL; dictv = NULL; closv = NULL; if (!nam || !MELT_PREDEF (INITIAL_SYSTEM_DATA)) goto end; namlen = strlen (nam); memset (tinybuf, 0, sizeof (tinybuf)); if (namlen < (int) sizeof (tinybuf) - 2) namdup = strcpy (tinybuf, nam); else namdup = strcpy ((char *) xcalloc (namlen + 1, 1), nam); gcc_assert (melt_magic_discr ((melt_ptr_t) MELT_PREDEF (CLASS_SYSTEM_DATA)) == MELTOBMAG_OBJECT); gcc_assert (melt_magic_discr ((melt_ptr_t) MELT_PREDEF (INITIAL_SYSTEM_DATA)) == MELTOBMAG_OBJECT); for (ix = 0; ix < namlen; ix++) if (ISALPHA (namdup[ix])) namdup[ix] = TOUPPER (namdup[ix]); if (MELT_PREDEF (INITIAL_SYSTEM_DATA) != 0) { dictv = melt_get_inisysdata (MELTFIELD_SYSDATA_SYMBOLDICT); if (melt_magic_discr ((melt_ptr_t) dictv) == MELTOBMAG_MAPSTRINGS) symbv = melt_get_mapstrings ((struct meltmapstrings_st *) dictv, namdup); if (symbv || !create) goto end; closv = melt_get_inisysdata (MELTFIELD_SYSDATA_ADDSYMBOL); if (melt_magic_discr ((melt_ptr_t) closv) == MELTOBMAG_CLOSURE) { union meltparam_un pararg[1]; memset (¶rg, 0, sizeof (pararg)); nstrv = meltgc_new_string ((meltobject_ptr_t) MELT_PREDEF (DISCR_STRING), namdup); pararg[0].meltbp_aptr = (melt_ptr_t *) & nstrv; symbv = melt_apply ((meltclosure_ptr_t) closv, (melt_ptr_t) MELT_PREDEF (INITIAL_SYSTEM_DATA), MELTBPARSTR_PTR, pararg, "", NULL); goto end; } } end: ; if (namdup && namdup != tinybuf) free (namdup); MELT_EXITFRAME (); return (melt_ptr_t) symbv; #undef symbv #undef dictv #undef closv #undef nstrv } melt_ptr_t meltgc_intern_symbol (melt_ptr_t symb_p) { MELT_ENTERFRAME (4, NULL); #define symbv meltfram__.mcfr_varptr[0] #define closv meltfram__.mcfr_varptr[1] #define nstrv meltfram__.mcfr_varptr[2] #define resv meltfram__.mcfr_varptr[3] #define obj_symbv ((meltobject_ptr_t)(symbv)) symbv = symb_p; if (melt_magic_discr ((melt_ptr_t) symbv) != MELTOBMAG_OBJECT || obj_symbv->obj_len < MELTLENGTH_CLASS_SYMBOL || !melt_is_instance_of ((melt_ptr_t) symbv, (melt_ptr_t) MELT_PREDEF (CLASS_SYMBOL))) goto fail; nstrv = obj_symbv->obj_vartab[MELTFIELD_NAMED_NAME]; if (melt_magic_discr ((melt_ptr_t) nstrv) != MELTOBMAG_STRING) goto fail; closv = melt_get_inisysdata (MELTFIELD_SYSDATA_INTERNSYMBOL); if (melt_magic_discr ((melt_ptr_t) closv) != MELTOBMAG_CLOSURE) goto fail; else { union meltparam_un pararg[1]; memset (¶rg, 0, sizeof (pararg)); pararg[0].meltbp_aptr = (melt_ptr_t *) & symbv; MELT_LOCATION_HERE ("intern symbol before apply"); resv = melt_apply ((meltclosure_ptr_t) closv, (melt_ptr_t) MELT_PREDEF (INITIAL_SYSTEM_DATA), MELTBPARSTR_PTR, pararg, "", NULL); goto end; } fail: resv = NULL; end: ; MELT_EXITFRAME (); return (melt_ptr_t) resv; #undef symbv #undef closv #undef nstrv #undef resv #undef obj_symbv } melt_ptr_t meltgc_intern_keyword (melt_ptr_t keyw_p) { MELT_ENTERFRAME (4, NULL); #define keywv meltfram__.mcfr_varptr[0] #define closv meltfram__.mcfr_varptr[1] #define nstrv meltfram__.mcfr_varptr[2] #define resv meltfram__.mcfr_varptr[3] #define obj_keywv ((meltobject_ptr_t)(keywv)) keywv = keyw_p; if (melt_magic_discr ((melt_ptr_t) keywv) != MELTOBMAG_OBJECT || melt_object_length ((melt_ptr_t) obj_keywv) < MELTLENGTH_CLASS_SYMBOL || !melt_is_instance_of ((melt_ptr_t) keywv, (melt_ptr_t) MELT_PREDEF (CLASS_KEYWORD))) goto fail; nstrv = obj_keywv->obj_vartab[MELTFIELD_NAMED_NAME]; if (melt_magic_discr ((melt_ptr_t) nstrv) != MELTOBMAG_STRING) goto fail; closv = melt_get_inisysdata (MELTFIELD_SYSDATA_INTERNKEYW); if (melt_magic_discr ((melt_ptr_t) closv) != MELTOBMAG_CLOSURE) goto fail; else { union meltparam_un pararg[1]; memset (¶rg, 0, sizeof (pararg)); pararg[0].meltbp_aptr = (melt_ptr_t *) & keywv; MELT_LOCATION_HERE ("intern keyword before apply"); resv = melt_apply ((meltclosure_ptr_t) closv, (melt_ptr_t) MELT_PREDEF (INITIAL_SYSTEM_DATA), MELTBPARSTR_PTR, pararg, "", NULL); goto end; } fail: resv = NULL; end: ; MELT_EXITFRAME (); return (melt_ptr_t) resv; #undef symbv #undef closv #undef nstrv #undef resv #undef obj_symbv } melt_ptr_t meltgc_named_keyword (const char *nam, int create) { int namlen = 0, ix = 0; char *namdup = 0; char tinybuf[130]; MELT_ENTERFRAME (4, NULL); #define keywv meltfram__.mcfr_varptr[0] #define dictv meltfram__.mcfr_varptr[1] #define closv meltfram__.mcfr_varptr[2] #define nstrv meltfram__.mcfr_varptr[3] keywv = NULL; dictv = NULL; closv = NULL; if (!nam || !MELT_PREDEF (INITIAL_SYSTEM_DATA)) goto end; if (nam[0] == ':') nam++; namlen = strlen (nam); memset (tinybuf, 0, sizeof (tinybuf)); if (namlen < (int) sizeof (tinybuf) - 2) namdup = strcpy (tinybuf, nam); else namdup = strcpy ((char *) xcalloc (namlen + 1, 1), nam); for (ix = 0; ix < namlen; ix++) if (ISALPHA (namdup[ix])) namdup[ix] = TOUPPER (namdup[ix]); gcc_assert (melt_magic_discr ((melt_ptr_t) MELT_PREDEF (CLASS_SYSTEM_DATA)) == MELTOBMAG_OBJECT); gcc_assert (melt_magic_discr ((melt_ptr_t) MELT_PREDEF (INITIAL_SYSTEM_DATA)) == MELTOBMAG_OBJECT); if (MELT_PREDEF (INITIAL_SYSTEM_DATA)) { dictv = melt_get_inisysdata (MELTFIELD_SYSDATA_KEYWDICT); if (melt_magic_discr ((melt_ptr_t) dictv) == MELTOBMAG_MAPSTRINGS) keywv = melt_get_mapstrings ((struct meltmapstrings_st *) dictv, namdup); if (keywv || !create) goto end; closv = melt_get_inisysdata (MELTFIELD_SYSDATA_ADDKEYW); if (melt_magic_discr ((melt_ptr_t) closv) == MELTOBMAG_CLOSURE) { union meltparam_un pararg[1]; memset (¶rg, 0, sizeof (pararg)); nstrv = meltgc_new_string ((meltobject_ptr_t) MELT_PREDEF (DISCR_STRING), namdup); pararg[0].meltbp_aptr = (melt_ptr_t *) & nstrv; keywv = melt_apply ((meltclosure_ptr_t) closv, (melt_ptr_t) MELT_PREDEF (INITIAL_SYSTEM_DATA), MELTBPARSTR_PTR, pararg, "", NULL); goto end; } } end: ; if (namdup && namdup != tinybuf) free (namdup); MELT_EXITFRAME (); return (melt_ptr_t) keywv; #undef keywv #undef dictv #undef closv #undef nstrv } static melt_ptr_t meltgc_readsexpr (struct melt_reading_st *rd, int endc) { int lineno = rd->rlineno; location_t loc = 0; #if MELT_HAVE_DEBUG char curlocbuf[100]; #endif MELT_ENTERFRAME (3, NULL); #define sexprv meltfram__.mcfr_varptr[0] #define contv meltfram__.mcfr_varptr[1] #define locmixv meltfram__.mcfr_varptr[2] gcc_assert (rd && rd->readmagic == MELT_READING_MAGIC); if (!endc || rdeof ()) MELT_READ_ERROR ("MELT: eof in s-expr (lin%d)", lineno); (void) melt_skipspace_getc (rd, COMMENT_SKIP); melt_linemap_compute_current_location (rd); loc = rd->rsrcloc; MELT_LOCATION_HERE_PRINTF (curlocbuf, "readsexpr @ %s:%d:%d", melt_basename(LOCATION_FILE(loc)), LOCATION_LINE (loc), LOCATION_COLUMN(loc)); contv = meltgc_readseqlist (rd, endc); sexprv = meltgc_makesexpr (rd, lineno, (melt_ptr_t) contv, loc, MELT_MACSTR_PLAIN); MELT_EXITFRAME (); return (melt_ptr_t) sexprv; #undef sexprv #undef contv #undef locmixv } /* if the string ends with "_ call gettext on it to have it localized/internationlized -i18n- */ static melt_ptr_t meltgc_readstring (struct melt_reading_st *rd) { int c = 0; int nbesc = 0; char *cstr = 0, *endc = 0; bool isintl = false; MELT_ENTERFRAME (1, NULL); #define strv meltfram__.mcfr_varptr[0] #define str_strv ((struct meltstring_st*)(strv)) gcc_assert (rd && rd->readmagic == MELT_READING_MAGIC); obstack_init (&melt_bstring_obstack); while ((c = rdcurc ()) != '"' && !rdeof ()) { if (c != '\\') { obstack_1grow (&melt_bstring_obstack, (char) c); if (c == '\n') { /* It is suspicious when a double-quote is parsed as the last character of a line; issue a warning in that case. This helps to catch missing, mismatched or extra double-quotes! */ if (obstack_object_size (&melt_bstring_obstack) <= 1) warning_at (rd->rsrcloc, 0, "suspicious MELT string starting at end of line"); c = melt_skipspace_getc (rd, COMMENT_NO); continue; } else rdnext (); } else { rdnext (); c = rdcurc (); nbesc++; switch (c) { case 'a': c = '\a'; rdnext (); break; case 'b': c = '\b'; rdnext (); break; case 't': c = '\t'; rdnext (); break; case 'n': c = '\n'; rdnext (); break; case 'v': c = '\v'; rdnext (); break; case 'f': c = '\f'; rdnext (); break; case 'r': c = '\r'; rdnext (); break; case '"': c = '\"'; rdnext (); break; case '\\': c = '\\'; rdnext (); break; case '\n': case '\r': melt_skipspace_getc (rd, COMMENT_NO); continue; case ' ': c = ' '; rdnext (); break; case 'x': rdnext (); c = (char) strtol (&rdcurc (), &endc, 16); if (c == 0 && endc <= &rdcurc ()) MELT_READ_ERROR ("MELT: illegal hex \\x escape in string %.20s", &rdcurc ()); if (*endc == ';') endc++; rd->rcol += endc - &rdcurc (); break; case '{': { int linbrac = rd->rlineno; /* the escaped left brace \{ read verbatim all the string till the right brace } */ rdnext (); while (rdcurc () != '}') { int cc; if (rdeof ()) MELT_READ_ERROR ("MELT: reached end of file in braced block string starting line %d", linbrac); cc = rdcurc (); if (cc == '\n') cc = melt_skipspace_getc (rd, COMMENT_NO); else obstack_1grow (&melt_bstring_obstack, (char) cc); rdnext (); }; rdnext (); } break; default: MELT_READ_ERROR ("MELT: illegal escape sequence %.10s in string -- got \\%c (hex %x)", &rdcurc () - 1, c, c); } obstack_1grow (&melt_bstring_obstack, (char) c); } } if (c == '"') rdnext (); else MELT_READ_ERROR ("MELT: unterminated string %.20s", &rdcurc ()); c = rdcurc (); if (c == '_' && !rdeof ()) { isintl = true; rdnext (); } obstack_1grow (&melt_bstring_obstack, (char) 0); cstr = XOBFINISH (&melt_bstring_obstack, char *); if (isintl) cstr = gettext (cstr); strv = meltgc_new_string ((meltobject_ptr_t) MELT_PREDEF (DISCR_STRING), cstr); obstack_free (&melt_bstring_obstack, cstr); MELT_EXITFRAME (); return (melt_ptr_t) strv; #undef strv #undef str_strv } /** macrostring so #{if ($A>0) printf("%s", $B);}# is parsed as would be parsed the s-expr ("if (" A ">0) printf(\"%s\", " B ");") read a macrostring sequence starting with #{ and ending with }# perhaps spanning several lines in the source no escape characters are handled (in particular no backslash escapes) except the dollar sign $ and then ending }# A $ followed by alphabetical caracters (or as in C by underscores or digits, provided the first is not a digit) is handled as a symbol. If it is immediately followed by an hash # the # is skipped A $ followed by a left parenthesis ( is read as an embedded S-expression, it should end with a balanced right parenthesis ) A $ followed by a left square bracket [ is read as a embedded sequence of S-epxressions, it should end with a balanced right square bracket ] **/ static melt_ptr_t meltgc_readmacrostringsequence (struct melt_reading_st *rd) { int lineno = rd->rlineno; int escaped = 0; int quoted = 0; location_t loc = 0; #if MELT_HAVE_DEBUG char curlocbuf[100]; #endif MELT_ENTERFRAME (8, NULL); #define readv meltfram__.mcfr_varptr[0] #define strv meltfram__.mcfr_varptr[1] #define symbv meltfram__.mcfr_varptr[2] #define seqv meltfram__.mcfr_varptr[3] #define sbufv meltfram__.mcfr_varptr[4] #define compv meltfram__.mcfr_varptr[5] #define subseqv meltfram__.mcfr_varptr[6] #define pairv meltfram__.mcfr_varptr[7] gcc_assert (rd && rd->readmagic == MELT_READING_MAGIC); melt_linemap_compute_current_location (rd); loc = rd->rsrcloc; MELT_LOCATION_HERE_PRINTF (curlocbuf, "readmacrostringsequence @ %s:%d:%d", melt_basename(LOCATION_FILE(loc)), LOCATION_LINE (loc), LOCATION_COLUMN(loc)); seqv = meltgc_new_list ((meltobject_ptr_t) MELT_PREDEF (DISCR_LIST)); sbufv = meltgc_new_strbuf((meltobject_ptr_t) MELT_PREDEF(DISCR_STRBUF), (char*)0); if (rdcurc() == '$' && rdfollowc(1)=='\'') { symbv = meltgc_named_symbol ("quote", MELT_CREATE); quoted = 1; meltgc_append_list((melt_ptr_t) seqv, (melt_ptr_t) symbv); symbv = NULL; rdnext (); rdnext (); } for(;;) { if (rdeof()) MELT_READ_ERROR("reached end of file in macrostring sequence started line %d; a }# is probably missing.", lineno); if (!rdcurc()) { /* reached end of line */ melt_skipspace_getc(rd, COMMENT_NO); continue; } loc = rd->rsrcloc; MELT_LOCATION_HERE_PRINTF (curlocbuf, "readmacrostringsequence inside @ %s:%d:%d", melt_basename(LOCATION_FILE(loc)), LOCATION_LINE (loc), LOCATION_COLUMN(loc)); if (rdcurc()=='}' && rdfollowc(1)=='#') { rdnext (); rdnext (); if (sbufv && melt_strbuf_usedlength((melt_ptr_t)sbufv)>0) { strv = meltgc_new_stringdup ((meltobject_ptr_t) MELT_PREDEF(DISCR_STRING), melt_strbuf_str((melt_ptr_t) sbufv)); meltgc_append_list((melt_ptr_t) seqv, (melt_ptr_t) strv); if (!escaped && strstr (melt_string_str((melt_ptr_t) strv), "}#")) warning_at(rd->rsrcloc, 0, "MELT macrostring starting at line %d containing }# might be suspicious", lineno); if (!escaped && strstr (melt_string_str((melt_ptr_t) strv), "#{")) warning_at(rd->rsrcloc, 0, "MELT macrostring starting at line %d containing #{ might be suspicious", lineno); sbufv = NULL; strv = NULL; } break; } else if (rdcurc()=='$') { /* $ followed by letters or underscore makes a symbol */ if (ISALPHA(rdfollowc(1)) || rdfollowc(1)=='_') { int lnam = 1; char tinybuf[64]; /* if there is any sbuf, make a string of it and add the string into the sequence */ if (sbufv && melt_strbuf_usedlength((melt_ptr_t)sbufv)>0) { strv = meltgc_new_stringdup((meltobject_ptr_t) MELT_PREDEF(DISCR_STRING), melt_strbuf_str((melt_ptr_t) sbufv)); gcc_assert (strv != NULL); meltgc_append_list((melt_ptr_t) seqv, (melt_ptr_t) strv); sbufv = NULL; strv = NULL; } while (ISALNUM(rdfollowc(lnam)) || rdfollowc(lnam) == '_') lnam++; if (lnam< (int)sizeof(tinybuf)-2) { memset(tinybuf, 0, sizeof(tinybuf)); memcpy(tinybuf, &rdfollowc(1), lnam-1); tinybuf[lnam] = (char)0; if (quoted) MELT_READ_WARNING ("quoted macro string with $%s symbol", tinybuf); symbv = meltgc_named_symbol(tinybuf, MELT_CREATE); } else { char *nambuf = (char*) xcalloc(lnam+2, 1); memcpy(nambuf, &rdfollowc(1), lnam-1); nambuf[lnam] = (char)0; symbv = meltgc_named_symbol(nambuf, MELT_CREATE); if (quoted) MELT_READ_WARNING ("quoted macro string with $%s symbol", nambuf); free(nambuf); } rd->rcol += lnam; /* skip the hash # if just after the symbol */ if (rdcurc() == '#') rdnext(); /* append the symbol */ meltgc_append_list((melt_ptr_t) seqv, (melt_ptr_t) symbv); symbv = NULL; } /* $. is silently skipped */ else if (rdfollowc(1) == '.') { escaped = 1; rdnext(); rdnext(); } /* $$ is handled as a single dollar $ */ else if (rdfollowc(1) == '$') { if (!sbufv) sbufv = meltgc_new_strbuf((meltobject_ptr_t) MELT_PREDEF(DISCR_STRBUF), (char*)0); meltgc_add_strbuf_raw_len((melt_ptr_t)sbufv, "$", 1); rdnext(); rdnext(); } /* $# is handled as a single hash # */ else if (rdfollowc(1) == '#') { escaped = 1; if (!sbufv) sbufv = meltgc_new_strbuf((meltobject_ptr_t) MELT_PREDEF(DISCR_STRBUF), (char*)0); meltgc_add_strbuf_raw_len((melt_ptr_t)sbufv, "#", 1); rdnext(); rdnext(); } /* $(some s-expr) is acceptable to embed a single s-expression */ else if (rdfollowc(1) == '(') { rdnext (); rdnext (); compv = meltgc_readsexpr (rd, ')'); /* append the s-expr */ meltgc_append_list((melt_ptr_t) seqv, (melt_ptr_t) compv); compv = NULL; } /* $[several sub-expr] is acceptable to embed a sequence of s-expressions */ else if (rdfollowc(1) == '[') { rdnext (); rdnext (); subseqv = meltgc_readseqlist(rd, ']'); if (melt_magic_discr ((melt_ptr_t)subseqv) == MELTOBMAG_LIST) { compv = NULL; for (pairv = ((struct meltlist_st*)(subseqv))->first; pairv && melt_magic_discr((melt_ptr_t)pairv) == MELTOBMAG_PAIR; pairv = ((struct meltpair_st*)(pairv))->tl) { compv = ((struct meltpair_st*)(pairv))->hd; if (compv) { meltgc_append_list ((melt_ptr_t) seqv, (melt_ptr_t) compv); } } pairv = NULL; compv = NULL; } } /* any other dollar something is an error */ else MELT_READ_ERROR("unexpected dollar escape in macrostring %.4s started line %d", &rdcurc(), lineno); } else if ( ISALNUM(rdcurc()) || ISSPACE(rdcurc()) ) { /* handle efficiently the common case of alphanum and spaces */ int nbc = 0; if (!sbufv) sbufv = meltgc_new_strbuf((meltobject_ptr_t) MELT_PREDEF(DISCR_STRBUF), (char*)0); while (ISALNUM(rdfollowc(nbc)) || ISSPACE(rdfollowc(nbc))) nbc++; meltgc_add_strbuf_raw_len((melt_ptr_t)sbufv, &rdcurc(), nbc); rd->rcol += nbc; } else { /* the current char is not a dollar $ nor an alnum */ /* if the macro string contains #{ it is suspicious. */ if (rdcurc() == '#' && rdfollowc(1) == '{') warning_at(rd->rsrcloc, 0, "internal #{ inside MELT macrostring starting at line %d might be suspicious", lineno); if (!sbufv) sbufv = meltgc_new_strbuf((meltobject_ptr_t) MELT_PREDEF(DISCR_STRBUF), (char*)0); meltgc_add_strbuf_raw_len((melt_ptr_t)sbufv, &rdcurc(), 1); rdnext(); } } readv = meltgc_makesexpr (rd, lineno, (melt_ptr_t) seqv, loc, MELT_MACSTR_MACRO); MELT_EXITFRAME (); return (melt_ptr_t) readv; #undef readv #undef strv #undef symbv #undef seqv #undef sbufv #undef compv #undef subseqv #undef pairv } static melt_ptr_t melrtgc_readhashescape (struct melt_reading_st *rd) { int c = 0; char *nam = NULL; int lineno = rd->rlineno; MELT_ENTERFRAME (4, NULL); #define readv meltfram__.mcfr_varptr[0] #define compv meltfram__.mcfr_varptr[1] #define listv meltfram__.mcfr_varptr[2] #define pairv meltfram__.mcfr_varptr[3] gcc_assert (rd && rd->readmagic == MELT_READING_MAGIC); readv = NULL; c = rdcurc (); if (!c || rdeof ()) MELT_READ_ERROR ("MELT: eof in hashescape %.20s starting line %d", &rdcurc (), lineno); if (c == '\\') { rdnext (); if (ISALPHA (rdcurc ()) && rdcurc () != 'x' && ISALPHA (rdfollowc (1))) { nam = melt_readsimplename (rd); c = 0; if (!strcmp (nam, "nul")) c = 0; else if (!strcmp (nam, "alarm")) c = '\a'; else if (!strcmp (nam, "backspace")) c = '\b'; else if (!strcmp (nam, "tab")) c = '\t'; else if (!strcmp (nam, "linefeed")) c = '\n'; else if (!strcmp (nam, "vtab")) c = '\v'; else if (!strcmp (nam, "page")) c = '\f'; else if (!strcmp (nam, "return")) c = '\r'; else if (!strcmp (nam, "space")) c = ' '; /* won't work on non ASCII or ISO or Unicode host, but we don't care */ else if (!strcmp (nam, "delete")) c = 0xff; else if (!strcmp (nam, "esc")) c = 0x1b; else MELT_READ_ERROR ("MELT: invalid char escape %s starting line %d", nam, lineno); obstack_free (&melt_bname_obstack, nam); char_escape: readv = meltgc_new_int ((meltobject_ptr_t) MELT_PREDEF (DISCR_CHARACTER_INTEGER), c); } else if (rdcurc () == 'x' && ISXDIGIT (rdfollowc (1))) { char *endc = 0; rdnext (); c = strtol (&rdcurc (), &endc, 16); if (c == 0 && endc <= &rdcurc ()) MELT_READ_ERROR ("MELT: illigal hex #\\x escape in char %.20s starting line %d", &rdcurc (), lineno); rd->rcol += endc - &rdcurc (); goto char_escape; } else if (ISPRINT (rdcurc ())) { c = rdcurc (); rdnext (); goto char_escape; } else MELT_READ_ERROR ("MELT: unrecognized char escape #\\%s starting line %d", &rdcurc (), lineno); } else if (c == '(') { int ln = 0, ix = 0; listv = meltgc_readseqlist (rd, ')'); ln = melt_list_length ((melt_ptr_t) listv); gcc_assert (ln >= 0); readv = meltgc_new_multiple ((meltobject_ptr_t) MELT_PREDEF (DISCR_MULTIPLE), ln); for ((ix = 0), (pairv = ((struct meltlist_st *) (listv))->first); ix < ln && melt_magic_discr ((melt_ptr_t) pairv) == MELTOBMAG_PAIR; pairv = ((struct meltpair_st *) (pairv))->tl) ((struct meltmultiple_st *) (readv))->tabval[ix++] = ((struct meltpair_st *) (pairv))->hd; meltgc_touch (readv); } else if (c == '[') { /* a melt extension #[ .... ] for lists */ readv = meltgc_readseqlist (rd, ']'); } else if ((c == 'b' || c == 'B') && ISDIGIT (rdfollowc (1))) { /* binary number */ char *endc = 0; long n = 0; rdnext (); n = strtol (&rdcurc (), &endc, 2); if (n == 0 && endc <= &rdcurc ()) MELT_READ_ERROR ("MELT: bad binary number %s starting line %d", endc, lineno); readv = meltgc_new_int ((meltobject_ptr_t) MELT_PREDEF (DISCR_INTEGER), n); } else if ((c == 'o' || c == 'O') && ISDIGIT (rdfollowc (1))) { /* octal number */ char *endc = 0; long n = 0; rdnext (); n = strtol (&rdcurc (), &endc, 8); if (n == 0 && endc <= &rdcurc ()) MELT_READ_ERROR ("MELT: bad octal number %s starting line %d", endc, lineno); readv = meltgc_new_int ((meltobject_ptr_t) MELT_PREDEF (DISCR_INTEGER), n); } else if ((c == 'd' || c == 'D') && ISDIGIT (rdfollowc (1))) { /* decimal number */ char *endc = 0; long n = 0; rdnext (); n = strtol (&rdcurc (), &endc, 10); if (n == 0 && endc <= &rdcurc ()) MELT_READ_ERROR ("MELT: bad decimal number %s starting line %d", endc, lineno); readv = meltgc_new_int ((meltobject_ptr_t) MELT_PREDEF (DISCR_INTEGER), n); } else if ((c == 'x' || c == 'x') && ISDIGIT (rdfollowc (1))) { /* hex number */ char *endc = 0; long n = 0; rdnext (); n = strtol (&rdcurc (), &endc, 16); if (n == 0 && endc <= &rdcurc ()) MELT_READ_ERROR ("MELT: bad octal number %s starting line %d", endc, lineno); readv = meltgc_new_int ((meltobject_ptr_t) MELT_PREDEF (DISCR_INTEGER), n); } else if (c == '+' && ISALPHA (rdfollowc (1))) { bool gotcomp = FALSE; char *nam = 0; nam = melt_readsimplename (rd); compv = meltgc_readval (rd, &gotcomp); if (!strcmp (nam, "MELT")) readv = compv; else readv = meltgc_readval (rd, &gotcomp); } /* #{ is a macrostringsequence; it is terminated by }# and each occurrence of $ followed by alphanum char is considered as a MELT symbol, the other caracters are considered as string chunks; the entire read is a sequence */ else if (c == '{') { rdnext (); readv = meltgc_readmacrostringsequence(rd); } else MELT_READ_ERROR ("MELT: invalid escape %.20s starting line %d", &rdcurc (), lineno); MELT_EXITFRAME (); return (melt_ptr_t) readv; #undef readv #undef listv #undef compv #undef pairv } static melt_ptr_t meltgc_readval (struct melt_reading_st *rd, bool * pgot) { int c = 0; char *nam = 0; int lineno = rd->rlineno; location_t loc = 0; #if MELT_HAVE_DEBUG char curlocbuf[120]; #endif MELT_ENTERFRAME (4, NULL); #define readv meltfram__.mcfr_varptr[0] #define compv meltfram__.mcfr_varptr[1] #define seqv meltfram__.mcfr_varptr[2] #define altv meltfram__.mcfr_varptr[3] gcc_assert (rd && rd->readmagic == MELT_READING_MAGIC); loc = rd->rsrcloc; MELT_LOCATION_HERE_PRINTF (curlocbuf, "readvalstart @ %s:%d:%d", melt_basename(LOCATION_FILE(loc)), LOCATION_LINE (loc), LOCATION_COLUMN(loc)); readv = NULL; c = melt_skipspace_getc (rd, COMMENT_SKIP); /* debugeprintf ("start meltgc_readval line %d col %d char %c", rd->rlineno, rd->rcol, ISPRINT (c) ? c : ' '); */ if (ISDIGIT (c) || ((c == '-' || c == '+') && (ISDIGIT (rdfollowc (1)) || rdfollowc (1) == '%' || rdfollowc (1) == '|'))) { long num = 0; num = melt_readsimplelong (rd); readv = meltgc_new_int ((meltobject_ptr_t) MELT_PREDEF (DISCR_INTEGER), num); *pgot = TRUE; goto end; } /* end if ISDIGIT or '-' or '+' */ else if (c == '"') { rdnext (); readv = meltgc_readstring (rd); *pgot = TRUE; goto end; } /* end if '"' */ else if (c == '(') { rdnext (); if (rdcurc () == ')') { rdnext (); readv = NULL; *pgot = TRUE; goto end; } readv = meltgc_readsexpr (rd, ')'); *pgot = TRUE; goto end; } /* end if '(' */ else if (c == ')') { readv = NULL; *pgot = FALSE; MELT_READ_ERROR ("MELT: unexpected closing parenthesis %.20s", &rdcurc ()); goto end; } else if (c == '[') { rdnext (); readv = meltgc_readsexpr (rd, ']'); *pgot = TRUE; goto end; } else if (c == '#') { rdnext (); c = rdcurc (); readv = melrtgc_readhashescape (rd); *pgot = TRUE; goto end; } else if (c == '\'') { bool got = false; rdnext (); compv = meltgc_readval (rd, &got); if (!got) MELT_READ_ERROR ("MELT: expecting value after quote %.20s", &rdcurc ()); seqv = meltgc_new_list ((meltobject_ptr_t) MELT_PREDEF (DISCR_LIST)); altv = meltgc_named_symbol ("quote", MELT_CREATE); meltgc_append_list ((melt_ptr_t) seqv, (melt_ptr_t) altv); meltgc_append_list ((melt_ptr_t) seqv, (melt_ptr_t) compv); melt_linemap_compute_current_location (rd); loc = rd->rsrcloc; MELT_LOCATION_HERE_PRINTF (curlocbuf, "readval quote @ %s:%d:%d", melt_basename(LOCATION_FILE(loc)), LOCATION_LINE (loc), LOCATION_COLUMN(loc)); readv = meltgc_makesexpr (rd, lineno, (melt_ptr_t) seqv, loc, MELT_MACSTR_PLAIN); *pgot = TRUE; goto end; } else if (c == '!' && (ISALPHA (rdfollowc (1)) || ISSPACE (rdfollowc (1)) || rdfollowc (1) == '(')) { bool got = false; location_t loc = 0; rdnext (); compv = meltgc_readval (rd, &got); if (!got) MELT_READ_ERROR ("MELT: expecting value after exclamation mark ! %.20s", &rdcurc ()); seqv = meltgc_new_list ((meltobject_ptr_t) MELT_PREDEF (DISCR_LIST)); altv = meltgc_named_symbol ("exclaim", MELT_CREATE); meltgc_append_list ((melt_ptr_t) seqv, (melt_ptr_t) altv); meltgc_append_list ((melt_ptr_t) seqv, (melt_ptr_t) compv); melt_linemap_compute_current_location (rd); loc = rd->rsrcloc; MELT_LOCATION_HERE_PRINTF (curlocbuf, "readval exclaim @ %s:%d:%d", melt_basename(LOCATION_FILE(loc)), LOCATION_LINE (loc), LOCATION_COLUMN(loc)); readv = meltgc_makesexpr (rd, lineno, (melt_ptr_t) seqv, loc, MELT_MACSTR_PLAIN); *pgot = TRUE; goto end; } else if (c == '`') { bool got = false; location_t loc = 0; rdnext (); melt_linemap_compute_current_location (rd); loc = rd->rsrcloc; MELT_LOCATION_HERE_PRINTF (curlocbuf, "readval backquote @ %s:%d:%d", melt_basename(LOCATION_FILE(loc)), LOCATION_LINE (loc), LOCATION_COLUMN(loc)); compv = meltgc_readval (rd, &got); if (!got) MELT_READ_ERROR ("MELT: expecting value after backquote %.20s", &rdcurc ()); seqv = meltgc_new_list ((meltobject_ptr_t) MELT_PREDEF (DISCR_LIST)); altv = meltgc_named_symbol ("backquote", MELT_CREATE); meltgc_append_list ((melt_ptr_t) seqv, (melt_ptr_t) altv); meltgc_append_list ((melt_ptr_t) seqv, (melt_ptr_t) compv); readv = meltgc_makesexpr (rd, lineno, (melt_ptr_t) seqv, loc, MELT_MACSTR_PLAIN); *pgot = TRUE; goto end; } else if (c == ',') { bool got = false; location_t loc = 0; rdnext (); melt_linemap_compute_current_location (rd); loc = rd->rsrcloc; MELT_LOCATION_HERE_PRINTF (curlocbuf, "readval comma @ %s:%d:%d", melt_basename(LOCATION_FILE(loc)), LOCATION_LINE (loc), LOCATION_COLUMN(loc)); compv = meltgc_readval (rd, &got); if (!got) MELT_READ_ERROR ("MELT: expecting value after comma %.20s", &rdcurc ()); seqv = meltgc_new_list ((meltobject_ptr_t) MELT_PREDEF (DISCR_LIST)); altv = meltgc_named_symbol ("comma", MELT_CREATE); meltgc_append_list ((melt_ptr_t) seqv, (melt_ptr_t) altv); meltgc_append_list ((melt_ptr_t) seqv, (melt_ptr_t) compv); readv = meltgc_makesexpr (rd, lineno, (melt_ptr_t) seqv, loc, MELT_MACSTR_PLAIN); *pgot = TRUE; goto end; } else if (c == '@') { bool got = false; location_t loc = 0; rdnext (); melt_linemap_compute_current_location (rd); loc = rd->rsrcloc; MELT_LOCATION_HERE_PRINTF (curlocbuf, "readval at @ %s:%d:%d", melt_basename(LOCATION_FILE(loc)), LOCATION_LINE (loc), LOCATION_COLUMN(loc)); compv = meltgc_readval (rd, &got); if (!got) MELT_READ_ERROR ("MELT: expecting value after at %.20s", &rdcurc ()); seqv = meltgc_new_list ((meltobject_ptr_t) MELT_PREDEF (DISCR_LIST)); altv = meltgc_named_symbol ("at", MELT_CREATE); meltgc_append_list ((melt_ptr_t) seqv, (melt_ptr_t) altv); meltgc_append_list ((melt_ptr_t) seqv, (melt_ptr_t) compv); readv = meltgc_makesexpr (rd, lineno, (melt_ptr_t) seqv, loc, MELT_MACSTR_PLAIN); *pgot = TRUE; goto end; } else if (c == '?') { bool got = false; location_t loc = 0; rdnext (); melt_linemap_compute_current_location (rd); loc = rd->rsrcloc; MELT_LOCATION_HERE_PRINTF (curlocbuf, "readval question @ %s:%d:%d", melt_basename(LOCATION_FILE(loc)), LOCATION_LINE (loc), LOCATION_COLUMN(loc)); compv = meltgc_readval (rd, &got); if (!got) MELT_READ_ERROR ("MELT: expecting value after question %.20s", &rdcurc ()); seqv = meltgc_new_list ((meltobject_ptr_t) MELT_PREDEF (DISCR_LIST)); altv = meltgc_named_symbol ("question", MELT_CREATE); meltgc_append_list ((melt_ptr_t) seqv, (melt_ptr_t) altv); meltgc_append_list ((melt_ptr_t) seqv, (melt_ptr_t) compv); readv = meltgc_makesexpr (rd, lineno, (melt_ptr_t) seqv, loc, MELT_MACSTR_PLAIN); *pgot = TRUE; goto end; } else if (c == ':') { if (!ISALPHA (rdfollowc(1))) MELT_READ_ERROR ("MELT: colon should be followed by letter for keyword, but got %c", rdfollowc(1)); nam = melt_readsimplename (rd); readv = meltgc_named_keyword (nam, MELT_CREATE); if (!readv) MELT_READ_ERROR ("MELT: unknown named keyword %s", nam); *pgot = TRUE; goto end; } else if (ISALPHA (c) || strchr (EXTRANAMECHARS, c) != NULL) { nam = melt_readsimplename (rd); readv = meltgc_named_symbol (nam, MELT_CREATE); *pgot = TRUE; goto end; } else { if (c >= 0) rdback (); readv = NULL; } end: MELT_EXITFRAME (); if (nam) { *nam = 0; obstack_free (&melt_bname_obstack, nam); }; return (melt_ptr_t) readv; #undef readv #undef compv #undef seqv #undef altv } void melt_error_str (melt_ptr_t mixloc_p, const char *msg, melt_ptr_t str_p) { int mixmag = 0; int lineno = 0; location_t loc = 0; MELT_ENTERFRAME (3, NULL); #define mixlocv meltfram__.mcfr_varptr[0] #define strv meltfram__.mcfr_varptr[1] #define finamv meltfram__.mcfr_varptr[2] gcc_assert (msg && msg[0]); melt_error_counter ++; mixlocv = mixloc_p; strv = str_p; mixmag = melt_magic_discr ((melt_ptr_t) mixlocv); if (mixmag == MELTOBMAG_MIXLOC) { loc = melt_location_mixloc ((melt_ptr_t) mixlocv); finamv = melt_val_mixloc ((melt_ptr_t) mixlocv); lineno = melt_num_mixloc ((melt_ptr_t) mixlocv); } else if (mixmag == MELTOBMAG_MIXINT) { loc = 0; finamv = melt_val_mixint ((melt_ptr_t) mixlocv); lineno = melt_num_mixint ((melt_ptr_t) mixlocv); } else { loc = 0; finamv = NULL; lineno = 0; } if (loc) { const char *cstr = melt_string_str ((melt_ptr_t) strv); if (cstr) error_at (loc, "Melt Error[#%ld]: %s - %s", melt_dbgcounter, msg, cstr); else error_at (loc, "Melt Error[#%ld]: %s", melt_dbgcounter, msg); } else { const char *cfilnam = melt_string_str ((melt_ptr_t) finamv); const char *cstr = melt_string_str ((melt_ptr_t) strv); if (cfilnam) { if (cstr) error ("Melt Error[#%ld] @ %s:%d: %s - %s", melt_dbgcounter, cfilnam, lineno, msg, cstr); else error ("Melt Error[#%ld] @ %s:%d: %s", melt_dbgcounter, cfilnam, lineno, msg); } else { if (cstr) error ("Melt Error[#%ld]: %s - %s", melt_dbgcounter, msg, cstr); else error ("Melt Error[#%ld]: %s", melt_dbgcounter, msg); } } MELT_EXITFRAME (); } #undef mixlocv #undef strv #undef finamv void melt_warning_at_strbuf (location_t loc, melt_ptr_t msgbuf) { char *str; if (!msgbuf || melt_magic_discr (msgbuf) != MELTOBMAG_STRBUF) return; str = xstrndup (melt_strbuf_str (msgbuf), (size_t) melt_strbuf_usedlength(msgbuf)); if(str == NULL) return; warning_at (loc, /*no OPT_*/0, "Melt Warning[#%ld]: %s", melt_dbgcounter, str); free (str); } void melt_warning_str (int opt, melt_ptr_t mixloc_p, const char *msg, melt_ptr_t str_p) { int mixmag = 0; int lineno = 0; location_t loc = 0; MELT_ENTERFRAME (3, NULL); #define mixlocv meltfram__.mcfr_varptr[0] #define strv meltfram__.mcfr_varptr[1] #define finamv meltfram__.mcfr_varptr[2] gcc_assert (msg && msg[0]); mixlocv = mixloc_p; strv = str_p; mixmag = melt_magic_discr ((melt_ptr_t) mixlocv); if (mixmag == MELTOBMAG_MIXLOC) { loc = melt_location_mixloc ((melt_ptr_t) mixlocv); finamv = melt_val_mixloc ((melt_ptr_t) mixlocv); lineno = melt_num_mixloc ((melt_ptr_t) mixlocv); } else if (mixmag == MELTOBMAG_MIXINT) { loc = 0; finamv = melt_val_mixint ((melt_ptr_t) mixlocv); lineno = melt_num_mixint ((melt_ptr_t) mixlocv); } else { loc = 0; finamv = NULL; lineno = 0; } if (loc) { const char *cstr = melt_string_str ((melt_ptr_t) strv); if (cstr) warning_at (loc, opt, "Melt Warning[#%ld]: %s - %s", melt_dbgcounter, msg, cstr); else warning_at (loc, opt, "Melt Warning[#%ld]: %s", melt_dbgcounter, msg); } else { const char *cfilnam = melt_string_str ((melt_ptr_t) finamv); const char *cstr = melt_string_str ((melt_ptr_t) strv); if (cfilnam) { if (cstr) warning (opt, "Melt Warning[#%ld] @ %s:%d: %s - %s", melt_dbgcounter, cfilnam, lineno, msg, cstr); else warning (opt, "Melt Warning[#%ld] @ %s:%d: %s", melt_dbgcounter, cfilnam, lineno, msg); } else { if (cstr) warning (opt, "Melt Warning[#%ld]: %s - %s", melt_dbgcounter, msg, cstr); else warning (opt, "Melt Warning[#%ld]: %s", melt_dbgcounter, msg); } } MELT_EXITFRAME (); } #undef mixlocv #undef strv #undef finamv void melt_inform_str (melt_ptr_t mixloc_p, const char *msg, melt_ptr_t str_p) { int mixmag = 0; int lineno = 0; location_t loc = 0; MELT_ENTERFRAME (3, NULL); #define mixlocv meltfram__.mcfr_varptr[0] #define strv meltfram__.mcfr_varptr[1] #define finamv meltfram__.mcfr_varptr[2] gcc_assert (msg && msg[0]); mixlocv = mixloc_p; strv = str_p; mixmag = melt_magic_discr ((melt_ptr_t) mixlocv); if (mixmag == MELTOBMAG_MIXLOC) { loc = melt_location_mixloc ((melt_ptr_t) mixlocv); finamv = melt_val_mixloc ((melt_ptr_t) mixlocv); lineno = melt_num_mixloc ((melt_ptr_t) mixlocv); } else if (mixmag == MELTOBMAG_MIXINT) { loc = 0; finamv = melt_val_mixint ((melt_ptr_t) mixlocv); lineno = melt_num_mixint ((melt_ptr_t) mixlocv); } else { loc = 0; finamv = NULL; lineno = 0; } if (loc) { const char *cstr = melt_string_str ((melt_ptr_t) strv); if (cstr) inform (loc, "Melt Inform[#%ld]: %s - %s", melt_dbgcounter, msg, cstr); else inform (loc, "Melt Inform[#%ld]: %s", melt_dbgcounter, msg); } else { const char *cfilnam = melt_string_str ((melt_ptr_t) finamv); const char *cstr = melt_string_str ((melt_ptr_t) strv); if (cfilnam) { if (cstr) inform (UNKNOWN_LOCATION, "Melt Inform[#%ld] @ %s:%d: %s - %s", melt_dbgcounter, cfilnam, lineno, msg, cstr); else inform (UNKNOWN_LOCATION, "Melt Inform[#%ld] @ %s:%d: %s", melt_dbgcounter, cfilnam, lineno, msg); } else { if (cstr) inform (UNKNOWN_LOCATION, "Melt Inform[#%ld]: %s - %s", melt_dbgcounter, msg, cstr); else inform (UNKNOWN_LOCATION, "Melt Inform[#%ld]: %s", melt_dbgcounter, msg); } } MELT_EXITFRAME (); } #undef mixlocv #undef strv #undef finamv melt_ptr_t meltgc_read_file (const char *filnam, const char *locnam) { #if MELT_HAVE_DEBUG char curlocbuf[140]; #endif struct melt_reading_st rds; FILE *fil = 0; struct melt_reading_st *rd = 0; char *filnamdup = 0; const char* srcpathstr = melt_argument ("source-path"); MELT_ENTERFRAME (3, NULL); #define valv meltfram__.mcfr_varptr[0] #define seqv meltfram__.mcfr_varptr[1] #define locnamv meltfram__.mcfr_varptr[2] memset (&rds, 0, sizeof (rds)); debugeprintf ("meltgc_read_file filnam %s locnam %s", filnam, locnam); if (!filnam || !filnam[0]) goto end; if (!locnam || !locnam[0]) locnam = melt_basename (filnam); if (melt_trace_source_fil) { fprintf (melt_trace_source_fil, "MELT reads MELT source file %s, locally %s\n", filnam, locnam); fflush (melt_trace_source_fil); } filnamdup = xstrdup (filnam); /* Store the filnamdup in the parsedmeltfilevect vector to be able to free them at end; we need to duplicate filnam because linemap_add store pointers to it. */ VEC_safe_push (meltchar_p, heap, parsedmeltfilevect, filnamdup); debugeprintf ("meltgc_read_file filnamdup %s locnam %s", filnamdup, locnam); fil = fopen (filnamdup, "rt"); /* If needed, find the file in the source path. */ if (!fil && !IS_ABSOLUTE_PATH(filnam)) { free (filnamdup), filnamdup = NULL; filnamdup = MELT_FIND_FILE (filnam, MELT_FILE_LOG, melt_trace_source_fil, MELT_FILE_IN_PATH, srcpathstr, MELT_FILE_IN_ENVIRON_PATH, melt_flag_bootstrapping?NULL:"GCCMELT_SOURCE_PATH", MELT_FILE_IN_DIRECTORY, melt_flag_bootstrapping?NULL:melt_source_dir, NULL); debugeprintf ("meltgc_read_file filenamdup %s", filnamdup); if (filnamdup) fil = fopen (filnamdup, "rt"); } if (!fil) { if (filnam && srcpathstr) inform (UNKNOWN_LOCATION, "didn't found MELT file %s with source path %s", filnam, srcpathstr); if (getenv("GCCMELT_SOURCE_PATH")) inform (UNKNOWN_LOCATION, "MELT tried from GCCMELT_SOURCE_PATH=%s environment variable", getenv("GCCMELT_SOURCE_PATH")); inform (UNKNOWN_LOCATION, "builtin MELT source directory is %s", melt_source_dir); if (melt_trace_source_fil) fflush (melt_trace_source_fil); else inform (UNKNOWN_LOCATION, "You could set the GCCMELT_TRACE_SOURCE env.var. to some file path for debugging"); melt_fatal_error ("cannot open MELT source file %s - %m", filnam); } /* warn if the filename has strange characters in its base name, notably + */ { const char* filbase = 0; int warn = 0; for (filbase = melt_basename (filnamdup); *filbase; filbase++) { if (ISALNUM (*filbase) || *filbase=='-' || *filbase=='_' || *filbase=='.') continue; warn = 1; } if (warn) warning (0, "MELT file name %s has strange characters", filnamdup); } MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_read_file start reading %s", filnamdup); /* debugeprintf ("starting loading file %s", filnamdup); */ rds.rfil = fil; rds.rpath = filnamdup; rds.rlineno = 0; (void) linemap_add (line_table, LC_ENTER, false, filnamdup, 0); locnamv = meltgc_new_stringdup ((meltobject_ptr_t) MELT_PREDEF (DISCR_STRING), locnam); rds.rpfilnam = (melt_ptr_t *) & locnamv; rds.rhas_file_location = true; rds.readmagic = MELT_READING_MAGIC; if (setjmp (rds.readjmpbuf)) { warning (0, "MELT reading of file %s failed", filnamdup); seqv = NULL; goto end; } rd = &rds; seqv = meltgc_new_list ((meltobject_ptr_t) MELT_PREDEF (DISCR_LIST)); while (!rdeof ()) { bool got = FALSE; location_t loc = 0; melt_skipspace_getc (rd, COMMENT_SKIP); if (rdeof ()) break; loc = rd->rsrcloc; MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_read_file @ %s:%d:%d", melt_basename(LOCATION_FILE(loc)), LOCATION_LINE (loc), LOCATION_COLUMN(loc)); valv = meltgc_readval (rd, &got); if (!got) MELT_READ_ERROR ("MELT: no value read %.20s", &rdcurc ()); meltgc_append_list ((melt_ptr_t) seqv, (melt_ptr_t) valv); }; if (rds.rfil) fclose (rds.rfil); linemap_add (line_table, LC_LEAVE, false, NULL, 0); memset (&rds, 0, sizeof(rds)); rd = 0; end: if (!seqv) { debugeprintf ("meltgc_read_file filnam %s fail & return NULL", filnamdup); warning(0, "MELT file %s read without content, perhaps failed.", filnamdup); } else debugeprintf ("meltgc_read_file filnam %s return list of %d elem", filnamdup, melt_list_length ((melt_ptr_t) seqv)); MELT_EXITFRAME (); return (melt_ptr_t) seqv; #undef vecshv #undef locnamv #undef seqv #undef valv } melt_ptr_t meltgc_read_from_rawstring (const char *rawstr, const char *locnam, location_t loch) { #if MELT_HAVE_DEBUG char curlocbuf[140]; #endif struct melt_reading_st rds; char *rbuf = 0; struct melt_reading_st *rd = 0; MELT_ENTERFRAME (3, NULL); #define seqv meltfram__.mcfr_varptr[0] #define locnamv meltfram__.mcfr_varptr[1] #define valv meltfram__.mcfr_varptr[2] memset (&rds, 0, sizeof (rds)); if (!rawstr) goto end; rbuf = xstrdup (rawstr); rds.rfil = 0; rds.rpath = 0; rds.rlineno = 0; rds.rcurlin = rbuf; rds.rsrcloc = loch; rd = &rds; if (locnam) { rds.rhas_file_location = true; locnamv = meltgc_new_stringdup ((meltobject_ptr_t) MELT_PREDEF (DISCR_STRING), locnam); MELT_LOCATION_HERE_PRINTF(curlocbuf, "meltgc_read_from_rawstring locnam=%s", locnam); } else { static long bufcount; char locnambuf[64]; bufcount++; snprintf (locnambuf, sizeof (locnambuf), "", bufcount); rds.rhas_file_location = false; locnamv = meltgc_new_string ((meltobject_ptr_t) MELT_PREDEF(DISCR_STRING), locnambuf); MELT_LOCATION_HERE_PRINTF(curlocbuf, "meltgc_read_from_rawstring rawstr=%.50s", rawstr); } seqv = meltgc_new_list ((meltobject_ptr_t) MELT_PREDEF (DISCR_LIST)); rds.readmagic = MELT_READING_MAGIC; if (setjmp (rds.readjmpbuf)) { warning (0, "MELT reading of string %s failed", melt_string_str ((melt_ptr_t) locnamv)); seqv = NULL; goto end; } rds.rpfilnam = (melt_ptr_t *) & locnamv; while (rdcurc ()) { bool got = FALSE; melt_skipspace_getc (rd, COMMENT_SKIP); if (!rdcurc () || rdeof ()) break; valv = meltgc_readval (rd, &got); if (!got) MELT_READ_ERROR ("MELT: no value read %.20s", &rdcurc ()); meltgc_append_list ((melt_ptr_t) seqv, (melt_ptr_t) valv); }; rd = 0; free (rbuf); end: MELT_EXITFRAME (); return (melt_ptr_t) seqv; #undef vecshv #undef seqv #undef locnamv #undef valv } melt_ptr_t meltgc_read_from_val (melt_ptr_t strv_p, melt_ptr_t locnam_p) { static long parsecount; #if MELT_HAVE_DEBUG char curlocbuf[140]; #endif struct melt_reading_st rds; char *rbuf = 0; struct melt_reading_st *rd = 0; int strmagic = 0; MELT_ENTERFRAME (4, NULL); #define valv meltfram__.mcfr_varptr[0] #define locnamv meltfram__.mcfr_varptr[1] #define seqv meltfram__.mcfr_varptr[2] #define strv meltfram__.mcfr_varptr[3] memset (&rds, 0, sizeof (rds)); strv = strv_p; locnamv = locnam_p; rbuf = 0; strmagic = melt_magic_discr ((melt_ptr_t) strv); seqv = meltgc_new_list ((meltobject_ptr_t) MELT_PREDEF (DISCR_LIST)); switch (strmagic) { case MELTOBMAG_STRING: rbuf = (char *) xstrdup (melt_string_str ((melt_ptr_t) strv)); break; case MELTOBMAG_STRBUF: rbuf = xstrdup (melt_strbuf_str ((melt_ptr_t) strv)); break; case MELTOBMAG_OBJECT: if (melt_is_instance_of ((melt_ptr_t) strv, (melt_ptr_t) MELT_PREDEF (CLASS_NAMED))) strv = melt_object_nth_field ((melt_ptr_t) strv, MELTFIELD_NAMED_NAME); else strv = NULL; if (melt_string_str ((melt_ptr_t) strv)) rbuf = xstrdup (melt_string_str ((melt_ptr_t) strv)); break; default: break; } if (!rbuf) goto end; parsecount++; rds.rfil = 0; rds.rpath = 0; rds.rlineno = 0; rds.rcurlin = rbuf; rds.rhas_file_location = true; rd = &rds; rds.readmagic = MELT_READING_MAGIC; if (setjmp (rds.readjmpbuf)) { warning (0, "MELT reading from value failed"); seqv = NULL; goto end; } MELT_LOCATION_HERE_PRINTF(curlocbuf, "meltgc_read_from_val rbuf=%.70s", rbuf); if (locnamv == NULL) { char buf[40]; memset(buf, 0, sizeof(buf)); snprintf (buf, sizeof(buf), "", parsecount); rds.rhas_file_location = false; locnamv = meltgc_new_string ((meltobject_ptr_t) MELT_PREDEF(DISCR_STRING), buf); rd->rpfilnam = (melt_ptr_t *) &locnamv; } rds.rpfilnam = (melt_ptr_t *) & locnamv; while (rdcurc ()) { bool got = FALSE; melt_skipspace_getc (rd, COMMENT_SKIP); if (!rdcurc () || rdeof ()) break; valv = meltgc_readval (rd, &got); if (!got) MELT_READ_ERROR ("MELT: no value read %.20s", &rdcurc ()); meltgc_append_list ((melt_ptr_t) seqv, (melt_ptr_t) valv); }; rd = 0; free (rbuf); end: MELT_EXITFRAME (); return (melt_ptr_t) seqv; #undef vecshv #undef locnamv #undef seqv #undef strv #undef valv } /* handle a "melt" attribute */ static tree handle_melt_attribute(tree *node, tree name, tree args, int flag ATTRIBUTE_UNUSED, bool *no_add_attrs ATTRIBUTE_UNUSED) { tree decl = *node; tree id = 0; const char* attrstr = 0; id = TREE_VALUE (args); if (TREE_CODE (id) != STRING_CST) { error ("melt attribute argument not a string"); return NULL_TREE; } attrstr = TREE_STRING_POINTER (id); melt_handle_melt_attribute (decl, name, attrstr, input_location); return NULL_TREE; } static struct attribute_spec /* See tree.h for details. */ melt_attr_spec = { "melt" /*=name*/, 1 /*=min_length*/, 1 /*=max_length*/, true /*=decl_required*/, false /*=type_required*/, false /*=function_type_required*/, handle_melt_attribute /*=handler*/, #if MELT_GCC_VERSION >= 4007 false /*=affects_type_identity*/, #endif }; /* the plugin callback to register melt attributes */ static void melt_attribute_callback (void *gcc_data ATTRIBUTE_UNUSED, void* user_data ATTRIBUTE_UNUSED) { register_attribute(&melt_attr_spec); } /* We declare weak functions because they cannot be linked when we use lto (it loses langage specific informations). If you use one of those functions you must check them to be not NULL. */ extern enum cpp_ttype __attribute__((weak)) pragma_lex (tree *); /* Test for GCC > 4.6.0. This should work even in the crazy cases, e.g. we compile melt.so with a gcc-4.3 for gcc-4.7! */ #if MELT_GCC_VERSION > 4006 /* Full pragma with data support. */ /* Call the MELT function which handle pragma: it is one of the handler of the list sysdata_meltpragmas. First argument is a tree containing the operator and the second argument contains a list of tree (the arguments of the pragma). Third argument is the index of the handler to use (in list sysdata_meltpragmas). */ void melt_handle_melt_pragma (melt_ptr_t optreev, melt_ptr_t listargtreev, long i_handler); extern void __attribute__((weak)) c_register_pragma_with_expansion_and_data (const char *space, const char *name, pragma_handler_2arg handler, void *data); /* Handle a melt pragma: data contains the index of the pragma handler. */ static void handle_melt_pragma (cpp_reader *ARG_UNUSED(dummy), void *data) { enum cpp_ttype token; /* List containing the pragma arguments . */ tree x; long i_handler = (long) data; MELT_ENTERFRAME (3, NULL); #define seqv meltfram__.mcfr_varptr[0] #define treev meltfram__.mcfr_varptr[1] #define optreev meltfram__.mcfr_varptr[2] if (!pragma_lex || !c_register_pragma_with_expansion_and_data) fatal_error ("Cannot use pragma symbol at this level \ (maybe you use -flto which is incompatible)."); MELT_LOCATION_HERE ("handle_melt_pragma"); MELT_CHECK_SIGNAL (); token = pragma_lex (&x); if (token != CPP_NAME) { error ("malformed #pragma melt, ignored"); goto end; } optreev = meltgc_new_tree ((meltobject_ptr_t) MELT_PREDEF (DISCR_TREE), x); /* If the pragma has the form #pragma MELT name id (...) then optreev is the tree containing "id". */ /* Next element should be a parenthesis opening. */ token = pragma_lex (&x); if (token != CPP_OPEN_PAREN) { if (token != CPP_EOF) { error ("malformed #pragma melt, ignored"); goto end; } else { /* We have a pragma of the type '#pragma MELT name instr'. */ melt_handle_melt_pragma ((melt_ptr_t ) optreev, (melt_ptr_t ) NULL, i_handler); } } else { /* Opening parenthesis. */ seqv = meltgc_new_list ((meltobject_ptr_t) MELT_PREDEF (DISCR_LIST)); do { token = pragma_lex (&x); if(token != CPP_NAME && token != CPP_STRING && token != CPP_NUMBER) { error ("malformed #pragma melt, ignored"); goto end; } /* Convert gcc tree into a boxed tree. */ treev = meltgc_new_tree ((meltobject_ptr_t) MELT_PREDEF (DISCR_TREE), x); /* Put the arg in IDENTIFIER_POINTER (x) in a list. */ meltgc_append_list ((melt_ptr_t) seqv, (melt_ptr_t) treev); token = pragma_lex (&x); } while (token == CPP_COMMA); if (token == CPP_CLOSE_PAREN && pragma_lex (&x) == CPP_EOF) melt_handle_melt_pragma ((melt_ptr_t ) optreev, (melt_ptr_t ) seqv, i_handler); else { error ("malformed #pragma melt, ignored"); goto end; } } end: MELT_EXITFRAME (); #undef seqv #undef treev #undef optreev } /* We accept a full pragma handling, with the possibility of having the name defined by the plugin. We use the data field of c_register_pragma_with_expansion_and_data to give the index (as a long) of the handler in the list of defined handler. To be accepted the pragma must have the following form: #pragma MELT plugin_name op or #pragma MELT plugin_name op (arg1, arg2 , ...) with argX as a name, a string or a number. */ static void melt_pragma_callback (void *gcc_data ATTRIBUTE_UNUSED, void *user_data ATTRIBUTE_UNUSED) { long i_handler, nb_pragma = 0; /* Recover the sysdata_meltpragma_list. */ MELT_ENTERFRAME (4, NULL); #define mulpragmav meltfram__.mcfr_varptr[0] #define cgccpragmav meltfram__.mcfr_varptr[1] #define pragmastrv meltfram__.mcfr_varptr[2] mulpragmav = melt_get_inisysdata (MELTFIELD_SYSDATA_MELTPRAGMAS); if (melt_magic_discr ((melt_ptr_t) mulpragmav) != MELTOBMAG_MULTIPLE) goto end; nb_pragma = (long) (((meltmultiple_ptr_t) mulpragmav)->nbval); MELT_LOCATION_HERE ("melt_pragma_callback"); MELT_CHECK_SIGNAL (); for (i_handler = 0; i_handler < (long) nb_pragma; i_handler++) { cgccpragmav = (( struct meltmultiple_st *) mulpragmav)->tabval[i_handler]; if (!melt_is_instance_of ((melt_ptr_t) cgccpragmav , ( melt_ptr_t) MELT_PREDEF (CLASS_GCC_PRAGMA))) { fatal_error("MELTFIELD_SYSDATA_MELTPRAGMAS must contains only \ CLASS_GCC_PRAGMA object."); } pragmastrv = melt_object_nth_field ((melt_ptr_t) cgccpragmav, MELTFIELD_NAMED_NAME); /* Register a new pass with the name registered in gcc_pragma object. We give it as data too, in order to use it in the handler. */ c_register_pragma_with_expansion_and_data ("MELT", melt_string_str ((melt_ptr_t) pragmastrv), handle_melt_pragma, ((void *) i_handler)); } end: MELT_EXITFRAME () ; #undef mulpragmav #undef cgccpragmav #undef pragmastrv } void melt_handle_melt_pragma (melt_ptr_t optreev, melt_ptr_t listargtreev, long i_handler) { MELT_ENTERFRAME (4, NULL); #define pragclov meltfram__.mcfr_varptr[0] #define cgccpragmav meltfram__.mcfr_varptr[1] #define seqv meltfram__.mcfr_varptr[2] #define mulpragmav meltfram__.mcfr_varptr[3] seqv = listargtreev; /* We first recover the list of the handler. */ mulpragmav = melt_get_inisysdata (MELTFIELD_SYSDATA_MELTPRAGMAS); if (melt_magic_discr ((melt_ptr_t) mulpragmav) != MELTOBMAG_MULTIPLE) { error ("MELT error : invalid pragma handling : field MELTFIELD_SYSDATA_MELTPRAGMAS \ should contain a multiple!"); goto end; } MELT_LOCATION_HERE ("melt_handle_melt_pragma"); MELT_CHECK_SIGNAL (); /* We use the i_handler to find the good handler (index handler). */ cgccpragmav = melt_multiple_nth ((melt_ptr_t) mulpragmav, i_handler); if (cgccpragmav == NULL) { error ("MELT error : invalid pragma handling : Invalid index %ld for the \ handler list defined in MELTFIELD_SYSDATA_MELTPRAGMAS!", i_handler); goto end; } pragclov = melt_object_nth_field((melt_ptr_t) cgccpragmav, MELTFIELD_GCCPRAGMA_HANDLER); /* We have the good handler, so we apply it. */ if (melt_magic_discr ((melt_ptr_t) pragclov) == MELTOBMAG_CLOSURE) { union meltparam_un pararg[1]; pararg[0].meltbp_aptr = (melt_ptr_t *) &seqv; (void) melt_apply ((meltclosure_ptr_t) pragclov, (melt_ptr_t) optreev, MELTBPARSTR_PTR , pararg, "", NULL); goto end; } else { error ("MELT error : invalid pragma handling : pragma_handler field not \ found in class_gcc_pragma!"); goto end; } end: MELT_EXITFRAME (); #undef mulpragmav #undef pragclov #undef cgccpragmav #undef seqv } #else /* Limited pragma handling (only one pragma name which is always 'melt'. */ void melt_handle_melt_pragma (melt_ptr_t optreev, melt_ptr_t listargtreev); extern void __attribute__((weak)) c_register_pragma_with_expansion (const char *, const char *, pragma_handler); /* Handle a melt pragma. */ static void handle_melt_pragma (cpp_reader *ARG_UNUSED(dummy)) { enum cpp_ttype token; /* List containing the pragma argument. */ tree x; MELT_ENTERFRAME (3, NULL); #define seqv meltfram__.mcfr_varptr[0] #define treev meltfram__.mcfr_varptr[1] #define optreev meltfram__.mcfr_varptr[2] if (! pragma_lex || ! c_register_pragma_with_expansion) fatal_error("Cannot use pragma symbol at this level (maybe you use -flto \ which is incompatible)."); MELT_LOCATION_HERE ("handle_melt_pragma"); MELT_CHECK_SIGNAL (); token = pragma_lex (&x); if (token != CPP_NAME) { error ("malformed #pragma melt, ignored"); goto end; } optreev = meltgc_new_tree ((meltobject_ptr_t) MELT_PREDEF (DISCR_TREE), x); /* If the pragma has the form #pragma PLUGIN melt id (...) then optreev is the tree containing "id". Next element should be a parenthesis opening. */ token = pragma_lex (&x); if (token != CPP_OPEN_PAREN) { if (token != CPP_EOF) { error ("malformed #pragma melt, ignored"); goto end; } else { /* We have a pragma of the type '#pragma PLUGIN melt instr'. */ melt_handle_melt_pragma ((melt_ptr_t ) optreev, (melt_ptr_t ) NULL); } } else { /* Opening parenthesis. */ seqv = meltgc_new_list ((meltobject_ptr_t) MELT_PREDEF (DISCR_LIST)); do { token = pragma_lex (&x); if(token != CPP_NAME && token != CPP_STRING && token != CPP_NUMBER) { error ("malformed #pragma melt, ignored"); goto end; } /* Convert gcc tree into a boxed tree. */ treev = meltgc_new_tree ((meltobject_ptr_t) MELT_PREDEF (DISCR_TREE), x); /* Put the arg in IDENTIFIER_POINTER (x) in a list. */ meltgc_append_list ((melt_ptr_t) seqv, (melt_ptr_t) treev); token = pragma_lex (&x); } while (token == CPP_COMMA); if (token == CPP_CLOSE_PAREN && pragma_lex(&x) == CPP_EOF) melt_handle_melt_pragma ((melt_ptr_t ) optreev, (melt_ptr_t ) seqv); else { error ("malformed #pragma melt, ignored"); goto end; } } end: MELT_EXITFRAME () ; #undef seqv #undef treev #undef optreev } /*Call the MELT function which handle pragma (sysdata_meltpragmas) and give as first argument a tree containing the operator and a second argument containing a list of tree (the arguments of the pragma). */ void melt_handle_melt_pragma (melt_ptr_t optreev, melt_ptr_t listargtreev) { MELT_ENTERFRAME (4, NULL); #define mulpragmav meltfram__.mcfr_varptr[0] #define cgccpragmav meltfram__.mcfr_varptr[1] #define pragclov meltfram__.mcfr_varptr[2] #define seqv meltfram__.mcfr_varptr[3] seqv = listargtreev; /* MELTFIELD_SYSDATA_MELTPRAGMAS is a list containing only one pragma handler (as we are in GCC 4.6 support mode). */ mulpragmav = melt_get_inisysdata (MELTFIELD_SYSDATA_MELTPRAGMAS); if (melt_magic_discr ((melt_ptr_t) mulpragmav) != MELTOBMAG_MULTIPLE) { error ("MELT error : invalid pragma handling : field MELTFIELD_SYSDATA_MELTPRAGMAS \ should contain a multiple!"); goto end; } MELT_LOCATION_HERE ("melt_handle_melt_pragma"); MELT_CHECK_SIGNAL (); cgccpragmav = melt_multiple_nth ((melt_ptr_t) mulpragmav, 0); pragclov = melt_object_nth_field((melt_ptr_t) cgccpragmav, MELTFIELD_GCCPRAGMA_HANDLER); if (melt_magic_discr ((melt_ptr_t) pragclov) == MELTOBMAG_CLOSURE) { union meltparam_un pararg[1]; pararg[0].meltbp_aptr = (melt_ptr_t *) & seqv; (void) melt_apply ((meltclosure_ptr_t) pragclov, (melt_ptr_t) optreev, MELTBPARSTR_PTR , pararg, "", NULL); goto end; } else { error ("MELT error : invalid pragma handling : pragma_handler \ field not found in class_gcc_pragma!"); goto end; } end: MELT_EXITFRAME (); #undef cgccpragmav #undef mulpragmav #undef pragclov #undef seqv } static void melt_pragma_callback (void *gcc_data ATTRIBUTE_UNUSED, void* user_data ATTRIBUTE_UNUSED) { c_register_pragma_with_expansion ("GCCPLUGIN", "melt", handle_melt_pragma); } #endif /*GCC >4.6 for handling pragma support*/ /* This function is used when PLUGIN_PRE_GENERICIZE callback is invoked. It calls the closure registered in field sydata_pre_genericize of initial_system_data. The first argument is the tree containing the function declaration (as given in file gcc/c-decl.c). */ static void melt_pre_genericize_callback (void *ptr_fndecl, void *user_data ATTRIBUTE_UNUSED) { int pregenmagic = 0; MELT_ENTERFRAME (2, NULL); #define pregenv meltfram__.mcfr_varptr[0] #define fndeclv meltfram__.mcfr_varptr[1] fndeclv = meltgc_new_tree ((meltobject_ptr_t) MELT_PREDEF (DISCR_TREE), ((tree) ptr_fndecl)); pregenv = melt_get_inisysdata (MELTFIELD_SYSDATA_PRE_GENERICIZE); pregenmagic = melt_magic_discr ((melt_ptr_t) pregenv); MELT_LOCATION_HERE ("melt_pre_genericize_callback"); MELT_CHECK_SIGNAL (); if (pregenmagic == MELTOBMAG_CLOSURE) { MELT_LOCATION_HERE ("melt_pre_genericize before applying pre_genericize closure"); (void) melt_apply ((meltclosure_ptr_t) pregenv, (melt_ptr_t) fndeclv, "", NULL, "", NULL); } MELT_EXITFRAME (); #undef fndeclv #undef pregenclosv } /* the plugin callback when starting a compilation unit */ static void melt_startunit_callback(void *gcc_data ATTRIBUTE_UNUSED, void* user_data ATTRIBUTE_UNUSED) { MELT_ENTERFRAME (1, NULL); #define staclosv meltfram__.mcfr_varptr[0] MELT_LOCATION_HERE ("melt_startunit_callback"); MELT_CHECK_SIGNAL (); staclosv = melt_get_inisysdata (MELTFIELD_SYSDATA_UNIT_STARTER); if (melt_magic_discr ((melt_ptr_t) staclosv) == MELTOBMAG_CLOSURE) { (void) melt_apply ((meltclosure_ptr_t) staclosv, (melt_ptr_t) NULL, "", NULL, "", NULL); } MELT_EXITFRAME (); #undef staclosv } /* the plugin callback when finishing a compilation unit */ static void melt_finishunit_callback(void *gcc_data ATTRIBUTE_UNUSED, void* user_data ATTRIBUTE_UNUSED) { MELT_ENTERFRAME (1, NULL); #define finclosv meltfram__.mcfr_varptr[0] finclosv = melt_get_inisysdata (MELTFIELD_SYSDATA_UNIT_FINISHER); MELT_LOCATION_HERE ("melt_finishunit_callback"); MELT_CHECK_SIGNAL (); if (melt_magic_discr ((melt_ptr_t) finclosv) == MELTOBMAG_CLOSURE) { MELT_LOCATION_HERE ("melt_finishunit_callback before applying finish unit closure"); (void) melt_apply ((meltclosure_ptr_t) finclosv, (melt_ptr_t) NULL, "", NULL, "", NULL); } /* Always force a minor GC to be sure nothing stays in young region */ melt_garbcoll (0, MELT_ONLY_MINOR); debugeprintf ("ending melt_finishunit_callback meltnbgc %ld", melt_nb_garbcoll); MELT_EXITFRAME (); #undef finclosv } /* The plugin callback for pass execution. */ static void meltgc_passexec_callback (void *gcc_data, void* user_data ATTRIBUTE_UNUSED) { struct opt_pass* pass = (struct opt_pass*) gcc_data; MELT_ENTERFRAME (2, NULL); #define passxhv meltfram__.mcfr_varptr[0] #define passnamev meltfram__.mcfr_varptr[1] passxhv = melt_get_inisysdata (MELTFIELD_SYSDATA_PASSEXEC_HOOK); MELT_LOCATION_HERE ("meltgc_passexec_callback"); MELT_CHECK_SIGNAL (); if (!passxhv) goto end; debugeprintf ("meltgc_passexec_callback pass %p named %s passxhv %p", (void*) pass, pass?pass->name:"_none_", passxhv); gcc_assert (pass != NULL); if (melt_magic_discr((melt_ptr_t) passxhv) == MELTOBMAG_CLOSURE) { char curlocbuf[96]; union meltparam_un pararg[1]; memset (¶rg, 0, sizeof (pararg)); pararg[0].meltbp_long = pass->static_pass_number; MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_passexec_callback pass %p named %s #%d", (void*) pass, pass->name, pass->static_pass_number); if (pass->name) passnamev = meltgc_new_stringdup ((meltobject_ptr_t) MELT_PREDEF(DISCR_STRING), pass->name); #if MELT_HAVE_DEBUG { static char locbuf[110]; memset (locbuf, 0, sizeof (locbuf)); MELT_LOCATION_HERE_PRINTF(locbuf, "meltgc_passexec_callback [pass %s #%d] before apply", pass->name, pass->static_pass_number); } #endif debugeprintf ("meltgc_passexec_callback before apply pass @ %p %s #%d", (void*)pass, pass->name, pass->static_pass_number); (void) melt_apply ((meltclosure_ptr_t) passxhv, (melt_ptr_t) passnamev, MELTBPARSTR_LONG, pararg, "", NULL); debugeprintf ("meltgc_passexec_callback after apply pass @ %p %s #%d", (void*)pass, pass->name, pass->static_pass_number); } #undef passxhv #undef passnamev end: MELT_EXITFRAME (); } static void do_finalize_melt (void); /* the plugin callback when finishing all */ static void melt_finishall_callback(void *gcc_data ATTRIBUTE_UNUSED, void* user_data ATTRIBUTE_UNUSED) { do_finalize_melt (); } /***** * Support for PLUGIN_ALL_PASSES_START; invoked in file * tree-optimize.c function tree_rest_of_compilation *****/ static void meltgc_all_passes_start_callback (void *gcc_data ATTRIBUTE_UNUSED, void* user_data ATTRIBUTE_UNUSED) { MELT_ENTERFRAME (1, NULL); #define closv meltfram__.mcfr_varptr[0] closv = melt_get_inisysdata (MELTFIELD_SYSDATA_ALL_PASSES_START_HOOK); if (closv && melt_magic_discr((melt_ptr_t)closv) == MELTOBMAG_CLOSURE) { MELT_LOCATION_HERE ("all_passes_start_callback applying"); (void) melt_apply ((meltclosure_ptr_t) closv, NULL, "", NULL, "", NULL); } MELT_EXITFRAME (); #undef closv } /***** * Support for PLUGIN_ALL_PASSES_END; invoked in file * tree-optimize.c function tree_rest_of_compilation *****/ static void meltgc_all_passes_end_callback (void *gcc_data ATTRIBUTE_UNUSED, void* user_data ATTRIBUTE_UNUSED) { MELT_ENTERFRAME (1, NULL); #define closv meltfram__.mcfr_varptr[0] closv = melt_get_inisysdata (MELTFIELD_SYSDATA_ALL_PASSES_END_HOOK); if (closv && melt_magic_discr((melt_ptr_t)closv) == MELTOBMAG_CLOSURE) { MELT_LOCATION_HERE ("all_passes_end_callback applying"); (void) melt_apply ((meltclosure_ptr_t) closv, NULL, "", NULL, "", NULL); } MELT_EXITFRAME (); #undef closv } /***** * Support for PLUGIN_ALL_IPA_PASSES_START; invoked in file * cgraphunit.c function ipa_passes *****/ static void meltgc_all_ipa_passes_start_callback (void *gcc_data ATTRIBUTE_UNUSED, void* user_data ATTRIBUTE_UNUSED) { MELT_ENTERFRAME (1, NULL); #define closv meltfram__.mcfr_varptr[0] closv = melt_get_inisysdata (MELTFIELD_SYSDATA_ALL_IPA_PASSES_START_HOOK); if (closv && melt_magic_discr((melt_ptr_t)closv) == MELTOBMAG_CLOSURE) { MELT_LOCATION_HERE ("all_ipa_passes_start_callback applying"); (void) melt_apply ((meltclosure_ptr_t) closv, NULL, "", NULL, "", NULL); } MELT_EXITFRAME (); #undef closv } /***** * Support for PLUGIN_ALL_IPA_PASSES_END; invoked in file * cgraphunit.c function ipa_passes *****/ static void meltgc_all_ipa_passes_end_callback (void *gcc_data ATTRIBUTE_UNUSED, void* user_data ATTRIBUTE_UNUSED) { MELT_ENTERFRAME (1, NULL); #define closv meltfram__.mcfr_varptr[0] closv = melt_get_inisysdata (MELTFIELD_SYSDATA_ALL_IPA_PASSES_END_HOOK); if (closv && melt_magic_discr((melt_ptr_t)closv) == MELTOBMAG_CLOSURE) { MELT_LOCATION_HERE ("all_ipa_passes_end_callback applying"); (void) melt_apply ((meltclosure_ptr_t) closv, NULL, "", NULL, "", NULL); } MELT_EXITFRAME (); #undef closv } /***** * Support for PLUGIN_EARLY_GIMPLE_PASSES_START; invoked in file * passes.c function execute_ipa_pass_list *****/ static void meltgc_early_gimple_passes_start_callback (void *gcc_data ATTRIBUTE_UNUSED, void* user_data ATTRIBUTE_UNUSED) { MELT_ENTERFRAME (1, NULL); #define closv meltfram__.mcfr_varptr[0] closv = melt_get_inisysdata (MELTFIELD_SYSDATA_EARLY_GIMPLE_PASSES_START_HOOK); if (closv && melt_magic_discr((melt_ptr_t)closv) == MELTOBMAG_CLOSURE) { MELT_LOCATION_HERE ("early_gimple_passes_start_callback applying"); (void) melt_apply ((meltclosure_ptr_t) closv, NULL, "", NULL, "", NULL); } MELT_EXITFRAME (); #undef closv } /***** * Support for PLUGIN_EARLY_GIMPLE_PASSES_END; invoked in file * passes.c function execute_ipa_pass_list *****/ static void meltgc_early_gimple_passes_end_callback (void *gcc_data ATTRIBUTE_UNUSED, void* user_data ATTRIBUTE_UNUSED) { MELT_ENTERFRAME (1, NULL); #define closv meltfram__.mcfr_varptr[0] closv = melt_get_inisysdata (MELTFIELD_SYSDATA_EARLY_GIMPLE_PASSES_END_HOOK); if (closv && melt_magic_discr((melt_ptr_t)closv) == MELTOBMAG_CLOSURE) { MELT_LOCATION_HERE ("early_gimple_passes_end_callback applying"); (void) melt_apply ((meltclosure_ptr_t) closv, NULL, "", NULL, "", NULL); } MELT_EXITFRAME (); #undef closv } /* Utility function to parse a C-encoded string in a line from a FOO*+meltdesc.c file; the argument should point to the starting double-quote "; returns a malloc-ed string. The C-encoded string has been produced with meltgc_add_out_cstr_len and friends like meltgc_add_strbuf_cstr... */ static char * melt_c_string_in_descr (const char* p) { char *res = NULL; struct obstack obs; if (!p || p[0] != '"') return NULL; memset (&obs, 0, sizeof(obs)); obstack_init (&obs); p++; while (*p && *p != '"') { if (*p == '\\') { p++; switch (*p) { case 'n': obstack_1grow (&obs, '\n'); p++; break; case 'r': obstack_1grow (&obs, '\r'); p++; break; case 't': obstack_1grow (&obs, '\t'); p++; break; case 'f': obstack_1grow (&obs, '\f'); p++; break; case 'v': obstack_1grow (&obs, '\v'); p++; break; case '\'': obstack_1grow (&obs, '\''); p++; break; case '"': obstack_1grow (&obs, '\"'); p++; break; case '\\': obstack_1grow (&obs, '\\'); p++; break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': { int c = 0; if (*p >= '0' && *p <= '7') c = c*8 + (*p - '0'), p++; if (*p >= '0' && *p <= '7') c = c*8 + (*p - '0'), p++; if (*p >= '0' && *p <= '7') c = c*8 + (*p - '0'), p++; obstack_1grow (&obs, (char)c); break; } case 'x': { char hexbuf[4] = {0,0,0,0}; int c = 0; p++; if (ISXDIGIT(p[0])) hexbuf[0] = p[0]; if (ISXDIGIT(p[1])) hexbuf[1] = p[1]; p += strlen(hexbuf); c = strtol (hexbuf, (char**)0, 16); obstack_1grow (&obs, (char)c); break; } default: obstack_1grow (&obs, *p); p++; break; } } else { obstack_1grow (&obs, *p); p++; } }; obstack_1grow (&obs, (char)0); res = xstrdup (XOBFINISH (&obs, char*)); obstack_free (&obs, NULL); return res; } /* Internal function to test if a given open file has the same md5sum as a given hex md5string. */ static int melt_same_md5sum_hex (const char* curpath, FILE* sfil, const char*md5hexstr) { char md5tab[16]; char md5hex[48]; int ix = 0; memset (md5tab, 0, sizeof(md5tab)); memset (md5hex, 0, sizeof(md5hex)); if (!curpath || !sfil || !md5hexstr) return 0; if (md5_stream (sfil, &md5tab)) melt_fatal_error ("failed to compute md5 of %s", curpath); for (ix = 0; ix < 16; ix++) { char hexb[4] = {0,0,0,0}; int curbyt = md5tab[ix] & 0xff; snprintf (hexb, sizeof(hexb)-1, "%02x", curbyt); md5hex[2*ix] = hexb[0]; md5hex[2*ix+1] = hexb[1]; } return !strcmp (md5hex, md5hexstr); } const char* melt_flavors_array[] = { "quicklybuilt", "optimized", "debugnoline", NULL }; /* Return a positive index, in the melt_modinfvec vector, of a module of given source base (the path, without "+meltdesc.c" suffix of the MELT descriptive file). This function don't run the melt_start_this_module routine of the loaded module, but does dlopen it. */ static int melt_load_module_index (const char*srcbase, const char*flavor, char**errorp) { int ix = -1; bool validh = FALSE; void *dlh = NULL; char *srcpath = NULL; char *sopath = NULL; char* sobase = NULL; FILE *descfil = NULL; char *descline = NULL; char* descversionmelt = NULL; char* descmodulename = NULL; char* desccumulatedhexmd5 = NULL; size_t descsize = 0; ssize_t desclinlen = 0; int desclinenum = 0; /* list of required dynamic symbols (dlsymed in the FOO module, provided in the FOO+meltdesc.c or FOO+melttime.h or FOO.c file) */ #define MELTDESCR_REQUIRED_LIST \ MELTDESCR_REQUIRED_SYMBOL (melt_build_timestamp, char); \ MELTDESCR_REQUIRED_SYMBOL (melt_cumulated_hexmd5, char); \ MELTDESCR_REQUIRED_SYMBOL (melt_gen_timenum, long long); \ MELTDESCR_REQUIRED_SYMBOL (melt_gen_timestamp, char); \ MELTDESCR_REQUIRED_SYMBOL (melt_lastsecfileindex, int); \ MELTDESCR_REQUIRED_SYMBOL (melt_modulename, char); \ MELTDESCR_REQUIRED_SYMBOL (melt_prepromd5meltrun, char); \ MELTDESCR_REQUIRED_SYMBOL (melt_primaryhexmd5, char); \ MELTDESCR_REQUIRED_SYMBOL (melt_secondaryhexmd5tab, char*); \ MELTDESCR_REQUIRED_SYMBOL (melt_versionmeltstr, char); \ MELTDESCR_REQUIRED_SYMBOL (melt_start_this_module, melt_start_rout_t) /* list of optional dynamic symbols (dlsymed in the module, provided in the FOO+meltdesc.c or FOO+melttime.h file). */ #define MELTDESCR_OPTIONAL_LIST \ MELTDESCR_OPTIONAL_SYMBOL (melt_versionstr, char); \ MELTDESCR_OPTIONAL_SYMBOL (melt_modulerealpath, char) /* declare our dynamic symbols */ #define MELTDESCR_REQUIRED_SYMBOL(Sym,Typ) Typ* dynr_##Sym = NULL MELTDESCR_REQUIRED_LIST; #undef MELTDESCR_REQUIRED_SYMBOL #define MELTDESCR_OPTIONAL_SYMBOL(Sym,Typ) Typ* dyno_##Sym = NULL MELTDESCR_OPTIONAL_LIST; #undef MELTDESCR_OPTIONAL_SYMBOL #define MELTDESCR_OPTIONAL(Sym) dyno_##Sym #define MELTDESCR_REQUIRED(Sym) dynr_##Sym debugeprintf ("melt_load_module_index start srcbase %s flavor %s", srcbase, flavor); if (errorp) *errorp = NULL; if (!srcbase) return -1; if (!flavor) flavor = MELT_DEFAULT_FLAVOR; if (!ISALNUM (flavor[0]) || strchr(flavor, '.') || strchr (flavor, '/') || strchr (flavor, '+')) melt_fatal_error ("invalid MELT flavor %s", flavor); /* open and parse the descriptive file. */ srcpath = concat (srcbase, MELT_DESC_FILESUFFIX, NULL); debugeprintf ("melt_load_module_index srcpath %s flavor %s", srcpath, flavor); descfil = fopen (srcpath, "r"); if (!descfil) { warning (0, "MELT failed to open descriptive file %s - %m", srcpath); goto end; } while (!feof (descfil)) { char *pc = NULL; char *pqu1 = NULL; char *pqu2 = NULL; desclinlen = getline (&descline, &descsize, descfil); desclinenum ++; if (desclinlen>0 && descline && descline[desclinlen-1] == '\n') descline[--desclinlen] = (char)0; if (desclinlen < 0) break; /* ignore comments and short lines */ if (desclinlen < 4) continue; if (descline[0] == '/' && descline[1] == '*') continue; if (descline[0] == '/' && descline[1] == '/') continue; /* ignore lines with extern "C" */ if (strstr(descline, "extern") && strstr(descline, "\"C\"")) continue; debugeprintf ("melt_load_module_index #%d,len%d: %s", desclinenum, (int) desclinlen, descline); /* parse the melt_versionmeltstr */ if (descversionmelt == NULL && (pc = strstr(descline, "melt_versionmeltstr[]")) != NULL && (pqu1 = strchr (pc, '"')) != NULL && (pqu2 = strchr (pqu1+1, '"')) != NULL && pqu2 > pqu1 + 10 /*actually should be more than 10*/) { descversionmelt = melt_c_string_in_descr (pqu1); debugeprintf ("melt_load_module_index found descversionmelt %s L%d", descversionmelt, desclinenum); } /* parse the melt_modulename */ if (descmodulename == NULL && (pc = strstr(descline, "melt_modulename[]")) != NULL && (pqu1 = strchr (pc, '"')) != NULL && (pqu2 = strchr (pqu1+1, '"')) != NULL) { descmodulename = melt_c_string_in_descr (pqu1); debugeprintf ("melt_load_module_index found descmodulename %s L%d", descmodulename, desclinenum); } /* parse the melt_cumulated_hexmd5 which should be not too short. */ if (desccumulatedhexmd5 == NULL && (pc = strstr(descline, "melt_cumulated_hexmd5[]")) != NULL && (pqu1 = strchr (pc, '"')) != NULL && (pqu2 = strchr (pqu1+2, '"')) != NULL && pqu2 > pqu1+10 /*maybe more than 10*/) { desccumulatedhexmd5 = melt_c_string_in_descr (pqu1); debugeprintf ("melt_load_module_index found desccumulatedhexmd5 %s L%d", desccumulatedhexmd5, desclinenum); } } if (descfil) fclose (descfil), descfil= NULL; debugeprintf ("melt_load_module_index srcpath %s after meltdescr parsing", srcpath); /* Perform simple checks */ if (!descmodulename) melt_fatal_error ("bad MELT descriptive file %s with no module name inside", srcpath); if (!descversionmelt) melt_fatal_error ("bad MELT descriptive file %s with no MELT version inside", srcpath); if (!desccumulatedhexmd5) melt_fatal_error ("bad MELT descriptive file %s with no cumulated hexmd5 inside", srcpath); if (strcmp (melt_basename (descmodulename), melt_basename (srcbase))) warning (0, "MELT module name %s in MELT descriptive file %s not as expected", descmodulename, srcpath); if (!melt_flag_bootstrapping && strcmp(descversionmelt, melt_version_str ())) warning (0, "MELT descriptive file %s for MELT version %s, but this MELT runtime is version %s", srcpath, descversionmelt, melt_version_str ()); /* Take care that the same file name should be given below, as argument to melt_compile_source. */ sobase = concat (melt_basename(descmodulename), ".meltmod-", desccumulatedhexmd5, ".", flavor, MELT_DYNLOADED_SUFFIX, NULL); debugeprintf ("melt_load_module_index long sobase %s workdir %s", sobase, melt_argument ("workdir")); if (melt_trace_module_fil) fprintf (melt_trace_module_fil, "base of module: %s\n", sobase); sopath = MELT_FIND_FILE (sobase, MELT_FILE_LOG, melt_trace_module_fil, /* First search in the temporary directory, but don't bother making it. */ MELT_FILE_IN_DIRECTORY, tempdir_melt, /* Search in the user provided work directory, if given. */ MELT_FILE_IN_DIRECTORY, melt_argument ("workdir"), /* Search in the user provided module path, if given. */ MELT_FILE_IN_PATH, melt_argument ("module-path"), /* Search using the GCCMELT_MODULE_PATH environment variable. */ MELT_FILE_IN_ENVIRON_PATH, melt_flag_bootstrapping?NULL:"GCCMELT_MODULE_PATH", /* Search in the built-in MELT module directory. */ MELT_FILE_IN_DIRECTORY, melt_flag_bootstrapping?NULL:melt_module_dir, /* Since the path is a complete path with an md5um in it, we also search in the current directory. */ MELT_FILE_IN_DIRECTORY, ".", NULL); debugeprintf ("melt_load_module_index sopath %s", sopath); /* Try also the other flavors when asked for default flavor. */ if (!sopath && !strcmp(flavor, MELT_DEFAULT_FLAVOR) && !melt_flag_bootstrapping) { const char* curflavor = NULL; char* cursobase = NULL; char* cursopath = NULL; int curflavorix; for (curflavorix=0; (curflavor=melt_flavors_array[curflavorix]) != NULL; curflavorix++) { debugeprintf ("melt_load_module_index curflavor %s curflavorix %d", curflavor, curflavorix); cursobase = concat (melt_basename(descmodulename), ".", desccumulatedhexmd5, ".", curflavor, MELT_DYNLOADED_SUFFIX, NULL); debugeprintf ("melt_load_module_index curflavor %s long cursobase %s workdir %s", curflavor, cursobase, melt_argument ("workdir")); cursopath = MELT_FIND_FILE (cursobase, MELT_FILE_LOG, melt_trace_module_fil, /* First search in the temporary directory, but don't bother making it. */ MELT_FILE_IN_DIRECTORY, tempdir_melt, /* Search in the user provided work directory, if given. */ MELT_FILE_IN_DIRECTORY, melt_argument ("workdir"), /* Search in the user provided module path, if given. */ MELT_FILE_IN_PATH, melt_argument ("module-path"), /* Search using the GCCMELT_MODULE_PATH environment variable. */ MELT_FILE_IN_ENVIRON_PATH, melt_flag_bootstrapping?NULL:"GCCMELT_MODULE_PATH", /* Search in the built-in MELT module directory. */ MELT_FILE_IN_DIRECTORY, melt_flag_bootstrapping?NULL:melt_module_dir, /* Since the path is a complete path with an md5um in it, we also search in the current directory. */ MELT_FILE_IN_DIRECTORY, ".", NULL); debugeprintf ("melt_load_module_index curflavorix=%d cursopath %s", curflavorix, cursopath); if (cursopath) { sopath = cursopath; inform (UNKNOWN_LOCATION, "MELT loading module %s instead of default flavor %s", cursopath, MELT_DEFAULT_FLAVOR); break; }; free (cursobase), cursobase = NULL; }; } /* Build the module if not found and the auto-build is not inhibited. */ if (!sopath && !melt_flag_bootstrapping && !melt_argument ("inhibit-auto-build")) { const char* worktmpdir = NULL; const char* binbase = NULL; worktmpdir = melt_argument("workdir"); if (!worktmpdir) worktmpdir = melt_tempdir_path (NULL, NULL); binbase = concat (worktmpdir, "/", melt_basename (srcbase), NULL); /* The same file name should be given above. */ sopath = concat (binbase, ".meltmod-", desccumulatedhexmd5, ".", flavor, MELT_DYNLOADED_SUFFIX, NULL); debugeprintf ("sopath %s", sopath); (void) remove (sopath); melt_compile_source (srcbase, binbase, worktmpdir, flavor); if (access (sopath, R_OK)) melt_fatal_error ("inaccessible MELT module %s after auto build - %m", sopath); } if (!sopath) { /* Show various informative error messages to help the user. */ if (sobase) error ("MELT failed to find module of base %s with module-path %s", sobase, melt_argument ("module-path")); if (tempdir_melt[0]) error ("MELT failed to find module of base %s in temporary dir %s", srcbase, tempdir_melt); if (melt_argument ("workdir")) error ("MELT failed to find module of base %s in work dir %s", srcbase, melt_argument ("workdir")); if (melt_argument ("module-path")) error ("MELT failed to find module of base %s in module-path %s", srcbase, melt_argument ("module-path")); if (getenv ("GCCMELT_MODULE_PATH")) error ("MELT failed to find module of base %s with GCCMELT_MODULE_PATH=%s", srcbase, getenv ("GCCMELT_MODULE_PATH")); if (!melt_flag_bootstrapping) error ("MELT failed to find module of base %s in builtin directory %s", srcbase, melt_module_dir); if (melt_trace_module_fil) fflush (melt_trace_module_fil); else inform (UNKNOWN_LOCATION, "You could set the GCCMELT_TRACE_MODULE env.var. to some file path for debugging"); melt_fatal_error ("No MELT module for source base %s flavor %s (parsed cumulated checksum %s)", srcbase, flavor, desccumulatedhexmd5 ? desccumulatedhexmd5 : "unknown"); } if (!IS_ABSOLUTE_PATH (sopath)) sopath = reconcat (sopath, getpwd (), "/", sopath, NULL); debugeprintf ("melt_load_module_index absolute sopath %s", sopath); if (access (sopath, R_OK)) melt_fatal_error ("Cannot access MELT module %s - %m", sopath); dlh = NULL; dlh = dlopen (sopath, RTLD_NOW | RTLD_GLOBAL); if (!dlh) melt_fatal_error ("Failed to dlopen MELT module %s - %s", sopath, dlerror ()); if (melt_trace_module_fil) fprintf (melt_trace_module_fil, "dlopened %s #%d\n", sopath, VEC_length (melt_module_info_t, melt_modinfvec)); validh = TRUE; /* Retrieve our dynamic symbols. */ #define MELTDESCR_UNION_SYMBOL(Sym,Typ) union { void* ptr_##Sym; \ Typ* dat_##Sym; } u_##Sym #define MELTDESCR_REQUIRED_SYMBOL(Sym,Typ) do { \ MELTDESCR_UNION_SYMBOL(Sym,Typ); \ u_##Sym.ptr_##Sym = (void*) dlsym (dlh, #Sym); \ debugeprintf ("melt_load_module_index req. " #Sym \ " %p validh %d", \ u_##Sym.ptr_##Sym, (int) validh); \ if (!u_##Sym.ptr_##Sym) { \ char* dler = dlerror (); \ debugeprintf("melt_load_module_index req. " #Sym \ " not found - %s", dler); \ if (dler && errorp && !*errorp) \ *errorp = concat("Cannot find " #Sym, "; ", \ dler, NULL); \ validh = FALSE; \ } else dynr_##Sym = u_##Sym.dat_##Sym; } while(0) MELTDESCR_REQUIRED_LIST; #undef MELTDESCR_REQUIRED_SYMBOL #define MELTDESCR_OPTIONAL_SYMBOL(Sym,Typ) do { \ MELTDESCR_UNION_SYMBOL(Sym,Typ); \ u_##Sym.ptr_##Sym = (void*) dlsym (dlh, #Sym); \ if (u_##Sym.ptr_##Sym) \ dyno_##Sym = u_##Sym.dat_##Sym; } while(0) MELTDESCR_OPTIONAL_LIST; #undef MELTDESCR_OPTIONAL_SYMBOL if (melt_flag_bootstrapping) { debugeprintf ("melt_load_module_index validh %d bootstrapping melt_modulename %s descmodulename %s", validh, MELTDESCR_REQUIRED (melt_modulename), descmodulename); validh = validh && !strcmp (melt_basename (MELTDESCR_REQUIRED (melt_modulename)), melt_basename (descmodulename)); } else { debugeprintf ("melt_load_module_index validh %d melt_modulename %s descmodulename %s", validh, MELTDESCR_REQUIRED (melt_modulename), descmodulename); validh = validh && !strcmp (MELTDESCR_REQUIRED (melt_modulename), descmodulename); } debugeprintf ("melt_load_module_index validh %d melt_cumulated_hexmd5 %s desccumulatedhexmd5 %s", validh, MELTDESCR_REQUIRED (melt_cumulated_hexmd5), desccumulatedhexmd5); validh = validh && !strcmp (MELTDESCR_REQUIRED (melt_cumulated_hexmd5), desccumulatedhexmd5); debugeprintf ("melt_load_module_index sopath %s validh %d melt_modulename %s melt_cumulated_hexmd5 %s", sopath, (int)validh, MELTDESCR_REQUIRED (melt_modulename), MELTDESCR_REQUIRED (melt_cumulated_hexmd5)); /* If the handle is still valid, perform some additional checks unless bootstrapping. Issue only warnings if something is wrong, because intrepid users might fail these checks on purpose. */ if (validh && !melt_flag_bootstrapping) { FILE *sfil = 0; char *curpath = 0; char *srcpath = 0; const char* srcpathstr = melt_argument ("source-path"); int nbsecfile = 0; int cursecix = 0; time_t gentim = 0; time_t nowt = 0; time (&nowt); if (strcmp (MELTDESCR_REQUIRED (melt_versionmeltstr), melt_version_str ())) warning (0, "MELT module %s for source %s has mismatching MELT version %s, expecting %s", sopath, srcbase, MELTDESCR_REQUIRED (melt_versionmeltstr), melt_version_str ()); if (strcmp (MELTDESCR_REQUIRED (melt_prepromd5meltrun), melt_run_preprocessed_md5)) warning (0, "MELT module %s for source %s has mismatching melt-run.h signature %s, expecting %s", sopath, srcbase, MELTDESCR_REQUIRED (melt_prepromd5meltrun), melt_run_preprocessed_md5); nbsecfile = *(MELTDESCR_REQUIRED(melt_lastsecfileindex)); debugeprintf ("melt_load_module_index descmodulename %s nbsecfile %d", descmodulename, nbsecfile); srcpath = concat (descmodulename, ".c", NULL); curpath = MELT_FIND_FILE (srcpath, MELT_FILE_LOG, melt_trace_source_fil, MELT_FILE_IN_DIRECTORY, ".", MELT_FILE_IN_PATH, srcpathstr, MELT_FILE_IN_ENVIRON_PATH, melt_flag_bootstrapping?NULL:"GCCMELT_SOURCE_PATH", MELT_FILE_IN_DIRECTORY, melt_source_dir, /* also search in the temporary directory, but don't bother making it. */ MELT_FILE_IN_DIRECTORY, tempdir_melt, /* Search in the user provided work directory, if given. */ MELT_FILE_IN_DIRECTORY, melt_argument ("workdir"), NULL); debugeprintf ("melt_load_module_index srcpath %s ", srcpath); debugeprintf ("melt_load_module_index curpath %s ", curpath); if (!curpath) warning (0, "MELT module %s cannot find its source path for base %s flavor %s", sopath, srcbase, flavor); else { sfil = fopen (curpath, "r"); if (!sfil) warning (0, "MELT module %s cannot open primary source file %s for %s - %m", sopath, curpath, srcbase); else { if (!melt_same_md5sum_hex (curpath, sfil, MELTDESCR_REQUIRED (melt_primaryhexmd5))) warning (0, "MELT primary source file %s has mismatching md5sum, expecting %s", curpath, MELTDESCR_REQUIRED (melt_primaryhexmd5)); fclose (sfil), sfil = NULL; }; } free (srcpath), srcpath = NULL; free (curpath), curpath = NULL; for (cursecix = 1; cursecix < nbsecfile; cursecix++) { char suffixbuf[32]; if (MELTDESCR_REQUIRED(melt_secondaryhexmd5tab)[cursecix] == NULL) continue; memset (suffixbuf, 0, sizeof(suffixbuf)); snprintf (suffixbuf, sizeof(suffixbuf)-1, "+%02d.c", cursecix); srcpath = concat (descmodulename, suffixbuf, NULL); curpath = MELT_FIND_FILE (srcpath, MELT_FILE_LOG, melt_trace_source_fil, MELT_FILE_IN_DIRECTORY, ".", MELT_FILE_IN_PATH, srcpathstr, MELT_FILE_IN_ENVIRON_PATH, melt_flag_bootstrapping?NULL:"GCCMELT_SOURCE_PATH", MELT_FILE_IN_DIRECTORY, melt_source_dir, NULL); debugeprintf ("melt_load_module_index srcpath %s ", srcpath); sfil = fopen (curpath, "r"); if (!sfil) warning (0, "MELT module %s cannot open secondary source file %s - %m", sopath, curpath); else { if (!melt_same_md5sum_hex (curpath, sfil, MELTDESCR_REQUIRED(melt_secondaryhexmd5tab)[cursecix])) warning (0, "MELT secondary source file %s has mismatching md5sum, expecting %s", curpath, MELTDESCR_REQUIRED(melt_secondaryhexmd5tab)[cursecix]); fclose (sfil), sfil = NULL; }; free (srcpath), srcpath = NULL; free (curpath), curpath = NULL; }; if (MELTDESCR_OPTIONAL(melt_versionstr) && strcmp(MELTDESCR_OPTIONAL(melt_versionstr), melt_version_str())) warning (0, "MELT module %s generated by %s but used by %s [possible version mismatch]", sopath, MELTDESCR_OPTIONAL(melt_versionstr), melt_version_str ()); gentim = (time_t) (*MELTDESCR_REQUIRED(melt_gen_timenum)); if (gentim > nowt) warning (0, "MELT module %s apparently generated in the future %s, now is %s", sopath, MELTDESCR_REQUIRED(melt_gen_timestamp), ctime (&nowt)); }; debugeprintf ("melt_load_module_index sopath %s validh %d dlh %p", sopath, (int)validh, dlh); if (validh) { melt_module_info_t minf = { 0, NULL, NULL, NULL, NULL }; ix = VEC_length (melt_module_info_t, melt_modinfvec); gcc_assert (ix > 0); if (ix > 40 && melt_flag_bootstrapping) melt_fatal_error ("too big module index %d when bootstrapping", ix); minf.mmi_dlh = dlh; minf.mmi_descrbase = xstrdup (srcbase); minf.mmi_modpath = xstrdup (sopath); minf.mmi_startrout = MELTDESCR_REQUIRED (melt_start_this_module); minf.mmi_magic = MELT_MODULE_MAGIC; #if MELT_GCC_VERSION >= 4008 // GCC 4.8 vector is C++ template so requires VEC_safe_push (melt_module_info_t, heap, melt_modinfvec, minf); #else VEC_safe_push (melt_module_info_t, heap, melt_modinfvec, &minf); #endif debugeprintf ("melt_load_module_index successful ix %d srcbase %s sopath %s flavor %s", ix, srcbase, sopath, flavor); if (!quiet_flag || melt_flag_debug) { if (MELTDESCR_OPTIONAL(melt_modulerealpath)) inform (UNKNOWN_LOCATION, "MELT loading module #%d for %s [realpath %s] with %s generated at %s built %s", ix, minf.mmi_descrbase, MELTDESCR_OPTIONAL(melt_modulerealpath), sopath, MELTDESCR_REQUIRED(melt_gen_timestamp), MELTDESCR_REQUIRED(melt_build_timestamp)); } } else { debugeprintf ("melt_load_module_index invalid dlh %p sopath %s", dlh, sopath); dlclose (dlh), dlh = NULL; } end: if (srcpath) free (srcpath), srcpath= NULL; if (descfil) fclose (descfil), descfil= NULL; if (descline) free (descline), descline = NULL; if (descversionmelt) free (descversionmelt), descversionmelt = NULL; if (desccumulatedhexmd5) free (desccumulatedhexmd5), desccumulatedhexmd5 = NULL; if (sopath) free (sopath), sopath = NULL; if (sobase) free (sobase), sobase = NULL; debugeprintf ("melt_load_module_index srcbase %s flavor %s return ix %d", srcbase, flavor, ix); return ix; } melt_ptr_t meltgc_run_c_extension (melt_ptr_t basename_p, melt_ptr_t env_p, melt_ptr_t litvaltup_p) { /* list of required dynamic symbols (dlsymed in the FOO module, provided in the FOO+meltdesc.c or FOO+melttime.h or FOO.c file) */ #define MELTRUNDESCR_REQUIRED_LIST \ MELTRUNDESCR_REQUIRED_SYMBOL (melt_build_timestamp, char); \ MELTRUNDESCR_REQUIRED_SYMBOL (melt_cumulated_hexmd5, char); \ MELTRUNDESCR_REQUIRED_SYMBOL (melt_gen_timenum, long long); \ MELTRUNDESCR_REQUIRED_SYMBOL (melt_gen_timestamp, char); \ MELTRUNDESCR_REQUIRED_SYMBOL (melt_lastsecfileindex, int); \ MELTRUNDESCR_REQUIRED_SYMBOL (melt_modulename, char); \ MELTRUNDESCR_REQUIRED_SYMBOL (melt_prepromd5meltrun, char); \ MELTRUNDESCR_REQUIRED_SYMBOL (melt_primaryhexmd5, char); \ MELTRUNDESCR_REQUIRED_SYMBOL (melt_secondaryhexmd5tab, char*); \ MELTRUNDESCR_REQUIRED_SYMBOL (melt_versionmeltstr, char); \ MELTRUNDESCR_REQUIRED_SYMBOL (melt_start_run_extension, melt_start_runext_rout_t) /* list of optional dynamic symbols (dlsymed in the module, provided in the FOO+meltdesc.c or FOO+melttime.h file). */ #define MELTRUNDESCR_OPTIONAL_LIST \ MELTRUNDESCR_OPTIONAL_SYMBOL (melt_versionstr, char); /* declare our dynamic symbols */ #define MELTRUNDESCR_REQUIRED_SYMBOL(Sym,Typ) Typ* dynr_##Sym = NULL MELTRUNDESCR_REQUIRED_LIST; #undef MELTRUNDESCR_REQUIRED_SYMBOL #define MELTRUNDESCR_OPTIONAL_SYMBOL(Sym,Typ) Typ* dyno_##Sym = NULL MELTRUNDESCR_OPTIONAL_LIST; #undef MELTRUNDESCR_OPTIONAL_SYMBOL #define MELTRUNDESCR_OPTIONAL(Sym) dyno_##Sym #define MELTRUNDESCR_REQUIRED(Sym) dynr_##Sym char basenamebuf[128]; char* descversionmelt = NULL; char* descpath = NULL; FILE *descfile = NULL; char *descline = NULL; size_t descsize = 0; ssize_t desclinlen = 0; int desclinenum = 0; int nbsecfileindex = -1; char* sopath = NULL; void* dlh = NULL; char descmd5hex[36]; /* 32 would be enough, but we want a zero terminated string. */ MELT_ENTERFRAME (5, NULL); #define resv meltfram__.mcfr_varptr[0] #define basenamev meltfram__.mcfr_varptr[1] #define environv meltfram__.mcfr_varptr[2] #define litvaltupv meltfram__.mcfr_varptr[3] #define envrefv meltfram__.mcfr_varptr[4] basenamev = basename_p; environv = env_p; litvaltupv = litvaltup_p; memset (descmd5hex, 0, sizeof(descmd5hex)); if (!basenamev || !environv || !litvaltupv) goto end; { const char* basestr = melt_string_str ((melt_ptr_t) basenamev); if (!basestr) goto end; memset (basenamebuf, 0, sizeof(basenamebuf)); strncpy (basenamebuf, basestr, sizeof(basenamebuf)-1); if (strcmp(basestr, basenamebuf)) { /* This probably should never happen, unless the basenamev is a too long name. */ melt_fatal_error ("MELT runnning extension buffered basename %s different of %s", basenamebuf, basestr); goto end; } } debugeprintf ("meltgc_run_c_extension basenamebuf=%s", basenamebuf); descpath = melt_tempdir_path (basenamebuf, "+meltdesc.c"); debugeprintf ("meltgc_run_c_extension descpath=%s", descpath); descfile = fopen (descpath, "r"); if (!descfile) { warning (0, "MELT running extension descriptor file %s not found - %s", descpath, xstrerror (errno)); goto end; } while (!feof (descfile)) { char *pc = NULL; char *pqu1 = NULL; char *pqu2 = NULL; desclinlen = getline (&descline, &descsize, descfile); desclinenum ++; if (desclinlen>0 && descline && descline[desclinlen-1] == '\n') descline[--desclinlen] = (char)0; if (desclinlen < 0) break; /* ignore comments and short lines */ if (desclinlen < 4) continue; if (descline[0] == '/' && descline[1] == '*') continue; if (descline[0] == '/' && descline[1] == '/') continue; /* ignore lines with extern "C" */ if (strstr(descline, "extern") && strstr(descline, "\"C\"")) continue; debugeprintf ("meltgc_run_c_extension (%s) #%d,len%d: %s", basenamebuf, desclinenum, (int) desclinlen, descline); /* parse the melt_versionmeltstr */ if (descversionmelt == NULL && (pc = strstr(descline, "melt_versionmeltstr[]")) != NULL && (pqu1 = strchr (pc, '"')) != NULL && (pqu2 = strchr (pqu1+1, '"')) != NULL && pqu2 > pqu1 + 10 /*actually should be more than 10*/) { descversionmelt = melt_c_string_in_descr (pqu1); debugeprintf ("meltgc_run_c_extension found descversionmelt %s", descversionmelt); }; /* check that melt_lastsecfileindex is 0 */ if (nbsecfileindex < 0 && (pc = strstr(descline, "melt_lastsecfileindex"))!= NULL && (pqu1 = strchr(pc, '=')) != NULL) if ((nbsecfileindex = atoi (pqu1+1))>0) melt_fatal_error ("cannot handle multi-C-file runtime extension %s [%d]", basenamebuf, nbsecfileindex); /* parse the melt_primaryhexmd5 */ if (descmd5hex[0] == (char)0 && (pc = strstr(descline, "melt_primaryhexmd5[]")) != NULL && (pqu1 = strchr (pc, '\"')) != NULL && (pqu2 = strchr (pqu1+1, '\"')) != NULL && (pqu2 >= pqu1 + 20) /* actually 32 */ && (pqu2 < pqu1 + sizeof(descmd5hex))) strncpy (descmd5hex, pqu1+1, pqu2-pqu1-1); }; /* end loop reading descfile */ /* check that the md5sum of the primary C file is descmd5hex */ { char compmd5buf[40]; /* Should be bigger than 32, for the terminating null char. */ char* cpath = NULL; memset (compmd5buf, 0, sizeof(compmd5buf)); cpath = concat (basenamebuf, ".c", NULL); if (access (cpath, R_OK)) melt_fatal_error ("cannot access runtime extension primary C file %s - %s", cpath, xstrerror (errno)); melt_string_hex_md5sum_file_to_hexbuf (cpath, compmd5buf); if (strcmp (compmd5buf, descmd5hex)) melt_fatal_error ("runtime extension primary file %s has md5sum of %s but expecting %s", cpath, compmd5buf, descmd5hex); free (cpath), cpath = NULL; } sopath = concat (basenamebuf, ".meltmod-", descmd5hex, ".runextend", MELT_DYNLOADED_SUFFIX, NULL); debugeprintf ("meltgc_run_c_extension sopath=%s", sopath); if (access (sopath, R_OK)) melt_fatal_error ("runtime extension module %s not accessible - %s", sopath, xstrerror(errno)); debugeprintf("meltgc_run_c_extension sopath %s before dlopen", sopath); dlh = dlopen (sopath, RTLD_NOW | RTLD_GLOBAL); if (!dlh) melt_fatal_error ("failed to dlopen runtime extension %s - %s", sopath, dlerror ()); MELT_LOCATION_HERE ("meltgc_run_c_extension after dlopen"); /* load the required and optional symbols */ #define MELTRUNDESCR_REQUIRED_SYMBOL(Sym,Typ) do { \ dynr_##Sym = (Typ*) dlsym (dlh, #Sym); \ if (!dynr_##Sym) \ melt_fatal_error \ ("failed to get " #Sym \ " from runtime extension %s - %s", \ sopath, dlerror()); \ } while(0) MELTRUNDESCR_REQUIRED_LIST; #undef MELTRUNDESCR_REQUIRED_SYMBOL #define MELTRUNDESCR_OPTIONAL_SYMBOL(Sym,Typ) \ dyno_##Sym = (Typ*) dlsym (dlh, #Sym); MELTRUNDESCR_OPTIONAL_LIST; #undef MELTRUNDESCR_OPTIONAL_SYMBOL /* check the primary md5sum */ if (!dynr_melt_primaryhexmd5 || strcmp(dynr_melt_primaryhexmd5, descmd5hex)) melt_fatal_error ("invalid primary md5sum in runtime extension %s - got %s expecting %s", sopath, dynr_melt_primaryhexmd5, descmd5hex); { melt_extension_info_t mext = { 0, 0, NULL, NULL, NULL }; int ix = 0; if (!melt_extinfvec) { melt_extension_info_t emptymei = {0, 0, NULL, NULL, NULL }; melt_extinfvec = VEC_alloc (melt_extension_info_t, heap, 32); /* don't use the index 0 so push a null at 0 in modextvec. */ #if MELT_GCC_VERSION >= 4008 // GCC 4.8 vector is C++ template so requires VEC_safe_push (melt_extension_info_t, heap, melt_extinfvec, emptymei); #else VEC_safe_push (melt_extension_info_t, heap, melt_extinfvec, &emptymei); #endif } /* check the melt_versionstr of the extension */ if (dyno_melt_versionstr) { if (strcmp(dyno_melt_versionstr, melt_version_str())) melt_fatal_error ("runtime extension %s for MELT version %s but this MELT expects %s", basenamebuf, dyno_melt_versionstr, melt_version_str()); } ix = VEC_length (melt_extension_info_t, melt_extinfvec); gcc_assert (ix > 0); mext.mmx_dlh = dlh; mext.mmx_descrbase = xstrdup (basenamebuf); mext.mmx_extpath = xstrdup (sopath); mext.mmx_rank = ix; mext.mmx_magic = MELT_EXTENSION_MAGIC; #if MELT_GCC_VERSION >= 4008 // GCC 4.8 vector is C++ template so requires VEC_safe_push (melt_extension_info_t, heap, melt_extinfvec, mext); #else VEC_safe_push (melt_extension_info_t, heap, melt_extinfvec, &mext); #endif debugeprintf ("meltgc_run_c_extension %s has index %d", basenamebuf, ix); } envrefv = meltgc_new_reference ((melt_ptr_t) environv); debugeprintf ("meltgc_run_c_extension envrefv@%p", (void*)envrefv); { #if MELT_HAVE_DEBUG char locbuf[80]; memset (locbuf,0,sizeof(locbuf)); MELT_LOCATION_HERE_PRINTF (locbuf, "run-c-ext.. basename %s", basenamebuf); #endif debugeprintf ("meltgc_run_c_extension before calling dynr_melt_start_run_extension@%p", (void*) dynr_melt_start_run_extension); resv = (*dynr_melt_start_run_extension) ((melt_ptr_t)envrefv, (melt_ptr_t)litvaltupv); debugeprintf ("meltgc_run_c_extension after call resv=%p", (void*)resv); MELT_LOCATION_HERE ("meltgc_run_c_extension ending"); } end: if (descpath) free (descpath), descpath = NULL; if (sopath) free (sopath), sopath = NULL; if (descfile) fclose (descfile), descfile = NULL; MELT_EXITFRAME (); return (melt_ptr_t) resv; #undef MELTRUNDESCR_REQUIRED_LIST #undef MELTRUNDESCR_OPTIONAL_LIST #undef MELTRUNDESCR_OPTIONAL #undef MELTRUNDESCR_REQUIRED #undef basenamev #undef environv #undef resv #undef envrefv } melt_ptr_t meltgc_start_module_by_index (melt_ptr_t env_p, int modix) { melt_module_info_t* mi = NULL; #if MELT_HAVE_DEBUG char locbuf[200]; #endif MELT_ENTERFRAME(2, NULL); #define resmodv meltfram__.mcfr_varptr[0] #define env meltfram__.mcfr_varptr[1] env = env_p; if (!melt_modinfvec || modix <= 0 || modix >= (int) VEC_length (melt_module_info_t, melt_modinfvec)) { debugeprintf ("meltgc_start_module_by_index bad index modix %d", modix); goto end; } #if MELT_GCC_VERSION >= 4008 // GCC 4.8 vector is C++ template so requires the "&" address-of. mi = &VEC_index (melt_module_info_t, melt_modinfvec, modix); #else /* GCC 4.7 or earlier vector is a C macro which don't want the "&" address-of. */ mi = VEC_index (melt_module_info_t, melt_modinfvec, modix); #endif /* GCC 4.8 */ if (!mi) { debugeprintf ("meltgc_start_module_by_index empty index modix %d", modix); goto end; } gcc_assert (mi->mmi_magic == MELT_MODULE_MAGIC); debugeprintf ("meltgc_start_module_by_index modix %d module %s", modix, mi->mmi_descrbase); if (mi->mmi_startrout) { MELT_LOCATION_HERE_PRINTF (locbuf, "meltgc_start_module_by_index before starting #%d %s", modix, mi->mmi_descrbase); resmodv = mi->mmi_startrout ((melt_ptr_t) env); mi->mmi_startrout = NULL; MELT_LOCATION_HERE_PRINTF (locbuf, "meltgc_start_module_by_index after starting #%d", modix); melt_nb_modules ++; } else warning (0, "MELT module #%d %s already started", modix, mi->mmi_descrbase); end: MELT_EXITFRAME (); return (melt_ptr_t) resmodv; #undef resmodv #undef env } melt_ptr_t meltgc_start_all_new_modules (melt_ptr_t env_p) { melt_module_info_t* mi = NULL; int modix; char locbuf[200]; MELT_ENTERFRAME(1, NULL); #define env meltfram__.mcfr_varptr[0] env = env_p; gcc_assert (melt_modinfvec != NULL); debugeprintf ("meltgc_start_all_new_modules env %p", env); for (modix = 1; VEC_iterate (melt_module_info_t, melt_modinfvec, modix, mi); modix++) { if (!mi) continue; gcc_assert (mi->mmi_magic == MELT_MODULE_MAGIC); if (!mi->mmi_startrout) continue; MELT_LOCATION_HERE_PRINTF (locbuf, "meltgc_start_all_new_modules before starting #%d module %s", modix, mi->mmi_modpath); debugeprintf ("meltgc_start_all_new_modules env %p before starting modix %d", env, modix); env = meltgc_start_module_by_index ((melt_ptr_t) env, modix); if (!env) melt_fatal_error ("MELT failed to start module #%d %s", modix, mi->mmi_modpath); } MELT_EXITFRAME (); return (melt_ptr_t) env; #undef env } #define MODLIS_SUFFIX ".modlis" #define MODLIS_MAXDEPTH 8 /* Load a single module, but don't initialize it. */ int meltgc_load_flavored_module (const char*modulbase, const char*flavor) { const char* srcpathstr = melt_argument ("source-path"); char* dupmodul = NULL; char* descrpath = NULL; char* descrfull = NULL; char* tempdirpath = melt_tempdir_path(NULL, NULL); int modix = 0; #if MELT_HAVE_DEBUG /* The location buffer is local, since this function may recurse! */ char curlocbuf[220]; #endif MELT_ENTEREMPTYFRAME (NULL); #if MELT_HAVE_DEBUG memset (curlocbuf, 0, sizeof (curlocbuf)); #endif debugeprintf("meltgc_load_flavored_module start base %s flavor %s tempdirpath %s", modulbase, flavor, tempdirpath); if (!modulbase || !modulbase[0]) goto end; dupmodul = xstrdup(modulbase); if (!flavor || !flavor[0]) flavor = MELT_DEFAULT_FLAVOR; debugeprintf ("meltgc_load_flavored_module dupmodul %s flavor %s", dupmodul, flavor); MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_load_flavored_module module %s flavor %s", dupmodul, flavor); { const char *modumelt_basename = melt_basename (modulbase); if (modumelt_basename && strchr (modumelt_basename, '.')) melt_fatal_error ("invalid module base to load %s with dot in base name", modulbase); } descrfull = concat (dupmodul, MELT_DESC_FILESUFFIX, NULL); debugeprintf ("meltgc_load_flavored_module descrfull %s flavor %s", descrfull, flavor); descrpath = MELT_FIND_FILE (descrfull, MELT_FILE_LOG, melt_trace_source_fil, MELT_FILE_IN_DIRECTORY, tempdirpath, MELT_FILE_IN_DIRECTORY, ".", MELT_FILE_IN_PATH, srcpathstr, MELT_FILE_IN_ENVIRON_PATH, melt_flag_bootstrapping?NULL:"GCCMELT_SOURCE_PATH", MELT_FILE_IN_DIRECTORY, melt_flag_bootstrapping?NULL:melt_source_dir, NULL); debugeprintf ("meltgc_load_flavored_module descrpath %s dupmodul %s", descrpath, dupmodul); if (!descrpath) { error ("MELT failed to find module %s with descriptive file %s", dupmodul, descrfull); /* Keep the order of the inform calls below same as the order for MELT_FIND_FILE above. */ if (tempdirpath && tempdirpath[0]) inform (UNKNOWN_LOCATION, "MELT temporary directory %s", tempdirpath); inform (UNKNOWN_LOCATION, "MELT current directory %s", getpwd()); if (srcpathstr) inform (UNKNOWN_LOCATION, "MELT source path %s", srcpathstr); if (getenv ("GCCMELT_SOURCE_PATH")) inform (UNKNOWN_LOCATION, "GCCMELT_SOURCE_PATH from environment %s", getenv ("GCCMELT_SOURCE_PATH")); if (!melt_flag_bootstrapping) inform (UNKNOWN_LOCATION, "builtin MELT source directory %s", melt_source_dir); melt_fatal_error ("failed to find MELT module %s", dupmodul); } if (!IS_ABSOLUTE_PATH(descrpath)) { char *realdescrpath = lrealpath (descrpath); debugeprintf ("meltgc_load_flavored_module realdescrpath %s", realdescrpath); free (descrpath), descrpath = NULL; gcc_assert (realdescrpath != NULL); descrpath = realdescrpath; } /* remove the +meltdesc.c suffix */ { char* pc = strstr (descrpath, MELT_DESC_FILESUFFIX); gcc_assert (pc != NULL); *pc = (char)0; } debugeprintf ("meltgc_load_flavored_module truncated descrpath %s flavor %s before melt_load_module_index", descrpath, flavor); { char *moderr = NULL; modix = melt_load_module_index (descrpath, flavor, &moderr); debugeprintf ("meltgc_load_flavored_module after melt_load_module_index modix %d descrpath %s", modix, descrpath); if (modix < 0) melt_fatal_error ("failed to load MELT module %s flavor %s - %s", descrpath, flavor, moderr?moderr:"..."); } end: MELT_EXITFRAME (); if (descrpath) free (descrpath), descrpath = NULL; if (tempdirpath) free (tempdirpath), tempdirpath = NULL; debugeprintf ("meltgc_load_flavored_module modul %s return modix %d", dupmodul, modix); if (dupmodul) free (dupmodul), dupmodul = NULL; return modix; } melt_ptr_t meltgc_start_flavored_module (melt_ptr_t env_p, const char*modulbase, const char*flavor) { char *moduldup = NULL; char *flavordup = NULL; int modix = -1; char modulbuf[80]; char flavorbuf[32]; #if MELT_HAVE_DEBUG /* The location buffer is local, since this function may recurse! */ char curlocbuf[220]; #endif MELT_ENTERFRAME(1, NULL); #define env meltfram__.mcfr_varptr[0] #if MELT_HAVE_DEBUG memset (curlocbuf, 0, sizeof (curlocbuf)); #endif env = env_p; memset (modulbuf, 0, sizeof(modulbuf)); memset (flavorbuf, 0, sizeof(flavorbuf)); debugeprintf ("meltgc_start_flavored_module env %p modulbase %s flavor %s", env, modulbase?modulbase:"*none*", flavor?flavor:"*none*"); if (!modulbase) { env = NULL; goto end; } /* copy the flavor and the modulebase */ if (strlen (modulbase) < sizeof(modulbuf)) { strncpy (modulbuf, modulbase, sizeof(modulbuf)); moduldup = modulbuf; } else moduldup = xstrdup (modulbase); if (!flavor) flavordup = NULL; else if (strlen (flavor) < sizeof(flavorbuf)) { strncpy (flavorbuf, flavor, sizeof(flavorbuf)); flavordup = flavorbuf; } else flavordup = xstrdup (flavor); if (flavordup) { char *pc; for (pc = flavordup; *pc; pc++) *pc = TOLOWER (*pc); } debugeprintf ("meltgc_start_flavored_module moduldup %s flavordup %s before load", moduldup?moduldup:"*none*", flavordup?flavordup:"*none*"); MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_start_flavored_module module %s flavor %s", moduldup, flavordup?flavordup:"*none*"); modix = meltgc_load_flavored_module (moduldup, flavordup); debugeprintf ("meltgc_start_flavored_module moduldup %s flavordup %s got modix %d", moduldup, flavordup?flavordup:"*none*", modix); if (modix < 0) { error ("MELT failed to load started module %s flavor %s", moduldup, flavordup?flavordup:"*none*"); env = NULL; goto end; } debugeprintf ("meltgc_start_flavored_module moduldup %s before starting all new", moduldup); env = meltgc_start_all_new_modules ((melt_ptr_t) env); debugeprintf ("meltgc_start_flavored_module moduldup %s after starting all new env %p", moduldup, env); end: if (moduldup && moduldup != modulbuf) free (moduldup), moduldup = NULL; if (flavordup && flavordup != flavorbuf) free (flavordup), flavordup = NULL; MELT_EXITFRAME (); return (melt_ptr_t) env; #undef env } int meltgc_load_one_module (const char*flavoredmodule) { int modix = -1; char tinybuf[80]; char* dupflavmod = NULL; char* dotptr = NULL; char* flavor = NULL; #if MELT_HAVE_DEBUG /* The location buffer is local, since this function may recurse! */ char curlocbuf[220]; #endif MELT_ENTEREMPTYFRAME (NULL); #if MELT_HAVE_DEBUG memset (curlocbuf, 0, sizeof (curlocbuf)); #endif if (!flavoredmodule) goto end; memset (tinybuf, 0, sizeof(tinybuf)); debugeprintf ("meltgc_load_one_module start flavoredmodule %s", flavoredmodule); MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_load_one_module flavoredmodule %s", flavoredmodule); if (strlen (flavoredmodule) < sizeof(tinybuf)-1) { strncpy (tinybuf, flavoredmodule, sizeof(tinybuf)-1); dupflavmod = tinybuf; } else dupflavmod = xstrdup (flavoredmodule); dotptr = CONST_CAST (char*, strchr (melt_basename (dupflavmod), '.')); if (dotptr) { *dotptr = (char)0; flavor = dotptr + 1; debugeprintf ("meltgc_load_one_module got flavor %s", flavor); } debugeprintf ("meltgc_load_one_module before loading module %s flavor %s", dupflavmod, flavor?flavor:"*none*"); modix = meltgc_load_flavored_module (dupflavmod, flavor); debugeprintf ("meltgc_load_one_module after loading module %s modix %d", dupflavmod, modix); end: if (dupflavmod && dupflavmod != tinybuf) free (dupflavmod), dupflavmod = NULL; debugeprintf ("meltgc_load_one_module flavoredmodule %s gives modix %d", flavoredmodule, modix); MELT_EXITFRAME (); return modix; } /* Load a module list, but don't initialize the modules yet. */ void meltgc_load_module_list (int depth, const char *modlistbase) { FILE *filmod = NULL; char *modlistfull = NULL; char *modlistpath = NULL; char *modlin = NULL; size_t modlinsiz = 0; ssize_t modlinlen = 0; int modlistbaselen = 0; int lincnt = 0; const char* srcpathstr = melt_argument ("source-path"); #if MELT_HAVE_DEBUG /* The location buffer is local, since this function recurses! */ char curlocbuf[220]; #endif MELT_ENTEREMPTYFRAME (NULL); #if MELT_HAVE_DEBUG memset (curlocbuf, 0, sizeof (curlocbuf)); #endif debugeprintf("meltgc_load_module_list start modlistbase %s depth %d", modlistbase, depth); MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_load_module_list start depth %d modlistbase %s", depth, modlistbase); if (!modlistbase) goto end; if (melt_trace_source_fil) { fprintf (melt_trace_source_fil, "Loading module list %s at depth %d\n", modlistbase, depth); fflush (melt_trace_source_fil); }; modlistbaselen = strlen (modlistbase); if (modlistbaselen > (int) strlen (MODLIS_SUFFIX) && !strcmp(modlistbase + modlistbaselen - strlen(MODLIS_SUFFIX), MODLIS_SUFFIX)) melt_fatal_error ("MELT module list %s should not be given with its suffix %s", modlistbase, MODLIS_SUFFIX); modlistfull = concat (modlistbase, MODLIS_SUFFIX, NULL); modlistpath = MELT_FIND_FILE (modlistfull, MELT_FILE_LOG, melt_trace_source_fil, MELT_FILE_IN_DIRECTORY, ".", MELT_FILE_IN_PATH, srcpathstr, MELT_FILE_IN_ENVIRON_PATH, melt_flag_bootstrapping?NULL:"GCCMELT_SOURCE_PATH", MELT_FILE_IN_DIRECTORY, melt_flag_bootstrapping?NULL:melt_source_dir, NULL); debugeprintf ("meltgc_load_module_list modlistpath %s", modlistpath); if (!modlistpath) { error ("cannot load MELT module list %s", modlistbase); if (srcpathstr) inform (UNKNOWN_LOCATION, "MELT source path %s", srcpathstr); if (getenv ("GCCMELT_SOURCE_PATH")) inform (UNKNOWN_LOCATION, "GCCMELT_SOURCE_PATH from environment %s", getenv ("GCCMELT_SOURCE_PATH")); if (!melt_flag_bootstrapping) inform (UNKNOWN_LOCATION, "builtin MELT source directory %s", melt_source_dir); if (melt_trace_source_fil) fflush (melt_trace_source_fil); else inform (UNKNOWN_LOCATION, "You could set GCCMELT_TRACE_SOURCE env.var. to a file path for tracing module list loads"); melt_fatal_error ("MELT failed to load module list %s", modlistfull); } if (!IS_ABSOLUTE_PATH (modlistpath)) { char *realmodlistpath = lrealpath (modlistpath); debugeprintf ("real module list path %s", realmodlistpath); free (modlistpath), modlistpath = NULL; modlistpath = realmodlistpath; } filmod = fopen (modlistpath, "r"); debugeprintf ("reading module list '%s'", modlistpath); if (!filmod) melt_fatal_error ("failed to open melt module list file %s - %m", modlistpath); while (!feof (filmod)) { modlinlen = getline (&modlin, &modlinsiz, filmod); lincnt++; if (modlinlen <= 0 || modlin[0] == '#' || modlin[0] == '\n') continue; if (modlinlen > 0 && modlin[modlinlen-1] == '\n') modlin[--modlinlen] = (char)0; debugeprintf ("meltgc_load_module_list line #%d: %s", lincnt, modlin); MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_load_module_list %s line %d: %s", modlistpath, lincnt, modlin); /* Handle nested module lists */ if (modlin[0] == '@') { if (depth > MODLIS_MAXDEPTH) melt_fatal_error ("MELT has too nested [%d] module list %s with %s", depth, modlistbase, modlin); MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_load_module_list %s recursive line %d: '%s'", modlistpath, lincnt, modlin); debugeprintf ("meltgc_load_module_list recurse depth %d sublist '%s'", depth, modlin+1); meltgc_load_module_list (depth+1, modlin+1); } else { MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_load_module_list %s plain line %d: '%s'", modlistpath, lincnt, modlin); debugeprintf ("meltgc_load_module_list depth %d module '%s'", depth, modlin); (void) meltgc_load_one_module (modlin); } MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_load_module_list %s done line %d: %s", modlistpath, lincnt, modlin); }; free (modlin), modlin = NULL; fclose (filmod), filmod = NULL; goto end; end: MELT_EXITFRAME (); if (modlistfull) free(modlistfull), modlistfull = NULL; if (modlin) free (modlin), modlin = NULL; if (modlistpath) free (modlistpath), modlistpath = NULL; return; } /* handle the inital mode or modes if it is a comma separated list of modes */ static void meltgc_do_initial_mode (melt_ptr_t modata_p, const char* modstr) { char *dupmodstr = NULL; char *curmodstr = NULL; char *comma = NULL; MELT_ENTERFRAME (5, NULL); #define dictv meltfram__.mcfr_varptr[0] #define closv meltfram__.mcfr_varptr[1] #define modatav meltfram__.mcfr_varptr[2] #define resv meltfram__.mcfr_varptr[3] #define cmdv meltfram__.mcfr_varptr[4] modatav = modata_p; modstr = melt_argument ("mode"); if (melt_debugging_after_mode) { inform (UNKNOWN_LOCATION, "MELT enabling debug messages after mode %s", modstr?modstr:"*none*"); melt_flag_debug = 1; } debugeprintf ("meltgc_do_initial_mode mode_string %s modatav %p", modstr, (void *) modatav); if (!modstr || !modstr[0]) { inform (UNKNOWN_LOCATION, "MELT don't do anything because no mode is given"); debugeprintf("meltgc_do_initial_mode do nothing without mode modata %p", modatav); goto end; } if (!MELT_PREDEF (INITIAL_SYSTEM_DATA)) { error ("MELT cannot execute initial mode %s without INITIAL_SYSTEM_DATA", modstr); goto end; } dictv = melt_get_inisysdata(MELTFIELD_SYSDATA_MODE_DICT); debugeprintf ("meltgc_do_initial_mode dictv=%p of magic %d", dictv, melt_magic_discr ((melt_ptr_t) dictv)); debugeprintvalue ("meltgc_do_initial_mode dictv", dictv); if (!dictv || melt_magic_discr ((melt_ptr_t) dictv) != MELTOBMAG_MAPSTRINGS) { debugeprintf("meltgc_do_initial_mode invalid dictv %p", dictv); melt_fatal_error ("invalid MELT mode dictionnary %p", dictv); goto end; }; if (strchr (modstr, ',')) curmodstr = dupmodstr = xstrdup (modstr); else curmodstr = CONST_CAST (char *, modstr); do { comma = strchr (curmodstr, ','); if (comma) *comma = (char)0; /* the mode exit is builtin */ if (curmodstr && !strcmp (curmodstr, "exit")) { debugeprintf("meltgc_do_initial_mode MELT setting exit_after_options for built-in mode '%s'", curmodstr); exit_after_options = true; goto end; } else cmdv = melt_get_mapstrings ((struct meltmapstrings_st *) dictv, curmodstr); debugeprintf ("meltgc_do_initial_mode cmdv=%p", cmdv); if (!cmdv) { error ("unknown MELT mode %s [of %d modes]", modstr, melt_count_mapstrings((struct meltmapstrings_st*)dictv)); goto end; } if (!melt_is_instance_of ((melt_ptr_t) cmdv, (melt_ptr_t) MELT_PREDEF (CLASS_MELT_MODE))) { debugeprintf ("meltgc_do_initial_mode invalid cmdv %p of magic %d", cmdv, melt_magic_discr((melt_ptr_t)cmdv)); error ("bad MELT mode %s, not instance of CLASS_MELT_MODE", modstr); goto end; }; closv = melt_object_nth_field ((melt_ptr_t) cmdv, MELTFIELD_MELTMODE_FUN); if (melt_magic_discr ((melt_ptr_t) closv) != MELTOBMAG_CLOSURE) { debugeprintf ("meltgc_do_initial_mode invalid closv %p", closv); error ("no closure for melt mode %s", modstr); goto end; }; { union meltparam_un pararg[4]; memset (pararg, 0, sizeof (pararg)); { /* apply the closure to the mode & the module data */ pararg[0].meltbp_aptr = (melt_ptr_t *) & modatav; debugeprintf ("meltgc_do_initial_mode before apply closv %p", closv); MELT_LOCATION_HERE ("meltgc_do_initial_mode before apply"); resv = melt_apply ((meltclosure_ptr_t) closv, (melt_ptr_t) cmdv, MELTBPARSTR_PTR, pararg, "", NULL); debugeprintf ("meltgc_do_initial_mode after apply closv %p resv %p", closv, resv); } if (!resv) { warning(0, "MELT mode %s failed, so compilation disabled", curmodstr); exit_after_options = TRUE; debugeprintf ("meltgc_do_initial_mode set exit_after_options for failed modstr %s", modstr); } } if (comma) curmodstr = comma+1; } while (comma); end: if (dupmodstr) free (dupmodstr); dupmodstr = NULL; debugeprintf ("meltgc_do_initial_mode end %s", modstr); MELT_EXITFRAME (); #undef dictv #undef closv #undef modatav #undef resv #undef cmdv } static void meltgc_set_user_options (const char* optstr) { #if MELT_HAVE_DEBUG char locbuf[220]; #endif MELT_ENTERFRAME(3, NULL); #define optsetv meltfram__.mcfr_varptr[0] #define optsymbv meltfram__.mcfr_varptr[1] #define optresv meltfram__.mcfr_varptr[2] debugeprintf ("meltgc_set_user_options start option; optstr %s", optstr); if (optstr) debugeprintf ("meltgc_set_user_options optstr.len %d ", (int) strlen (optstr)); optsetv = NULL; if (optstr && optstr[0]) { optsetv=melt_get_inisysdata (MELTFIELD_SYSDATA_OPTION_SET); debugeprintf("meltfield_sysdata_option_set optsetv %p for optstr '%s'", optsetv, optstr); if (optsetv != NULL && melt_magic_discr ((melt_ptr_t) optsetv) == MELTOBMAG_CLOSURE) { char *optc = 0; char *optname = 0; char *optvalue = 0; for (optc = CONST_CAST (char *, optstr); optc && *optc; ) { optname = optvalue = NULL; if (!ISALPHA(*optc)) melt_fatal_error ("invalid MELT option name %s [should start with letter]", optc); optname = optc; while (*optc && (ISALNUM(*optc) || *optc=='_' || *optc=='-')) optc++; if (*optc == '=') { warning(0, "MELT option %s with obsolete equal sign '=' replaced by colon ':'", optstr); *optc = ':'; } if (*optc == ':') { *optc = (char)0; optc++; optvalue = optc; while (*optc && *optc != ',') optc++; } if (*optc==',') { *optc = (char)0; optc++; } debugeprintf("optname '%s", optname); if (!optname || !optname[0]) error ("MELT option %s without valid name", optstr); optsymbv = meltgc_named_symbol (optname, MELT_CREATE); debugeprintf("optname '%s got optsymbv %p", optname, optsymbv); { union meltparam_un pararg[1]; memset (¶rg, 0, sizeof (pararg)); pararg[0].meltbp_cstring = optvalue; MELT_LOCATION_HERE_PRINTF (locbuf, "meltgc_set_user_options option %s set before apply", optname); debugeprintf ("MELT option %s value %s", optname, optvalue?optvalue:"_"); optresv = melt_apply ((meltclosure_ptr_t) optsetv, (melt_ptr_t) optsymbv, MELTBPARSTR_CSTRING, pararg, "", NULL); if (!optresv) warning (0, "unhandled MELT option %s", optname); /* after options setting, force a minor collection to ensure nothing is left in young region */ MELT_LOCATION_HERE ("meltgc_set_user_options option set done"); melt_garbcoll (0, MELT_ONLY_MINOR); } } } } MELT_EXITFRAME(); #undef optsetv #undef optsymbv #undef optresv } static void meltgc_load_modules_and_do_mode (void) { char *curmod = NULL; char *nextmod = NULL; const char*modstr = NULL; const char*inistr = NULL; const char* xtrastr = NULL; char *dupmodpath = NULL; int lastmodix = 0; #if MELT_HAVE_DEBUG char locbuf[240]; #endif MELT_ENTERFRAME(1, NULL); #define modatv meltfram__.mcfr_varptr[0] modstr = melt_argument ("mode"); inistr = melt_argument ("init"); debugeprintf ("meltgc_load_modules_and_do_mode start modstr %s inistr %s", modstr, inistr); if (!modstr || !modstr[0]) { debugeprintf ("meltgc_load_modules_and_do_mode do nothing without mode (inistr=%s)", inistr); goto end; } /* if there is no -fmelt-init use the default list of modules */ if (!inistr || !inistr[0]) { inistr = "@@"; debugeprintf ("meltgc_load_modules_and_do_mode inistr set to default %s", inistr); } dupmodpath = xstrdup (inistr); xtrastr = melt_argument ("extra"); debugeprintf ("meltgc_load_modules_and_do_mode xtrastr %s", xtrastr); modatv = NULL; /** * first we load all the initial modules **/ curmod = dupmodpath; while (curmod && curmod[0]) { #if MELT_HAVE_DEBUG char locbuf[250]; #endif nextmod = strchr (curmod, ':'); if (nextmod) { *nextmod = (char) 0; nextmod++; } debugeprintf ("meltgc_load_modules_and_do_mode curmod %s before", curmod); MELT_LOCATION_HERE_PRINTF (locbuf, "meltgc_load_modules_and_do_mode before loading curmod %s", curmod); if (!strcmp(curmod, "@@")) { int lastixmodule = VEC_length (melt_module_info_t, melt_modinfvec); /* the @@ notation means the initial module list; it should always be first. */ if (melt_nb_modules > 0 || lastixmodule > 1) melt_fatal_error ("MELT default module list should be loaded at first (melt_nb_modules=%d, lastixmodule=%d)!", melt_nb_modules, lastixmodule); debugeprintf ("meltgc_load_modules_and_do_mode loading default module list %s", melt_default_modlis); meltgc_load_module_list (0, melt_default_modlis); debugeprintf ("meltgc_load_modules_and_do_mode loaded default module list %s", melt_default_modlis); } else if (curmod[0] == '@') { debugeprintf ("meltgc_load_modules_and_do_mode loading given module list %s", curmod+1); meltgc_load_module_list (0, curmod+1); debugeprintf ("meltgc_load_modules_and_do_mode loaded given module list %s", curmod+1); } else { debugeprintf ("meltgc_load_modules_and_do_mode loading given single module %s", curmod); meltgc_load_one_module (curmod); debugeprintf ("meltgc_load_modules_and_do_mode loaded given single module %s", curmod); } debugeprintf ("meltgc_load_modules_and_do_mode done curmod %s", curmod); curmod = nextmod; } /** * Then we start all the initial modules **/ debugeprintf ("meltgc_load_modules_and_do_mode before starting all new modules modatv=%p", modatv); modatv = meltgc_start_all_new_modules ((melt_ptr_t) modatv); debugeprintf ("meltgc_load_modules_and_do_mode started all new modules modatv=%p", modatv); /* Then we load and start every extra module, if given */ debugeprintf ("meltgc_load_modules_and_do_mode xtrastr %s lastmodix #%d", xtrastr, lastmodix); if (xtrastr && xtrastr[0]) { char* dupxtra = xstrdup (xtrastr); char *curxtra = 0; char *nextxtra = 0; for (curxtra = dupxtra; curxtra && *curxtra; curxtra = nextxtra) { nextxtra = strchr (curxtra, ':'); if (nextxtra) { *nextxtra = (char) 0; nextxtra++; } debugeprintf ("meltgc_load_modules_and_do_mode before loading curxtra %s", curxtra); if (curxtra[0] == '@' && curxtra[1]) { MELT_LOCATION_HERE_PRINTF (locbuf, "meltgc_load_modules_and_do_mode before extra modlist %s", curxtra); meltgc_load_module_list (0, curxtra+1); } else { MELT_LOCATION_HERE_PRINTF (locbuf, "meltgc_load_modules_and_do_mode before single extra %s", curxtra); meltgc_load_one_module (curxtra); } /* Start all the new loaded modules. */ modatv = meltgc_start_all_new_modules ((melt_ptr_t) modatv); debugeprintf ("meltgc_load_modules_and_do_mode done curxtra %s", curxtra); } /* end for curxtra */ } /** * then we do the mode if needed **/ if (melt_get_inisysdata (MELTFIELD_SYSDATA_MODE_DICT) && modstr && modstr[0]) { /** * First we set MELT options. **/ const char* optstr = melt_argument("option"); debugeprintf("meltgc_load_modules_and_do_mode optstr %s", optstr); if (optstr && optstr[0]) { char* optdup = xstrdup (optstr); MELT_LOCATION_HERE_PRINTF (locbuf, "meltgc_load_modules_and_do_mode mode %s before setting options %s", modstr, optdup); debugeprintf("meltgc_load_modules_and_do_mode handling user options optdup %s", optdup); meltgc_set_user_options (optdup); debugeprintf("meltgc_load_modules_and_do_mode handled user options optdup %s", optdup); free (optdup); } MELT_LOCATION_HERE_PRINTF (locbuf, "meltgc_load_modules_and_do_mode before do_initial_mode mode %s", modstr); meltgc_do_initial_mode ((melt_ptr_t) modatv, modstr); debugeprintf ("meltgc_load_modules_and_do_mode after do_initial_mode mode_string %s", modstr); MELT_LOCATION_HERE_PRINTF (locbuf, "meltgc_load_modules_and_do_mode after do_initial_mode mode %s", modstr); } else if (modstr) melt_fatal_error ("melt with mode string %s without mode dispatcher", modstr); end: MELT_EXITFRAME (); #undef modatv if (dupmodpath) free (dupmodpath), dupmodpath = NULL; } /* The low level SIGIO signal handler installed thru sigaction, when IO is possible on input channels. Actual signal handling is done at safe places thru MELT_CHECK_SIGNAL & melt_handle_signal & meltgc_handle_sigio (because signal handlers can call very few async-signal-safe functions, see signal(7) man page on e.g. Linux). */ static void melt_raw_sigio_signal(int sig) { gcc_assert (sig == SIGIO || sig == SIGPIPE); melt_got_sigio = 1; melt_signaled = 1; } /* The low level SIGALRM/SIGVTALRM signal handler installed thru sigaction, when an alarm ringed. Actual signal handling is done at safe places thru MELT_CHECK_SIGNAL & melt_handle_signal & meltgc_handle_sigalrm (because signal handlers can call very few async-signal-safe functions, see signal(7) man page on e.g. Linux). */ static void melt_raw_sigalrm_signal(int sig) { gcc_assert (sig == SIGALRM || sig == SIGVTALRM); melt_got_sigalrm = 1; melt_signaled = 1; } /* The low level SIGCHLD signal handler installed thru sigaction, when a child process exits. Actual signal handling is done at safe places thru MELT_CHECK_SIGNAL & melt_handle_signal & meltgc_handle_sigalrm (because signal handlers can call very few async-signal-safe functions, see signal(7) man page on e.g. Linux). */ static void melt_raw_sigchld_signal(int sig) { gcc_assert (sig == SIGCHLD); melt_got_sigchld = 1; melt_signaled = 1; } static void melt_install_signal_handlers (void) { signal (SIGALRM, melt_raw_sigalrm_signal); signal (SIGVTALRM, melt_raw_sigalrm_signal); signal (SIGIO, melt_raw_sigio_signal); signal (SIGPIPE, melt_raw_sigio_signal); signal (SIGCHLD, melt_raw_sigchld_signal); debugeprintf ("melt_install_signal_handlers install handlers for SIGIO %d, SIGPIPE %d, SIGALRM %d, SIGVTALRM %d SIGCHLD %d", SIGIO, SIGPIPE, SIGALRM, SIGVTALRM, SIGCHLD); } long melt_relative_time_millisec (void) { struct timeval tv = {0,0}; errno = 0; if (gettimeofday (&tv, NULL)) melt_fatal_error ("MELT cannot call gettimeofday - %s", xstrerror(errno)); return (long)(tv.tv_sec - melt_start_time.tv_sec)*1000L + (long)(tv.tv_usec - melt_start_time.tv_usec)/1000L; } void melt_set_real_timer_millisec (long millisec) { #define MELT_MINIMAL_TIMER_MILLISEC 50 struct itimerval itv; itv.it_interval.tv_sec = 0; itv.it_interval.tv_usec = 0; itv.it_value.tv_sec = 0; itv.it_value.tv_usec = 0; if (millisec > 0) { if (millisec < MELT_MINIMAL_TIMER_MILLISEC) millisec = MELT_MINIMAL_TIMER_MILLISEC; itv.it_value.tv_sec = millisec / 1000; itv.it_value.tv_usec = (millisec % 1000) * 1000; }; if (setitimer (ITIMER_REAL, &itv, NULL)) melt_fatal_error ("MELT cannot set real timer to %ld millisec - %s", millisec, xstrerror(errno)); } /**** * Initialize melt. Called from toplevel.c before pass management. * Should become the MELT plugin initializer. ****/ static void melt_really_initialize (const char* pluginame, const char*versionstr) { static int inited; long seed = 0; #if MELT_GCC_VERSION<=4006 /* In GCC 4.6 the random seed is a string. */ const char *pc = NULL; const char *randomseedstr = NULL; #else /* In GCC 4.7, the random seed is a number. */ long randomseednum = 0; #endif const char *modstr = NULL; const char *inistr = NULL; const char *countdbgstr = NULL; const char *printset = NULL; struct stat mystat; if (inited) return; melt_plugin_gcc_version = &gcc_version; /* from plugin-version.h */ debugeprintf ("melt_really_initialize pluginame '%s' versionstr '%s'", pluginame, versionstr); debugeprintf ("melt_really_initialize update_path(\"plugins\", \"GCC\")=%s", update_path ("plugins","GCC")); gcc_assert (pluginame && pluginame[0]); gcc_assert (versionstr && versionstr[0]); errno = 0; if (gettimeofday (&melt_start_time, NULL)) melt_fatal_error ("MELT cannot call gettimeofday for melt_start_time (%s)", xstrerror(errno)); debugeprintf ("melt_really_initialize melt_start_time=%ld", (long) melt_start_time.tv_sec); melt_payload_initialize_static_descriptors (); #ifdef MELT_IS_PLUGIN /* when MELT is a plugin, we need to process the debug argument. When MELT is a branch, the melt_argument function is using melt_flag_debug for "debug" so we don't want this. */ { const char *dbgstr = melt_argument ("debug"); const char *debuggingstr = melt_argument ("debugging"); /* debug=n or debug=0 is handled as no debug */ if (dbgstr && (!dbgstr[0] || !strchr("Nn0", dbgstr[0]))) { inform (UNKNOWN_LOCATION, "MELT plugin option -fplugin-arg-melt-debug is obsolete, same as -fplugin-arg-melt-debugging=mode"); melt_flag_debug = 0; melt_debugging_after_mode = 1; inform (UNKNOWN_LOCATION, "MELT plugin will give debugging messages after mode processing" " with obsolete -fplugin-arg-melt-debug. Use -fplugin-arg-melt-debugging=mode instead."); } if (debuggingstr && *debuggingstr && !strrchr("Nn0", debuggingstr[0])) { if (!strcmp (debuggingstr, "all")) { inform (UNKNOWN_LOCATION, "MELT plugin is giving all debugging messages."); melt_flag_debug = 1; } else if (!strcmp (debuggingstr, "mode")) { melt_flag_debug = 0; melt_debugging_after_mode = 1; inform (UNKNOWN_LOCATION, "MELT plugin will give debugging messages after mode processing."); } else { warning (0, "MELT plugin gets unrecognized -fmelt-arg-plugin-debugging=%s option, " "expects 'mode','all', or 'no'", debuggingstr); } } } /* When MELT is a plugin, we need to process the bootstrapping argument. When MELT is a branch, the melt_argument function is using melt_flag_bootstrapping for "bootstrapping" so we don't want this. Likewise for "generate-work-link" and melt_flag_generate_work_link. */ { const char *bootstr = melt_argument ("bootstrapping"); const char *genworkdir = melt_argument ("generate-workdir"); /* debug=n or debug=0 is handled as no debug */ if (bootstr && (!bootstr[0] || !strchr("Nn0", bootstr[0]))) melt_flag_bootstrapping = 1; if (genworkdir && (!genworkdir[0] || !strchr("Nn0", genworkdir[0]))) melt_flag_generate_work_link = 1; } #else /*!MELT_IS_PLUGIN*/ { /* for the MELT branch */ const char* debuggingstr = melt_argument ("debugging"); if (debuggingstr && !strcasecmp(debuggingstr, "mode")) { /* We forcibly clear the melt_flag_debug, which will be set in meltgc_do_initial_mode. */ inform (UNKNOWN_LOCATION, "MELT branch will give debugging messages after mode processing"); melt_flag_debug = 0; melt_debugging_after_mode = 1; } else if (debuggingstr && !strcasecmp(debuggingstr, "all")) { melt_flag_debug = 1; inform (UNKNOWN_LOCATION, "MELT branch giving all debugging messages"); } } #endif /* MELT_IS_PLUGIN */ #if MELT_HAVE_DEBUG { char* tracepath = getenv ("GCCMELT_TRACE_LOCATION"); if (tracepath) { melt_loctrace_file = fopen (tracepath, "w"); if (melt_loctrace_file) { time_t now = 0; time (&now); fprintf (melt_loctrace_file, "#MELT debug location trace file %s for pid %d version %s at %s", tracepath, (int)getpid(), melt_version_str(), ctime (&now)); inform (UNKNOWN_LOCATION, "MELT debug tracing location in file %s" " from GCCMELT_TRACE_LOCATION env.var", tracepath); } else warning (0, "MELT failed to open tracing location file %s" " from GCCMELT_TRACE_LOCATION env.var - %s", tracepath, xstrerror (errno)); } } #endif /*MELT_HAVE_DEBUG*/ /* Ensure that melt_source_dir & melt_module_dir are non-empty paths and accessible directories. Otherwise, this file has been miscompiled, or something strange happens, so we issue a warning. */ errno = 0; gcc_assert (melt_source_dir[0]); gcc_assert (melt_module_dir[0]); debugeprintf ("melt_really_initialize builtin melt_source_dir %s", melt_source_dir); debugeprintf ("melt_really_initialize builtin melt_module_dir %s", melt_module_dir); memset (&mystat, 0, sizeof(mystat)); if (!melt_flag_bootstrapping && ((errno=ENOTDIR), (stat(melt_source_dir, &mystat) || !S_ISDIR(mystat.st_mode)))) warning (0, "MELT with bad builtin source directory %s : %s", melt_source_dir, xstrerror (errno)); memset (&mystat, 0, sizeof(mystat)); if (!melt_flag_bootstrapping && ((errno=ENOTDIR), (stat(melt_module_dir, &mystat) || !S_ISDIR(mystat.st_mode)))) warning (0, "MELT with bad builtin module directory %s : %s", melt_module_dir, xstrerror (errno)); /* Ensure that the module makefile exists. */ gcc_assert (melt_module_make_command[0]); gcc_assert (melt_module_makefile[0]); if (!melt_flag_bootstrapping && access(melt_module_makefile, R_OK)) warning (0, "MELT cannot access module makefile %s : %s", melt_module_makefile, xstrerror (errno)); errno = 0; /* Open the list of generated C files */ { const char* genfilpath = melt_argument("generated-c-file-list"); if (genfilpath && genfilpath[0]) { time_t now = 0; time (&now); melt_generated_c_files_list_fil = fopen(genfilpath, "w"); if (!melt_generated_c_files_list_fil) fatal_error ("failed to open file %s for generated C file list [%s]", genfilpath, xstrerror (errno)); fprintf (melt_generated_c_files_list_fil, "# file %s with list of [over-]written generated emitted C files\n", genfilpath); fprintf (melt_generated_c_files_list_fil, "# MELT version %s run at %s", MELT_VERSION_STRING, /* ctime adds the ending newline! */ ctime (&now)); fprintf (melt_generated_c_files_list_fil, "# unchanged files are prefixed with =, new files are prefixed with +\n"); } } /* These are probably never freed! */ melt_gccversionstr = concat (versionstr, " MELT_", MELT_VERSION_STRING, NULL); melt_plugin_name = xstrdup (pluginame); modstr = melt_argument ("mode"); inistr = melt_argument ("init"); countdbgstr = melt_argument ("debugskip"); parsedmeltfilevect = VEC_alloc (meltchar_p, heap, 12); printset = melt_argument ("print-settings"); if (printset) { /* If asked for print-settings, output the settings in a format which should be sourcable by a Posix shell. */ FILE *setfil = NULL; time_t now = 0; char nowbuf[32]; char *curlocale = setlocale (LC_ALL, NULL); time (&now); memset (nowbuf, 0, sizeof nowbuf); strncpy (nowbuf, ctime (&now), sizeof(nowbuf)-1); { char *pcnl = strchr(nowbuf, '\n'); if (pcnl) *pcnl = 0; } if (!printset[0] || !strcmp(printset, "-")) setfil = stdout; else { setfil = fopen (printset, "w"); if (!setfil) fatal_error ("MELT cannot open print-settings file %s : %m", printset); } fprintf (setfil, "## MELT builtin settings %s\n", printset[0]?printset:"-"); /* Print the information with a # prefix, so a shell would ignore it. */ melt_print_version_info (setfil, "# "); /* We don't quote or escape builtin directories path, since they should not contain strange characters... */ fprintf (setfil, "MELTGCCBUILTIN_SOURCE_DIR='%s'\n", melt_source_dir); fprintf (setfil, "MELTGCCBUILTIN_MODULE_DIR='%s'\n", melt_module_dir); fprintf (setfil, "MELTGCCBUILTIN_MODULE_MAKE_COMMAND='%s'\n", melt_module_make_command); fprintf (setfil, "MELTGCCBUILTIN_MODULE_MAKEFILE='%s'\n", melt_module_makefile); fprintf (setfil, "MELTGCCBUILTIN_MODULE_CFLAGS='%s'\n", melt_module_cflags); fprintf (setfil, "MELTGCCBUILTIN_DEFAULT_MODLIS='%s'\n", melt_default_modlis); fprintf (setfil, "MELTGCCBUILTIN_GCC_VERSION=%d\n", melt_gcc_version); fprintf (setfil, "MELTGCCBUILTIN_VERSION='%s'\n", MELT_VERSION_STRING); fprintf (setfil, "MELTGCCBUILTIN_VERSION_STRING='%s'\n", melt_version_str ()); fprintf (setfil, "MELTGCCBUILTIN_RUNTIME_BUILD_DATE='%s'\n", melt_runtime_build_date); fprintf (setfil, "MELTGCCBUILTIN_PLUGIN_NAME='%s'\n", pluginame); fprintf (setfil, "MELTGCCBUILTIN_MELTRUN_PREPROCESSED_MD5='%s'\n", melt_run_preprocessed_md5); fprintf (setfil, "MELTGCCBUILTIN_GENERATED='%s'\n", nowbuf); fprintf (setfil, "MELTGCCBUILTIN_PROBE='%s'\n", melt_default_probe); if (gcc_exec_prefix) fprintf (setfil, "MELTGCCBUILTIN_GCC_EXEC_PREFIX='%s'\n", gcc_exec_prefix); else fprintf (setfil, "# MELTGCCBUILTIN_GCC_EXEC_PREFIX is not set\n"); #if defined(ENABLE_BUILD_WITH_CXX) || MELT_GCC_VERSION >= 4008 #ifdef __cplusplus fprintf (setfil, "MELTGCCBUILTIN_BUILD_WITH_CXX=1\n"); #else fprintf (setfil, "MELTGCCBUILTIN_BUILD_WITH_CXX=O\n"); #endif /*__cplusplus*/ #else /* !ENABLE_BUILD_WITH_CXX*/ fprintf (setfil, "# MELTGCCBUILTIN_BUILD_WITH_CXX is not set\n"); #endif /*ENABLE_BUILD_WITH_CXX*/ fflush (setfil); if (setfil == stdout) inform (UNKNOWN_LOCATION, "MELT printed builtin settings on "); else { inform (UNKNOWN_LOCATION, "MELT printed builtin settings in %s", printset); fclose (setfil); setfil = 0; } if (curlocale && curlocale[0] && strcmp(curlocale, "C") && strcmp(curlocale, "POSIX")) warning(0, "MELT printed settings in %s locale, better use C or POSIX locale!", curlocale); } /* Give messages for bootstrapping about ignored directories. */ if (melt_flag_bootstrapping) { char* envpath = NULL; inform (UNKNOWN_LOCATION, "MELT is bootstrapping so ignore builtin source directory %s", melt_source_dir); inform (UNKNOWN_LOCATION, "MELT is bootstrapping so ignore builtin module directory %s", melt_module_dir); if ((envpath = getenv ("GCCMELT_SOURCE_PATH")) != NULL) inform (UNKNOWN_LOCATION, "MELT is bootstrapping so ignore GCCMELT_SOURCE_PATH=%s", envpath); if ((envpath = getenv ("GCCMELT_MODULE_PATH")) != NULL) inform (UNKNOWN_LOCATION, "MELT is bootstrapping so ignore GCCMELT_MODULE_PATH=%s", envpath); } fflush (stderr); fflush (stdout); /* Return immediately if no mode is given. */ if (!modstr || *modstr=='\0') { debugeprintf ("melt_really_initialize return immediately since no mode (inistr=%s)", inistr); return; } /* Optionally trace the dynamic linking of modules. */ { char* moduleenv = getenv ("GCCMELT_TRACE_MODULE"); if (moduleenv) { melt_trace_module_fil = fopen (moduleenv, "a"); if (melt_trace_module_fil) { const char *outarg = melt_argument ("output"); time_t now = 0; time (&now); fprintf (melt_trace_module_fil, "# MELT module tracing start pid %d MELT version %s mode %s at %s", (int) getpid(), MELT_VERSION_STRING, modstr, ctime (&now)); if (outarg) fprintf (melt_trace_module_fil, "# MELT output argument %s\n", outarg); fflush (melt_trace_module_fil); inform (UNKNOWN_LOCATION, "MELT tracing module loading in %s (GCCMELT_TRACE_MODULE environment variable)", moduleenv); } } } /* Optionally trace the source files search. */ { char *sourceenv = getenv ("GCCMELT_TRACE_SOURCE"); if (sourceenv) { melt_trace_source_fil = fopen (sourceenv, "a"); if (melt_trace_source_fil) { const char *outarg = melt_argument ("output"); time_t now = 0; time (&now); fprintf (melt_trace_source_fil, "# MELT source tracing start pid %d MELT version %s mode %s at %s", (int) getpid(), MELT_VERSION_STRING, modstr, ctime (&now)); if (outarg) fprintf (melt_trace_source_fil, "# MELT output argument %s\n", outarg); fflush (melt_trace_source_fil); inform (UNKNOWN_LOCATION, "MELT tracing source loading in %s (GCCMELT_TRACE_SOURCE environment variable)", sourceenv); } } } if (melt_minorsizekilow == 0) { const char* minzstr = melt_argument ("minor-zone"); melt_minorsizekilow = minzstr ? (atol (minzstr)) : 0; if (melt_minorsizekilow < 256) melt_minorsizekilow = 256; else if (melt_minorsizekilow > 32768) melt_minorsizekilow = 32768; } melt_modinfvec = VEC_alloc (melt_module_info_t, heap, 32); /* don't use the index 0 so push an empty at 0 in modinfvec. */ { melt_module_info_t emptymi = {0, NULL, NULL, NULL, NULL}; #if MELT_GCC_VERSION >= 4008 // GCC 4.8 vector is C++ template so requires VEC_safe_push (melt_module_info_t, heap, melt_modinfvec, emptymi); #else VEC_safe_push (melt_module_info_t, heap, melt_modinfvec, &emptymi); #endif } /* The program handle dlopen is not traced! */ proghandle = dlopen (NULL, RTLD_NOW | RTLD_GLOBAL); if (!proghandle) /* Don't call melt_fatal_error - we are initializing! */ fatal_error ("melt failed to get whole program handle - %s", dlerror ()); if (countdbgstr != (char *) 0) melt_debugskipcount = atol (countdbgstr); seed = 0; /* In GCC 4.6, get_random_seed gives a string, but in 4.7 it gives a number. */ #if MELT_GCC_VERSION<=4006 randomseedstr = get_random_seed (false); gcc_assert (randomseedstr != (char *) 0); #else randomseednum = get_random_seed (false); #endif gcc_assert (MELT_ALIGN == sizeof (void *) || MELT_ALIGN == 2 * sizeof (void *) || MELT_ALIGN == 4 * sizeof (void *)); inited = 1; ggc_collect (); obstack_init (&melt_bstring_obstack); obstack_init (&melt_bname_obstack); #if MELT_GCC_VERSION<=4006 for (pc = randomseedstr; *pc; pc++) seed ^= (seed << 6) + (*pc); #else seed = ((seed * 35851) ^ (randomseednum * 65867)); #endif /*MELT_GCC_VERSION*/ srand48 (seed); gcc_assert (!melt_curalz); { size_t wantedwords = melt_minorsizekilow * 4096; if (wantedwords < (1 << 20)) wantedwords = (1 << 20); gcc_assert (melt_startalz == NULL && melt_endalz == NULL); gcc_assert (wantedwords * sizeof (void *) > 300 * MELTGLOB__LASTGLOB * sizeof (struct meltobject_st)); melt_allocate_young_gc_zone (wantedwords / sizeof(void*)); melt_newspecdatalist = NULL; melt_oldspecdatalist = NULL; debugeprintf ("melt_really_initialize alz %p-%p (%ld Kw)", melt_startalz, melt_endalz, (long) wantedwords >> 10); } /* Install the signal handlers, even if the signals won't be sent. */ melt_install_signal_handlers (); /* We are using register_callback here, even if MELT is not compiled as a plugin. */ register_callback (melt_plugin_name, PLUGIN_GGC_MARKING, melt_marking_callback, NULL); register_callback (melt_plugin_name, PLUGIN_GGC_START, melt_ggcstart_callback, NULL); register_callback (melt_plugin_name, PLUGIN_ATTRIBUTES, melt_attribute_callback, NULL); register_callback (melt_plugin_name, PLUGIN_PRAGMAS, melt_pragma_callback, NULL); register_callback (melt_plugin_name, PLUGIN_PRE_GENERICIZE, melt_pre_genericize_callback, NULL); register_callback (melt_plugin_name, PLUGIN_START_UNIT, melt_startunit_callback, NULL); register_callback (melt_plugin_name, PLUGIN_FINISH_UNIT, melt_finishunit_callback, NULL); register_callback (melt_plugin_name, PLUGIN_FINISH, melt_finishall_callback, NULL); register_callback (melt_plugin_name, PLUGIN_ALL_PASSES_START, meltgc_all_passes_start_callback, NULL); register_callback (melt_plugin_name, PLUGIN_ALL_PASSES_END, meltgc_all_passes_end_callback, NULL); register_callback (melt_plugin_name, PLUGIN_ALL_IPA_PASSES_START, meltgc_all_ipa_passes_start_callback, NULL); register_callback (melt_plugin_name, PLUGIN_ALL_IPA_PASSES_END, meltgc_all_ipa_passes_end_callback, NULL); register_callback (melt_plugin_name, PLUGIN_EARLY_GIMPLE_PASSES_START, meltgc_early_gimple_passes_start_callback, NULL); register_callback (melt_plugin_name, PLUGIN_EARLY_GIMPLE_PASSES_END, meltgc_early_gimple_passes_end_callback, NULL); /* TYhe meltgc_passexec_callback is always registered, perhaps just to check for signals. */ register_callback (melt_plugin_name, PLUGIN_PASS_EXECUTION, meltgc_passexec_callback, NULL); debugeprintf ("melt_really_initialize cpp_PREFIX=%s", cpp_PREFIX); debugeprintf ("melt_really_initialize cpp_EXEC_PREFIX=%s", cpp_EXEC_PREFIX); debugeprintf ("melt_really_initialize gcc_exec_prefix=%s", gcc_exec_prefix); debugeprintf ("melt_really_initialize melt_source_dir=%s", melt_source_dir); debugeprintf ("melt_really_initialize melt_module_dir=%s", melt_module_dir); debugeprintf ("melt_really_initialize inistr=%s", inistr); /* I really want meltgc_make_special to be linked in, even in plugin mode... So I test that the routine exists! */ debugeprintf ("melt_really_initialize meltgc_make_special=%#lx", (long) meltgc_make_special); meltgc_load_modules_and_do_mode (); /* force a minor GC */ melt_garbcoll (0, MELT_ONLY_MINOR); debugeprintf ("melt_really_initialize ended init=%s mode=%s", inistr, modstr); if (!quiet_flag) { #if MELT_IS_PLUGIN fprintf (stderr, "MELT plugin {%s} initialized for mode %s [%d modules]\n", versionstr, modstr, melt_nb_modules); #else fprintf (stderr, "GCC-MELT {%s} initialized for mode %s [%d modules]\n", versionstr, modstr, melt_nb_modules); #endif /*MELT_IS_PLUGIN*/ fflush (stderr); } } static void do_finalize_melt (void) { static int didfinal; const char* modstr = NULL; MELT_ENTERFRAME (1, NULL); #define finclosv meltfram__.mcfr_varptr[0] if (didfinal++>0) goto end; modstr = melt_argument ("mode"); if (!modstr) goto end; finclosv = melt_get_inisysdata (MELTFIELD_SYSDATA_EXIT_FINALIZER); if (melt_magic_discr ((melt_ptr_t) finclosv) == MELTOBMAG_CLOSURE) { MELT_LOCATION_HERE ("do_finalize_melt before applying final closure"); (void) melt_apply ((meltclosure_ptr_t) finclosv, (melt_ptr_t) NULL, "", NULL, "", NULL); } /* Always force a minor GC to be sure nothing stays in young region. */ melt_garbcoll (0, MELT_ONLY_MINOR); /* Clear the temporary directory if needed. */ if (tempdir_melt[0]) { DIR *tdir = opendir (tempdir_melt); VEC (meltchar_p, heap) * dirvec = 0; int nbdelfil = 0; struct dirent *dent = 0; if (!tdir) melt_fatal_error ("failed to open tempdir %s %m", tempdir_melt); dirvec = VEC_alloc (meltchar_p, heap, 30); while ((dent = readdir (tdir)) != NULL) { if (dent->d_name[0] && dent->d_name[0] != '.') /* this skips '.' & '..' and we have no .* file */ VEC_safe_push (meltchar_p, heap, dirvec, concat (tempdir_melt, "/", dent->d_name, NULL)); } closedir (tdir); while (!VEC_empty (meltchar_p, dirvec)) { char *tfilnam = VEC_pop (meltchar_p, dirvec); debugeprintf ("melt_finalize remove file %s", tfilnam); if (!remove (tfilnam)) nbdelfil++; free (tfilnam); }; VEC_free (meltchar_p, heap, dirvec); if (nbdelfil>0) inform (UNKNOWN_LOCATION, "MELT removed %d temporary files from %s", nbdelfil, tempdir_melt); } if (made_tempdir_melt && tempdir_melt[0]) { errno = 0; if (rmdir (tempdir_melt)) /* @@@ I don't know if it should be a warning or a fatal error - we are finalizing! */ warning (0, "failed to rmdir melt tempdir %s (%s)", tempdir_melt, xstrerror (errno)); } VEC_free (meltchar_p, heap, parsedmeltfilevect); parsedmeltfilevect = NULL; if (melt_generated_c_files_list_fil) { fprintf (melt_generated_c_files_list_fil, "# end of generated C file list\n"); fclose (melt_generated_c_files_list_fil); melt_generated_c_files_list_fil = NULL; } if (melt_trace_module_fil) { fprintf (melt_trace_module_fil, "# end of MELT module trace for pid %d\n\n", (int) getpid()); fclose (melt_trace_module_fil); melt_trace_module_fil = NULL; } if (melt_trace_source_fil) { fprintf (melt_trace_source_fil, "# end of MELT source trace for pid %d\n\n", (int) getpid()); fclose (melt_trace_source_fil); melt_trace_source_fil = NULL; } #if MELT_HAVE_DEBUG if (melt_loctrace_file) { long l = 0; fprintf (melt_loctrace_file, "\n##*## end of MELT debug location trace file MELT version %s\n", melt_version_str ()); fflush (melt_loctrace_file); l = ftell (melt_loctrace_file); fclose (melt_loctrace_file), melt_loctrace_file = NULL; inform (UNKNOWN_LOCATION, "MELT wrote trace location file of %ld Kbytes with GCCMELT_TRACE_LOCATION=%s\n", l>>10, getenv ("GCCMELT_TRACE_LOCATION")); } #endif dbgprintf ("do_finalize_melt ended melt_nb_modules=%d", melt_nb_modules); end: MELT_EXITFRAME (); #undef finclosv } #ifdef MELT_IS_PLUGIN /* this code is GPLv3 licenced & FSF copyrighted, so of course it is a GPL compatible GCC plugin. */ int plugin_is_GPL_compatible = 1; /* the plugin initialization code has to be exactly plugin_init */ int plugin_init (struct plugin_name_args* plugin_info, struct plugin_gcc_version* gcc_version) { char* gccversionstr = NULL; gcc_assert (plugin_info != NULL); gcc_assert (gcc_version != NULL); melt_plugin_argc = plugin_info->argc; melt_plugin_argv = plugin_info->argv; gccversionstr = concat (gcc_version->basever, " ", gcc_version->datestamp, " (", gcc_version->devphase, ") [MELT plugin]", NULL); if (!plugin_info->version) { /* this string is never freed */ plugin_info->version = concat ("MELT ", melt_version_str (), NULL); }; if (!plugin_info->help) plugin_info->help = "MELT is a meta plugin providing a high-level \ lispy domain specific language to extend GCC. See http://gcc-melt.org/"; melt_really_initialize (plugin_info->base_name, gccversionstr); free (gccversionstr); debugeprintf ("end of melt plugin_init"); return 0; /* success */ } #else /* !MELT_IS_PLUGIN*/ void melt_initialize (void) { debugeprintf ("start of melt_initialize [builtin MELT] version_string %s", version_string); /* For the MELT branch, we are using the plugin facilities without calling add_new_plugin, so we need to force the flag_plugin_added so that every plugin hook registration runs as if there was a MELT plugin! */ flag_plugin_added = true; melt_really_initialize ("MELT/_builtin", version_string); debugeprintf ("end of melt_initialize [builtin MELT] meltruntime %s", __DATE__); } #endif /* MELT_IS_PLUGIN */ int * melt_dynobjstruct_fieldoffset_at (const char *fldnam, const char *fil, int lin) { char *nam = 0; void *ptr = 0; nam = concat ("meltfieldoff__", fldnam, NULL); ptr = melt_dlsym_all (nam); if (!ptr) warning (0, "MELT failed to find field offset %s - %s (%s:%d)", nam, dlerror (), fil, lin); free (nam); return (int *) ptr; } int * melt_dynobjstruct_classlength_at (const char *clanam, const char *fil, int lin) { char *nam = 0; void *ptr = 0; nam = concat ("meltclasslen__", clanam, NULL); ptr = melt_dlsym_all (nam); if (!ptr) warning (0, "MELT failed to find class length %s - %s (%s:%d)", nam, dlerror (), fil, lin); free (nam); return (int *) ptr; } /**** * finalize melt. Called from toplevel.c after all is done ****/ void melt_finalize (void) { do_finalize_melt (); debugeprintf ("melt_finalize with %ld GarbColl, %ld fullGc", melt_nb_garbcoll, melt_nb_full_garbcoll); } static void discr_out (struct debugprint_melt_st *dp, meltobject_ptr_t odiscr) { int dmag = melt_magic_discr ((melt_ptr_t) odiscr); struct meltstring_st *str = NULL; if (dmag != MELTOBMAG_OBJECT) { fprintf (dp->dfil, "?discr@%p?", (void *) odiscr); return; } if (odiscr->obj_len >= MELTLENGTH_CLASS_NAMED && odiscr->obj_vartab) { str = (struct meltstring_st *) odiscr->obj_vartab[MELTFIELD_NAMED_NAME]; if (melt_magic_discr ((melt_ptr_t) str) != MELTOBMAG_STRING) str = NULL; } if (!str) { fprintf (dp->dfil, "?odiscr/%d?", odiscr->obj_hash); return; } fprintf (dp->dfil, "#%s", str->val); } static void nl_debug_out (struct debugprint_melt_st *dp, int depth) { int i; putc ('\n', dp->dfil); for (i = 0; i < depth; i++) putc (' ', dp->dfil); } static void skip_debug_out (struct debugprint_melt_st *dp, int depth) { if (dp->dcount % 4 == 0) nl_debug_out (dp, depth); else putc (' ', dp->dfil); } static bool is_named_obj (meltobject_ptr_t ob) { struct meltstring_st *str = 0; if (melt_magic_discr ((melt_ptr_t) ob) != MELTOBMAG_OBJECT) return FALSE; if (ob->obj_len < MELTLENGTH_CLASS_NAMED || !ob->obj_vartab) return FALSE; str = (struct meltstring_st *) ob->obj_vartab[MELTFIELD_NAMED_NAME]; if (melt_magic_discr ((melt_ptr_t) str) != MELTOBMAG_STRING) return FALSE; if (melt_is_instance_of ((melt_ptr_t) ob, (melt_ptr_t) MELT_PREDEF (CLASS_NAMED))) return TRUE; return FALSE; } static void debug_outstr (struct debugprint_melt_st *dp, const char *str) { int nbclin = 0; const char *pc; for (pc = str; *pc; pc++) { nbclin++; if (nbclin > 60 && strlen (pc) > 5) { if (ISSPACE (*pc) || ISPUNCT (*pc) || nbclin > 72) { fputs ("\\\n", dp->dfil); nbclin = 0; } } switch (*pc) { case '\n': fputs ("\\n", dp->dfil); break; case '\r': fputs ("\\r", dp->dfil); break; case '\t': fputs ("\\t", dp->dfil); break; case '\v': fputs ("\\v", dp->dfil); break; case '\f': fputs ("\\f", dp->dfil); break; case '\"': fputs ("\\q", dp->dfil); break; case '\'': fputs ("\\a", dp->dfil); break; default: if (ISPRINT (*pc)) putc (*pc, dp->dfil); else fprintf (dp->dfil, "\\x%02x", (*pc) & 0xff); break; } } } void melt_debug_out (struct debugprint_melt_st *dp, melt_ptr_t ptr, int depth) { int mag = melt_magic_discr (ptr); int ix; if (!dp->dfil) return; dp->dcount++; switch (mag) { case 0: { if (ptr) fprintf (dp->dfil, "??@%p??", (void *) ptr); else fputs ("@@", dp->dfil); break; } case MELTOBMAG_OBJECT: { struct meltobject_st *p = (struct meltobject_st *) ptr; bool named = is_named_obj (p); fputs ("%", dp->dfil); discr_out (dp, p->meltobj_class); fprintf (dp->dfil, "/L%dH%d", p->obj_len, p->obj_hash); if (p->obj_num) fprintf (dp->dfil, "N%d", p->obj_num); if (named) fprintf (dp->dfil, "<#%s>", ((struct meltstring_st *) (p->obj_vartab [MELTFIELD_NAMED_NAME]))->val); if ((!named || depth == 0) && depth < dp->dmaxdepth) { fputs ("[", dp->dfil); if (p->obj_vartab) for (ix = 0; ix < (int) p->obj_len; ix++) { if (ix > 0) skip_debug_out (dp, depth); melt_debug_out (dp, p->obj_vartab[ix], depth + 1); } fputs ("]", dp->dfil); } else if (!named) fputs ("..", dp->dfil); break; } case MELTOBMAG_MULTIPLE: { struct meltmultiple_st *p = (struct meltmultiple_st *) ptr; fputs ("*", dp->dfil); discr_out (dp, p->discr); if (depth < dp->dmaxdepth) { fputs ("(", dp->dfil); for (ix = 0; ix < (int) p->nbval; ix++) { if (ix > 0) skip_debug_out (dp, depth); melt_debug_out (dp, p->tabval[ix], depth + 1); } fputs (")", dp->dfil); } else fputs ("..", dp->dfil); break; } case MELTOBMAG_STRING: { struct meltstring_st *p = (struct meltstring_st *) ptr; fputs ("!", dp->dfil); discr_out (dp, p->discr); if (depth < dp->dmaxdepth) { fputs ("\"", dp->dfil); debug_outstr (dp, p->val); fputs ("\"", dp->dfil); } else fputs ("..", dp->dfil); break; } case MELTOBMAG_INT: { struct meltint_st *p = (struct meltint_st *) ptr; fputs ("!", dp->dfil); discr_out (dp, p->discr); fprintf (dp->dfil, "#%ld", p->val); break; } case MELTOBMAG_MIXINT: { struct meltmixint_st *p = (struct meltmixint_st *) ptr; fputs ("!", dp->dfil); discr_out (dp, p->discr); fprintf (dp->dfil, "[#%ld&", p->intval); melt_debug_out (dp, p->ptrval, depth + 1); fputs ("]", dp->dfil); break; } case MELTOBMAG_MIXLOC: { struct meltmixloc_st *p = (struct meltmixloc_st *) ptr; fputs ("!", dp->dfil); discr_out (dp, p->discr); fprintf (dp->dfil, "[#%ld&", p->intval); melt_debug_out (dp, p->ptrval, depth + 1); fputs ("]", dp->dfil); break; } case MELTOBMAG_LIST: { struct meltlist_st *p = (struct meltlist_st *) ptr; fputs ("!", dp->dfil); discr_out (dp, p->discr); if (depth < dp->dmaxdepth) { int ln = melt_list_length ((melt_ptr_t) p); struct meltpair_st *pr = 0; if (ln > 2) fprintf (dp->dfil, "[/%d ", ln); else fputs ("[", dp->dfil); for (pr = p->first; pr && melt_magic_discr ((melt_ptr_t) pr) == MELTOBMAG_PAIR; pr = pr->tl) { melt_debug_out (dp, pr->hd, depth + 1); if (pr->tl) skip_debug_out (dp, depth); } fputs ("]", dp->dfil); } else fputs ("..", dp->dfil); break; } case MELTOBMAG_MAPSTRINGS: { struct meltmapstrings_st *p = (struct meltmapstrings_st *) ptr; fputs ("|", dp->dfil); discr_out (dp, p->discr); if (depth < dp->dmaxdepth) { int ln = melt_primtab[p->lenix]; fprintf (dp->dfil, "{~%d/", p->count); if (p->entab) for (ix = 0; ix < ln; ix++) { const char *ats = p->entab[ix].e_at; if (!ats || ats == HTAB_DELETED_ENTRY) continue; nl_debug_out (dp, depth); fputs ("'", dp->dfil); debug_outstr (dp, ats); fputs ("' = ", dp->dfil); melt_debug_out (dp, p->entab[ix].e_va, depth + 1); fputs (";", dp->dfil); } fputs (" ~}", dp->dfil); } else fputs ("..", dp->dfil); break; } case MELTOBMAG_MAPOBJECTS: { struct meltmapobjects_st *p = (struct meltmapobjects_st *) ptr; fputs ("|", dp->dfil); discr_out (dp, p->discr); if (depth < dp->dmaxdepth) { int ln = melt_primtab[p->lenix]; fprintf (dp->dfil, "{%d/", p->count); if (p->entab) for (ix = 0; ix < ln; ix++) { meltobject_ptr_t atp = p->entab[ix].e_at; if (!atp || atp == HTAB_DELETED_ENTRY) continue; nl_debug_out (dp, depth); melt_debug_out (dp, (melt_ptr_t) atp, dp->dmaxdepth); fputs ("' = ", dp->dfil); melt_debug_out (dp, p->entab[ix].e_va, depth + 1); fputs (";", dp->dfil); } fputs (" }", dp->dfil); } else fputs ("..", dp->dfil); break; } case MELTOBMAG_CLOSURE: { struct meltclosure_st *p = (struct meltclosure_st *) ptr; fputs ("!.", dp->dfil); discr_out (dp, p->discr); if (depth < dp->dmaxdepth) { fprintf (dp->dfil, "[. rout="); melt_debug_out (dp, (melt_ptr_t) p->rout, depth + 1); skip_debug_out (dp, depth); fprintf (dp->dfil, " /%d: ", p->nbval); for (ix = 0; ix < (int) p->nbval; ix++) { if (ix > 0) skip_debug_out (dp, depth); melt_debug_out (dp, p->tabval[ix], depth + 1); } fputs (".]", dp->dfil); } else fputs ("..", dp->dfil); break; } case MELTOBMAG_ROUTINE: { struct meltroutine_st *p = (struct meltroutine_st *) ptr; fputs ("!:", dp->dfil); discr_out (dp, p->discr); if (depth < dp->dmaxdepth) { fprintf (dp->dfil, ".%s[:/%d ", p->routdescr, p->nbval); for (ix = 0; ix < (int) p->nbval; ix++) { if (ix > 0) skip_debug_out (dp, depth); melt_debug_out (dp, p->tabval[ix], depth + 1); } fputs (":]", dp->dfil); } else fputs ("..", dp->dfil); break; } case MELTOBMAG_STRBUF: { struct meltstrbuf_st *p = (struct meltstrbuf_st *) ptr; fputs ("!`", dp->dfil); discr_out (dp, p->discr); if (depth < dp->dmaxdepth) { fprintf (dp->dfil, "[`buflen=%ld ", melt_primtab[p->buflenix]); gcc_assert (p->bufstart <= p->bufend && p->bufend < (unsigned) melt_primtab[p->buflenix]); fprintf (dp->dfil, "bufstart=%u bufend=%u buf='", p->bufstart, p->bufend); if (p->bufzn) debug_outstr (dp, p->bufzn + p->bufstart); fputs ("' `]", dp->dfil); } else fputs ("..", dp->dfil); break; } case MELTOBMAG_PAIR: { struct meltpair_st *p = (struct meltpair_st *) ptr; fputs ("[pair:", dp->dfil); discr_out (dp, p->discr); if (depth < dp->dmaxdepth) { fputs ("hd:", dp->dfil); melt_debug_out (dp, p->hd, depth + 1); fputs ("; ti:", dp->dfil); melt_debug_out (dp, (melt_ptr_t) p->tl, depth + 1); } else fputs ("..", dp->dfil); fputs ("]", dp->dfil); break; } case MELTOBMAG_TREE: case MELTOBMAG_GIMPLE: case MELTOBMAG_GIMPLESEQ: case MELTOBMAG_BASICBLOCK: case MELTOBMAG_EDGE: case MELTOBMAG_MAPTREES: case MELTOBMAG_MAPGIMPLES: case MELTOBMAG_MAPGIMPLESEQS: case MELTOBMAG_MAPBASICBLOCKS: case MELTOBMAG_MAPEDGES: case MELTOBMAG_DECAY: melt_fatal_error ("debug_out unimplemented magic %d", mag); default: melt_fatal_error ("debug_out invalid magic %d", mag); } } void melt_dbgeprint (void *p) { struct debugprint_melt_st dps = { 0, 4, 0 }; dps.dfil = stderr; melt_debug_out (&dps, (melt_ptr_t) p, 0); putc ('\n', stderr); fflush (stderr); } void meltgc_debugmsgval(void* val_p, const char*msg, long count) { MELT_ENTERFRAME(2,NULL); #define valv meltfram__.mcfr_varptr[0] #define dbgfv meltfram__.mcfr_varptr[1] valv = val_p; dbgfv = melt_get_inisysdata (MELTFIELD_SYSDATA_DEBUGMSG); { union meltparam_un argtab[2]; memset(argtab, 0, sizeof(argtab)); argtab[0].meltbp_cstring = msg; argtab[1].meltbp_long = count; (void) melt_apply ((meltclosure_ptr_t) dbgfv, (melt_ptr_t)valv, MELTBPARSTR_CSTRING MELTBPARSTR_LONG, argtab, "", NULL); } MELT_EXITFRAME(); #undef valv #undef dbgfv } void melt_dbgbacktrace (int depth) { int curdepth = 1, totdepth = 0; struct melt_callframe_st *fr = 0; fprintf (stderr, " <{\n"); for (fr = melt_topframe; fr != NULL && curdepth < depth; (fr = fr->mcfr_prev), (curdepth++)) { fprintf (stderr, "frame#%d closure: ", curdepth); #if MELT_HAVE_DEBUG if (fr->mcfr_flocs) fprintf (stderr, "{%s} ", fr->mcfr_flocs); else fputs (" ", stderr); #endif if (fr->mcfr_nbvar >= 0 && fr->mcfr_closp) melt_dbgeprint (fr->mcfr_closp); } for (totdepth = curdepth; fr != NULL; fr = fr->mcfr_prev); fprintf (stderr, "}> backtraced %d frames of %d\n", curdepth, totdepth); fflush (stderr); } void melt_dbgshortbacktrace (const char *msg, int maxdepth) { int curdepth = 1; struct melt_callframe_st *fr = 0; if (maxdepth < 3) maxdepth = 3; fprintf (stderr, "\nSHORT BACKTRACE[#%ld] %s;", melt_dbgcounter, msg ? msg : "/"); for (fr = melt_topframe; fr != NULL && curdepth < maxdepth; (fr = fr->mcfr_prev), (curdepth++)) { fputs ("\n", stderr); fprintf (stderr, "#%d:", curdepth); if (fr->mcfr_closp && fr->mcfr_nbvar >= 0 && melt_magic_discr ((melt_ptr_t) fr->mcfr_closp) == MELTOBMAG_CLOSURE) { meltroutine_ptr_t curout = fr->mcfr_closp->rout; if (melt_magic_discr ((melt_ptr_t) curout) == MELTOBMAG_ROUTINE) fprintf (stderr, "<%s> ", curout->routdescr); else fputs ("?norout?", stderr); #if _GNU_SOURCE /* we have dladdr! */ { PTR_UNION_TYPE(meltroutfun_t*) funad = {0}; Dl_info funinf; memset (&funinf, 0, sizeof(funinf)); PTR_UNION_AS_CAST_PTR (funad) = curout->routfunad; if (dladdr (PTR_UNION_AS_VOID_PTR (funad), &funinf)) { if (funinf.dli_fname) /* Just print the basename of the *.so since it has an md5sum in the path. */ fprintf (stderr, "\n %s", melt_basename (funinf.dli_fname)); if (funinf.dli_sname) fprintf (stderr, " [%s=%p]", funinf.dli_sname, funinf.dli_saddr); fputc('\n', stderr); } else fputs (" ?", stderr); } #endif /*_GNU_SOURCE*/ } else fprintf (stderr, "_ "); #if MELT_HAVE_DEBUG if (fr->mcfr_flocs && fr->mcfr_flocs[0]) fprintf (stderr, "%s\n", fr->mcfr_flocs); else fputs (" ?", stderr); #endif }; if (fr) fprintf (stderr, "...&%d", maxdepth - curdepth); else fputs (".", stderr); putc ('\n', stderr); putc ('\n', stderr); fflush (stderr); } void melt_warn_for_no_expected_secondary_results_at (const char*fil, int lin) { static long cnt; if (cnt++ > 8) return; /* This warning is emitted when a MELT function caller expects secondary results, but none are returned. */ warning(0, "MELT RUNTIME WARNING [#%ld]: Secondary results are exepected at %s line %d", melt_dbgcounter, fil, lin); if (melt_flag_bootstrapping || melt_flag_debug) melt_dbgshortbacktrace("MELT caller expected secondary result[s] but got none", 10); } /* wrapping gimple & tree prettyprinting for MELT debug */ /* we really need in memory FILE* output; GNU libc -ie Linux- provides open_memstream for that; on other systems we use a temporary file, which would be very slow if it happens to not be cached in memory */ char* meltppbuffer; size_t meltppbufsiz; FILE* meltppfile; #if !HAVE_OPEN_MEMSTREAM static char* meltppfilename; #endif /* open the melttppfile for pretty printing, return the old one */ FILE* melt_open_ppfile (void) { FILE* oldfile = meltppfile; #if HAVE_OPEN_MEMSTREAM meltppbufsiz = 1024; meltppbuffer = xcalloc (1, meltppbufsiz); meltppfile = open_memstream (&meltppbuffer, &meltppsiz); if (!meltppfile) melt_fatal_error ("failed to open meltpp file in memory"); #else if (!meltppfilename) { #ifdef MELT_IS_PLUGIN /* in plugin mode, make_temp_file is not available from cc1, because make_temp_file is defined in libiberty.a and cc1 does not use make_temp_file so do not load the make_temp_file.o member of the static library libiberty! See also http://gcc.gnu.org/ml/gcc/2009-07/msg00157.html */ static char ourtempnamebuf[L_tmpnam+1]; int tfd = -1; strcpy (ourtempnamebuf, "/tmp/meltemp_XXXXXX"); tfd = mkstemp (ourtempnamebuf); if (tfd>=0) meltppfilename = ourtempnamebuf; else melt_fatal_error ("melt temporary file: mkstemp %s failed", ourtempnamebuf); #else /* !MELT_IS_PLUGIN */ meltppfilename = make_temp_file (".meltmem"); if (!meltppfilename) melt_fatal_error ("failed to get melt memory temporary file %s", xstrerror(errno)); #endif /* MELT_IS_PLUGIN */ } meltppfile = fopen (meltppfilename, "w+"); #endif return oldfile; } /* close the meltppfile for pretty printing; after than, the meltppbuffer & meltppbufsize contains the FILE* content */ void melt_close_ppfile (FILE *oldfile) { gcc_assert (meltppfile != (FILE*)0); #if HAVE_OPEN_MEMSTREAM /* the fclose automagically updates meltppbuffer & meltppbufsiz */ fclose (meltppfile); #else /* we don't have an in-memory FILE*; so we read the file; you'll better have it in a fast file system, like a memory one. */ fflush (meltppfile); meltppbufsiz = (size_t) ftell (meltppfile); rewind (meltppfile); meltppbuffer = (char*) xcalloc(1, meltppbufsiz); if (fread (meltppbuffer, meltppbufsiz, 1, meltppfile) <= 0) melt_fatal_error ("failed to re-read melt buffer temporary file (%s)", xstrerror (errno)); fclose (meltppfile); #endif meltppfile = oldfile; } /* pretty print into an outbuf a gimple */ void meltgc_ppout_gimple (melt_ptr_t out_p, int indentsp, gimple gstmt) { int outmagic = 0; #define outv meltfram__.mcfr_varptr[0] MELT_ENTERFRAME (1, NULL); outv = out_p; if (!outv) goto end; outmagic = melt_magic_discr ((melt_ptr_t) outv); if (!gstmt) { meltgc_add_out ((melt_ptr_t) outv, "%nullgimple%"); goto end; } switch (outmagic) { case MELTOBMAG_STRBUF: { FILE* oldfil = melt_open_ppfile (); print_gimple_stmt (meltppfile, gstmt, indentsp, TDF_LINENO | TDF_SLIM | TDF_VOPS); melt_close_ppfile (oldfil); meltgc_add_out_raw_len ((melt_ptr_t) outv, meltppbuffer, (int) meltppbufsiz); free(meltppbuffer); meltppbuffer = 0; meltppbufsiz = 0; } break; case MELTOBMAG_SPECIAL_DATA: { FILE* f = melt_get_file ((melt_ptr_t)outv); if (!f) goto end; print_gimple_stmt (f, gstmt, indentsp, TDF_LINENO | TDF_SLIM | TDF_VOPS); fflush (f); } break; default: goto end; } end: MELT_EXITFRAME (); #undef outv } /* pretty print into an outbuf a gimple seq */ void meltgc_ppout_gimple_seq (melt_ptr_t out_p, int indentsp, gimple_seq gseq) { int outmagic = 0; #define outv meltfram__.mcfr_varptr[0] MELT_ENTERFRAME (2, NULL); outv = out_p; if (!outv) goto end; if (!gseq) { meltgc_add_out ((melt_ptr_t) outv, "%nullgimpleseq%"); goto end; } outmagic = melt_magic_discr ((melt_ptr_t) outv); switch (outmagic) { case MELTOBMAG_STRBUF: { FILE* oldfil = melt_open_ppfile (); print_gimple_seq (meltppfile, gseq, indentsp, TDF_LINENO | TDF_SLIM | TDF_VOPS); melt_close_ppfile (oldfil); meltgc_add_out_raw_len ((melt_ptr_t) outv, meltppbuffer, (int) meltppbufsiz); free(meltppbuffer); meltppbuffer = 0; meltppbufsiz = 0; } break; case MELTOBMAG_SPECIAL_DATA: { FILE* f = melt_get_file ((melt_ptr_t)outv); if (!f) goto end; print_gimple_seq (f, gseq, indentsp, TDF_LINENO | TDF_SLIM | TDF_VOPS); fflush (f); } break; default: goto end; } end: MELT_EXITFRAME (); #undef endv } /* pretty print a tree */ void meltgc_ppout_tree_perhaps_briefly (melt_ptr_t out_p, int indentsp, tree tr, bool briefly) { int outmagic = 0; #define outv meltfram__.mcfr_varptr[0] MELT_ENTERFRAME (2, NULL); outv = out_p; if (!outv) goto end; if (!tr) { meltgc_add_out_raw ((melt_ptr_t) outv, "%nulltree%"); goto end; } outmagic = melt_magic_discr ((melt_ptr_t) outv); switch (outmagic) { case MELTOBMAG_STRBUF: { FILE* oldfil = melt_open_ppfile (); if (briefly) print_node_brief (meltppfile, "", tr, indentsp); else print_node (meltppfile, "", tr, indentsp); melt_close_ppfile (oldfil); meltgc_add_out_raw_len ((melt_ptr_t) outv, meltppbuffer, (int) meltppbufsiz); free(meltppbuffer); meltppbuffer = 0; meltppbufsiz = 0; } break; case MELTOBMAG_SPECIAL_DATA: { FILE* f = melt_get_file ((melt_ptr_t)outv); if (!f) goto end; if (briefly) print_node_brief (f, "", tr, indentsp); else print_node (f, "", tr, indentsp); fflush (f); } break; default: goto end; } end: MELT_EXITFRAME (); #undef outv } /* pretty print into an outbuf a basicblock */ void meltgc_ppout_basicblock (melt_ptr_t out_p, int indentsp, basic_block bb) { gimple_seq gsq = 0; #define outv meltfram__.mcfr_varptr[0] MELT_ENTERFRAME (2, NULL); outv = out_p; if (!outv) goto end; if (!bb) { meltgc_add_out_raw ((melt_ptr_t) outv, "%nullbasicblock%"); goto end; } meltgc_out_printf ((melt_ptr_t) outv, "basicblock ix%d", bb->index); gsq = bb_seq (bb); if (gsq) { meltgc_add_out_raw ((melt_ptr_t) outv, "{."); meltgc_ppout_gimple_seq ((melt_ptr_t) outv, indentsp + 1, gsq); meltgc_add_out_raw ((melt_ptr_t) outv, ".}"); } else meltgc_add_out_raw ((melt_ptr_t) outv, "_;"); end: MELT_EXITFRAME (); #undef sbufv } /* print into an outbuf an edge */ void meltgc_out_edge (melt_ptr_t out_p, edge edg) { int outmagic = 0; #define outv meltfram__.mcfr_varptr[0] MELT_ENTERFRAME (1, NULL); outv = out_p; if (!outv) goto end; outmagic = melt_magic_discr ((melt_ptr_t) outv); if (!edg) { meltgc_add_out ((melt_ptr_t) outv, "%nulledge%"); goto end; } switch (outmagic) { case MELTOBMAG_STRBUF: { FILE* oldfil= melt_open_ppfile (); dump_edge_info (meltppfile, edg, #if MELT_GCC_VERSION >= 4008 TDF_DETAILS, #endif /*do_succ=*/ 1); melt_close_ppfile (oldfil); meltgc_add_out_raw_len ((melt_ptr_t) outv, meltppbuffer, (int) meltppbufsiz); free(meltppbuffer); meltppbuffer = 0; meltppbufsiz = 0; } break; case MELTOBMAG_SPECIAL_DATA: { FILE* f = melt_get_file ((melt_ptr_t)outv); if (!f) goto end; dump_edge_info (f, edg, #if MELT_GCC_VERSION >= 4008 TDF_DETAILS, // argument appearing in GCC 4.8 august 2012 trunk #endif /*do_succ=*/ 1); fflush (f); } break; default: goto end; } end: MELT_EXITFRAME (); #undef outv } /* print into an outbuf a loop */ void meltgc_out_loop (melt_ptr_t out_p, loop_p loo) { int outmagic = 0; #define outv meltfram__.mcfr_varptr[0] MELT_ENTERFRAME (1, NULL); outv = out_p; if (!outv) goto end; outmagic = melt_magic_discr ((melt_ptr_t) outv); if (!loo) { meltgc_add_out ((melt_ptr_t) outv, "%null_loop%"); goto end; } switch (outmagic) { case MELTOBMAG_STRBUF: { FILE* oldfil= melt_open_ppfile (); fprintf (meltppfile, "loop@%p: ", (void*) loo); flow_loop_dump (loo, meltppfile, NULL, 1); melt_close_ppfile (oldfil); meltgc_add_out_raw_len ((melt_ptr_t) outv, meltppbuffer, (int) meltppbufsiz); free(meltppbuffer); meltppbuffer = 0; meltppbufsiz = 0; } break; case MELTOBMAG_SPECIAL_DATA: { FILE* f = melt_get_file ((melt_ptr_t)outv); if (!f) goto end; fprintf (f, "loop@%p: ", (void*) loo); flow_loop_dump (loo, f, NULL, 1); fflush (f); } break; default: goto end; } end: MELT_EXITFRAME (); #undef outv } /* pretty print into an sbuf a mpz_t GMP multiprecision integer */ void meltgc_ppout_mpz (melt_ptr_t out_p, int indentsp, mpz_t mp) { int len = 0; char* cbuf = 0; char tinybuf [64]; #define outv meltfram__.mcfr_varptr[0] MELT_ENTERFRAME (2, NULL); outv = out_p; memset(tinybuf, 0, sizeof (tinybuf)); if (!outv || indentsp<0) goto end; if (!mp) { meltgc_add_out_raw ((melt_ptr_t) outv, "%nullmp%"); goto end; } len = mpz_sizeinbase(mp, 10) + 2; if (len < (int)sizeof(tinybuf)-2) { mpz_get_str (tinybuf, 10, mp); meltgc_add_out_raw ((melt_ptr_t) outv, tinybuf); } else { cbuf = (char*) xcalloc(len+2, 1); mpz_get_str(cbuf, 10, mp); meltgc_add_out_raw ((melt_ptr_t) outv, cbuf); free(cbuf); } end: MELT_EXITFRAME (); #undef sbufv } /* pretty print into an out the GMP multiprecision integer of a mixbigint */ void meltgc_ppout_mixbigint (melt_ptr_t out_p, int indentsp, melt_ptr_t big_p) { #define outv meltfram__.mcfr_varptr[0] #define bigv meltfram__.mcfr_varptr[1] MELT_ENTERFRAME (3, NULL); outv = out_p; bigv = big_p; if (!outv) goto end; if (!bigv || melt_magic_discr ((melt_ptr_t) bigv) != MELTOBMAG_MIXBIGINT) goto end; { mpz_t mp; mpz_init (mp); if (melt_fill_mpz_from_mixbigint((melt_ptr_t) bigv, mp)) meltgc_ppout_mpz ((melt_ptr_t) outv, indentsp, mp); mpz_clear (mp); } end: MELT_EXITFRAME (); #undef sbufv #undef bigv } /* make a new boxed file */ melt_ptr_t meltgc_new_file (melt_ptr_t discr_p, FILE* fil) { unsigned mag = 0; MELT_ENTERFRAME(2, NULL); #define discrv meltfram__.mcfr_varptr[0] #define object_discrv ((meltobject_ptr_t)(discrv)) #define resv meltfram__.mcfr_varptr[1] #define spec_resv ((struct meltspecial_st*)(resv)) #define spda_resv ((struct meltspecialdata_st*)(resv)) discrv = (void *) discr_p; if (melt_magic_discr ((melt_ptr_t) (discrv)) != MELTOBMAG_OBJECT) goto end; mag = object_discrv->meltobj_magic; switch (mag) { case MELTOBMAG_SPECIAL_DATA: { resv = meltgc_make_specialdata ((melt_ptr_t) discrv); /* first handle rawfile which are special cases of files */ if (discrv == MELT_PREDEF(DISCR_RAWFILE) || melt_is_subclass_of ((meltobject_ptr_t)discrv, (meltobject_ptr_t)MELT_PREDEF(DISCR_RAWFILE))) { spda_resv->meltspec_kind = meltpydkind_rawfile; spda_resv->meltspec_payload.meltpayload_file1 = fil; } else if (discrv == MELT_PREDEF(DISCR_FILE) || melt_is_subclass_of ((meltobject_ptr_t)discrv, (meltobject_ptr_t)MELT_PREDEF(DISCR_FILE))) { spda_resv->meltspec_kind = meltpydkind_file; spda_resv->meltspec_payload.meltpayload_file1 = fil; } } break; default: resv = NULL; goto end; } goto end; end: MELT_EXITFRAME (); return (melt_ptr_t) resv; #undef resv #undef spec_resv #undef spda_resv } /* Write a buffer to a file, but take care to not overwrite the file if it does not change. */ void melt_output_strbuf_to_file_no_overwrite (melt_ptr_t sbufv, const char*filnam) { static unsigned cnt; char buf[64]; time_t now = 0; char* tempath = NULL; char* bakpath = NULL; long r = 0; FILE *ftemp = NULL; FILE *filold = NULL; bool samefc = false; if (melt_magic_discr (sbufv) != MELTOBMAG_STRBUF) return; if (!filnam || !filnam[0]) return; cnt++; memset (buf, 0, sizeof(buf)); time (&now); r = (melt_lrand () & 0x3ffffff) ^ ((long)now & (0x7fffffff)); snprintf (buf, sizeof (buf), "_n%d_p%d_r%lx.tmp", cnt, (int) getpid(), r); tempath = concat (filnam, buf, NULL); ftemp = fopen(tempath, "w+"); if (!ftemp) melt_fatal_error ("failed to open temporary %s for uniquely [over-]writing %s - %m", tempath, filnam); if (fwrite (melt_strbuf_str (sbufv), melt_strbuf_usedlength (sbufv), 1, ftemp) != 1) melt_fatal_error ("failed to write into temporary %s for writing %s - %m", tempath, filnam); fflush(ftemp); filold = fopen(filnam, "r"); if (!filold) { fclose(ftemp); if (rename (tempath, filnam)) melt_fatal_error ("failed to rename %s to new %s - %m", tempath, filnam); free (tempath), tempath = NULL; return; } samefc = true; rewind (ftemp); while (samefc) { int tc = getc (ftemp); int oc = getc (filold); if (tc == EOF && oc == EOF) break; if (tc != oc) samefc = false; }; samefc = samefc && feof(ftemp) && feof(filold); fclose (ftemp), ftemp = NULL; fclose (filold), filold = NULL; if (samefc) { remove (tempath); return; } else { bakpath = concat (filnam, "~", NULL); (void) rename (filnam, bakpath); if (rename (tempath, filnam)) melt_fatal_error ("failed to rename %s to overwritten %s - %m", tempath, filnam); } free (tempath), tempath = NULL; free (bakpath), bakpath = NULL; } /*********************************************************** * generate C code for a melt unit name; take care to avoid touching * the generated C file when it happens to be the same as what existed * on disk before, to help the "make" utility. ***********************************************************/ void melt_output_cfile_decl_impl_secondary_option (melt_ptr_t unitnam, melt_ptr_t declbuf, melt_ptr_t implbuf, melt_ptr_t optbuf, int filrank) { static unsigned cnt; bool samefil = false; char *dotcnam = NULL; char *dotempnam = NULL; char *dotcpercentnam = NULL; FILE *cfil = NULL; FILE *oldfil = NULL; char *mycwd = getpwd (); const char *workdir = NULL; gcc_assert (melt_magic_discr (unitnam) == MELTOBMAG_STRING); gcc_assert (melt_magic_discr (declbuf) == MELTOBMAG_STRBUF); gcc_assert (melt_magic_discr (implbuf) == MELTOBMAG_STRBUF); cnt++; /** FIXME : should implement some policy about the location of the generated C file; currently using the pwd */ { const char *s = melt_string_str (unitnam); int slen = strlen (s); char bufpid[48]; time_t now = 0; time (&now); if (melt_flag_generate_work_link) workdir = melt_argument ("workdir"); debugeprintf ("melt_output_cfile_decl_impl_secondary s=%s cnt=%u workdir=%s", s, cnt, workdir); /* generate in bufpid a unique file suffix from the pid and the time */ memset (bufpid, 0, sizeof(bufpid)); snprintf (bufpid, sizeof(bufpid)-1, "_p%d_n%d_r%x_c%u", (int) getpid(), (int) (now%100000), (int)((melt_lrand()) & 0xffff), cnt); if (slen>2 && (s[slen-2]!='.' || s[slen-1]!='c')) { dotcnam = concat (s, ".c", NULL); dotcpercentnam = concat (s, ".c%", NULL); if (workdir && !strcmp(workdir, ".") && melt_flag_generate_work_link) dotempnam = concat (workdir, /*DIR_SEPARATOR here*/ "/", melt_basename (s), ".c%", bufpid, NULL); else dotempnam = concat (s, ".c%", bufpid, NULL); } else { dotcnam = xstrdup (s); dotcpercentnam = concat (s, "%", NULL); if (workdir && !strcmp(workdir, ".") && melt_flag_generate_work_link) dotempnam = concat (workdir, /*DIR_SEPARATOR here*/ "/", melt_basename (s), "%", bufpid, NULL); else dotempnam = concat (s, "%", bufpid, NULL); }; } debugeprintf ("melt_output_cfile_decl_impl_secondary_option dotempnam=%s melt_flag_generate_work_link=%d", dotempnam, melt_flag_generate_work_link); /* we first write in the temporary name */ cfil = fopen (dotempnam, "w"); if (!cfil) melt_fatal_error ("failed to open melt generated file %s - %m", dotempnam); fprintf (cfil, "/* GCC MELT GENERATED FILE %s - DO NOT EDIT */\n", melt_basename (dotcnam)); if (filrank <= 0) { if (melt_magic_discr (optbuf) == MELTOBMAG_STRBUF) { fprintf (cfil, "\n/***+ %s options +***\n", melt_basename (melt_string_str (unitnam))); melt_putstrbuf (cfil, optbuf); fprintf (cfil, "\n***- end %s options -***/\n", melt_basename (melt_string_str (unitnam))); } else fprintf (cfil, "\n/***+ %s without options +***/\n", melt_basename (melt_string_str (unitnam))); } else fprintf (cfil, "/* secondary MELT generated C file of rank #%d */\n", filrank); fprintf (cfil, "#include \"melt-run.h\"\n\n");; if (filrank <= 0) fprintf (cfil, "\n/* used hash from melt-run.h when compiling this file: */\n" "MELT_EXTERN const char meltrun_used_md5_melt[] = MELT_RUN_HASHMD5 /* from melt-run.h */;\n\n"); else fprintf (cfil, "\n/* used hash from melt-run.h when compiling this file: */\n" "MELT_EXTERN const char meltrun_used_md5_melt_f%d[] = MELT_RUN_HASHMD5 /* from melt-run.h */;\n\n", filrank); fprintf (cfil, "\n/**** %s declarations ****/\n", melt_basename (melt_string_str (unitnam))); melt_putstrbuf (cfil, declbuf); putc ('\n', cfil); fflush (cfil); fprintf (cfil, "\n/**** %s implementations ****/\n", melt_basename (melt_string_str (unitnam))); melt_putstrbuf (cfil, implbuf); putc ('\n', cfil); fflush (cfil); fprintf (cfil, "\n/**** end of %s ****/\n", melt_basename (melt_string_str (unitnam))); fclose (cfil); cfil = 0; /* reopen the dotempnam and the dotcnam files to compare their content */ cfil = fopen (dotempnam, "r"); if (!cfil) melt_fatal_error ("failed to re-open melt generated file %s - %m", dotempnam); oldfil = fopen (dotcnam, "r"); /* we compare oldfil & cfil; if they are the same we don't overwrite the oldfil; this is for the happiness of make utility. */ samefil = oldfil != NULL; if (samefil) { /* files of different sizes are different */ struct stat cfilstat, oldfilstat; memset (&cfilstat, 0, sizeof (cfilstat)); memset (&oldfilstat, 0, sizeof (oldfilstat)); if (fstat (fileno(cfil), &cfilstat) || fstat (fileno (oldfil), &oldfilstat) || cfilstat.st_size != oldfilstat.st_size) samefil = false; } while (samefil && (!feof(cfil) || !feof(oldfil))) { int c = getc (cfil); int o = getc (oldfil); if (c != o) samefil = false; if (c < 0) break; }; samefil = samefil && feof(cfil) && feof(oldfil); fclose (cfil); if (oldfil) fclose (oldfil); if (samefil) { /* Rare case when the generated file is the same as what existed in the filesystem, so discard the generated temporary file. */ if (remove (dotempnam)) melt_fatal_error ("failed to remove %s as melt generated file - %m", dotempnam); if (IS_ABSOLUTE_PATH(dotcnam)) inform (UNKNOWN_LOCATION, "MELT generated same file %s", dotcnam); else inform (UNKNOWN_LOCATION, "MELT generated same file %s in %s", dotcnam, mycwd); if (melt_generated_c_files_list_fil) fprintf (melt_generated_c_files_list_fil, "= %s\n", dotcnam); } else { bool samemdfil = false; char *md5nam = NULL; /* Usual case when the generated file is not the same as its former variant; rename the old foo.c as foo.c% for backup, etc... */ (void) rename (dotcnam, dotcpercentnam); if (melt_flag_generate_work_link && workdir) { /* if symlinks to work files are required, we generate a unique filename in the work directory using the md5sum of the generated file, then we symlink it.. */ int mln = 0; FILE* mdfil = NULL; char *realworkdir = NULL; char md5hexbuf[40]; /* larger than md5 hex, for null termination... */ memset (md5hexbuf, 0, sizeof(md5hexbuf)); melt_string_hex_md5sum_file_to_hexbuf (dotempnam, md5hexbuf); if (!md5hexbuf[0]) melt_fatal_error ("failed to compute md5sum of %s - %m", dotempnam); realworkdir = lrealpath (workdir); md5nam = concat (realworkdir, /*DIR_SEPARATOR here*/ "/", melt_basename (dotcnam), NULL); free (realworkdir), realworkdir = NULL; mln = strlen (md5nam); if (mln>3 && !strcmp(md5nam + mln -2, ".c")) md5nam[mln-2] = (char)0; md5nam = reconcat (md5nam, md5nam, ".", md5hexbuf, ".mdsumed.c", NULL); mdfil = fopen (md5nam, "r"); if (mdfil) { FILE* dotempfil = fopen(dotempnam, "r"); samemdfil = (dotempfil != NULL); while (samemdfil && (!feof(mdfil) || !feof(dotempfil))) { int c = getc (mdfil); int o = getc (dotempfil); if (c != o) samemdfil = false; if (c < 0) /*both are eof*/ break; }; fclose (mdfil), mdfil = NULL; if (dotempfil) fclose (dotempfil); }; if (samemdfil) { unlink (dotempnam); if (symlink (md5nam, dotcnam)) melt_fatal_error ("failed to symlink old %s as %s - %m", md5nam, dotcnam); if (IS_ABSOLUTE_PATH (dotcnam)) inform (UNKNOWN_LOCATION, "MELT symlinked existing file %s to %s", md5nam, dotcnam); else inform (UNKNOWN_LOCATION, "MELT symlinked existing file %s to %s in %s", md5nam, dotcnam, mycwd); if (melt_generated_c_files_list_fil) { fprintf (melt_generated_c_files_list_fil, "# same symlink -> %s:\n", md5nam); fprintf (melt_generated_c_files_list_fil, "= %s\n", dotcnam); } } else { /* if the file md5nam exist, either we have an improbable md5 collision, or it was edited after generation. */ if (!access (md5nam, R_OK)) inform (UNKNOWN_LOCATION, "MELT overwriting generated file %s (perhaps manually edited)", md5nam); if (rename (dotempnam, md5nam)) melt_fatal_error ("failed to rename %s as %s melt generated work file - %m", dotempnam, md5nam); if (symlink (md5nam, dotcnam)) melt_fatal_error ("failed to symlink new %s as %s - %m", md5nam, dotcnam); if (IS_ABSOLUTE_PATH (dotcnam)) inform (UNKNOWN_LOCATION, "MELT symlinked new file %s to %s", md5nam, dotcnam); else inform (UNKNOWN_LOCATION, "MELT symlinked new file %s to %s in %s", md5nam, dotcnam, mycwd); if (melt_generated_c_files_list_fil) fprintf (melt_generated_c_files_list_fil, "# symlink to new %s is:\n" "+ %s\n", md5nam, dotcnam); } free (md5nam), md5nam = NULL; } else { /* rename the generated temporary */ if (rename (dotempnam, dotcnam)) melt_fatal_error ("failed to rename %s as %s melt generated file - %m", dotempnam, dotcnam); if (IS_ABSOLUTE_PATH (dotcnam)) inform (UNKNOWN_LOCATION, "MELT generated new file %s", dotcnam); else inform (UNKNOWN_LOCATION, "MELT generated new file %s in %s", dotcnam, mycwd); if (melt_generated_c_files_list_fil) fprintf (melt_generated_c_files_list_fil, "#new file:\n" "+ %s\n", dotcnam); } } debugeprintf ("output_cfile done dotcnam %s", dotcnam); free (dotcnam); free (dotempnam); free (dotcpercentnam); } /* 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) { MELT_ENTERFRAME(4, NULL); #define valv meltfram__.mcfr_varptr[0] #define compv meltfram__.mcfr_varptr[1] #define pairv meltfram__.mcfr_varptr[2] valv = val_p; if (!fil || !valv) goto end; switch (melt_magic_discr((melt_ptr_t)valv)) { case MELTOBMAG_STRING: melt_puts (fil, melt_string_str ((melt_ptr_t)valv)); break; case MELTOBMAG_STRBUF: melt_puts (fil, melt_strbuf_str ((melt_ptr_t)valv)); break; case MELTOBMAG_INT: fprintf (fil, "%ld", melt_get_int ((melt_ptr_t)valv)); break; case MELTOBMAG_LIST: { for (pairv = ((struct meltlist_st*)(valv))->first; pairv && melt_magic_discr((melt_ptr_t)pairv) == MELTOBMAG_PAIR; pairv = ((struct meltpair_st*)(pairv))->tl) { compv = ((struct meltpair_st*)(pairv))->hd; if (compv) meltgc_output_file (fil, (melt_ptr_t) compv); compv = NULL; }; pairv = NULL; /* for GC happiness */ } break; case MELTOBMAG_MULTIPLE: { int sz = ((struct meltmultiple_st*)(valv))->nbval; int ix = 0; for (ix = 0; ix < sz; ix ++) { compv = melt_multiple_nth ((melt_ptr_t)valv, ix); if (!compv) continue; meltgc_output_file (fil, (melt_ptr_t) compv); } } break; default: /* FIXME: perhaps add a warning, or handle more cases... */ ; } end: MELT_EXITFRAME(); #undef valv #undef compv #undef pairv } /* Added */ #undef melt_assert_failed #undef melt_check_failed void melt_assert_failed (const char *msg, const char *filnam, int lineno, const char *fun) { time_t nowt = 0; static char msgbuf[600]; if (!msg) msg = "??no-msg??"; if (!filnam) filnam = "??no-filnam??"; if (!fun) fun = "??no-func??"; if (melt_dbgcounter > 0) snprintf (msgbuf, sizeof (msgbuf) - 1, "%s:%d: MELT ASSERT #!%ld: %s {%s}", melt_basename (filnam), lineno, melt_dbgcounter, fun, msg); else snprintf (msgbuf, sizeof (msgbuf) - 1, "%s:%d: MELT ASSERT: %s {%s}", melt_basename (filnam), lineno, fun, msg); time (&nowt); melt_fatal_info (filnam, lineno); /* don't call melt_fatal_error here! */ fatal_error ("%s:%d: MELT ASSERT FAILED <%s> : %s\n @ %s\n", melt_basename (filnam), lineno, fun, msg, ctime (&nowt)); } /* Should usually be called from melt_fatal_error macro... */ void melt_fatal_info (const char*filename, int lineno) { int ix = 0; const char* workdir = NULL; int workdirlen = 0; melt_module_info_t* mi=0; if (filename != NULL && lineno>0) { error ("MELT fatal failure from %s:%d [MELT built %s, version %s]", filename, lineno, melt_runtime_build_date, melt_version_str ()); inform (UNKNOWN_LOCATION, "MELT failed at %s:%d in directory %s", filename, lineno, getpwd ()); } else { error ("MELT fatal failure without location [MELT built %s, version %s]", melt_runtime_build_date, melt_version_str ()); inform (UNKNOWN_LOCATION, "MELT failed in directory %s", getpwd ()); } workdir = melt_argument("workdir"); if (workdir && workdir[0]) { workdirlen = (int) strlen(workdir); inform (UNKNOWN_LOCATION, "MELT failed with work directory %s", workdir); } fflush (NULL); #if MELT_HAVE_DEBUG melt_dbgshortbacktrace ("MELT fatal failure", 100); #endif if (melt_modinfvec) /* Index 0 is unused in melt_modinfvec! */ for (ix = 1; VEC_iterate (melt_module_info_t, melt_modinfvec, ix, mi); ix++) { char*curmodpath = NULL; if (!mi || !mi->mmi_dlh || !(curmodpath = mi->mmi_modpath) || mi->mmi_magic != MELT_MODULE_MAGIC) continue; if (workdirlen>0 && !strncmp (workdir, curmodpath, workdirlen)) inform (UNKNOWN_LOCATION, "MELT failure with loaded work module #%d: %s", ix, curmodpath+workdirlen); else inform (UNKNOWN_LOCATION, "MELT failure with loaded module #%d: %s", ix, melt_basename (curmodpath)); }; if (filename != NULL && lineno>0) inform (UNKNOWN_LOCATION, "MELT got fatal failure from %s:%d", filename, lineno); if (cfun && cfun->decl) inform (UNKNOWN_LOCATION, "MELT got fatal failure with current function (cfun %p) as %q+D", (void*) cfun, cfun->decl); if (current_pass) inform (UNKNOWN_LOCATION, "MELT got fatal failure from current_pass %p #%d named %s", (void*) current_pass, current_pass->static_pass_number, current_pass->name); fflush (NULL); } void melt_check_failed (const char *msg, const char *filnam, int lineno, const char *fun) { static char msgbuf[500]; if (!msg) msg = "??no-msg??"; if (!filnam) filnam = "??no-filnam??"; if (!fun) fun = "??no-func??"; if (melt_dbgcounter > 0) snprintf (msgbuf, sizeof (msgbuf) - 1, "%s:%d: MELT CHECK #!%ld: %s {%s}", melt_basename (filnam), lineno, melt_dbgcounter, fun, msg); else snprintf (msgbuf, sizeof (msgbuf) - 1, "%s:%d: MELT CHECK: %s {%s}", melt_basename (filnam), lineno, fun, msg); melt_dbgshortbacktrace (msgbuf, 100); warning (0, "%s:%d: MELT CHECK FAILED <%s> : %s\n", melt_basename (filnam), lineno, fun, msg); } /* internal function to run the melt pass after hook, at end of every MELT pass exec function. */ static void meltgc_run_meltpass_after_hook (void) { const char* passname = current_pass?current_pass->name:NULL; int passnumber = current_pass?current_pass->static_pass_number:0; MELT_ENTERFRAME (2, NULL); #define pahookv meltfram__.mcfr_varptr[0] MELT_LOCATION_HERE ("meltgc_run_meltpass_after_hook"); MELT_CHECK_SIGNAL (); pahookv = melt_get_inisysdata (MELTFIELD_SYSDATA_MELTPASS_AFTER_HOOK); if (pahookv == NULL) goto end; if (melt_magic_discr ((melt_ptr_t) pahookv) == MELTOBMAG_CLOSURE) { union meltparam_un argtab[2]; memset (argtab, 0, sizeof (argtab)); argtab[0].meltbp_cstring = passname; argtab[1].meltbp_long = passnumber; MELT_LOCATION_HERE ("meltgc_run_meltpass_after_hook before apply"); (void) melt_apply ((meltclosure_ptr_t) pahookv, NULL, MELTBPARSTR_CSTRING MELTBPARSTR_LONG, argtab, "", (union meltparam_un*)0); MELT_LOCATION_HERE ("meltgc_run_meltpass_after_hook after apply"); } melt_clear_inisysdata (MELTFIELD_SYSDATA_MELTPASS_AFTER_HOOK); end: MELT_EXITFRAME (); } /* convert a MELT value to a plugin flag or option */ static unsigned long melt_val2passflag(melt_ptr_t val_p) { unsigned long res = 0; int valmag = 0; MELT_ENTERFRAME (3, NULL); #define valv meltfram__.mcfr_varptr[0] #define compv meltfram__.mcfr_varptr[1] #define pairv meltfram__.mcfr_varptr[2] valv = val_p; if (!valv) goto end; valmag = melt_magic_discr((melt_ptr_t) valv); if (valmag == MELTOBMAG_INT || valmag == MELTOBMAG_MIXINT) { res = melt_get_int((melt_ptr_t) valv); goto end; } else if (valmag == MELTOBMAG_OBJECT && melt_is_instance_of((melt_ptr_t) valv, (melt_ptr_t) MELT_PREDEF(CLASS_NAMED))) { compv = ((meltobject_ptr_t)valv)->obj_vartab[MELTFIELD_NAMED_NAME]; res = melt_val2passflag((melt_ptr_t) compv); goto end; } else if (valmag == MELTOBMAG_STRING) { const char *valstr = melt_string_str((melt_ptr_t) valv); /* should be kept in sync with the defines in tree-pass.h */ #define WHENFLAG(F) if (!strcasecmp(valstr, #F)) { res = F; goto end; } WHENFLAG(PROP_gimple_any); WHENFLAG(PROP_gimple_lcf); WHENFLAG(PROP_gimple_leh); WHENFLAG(PROP_cfg); #ifdef PROP_referenced_vars WHENFLAG(PROP_referenced_vars); /* not defined in GCC 4.8 */ #endif WHENFLAG(PROP_ssa); WHENFLAG(PROP_no_crit_edges); WHENFLAG(PROP_rtl); WHENFLAG(PROP_gimple_lomp); WHENFLAG(PROP_cfglayout); WHENFLAG(PROP_trees); /* likewise for TODO flags */ #ifdef TODO_dump_func WHENFLAG(TODO_dump_func); /* not defined in GCC 4.8 */ #endif /*TODO_dump_func*/ WHENFLAG(TODO_ggc_collect); WHENFLAG(TODO_verify_ssa); WHENFLAG(TODO_verify_flow); WHENFLAG(TODO_verify_stmts); WHENFLAG(TODO_cleanup_cfg); #ifdef TODO_dump_cgraph WHENFLAG(TODO_dump_cgraph); /* not defined in GCC 4.8 */ #endif /*TODO_dump_cgraph*/ WHENFLAG(TODO_remove_functions); WHENFLAG(TODO_rebuild_frequencies); WHENFLAG(TODO_verify_rtl_sharing); WHENFLAG(TODO_update_ssa); WHENFLAG(TODO_update_ssa_no_phi); WHENFLAG(TODO_update_ssa_full_phi); WHENFLAG(TODO_update_ssa_only_virtuals); WHENFLAG(TODO_remove_unused_locals); WHENFLAG(TODO_df_finish); WHENFLAG(TODO_df_verify); WHENFLAG(TODO_mark_first_instance); WHENFLAG(TODO_rebuild_alias); WHENFLAG(TODO_update_address_taken); WHENFLAG(TODO_update_ssa_any); WHENFLAG(TODO_verify_all); #undef WHENFLAG goto end; } else if (valmag == MELTOBMAG_LIST) { for (pairv = ((struct meltlist_st *) valv)->first; melt_magic_discr ((melt_ptr_t) pairv) == MELTOBMAG_PAIR; pairv = ((struct meltpair_st *)pairv)->tl) { compv = ((struct meltpair_st *)pairv)->hd; res |= melt_val2passflag((melt_ptr_t) compv); } } else if (valmag == MELTOBMAG_MULTIPLE) { int i=0, l=0; l = melt_multiple_length((melt_ptr_t)valv); for (i=0; imeltspec_kind == meltpydkind_rawfile) { oldf = ((struct meltspecialdata_st*)dumpv)->meltspec_payload.meltpayload_file1; if (oldf) fflush (oldf); ((struct meltspecialdata_st*)dumpv)->meltspec_payload.meltpayload_file1 = dumpf; goto end; } } end: MELT_EXITFRAME(); return oldf; #undef dumpv } static void meltgc_restore_dump_file (FILE* oldf) { MELT_ENTERFRAME(1, NULL); #define dumpv meltfram__.mcfr_varptr[0] if (dump_file) fflush (dump_file); dumpv = melt_get_inisysdata (MELTFIELD_SYSDATA_DUMPFILE); if (melt_discr((melt_ptr_t) dumpv) == (meltobject_ptr_t) MELT_PREDEF(DISCR_RAWFILE)) { if (melt_magic_discr ((melt_ptr_t) dumpv) == MELTOBMAG_SPECIAL_DATA && ((struct meltspecialdata_st*)dumpv)->meltspec_kind == meltpydkind_rawfile) { ((struct meltspecialdata_st*)dumpv)->meltspec_payload.meltpayload_file1 = oldf; goto end; } } end: MELT_EXITFRAME(); #undef dumpv } /* the gate function of MELT gimple passes */ static bool meltgc_gimple_gate(void) { int ok = TRUE; static const char* modstr; FILE *oldf = NULL; #if MELT_HAVE_DEBUG char curlocbuf[120]; #endif MELT_ENTERFRAME(4, NULL); #define passv meltfram__.mcfr_varptr[0] #define passdictv meltfram__.mcfr_varptr[1] #define closv meltfram__.mcfr_varptr[2] #define resv meltfram__.mcfr_varptr[3] if (!modstr) modstr = melt_argument ("mode"); if (!modstr || !modstr) goto end; MELT_LOCATION_HERE ("meltgc_gimple_gate"); MELT_CHECK_SIGNAL (); gcc_assert(current_pass != NULL); gcc_assert(current_pass->name != NULL); gcc_assert(current_pass->type == GIMPLE_PASS); debugeprintf ("meltgc_gimple_gate pass %s", current_pass->name); passdictv = melt_get_inisysdata (MELTFIELD_SYSDATA_PASS_DICT); if (melt_magic_discr((melt_ptr_t) passdictv) != MELTOBMAG_MAPSTRINGS) goto end; passv = melt_get_mapstrings((struct meltmapstrings_st*) passdictv, current_pass->name); if (!passv || !melt_is_instance_of((melt_ptr_t) passv, (melt_ptr_t) MELT_PREDEF(CLASS_GCC_GIMPLE_PASS))) goto end; closv = melt_object_nth_field((melt_ptr_t) passv, MELTFIELD_GCCPASS_GATE); if (melt_magic_discr((melt_ptr_t) closv) != MELTOBMAG_CLOSURE) goto end; oldf = meltgc_set_dump_file (dump_file); debugeprintf ("meltgc_gimple_gate pass %s before apply", current_pass->name); MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_gimple_gate pass %s before apply", current_pass->name); MELT_CHECK_SIGNAL (); resv = melt_apply ((struct meltclosure_st *) closv, (melt_ptr_t) passv, "", (union meltparam_un *) 0, "", (union meltparam_un *) 0); ok = (resv != NULL); debugeprintf ("meltgc_gimple_gate pass %s after apply ok=%d", current_pass->name, ok); meltgc_restore_dump_file (oldf); end: debugeprintf ("meltgc_gimple_gate pass %s ended ok=%d", current_pass->name, ok); MELT_EXITFRAME(); return ok; #undef passv #undef passdictv #undef closv #undef resv } /* the execute function of MELT gimple passes */ static unsigned int meltgc_gimple_execute (void) { unsigned int res = 0; static const char* modstr; #if MELT_HAVE_DEBUG char curlocbuf[120]; #endif MELT_ENTERFRAME(4, NULL); #define passv meltfram__.mcfr_varptr[0] #define passdictv meltfram__.mcfr_varptr[1] #define closv meltfram__.mcfr_varptr[2] #define resvalv meltfram__.mcfr_varptr[3] if (!modstr) modstr = melt_argument ("mode"); if (!modstr || !modstr[0]) goto end; MELT_LOCATION_HERE("meltgc_gimple_execute"); MELT_CHECK_SIGNAL (); gcc_assert (current_pass != NULL); gcc_assert (current_pass->name != NULL); gcc_assert (current_pass->type == GIMPLE_PASS); debugeprintf ("meltgc_gimple_execute pass %s starting", current_pass->name); passdictv = melt_get_inisysdata (MELTFIELD_SYSDATA_PASS_DICT); if (melt_magic_discr((melt_ptr_t) passdictv) != MELTOBMAG_MAPSTRINGS) goto end; passv = melt_get_mapstrings((struct meltmapstrings_st *)passdictv, current_pass->name); if (!passv || !melt_is_instance_of((melt_ptr_t) passv, (melt_ptr_t) MELT_PREDEF(CLASS_GCC_GIMPLE_PASS))) goto end; closv = melt_object_nth_field((melt_ptr_t) passv, MELTFIELD_GCCPASS_EXEC); if (melt_magic_discr((melt_ptr_t) closv) != MELTOBMAG_CLOSURE) goto end; { long passdbgcounter = melt_dbgcounter; long todol = 0; FILE *oldf = NULL; union meltparam_un restab[1]; memset (&restab, 0, sizeof (restab)); debugeprintf ("gimple_execute passname %s dbgcounter %ld cfun %p ", current_pass->name, melt_dbgcounter, (void *) cfun); if (cfun && melt_flag_debug) debug_tree (cfun->decl); debugeprintf ("gimple_execute passname %s before apply", current_pass->name); oldf = meltgc_set_dump_file (dump_file); debugeprintf ("gimple_execute passname %s before apply dbgcounter %ld", current_pass->name, passdbgcounter); /* apply with one extra long result */ MELT_LOCATION_HERE_PRINTF(curlocbuf, "meltgc_gimple_execute pass %s before apply", current_pass->name); MELT_CHECK_SIGNAL (); restab[0].meltbp_longptr = &todol; resvalv = melt_apply ((struct meltclosure_st *) closv, (melt_ptr_t) passv, "", (union meltparam_un *) 0, MELTBPARSTR_LONG "", restab); debugeprintf ("gimple_execute passname %s after apply dbgcounter %ld", current_pass->name, passdbgcounter); meltgc_restore_dump_file (oldf); MELT_LOCATION_HERE_PRINTF(curlocbuf, "meltgc_gimple_execute pass %s after apply", current_pass->name); MELT_CHECK_SIGNAL (); if (resvalv) res = (unsigned int) todol; meltgc_run_meltpass_after_hook (); } end: debugeprintf ("meltgc_gimple_execute pass %s ended res=%u", current_pass->name, res); MELT_EXITFRAME(); return res; #undef passv #undef passdictv #undef closv #undef resvalv } /* the gate function of MELT rtl passes */ static bool meltgc_rtl_gate(void) { #if MELT_HAVE_DEBUG char curlocbuf[120]; #endif int ok = TRUE; FILE* oldf = NULL; static const char* modstr; MELT_ENTERFRAME(4, NULL); #define passv meltfram__.mcfr_varptr[0] #define passdictv meltfram__.mcfr_varptr[1] #define closv meltfram__.mcfr_varptr[2] #define resv meltfram__.mcfr_varptr[3] if (!modstr) modstr = melt_argument ("mode"); if (!modstr || !modstr[0]) goto end; MELT_LOCATION_HERE ("meltgc_rtl_gate"); MELT_CHECK_SIGNAL (); gcc_assert(current_pass != NULL); gcc_assert(current_pass->name != NULL); gcc_assert(current_pass->type == RTL_PASS); debugeprintf ("meltgc_rtl_gate pass %s start", current_pass->name); passdictv = melt_get_inisysdata (MELTFIELD_SYSDATA_PASS_DICT); if (melt_magic_discr((melt_ptr_t) passdictv) != MELTOBMAG_MAPSTRINGS) goto end; passv = melt_get_mapstrings((struct meltmapstrings_st*) passdictv, current_pass->name); if (!passv || !melt_is_instance_of((melt_ptr_t) passv, (melt_ptr_t) MELT_PREDEF(CLASS_GCC_RTL_PASS))) goto end; closv = melt_object_nth_field((melt_ptr_t) passv, MELTFIELD_GCCPASS_GATE); if (melt_magic_discr((melt_ptr_t) closv) != MELTOBMAG_CLOSURE) goto end; oldf = meltgc_set_dump_file (dump_file); MELT_LOCATION_HERE_PRINTF(curlocbuf, "meltgc_rtl_gate pass %s before apply", current_pass->name); MELT_CHECK_SIGNAL (); resv = melt_apply ((struct meltclosure_st *) closv, (melt_ptr_t) passv, "", (union meltparam_un *) 0, "", (union meltparam_un *) 0); MELT_LOCATION_HERE_PRINTF(curlocbuf, "meltgc_rtl_gate pass %s after apply", current_pass->name); MELT_CHECK_SIGNAL (); meltgc_restore_dump_file (oldf); ok = (resv != NULL); end: debugeprintf ("meltgc_rtl_gate pass %s end ok=%d", current_pass->name, ok); MELT_EXITFRAME(); return ok; } /* the execute function of MELT rtl passes */ static unsigned int meltgc_rtl_execute(void) { unsigned int res = 0; FILE* oldf = NULL; static const char*modstr; #if MELT_HAVE_DEBUG char curlocbuf[120]; #endif MELT_ENTERFRAME(4, NULL); #define passv meltfram__.mcfr_varptr[0] #define passdictv meltfram__.mcfr_varptr[1] #define closv meltfram__.mcfr_varptr[2] #define resvalv meltfram__.mcfr_varptr[3] if (!modstr) modstr = melt_argument ("mode"); if (!modstr || !modstr[0]) goto end; MELT_LOCATION_HERE ("meltgc_rtl_execute"); MELT_CHECK_SIGNAL (); gcc_assert (current_pass != NULL); gcc_assert (current_pass->name != NULL); gcc_assert (current_pass->type == RTL_PASS); debugeprintf ("meltgc_rtl_execute pass %s start", current_pass->name); passdictv = melt_get_inisysdata (MELTFIELD_SYSDATA_PASS_DICT); if (melt_magic_discr((melt_ptr_t) passdictv) != MELTOBMAG_MAPSTRINGS) goto end; passv = melt_get_mapstrings((struct meltmapstrings_st*) passdictv, current_pass->name); if (!passv || !melt_is_instance_of((melt_ptr_t) passv, (melt_ptr_t) MELT_PREDEF(CLASS_GCC_RTL_PASS))) goto end; closv = melt_object_nth_field((melt_ptr_t) passv, MELTFIELD_GCCPASS_EXEC); if (melt_magic_discr((melt_ptr_t) closv) != MELTOBMAG_CLOSURE) goto end; { long passdbgcounter = melt_dbgcounter; long todol = 0; union meltparam_un restab[1]; oldf = meltgc_set_dump_file (dump_file); memset (&restab, 0, sizeof (restab)); restab[0].meltbp_longptr = &todol; debugeprintf ("rtl_execute passname %s dbgcounter %ld", current_pass->name, melt_dbgcounter); debugeprintf ("rtl_execute passname %s before apply", current_pass->name); /* apply with one extra long result */ MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_rtl_execute pass %s before apply", current_pass->name); MELT_CHECK_SIGNAL (); resvalv = melt_apply ((struct meltclosure_st *) closv, (melt_ptr_t) passv, "", (union meltparam_un *) 0, MELTBPARSTR_LONG "", restab); MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_rtl_execute pass %s after apply", current_pass->name); MELT_CHECK_SIGNAL (); debugeprintf ("rtl_execute passname %s after apply dbgcounter %ld", current_pass->name, passdbgcounter); meltgc_restore_dump_file (oldf); if (resvalv) res = (unsigned int) todol; meltgc_run_meltpass_after_hook (); } end: debugeprintf ("meltgc_rtl_execute pass %s end res=%ud", current_pass->name, res); MELT_EXITFRAME(); return res; #undef passv #undef passdictv #undef closv #undef resvalv } /* the gate function of MELT simple_ipa passes */ static bool meltgc_simple_ipa_gate(void) { int ok = TRUE; #if MELT_HAVE_DEBUG char curlocbuf[120]; #endif FILE* oldf = NULL; static const char*modstr; MELT_ENTERFRAME(4, NULL); #define passv meltfram__.mcfr_varptr[0] #define passdictv meltfram__.mcfr_varptr[1] #define closv meltfram__.mcfr_varptr[2] #define resv meltfram__.mcfr_varptr[3] if (!modstr) modstr = melt_argument ("mode"); if (!modstr || !modstr[0]) goto end; MELT_LOCATION_HERE ("meltgc_simple_ipa_gate"); MELT_CHECK_SIGNAL (); gcc_assert(current_pass != NULL); gcc_assert(current_pass->name != NULL); gcc_assert(current_pass->type == SIMPLE_IPA_PASS); debugeprintf ("meltgc_simple_ipa_gate pass %s start", current_pass->name); passdictv = melt_get_inisysdata (MELTFIELD_SYSDATA_PASS_DICT); if (melt_magic_discr((melt_ptr_t) passdictv) != MELTOBMAG_MAPSTRINGS) goto end; passv = melt_get_mapstrings((struct meltmapstrings_st*) passdictv, current_pass->name); if (!passv || !melt_is_instance_of((melt_ptr_t) passv, (melt_ptr_t) MELT_PREDEF(CLASS_GCC_SIMPLE_IPA_PASS))) goto end; closv = melt_object_nth_field((melt_ptr_t) passv, MELTFIELD_GCCPASS_GATE); if (melt_magic_discr((melt_ptr_t) closv) != MELTOBMAG_CLOSURE) goto end; oldf = meltgc_set_dump_file (dump_file); debugeprintf ("meltgc_simple_ipa_gate pass %s before apply", current_pass->name); MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_simple_ipa_gate pass %s before apply", current_pass->name); MELT_CHECK_SIGNAL (); resv = melt_apply ((struct meltclosure_st *) closv, (melt_ptr_t) passv, "", (union meltparam_un *) 0, "", (union meltparam_un *) 0); debugeprintf ("meltgc_simple_ipa_gate pass %s after apply", current_pass->name); ok = (resv != NULL); MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_simple_ipa_gate pass %s after apply", current_pass->name); MELT_CHECK_SIGNAL (); meltgc_restore_dump_file (oldf); end: debugeprintf ("meltgc_simple_ipa_gate pass %s end ok=%d", current_pass->name, ok); MELT_EXITFRAME(); return ok; #undef passv #undef passdictv #undef closv #undef resv #undef dumpv } /* the execute function of MELT simple_ipa passes */ static unsigned int meltgc_simple_ipa_execute(void) { static const char*modstr; FILE* oldf = NULL; unsigned int res = 0; #if MELT_HAVE_DEBUG char curlocbuf[120]; #endif MELT_ENTERFRAME(4, NULL); #define passv meltfram__.mcfr_varptr[0] #define passdictv meltfram__.mcfr_varptr[1] #define closv meltfram__.mcfr_varptr[2] #define resvalv meltfram__.mcfr_varptr[3] if (!modstr) modstr = melt_argument ("mode"); if (!modstr || !modstr[0]) goto end; MELT_LOCATION_HERE ("meltgc_simple_ipa_execute"); MELT_CHECK_SIGNAL (); gcc_assert (current_pass != NULL); gcc_assert (current_pass->name != NULL); gcc_assert (current_pass->type == SIMPLE_IPA_PASS); debugeprintf ("meltgc_simple_ipa_execute pass %s start", current_pass->name); passdictv = melt_get_inisysdata (MELTFIELD_SYSDATA_PASS_DICT); if (melt_magic_discr((melt_ptr_t) passdictv) != MELTOBMAG_MAPSTRINGS) goto end; passv = melt_get_mapstrings((struct meltmapstrings_st*)passdictv, current_pass->name); if (!passv || !melt_is_instance_of((melt_ptr_t) passv, (melt_ptr_t) MELT_PREDEF(CLASS_GCC_SIMPLE_IPA_PASS))) goto end; closv = melt_object_nth_field((melt_ptr_t) passv, MELTFIELD_GCCPASS_EXEC); if (melt_magic_discr((melt_ptr_t) closv) != MELTOBMAG_CLOSURE) goto end; { long passdbgcounter = melt_dbgcounter; long todol = 0; union meltparam_un restab[1]; memset (&restab, 0, sizeof (restab)); restab[0].meltbp_longptr = &todol; debugeprintf ("simple_ipa_execute passname %s dbgcounter %ld", current_pass->name, melt_dbgcounter); debugeprintf ("simple_ipa_execute passname %s before apply", current_pass->name); oldf = meltgc_set_dump_file (dump_file); debugeprintf ("meltgc_simple_ipa_execute pass %s before apply", current_pass->name); MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_simple_ipa_execute pass %s before apply", current_pass->name); MELT_CHECK_SIGNAL (); /* apply with one extra long result */ resvalv = melt_apply ((struct meltclosure_st *) closv, (melt_ptr_t) passv, "", (union meltparam_un *) 0, MELTBPARSTR_LONG "", restab); MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_simple_ipa_execute pass %s after apply", current_pass->name); meltgc_restore_dump_file (oldf); MELT_CHECK_SIGNAL (); debugeprintf ("simple_ipa_execute passname %s after apply dbgcounter %ld", current_pass->name, passdbgcounter); if (resvalv) res = (unsigned int) todol; meltgc_run_meltpass_after_hook (); } end: MELT_EXITFRAME(); return res; #undef passv #undef passdictv #undef closv #undef resvalv #undef dumpv } /* register a MELT pass; there is no way to unregister it, and the opt_pass and plugin_pass used internally are never deallocated. 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) { #if MELT_HAVE_DEBUG char curlocbuf[120]; #endif static const char*modstr; /* the register_pass_info can be local, since it is only locally used in passes.c */ struct register_pass_info plugpassinf = { NULL, NULL, 0, PASS_POS_INSERT_AFTER }; enum pass_positioning_ops posop = PASS_POS_INSERT_AFTER; unsigned long propreq=0, propprov=0, propdest=0, todostart=0, todofinish=0; MELT_ENTERFRAME (4, NULL); #define passv meltfram__.mcfr_varptr[0] #define passdictv meltfram__.mcfr_varptr[1] #define compv meltfram__.mcfr_varptr[2] #define namev meltfram__.mcfr_varptr[3] passv = pass_p; if (!modstr) modstr = melt_argument("mode"); if (!modstr || !modstr[0]) goto end; MELT_LOCATION_HERE("meltgc_register_pass"); debugeprintf ("meltgc_register_pass start passv %p refpassname %s positioning %s", (void*)passv, refpassname, positioning); if (!refpassname || !refpassname[0]) goto end; if (!positioning || !positioning[0]) goto end; if (!strcasecmp(positioning,"after")) posop = PASS_POS_INSERT_AFTER; else if (!strcasecmp(positioning,"before")) posop = PASS_POS_INSERT_BEFORE; else if (!strcasecmp(positioning,"replace")) posop = PASS_POS_REPLACE; else melt_fatal_error("invalid positioning string %s in MELT pass", positioning); if (!passv || melt_object_length((melt_ptr_t) passv) < MELTLENGTH_CLASS_GCC_PASS || !melt_is_instance_of((melt_ptr_t) passv, (melt_ptr_t) MELT_PREDEF(CLASS_GCC_PASS))) goto end; namev = melt_object_nth_field((melt_ptr_t) passv, MELTFIELD_NAMED_NAME); if (melt_magic_discr((melt_ptr_t) namev) != MELTOBMAG_STRING) { warning (0, "registering a MELT pass without any name!"); goto end; }; debugeprintf ("meltgc_register_pass name %s refpassname %s positioning %s posop %d", melt_string_str ((melt_ptr_t) namev), refpassname, positioning, (int)posop); passdictv = melt_get_inisysdata (MELTFIELD_SYSDATA_PASS_DICT); if (melt_magic_discr((melt_ptr_t)passdictv) != MELTOBMAG_MAPSTRINGS) goto end; if (melt_get_mapstrings((struct meltmapstrings_st*)passdictv, melt_string_str((melt_ptr_t) namev))) goto end; compv = melt_object_nth_field((melt_ptr_t) passv, MELTFIELD_GCCPASS_PROPERTIES_REQUIRED); propreq = melt_val2passflag((melt_ptr_t) compv); compv = melt_object_nth_field((melt_ptr_t) passv, MELTFIELD_GCCPASS_PROPERTIES_PROVIDED); propprov = melt_val2passflag((melt_ptr_t) compv); compv = melt_object_nth_field((melt_ptr_t) passv, MELTFIELD_GCCPASS_TODO_FLAGS_START); todostart = melt_val2passflag((melt_ptr_t) compv); compv = melt_object_nth_field((melt_ptr_t) passv, MELTFIELD_GCCPASS_TODO_FLAGS_FINISH); todofinish = melt_val2passflag((melt_ptr_t) compv); /* allocate the opt pass and fill it; it is never deallocated (ie it is never free-d)! */ if (melt_is_instance_of((melt_ptr_t) passv, (melt_ptr_t) MELT_PREDEF(CLASS_GCC_GIMPLE_PASS))) { struct gimple_opt_pass* gimpass = NULL; gimpass = XNEW(struct gimple_opt_pass); memset(gimpass, 0, sizeof(struct gimple_opt_pass)); gimpass->pass.type = GIMPLE_PASS; /* the name of the pass is also strduped and is never deallocated (so it it never free-d! */ gimpass->pass.name = xstrdup(melt_string_str((melt_ptr_t) namev)); MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_register_pass Gimple pass name %s", gimpass->pass.name); MELT_CHECK_SIGNAL (); gimpass->pass.gate = meltgc_gimple_gate; gimpass->pass.execute = meltgc_gimple_execute; gimpass->pass.tv_id = TV_PLUGIN_RUN; gimpass->pass.properties_required = propreq; gimpass->pass.properties_provided = propprov; gimpass->pass.properties_destroyed = propdest; gimpass->pass.todo_flags_start = todostart; gimpass->pass.todo_flags_finish = todofinish; plugpassinf.pass = (struct opt_pass*) gimpass; plugpassinf.reference_pass_name = refpassname; plugpassinf.ref_pass_instance_number = refpassnum; plugpassinf.pos_op = posop; debugeprintf ("meltgc_register_pass name %s GIMPLE_PASS %p refpassname %s", melt_string_str ((melt_ptr_t) namev), (void*)gimpass, refpassname); register_callback(melt_plugin_name, PLUGIN_PASS_MANAGER_SETUP, NULL, &plugpassinf); /* add the pass into the pass dict */ meltgc_put_mapstrings((struct meltmapstrings_st*) passdictv, gimpass->pass.name, (melt_ptr_t) passv); } else if (melt_is_instance_of((melt_ptr_t) passv, (melt_ptr_t) MELT_PREDEF(CLASS_GCC_RTL_PASS))) { struct rtl_opt_pass* rtlpass = NULL; rtlpass = XNEW(struct rtl_opt_pass); memset(rtlpass, 0, sizeof(struct rtl_opt_pass)); rtlpass->pass.type = RTL_PASS; /* the name of the pass is also strduped and is never deallocated (so it it never free-d! */ rtlpass->pass.name = xstrdup(melt_string_str((melt_ptr_t) namev)); MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_register_pass RTL pass name %s", rtlpass->pass.name); MELT_CHECK_SIGNAL (); rtlpass->pass.gate = meltgc_rtl_gate; rtlpass->pass.execute = meltgc_rtl_execute; rtlpass->pass.tv_id = TV_PLUGIN_RUN; rtlpass->pass.properties_required = propreq; rtlpass->pass.properties_provided = propprov; rtlpass->pass.properties_destroyed = propdest; rtlpass->pass.todo_flags_start = todostart; rtlpass->pass.todo_flags_finish = todofinish; plugpassinf.pass = (struct opt_pass*)rtlpass; plugpassinf.reference_pass_name = refpassname; plugpassinf.ref_pass_instance_number = refpassnum; plugpassinf.pos_op = posop; debugeprintf ("meltgc_register_pass name %s RTL_PASS %p refpassname %s", melt_string_str ((melt_ptr_t) namev), (void*)rtlpass, refpassname); register_callback(melt_plugin_name, PLUGIN_PASS_MANAGER_SETUP, NULL, &plugpassinf); /* add the pass into the pass dict */ meltgc_put_mapstrings((struct meltmapstrings_st*) passdictv, rtlpass->pass.name, (melt_ptr_t) passv); } else if (melt_is_instance_of((melt_ptr_t) passv, (melt_ptr_t) MELT_PREDEF(CLASS_GCC_SIMPLE_IPA_PASS))) { struct simple_ipa_opt_pass* sipapass = NULL; sipapass = XNEW(struct simple_ipa_opt_pass); memset(sipapass, 0, sizeof(struct simple_ipa_opt_pass)); sipapass->pass.type = SIMPLE_IPA_PASS; /* the name of the pass is also strduped and is never deallocated (so it it never free-d! */ sipapass->pass.name = xstrdup(melt_string_str((melt_ptr_t) namev)); MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_register_pass simple IPA pass name %s", sipapass->pass.name); MELT_CHECK_SIGNAL (); sipapass->pass.gate = meltgc_simple_ipa_gate; sipapass->pass.execute = meltgc_simple_ipa_execute; sipapass->pass.tv_id = TV_PLUGIN_RUN; sipapass->pass.properties_required = propreq; sipapass->pass.properties_provided = propprov; sipapass->pass.properties_destroyed = propdest; sipapass->pass.todo_flags_start = todostart; sipapass->pass.todo_flags_finish = todofinish; plugpassinf.pass = (struct opt_pass*) sipapass; plugpassinf.reference_pass_name = refpassname; plugpassinf.ref_pass_instance_number = refpassnum; plugpassinf.pos_op = posop; debugeprintf ("meltgc_register_pass name %s SIMPLE_IPA_PASS %p refpassname %s", melt_string_str ((melt_ptr_t) namev), (void*)sipapass, refpassname); register_callback(melt_plugin_name, PLUGIN_PASS_MANAGER_SETUP, NULL, &plugpassinf); /* add the pass into the pass dict */ meltgc_put_mapstrings((struct meltmapstrings_st*) passdictv, sipapass->pass.name, (melt_ptr_t) passv); } else if (melt_is_instance_of((melt_ptr_t) passv, (melt_ptr_t) MELT_PREDEF(CLASS_GCC_TRANSFORM_IPA_PASS))) { struct ipa_opt_pass_d* tipapass = NULL; tipapass = XNEW(struct ipa_opt_pass_d); memset(tipapass, 0, sizeof(struct ipa_opt_pass_d)); tipapass->pass.name = xstrdup(melt_string_str((melt_ptr_t) namev)); MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_register_pass transform IPA pass name %s", tipapass->pass.name); MELT_CHECK_SIGNAL (); /* FIXME! */ /* #warning incomplete transform IPA passes */ melt_fatal_error ("MELT transform IPA not implemented for passv %p", passv); } /* non simple ipa passes are a different story - TODO! */ else melt_fatal_error ("MELT cannot register pass %s of unexpected class %s", melt_string_str ((melt_ptr_t) namev), melt_string_str (melt_object_nth_field ((melt_ptr_t) melt_discr((melt_ptr_t) passv), MELTFIELD_NAMED_NAME))); end: debugeprintf ("meltgc_register_pass name %s refpassname %s end", melt_string_str ((melt_ptr_t) namev), refpassname); MELT_EXITFRAME(); #undef passv #undef passdictv #undef namev } /***************** * Support for PLUGIN_FINISH_TYPE hook. *****************/ static void meltgc_finishtype_callback (void *gcc_data, void *user_data ATTRIBUTE_UNUSED) { tree tr = (tree) gcc_data; MELT_ENTERFRAME(2, NULL); #define ftyhookv meltfram__.mcfr_varptr[0] #define boxtreev meltfram__.mcfr_varptr[1] ftyhookv = melt_get_inisysdata (MELTFIELD_SYSDATA_FINISHTYPE_HOOK); if (melt_magic_discr ((melt_ptr_t)ftyhookv) != MELTOBMAG_CLOSURE) /* this really should ever happen */ melt_fatal_error ("MELT PLUGIN_FINISH_TYPE callback bad :sysdata_finishtype (bad magic #%d)", melt_magic_discr ((melt_ptr_t)ftyhookv)); if (tr) boxtreev = meltgc_new_tree ((meltobject_ptr_t) MELT_PREDEF(DISCR_TREE), tr); else boxtreev = NULL; MELT_LOCATION_HERE ("meltgc_finishtype_callback before applying :sysdata_finishtype closure"); MELT_CHECK_SIGNAL (); (void) melt_apply ((meltclosure_ptr_t) ftyhookv, (melt_ptr_t) boxtreev, "", NULL, "", NULL); MELT_EXITFRAME(); #undef ftyhookv #undef boxtreev } /* Function to be called by MELT code when the :sysdata_finishtype_hook is changed. Called by code_chunk-s inside MELT file melt/warmelt-base.melt. */ void meltgc_notify_finish_type_hook (void) { /* the PLUGIN_FINISH_TYPE hook is getting a tree data; see function c_parser_declspecs of file c-parser.c */ MELT_ENTERFRAME (1, NULL); #define ftyhookv meltfram__.mcfr_varptr[0] MELT_LOCATION_HERE ("meltgc_notify_finish_type_hook"); MELT_CHECK_SIGNAL (); ftyhookv = melt_get_inisysdata (MELTFIELD_SYSDATA_FINISHTYPE_HOOK); if (ftyhookv == NULL) { unregister_callback (melt_plugin_name, PLUGIN_FINISH_TYPE); } else if (melt_magic_discr ((melt_ptr_t) ftyhookv) == MELTOBMAG_CLOSURE) { register_callback (melt_plugin_name, PLUGIN_FINISH_TYPE, meltgc_finishtype_callback, NULL); } else { /* This should never happen. The calling MELT code should test that the :sysdata_passexec_hook is either a closure or null. */ melt_fatal_error ("sysdata_finishtype_hook has invalid kind magic #%d", melt_magic_discr ((melt_ptr_t)ftyhookv)); } MELT_EXITFRAME (); #undef passxhv } /****************** * Support for PLUGIN_FINISH_DECL hook, which exists only in GCC 4.7 but not 4.6 ******************/ #if MELT_GCC_VERSION >= 4007 /* GCC 4.7 */ static void meltgc_finishdecl_callback (void *gcc_data, void *user_data ATTRIBUTE_UNUSED) { tree tr = (tree) gcc_data; MELT_ENTERFRAME(2, NULL); #define fdclhookv meltfram__.mcfr_varptr[0] #define boxtreev meltfram__.mcfr_varptr[1] MELT_LOCATION_HERE ("meltgc_finishdecl_callback"); MELT_CHECK_SIGNAL (); fdclhookv = melt_get_inisysdata (MELTFIELD_SYSDATA_FINISHDECL_HOOK); if (melt_magic_discr ((melt_ptr_t)fdclhookv) != MELTOBMAG_CLOSURE) /* this really should ever happen */ melt_fatal_error ("MELT PLUGIN_FINISH_TYPE callback bad :sysdata_finishdecl (bad magic #%d)", melt_magic_discr ((melt_ptr_t)fdclhookv)); if (tr) boxtreev = meltgc_new_tree ((meltobject_ptr_t) MELT_PREDEF(DISCR_TREE), tr); else boxtreev = NULL; MELT_LOCATION_HERE ("meltgc_finishdecl_callback before applying :sysdata_finishdecl closure"); (void) melt_apply ((meltclosure_ptr_t) fdclhookv, (melt_ptr_t) boxtreev, "", NULL, "", NULL); MELT_EXITFRAME(); #undef fdclhookv #undef boxtreev } #endif /* MELT_GCC_VERSION >= 4007 */ /* Function to be called by MELT code when the :sysdata_finishdecl_hook is changed. Called by code_chunk-s inside MELT file melt/warmelt-base.melt. */ void meltgc_notify_finish_decl_hook (void) { /* the PLUGIN_FINISH_DECL hook is getting a tree data; see function finish_decl of file c-decl.c */ MELT_ENTERFRAME (1, NULL); #define ftyhookv meltfram__.mcfr_varptr[0] MELT_LOCATION_HERE ("meltgc_notify_finish_decl_hook"); MELT_CHECK_SIGNAL (); #if MELT_GCC_VERSION >= 4007 /* GCC 4.7 */ ftyhookv = melt_get_inisysdata (MELTFIELD_SYSDATA_FINISHDECL_HOOK); if (ftyhookv == NULL) { unregister_callback (melt_plugin_name, PLUGIN_FINISH_DECL); } else if (melt_magic_discr ((melt_ptr_t) ftyhookv) == MELTOBMAG_CLOSURE) { register_callback (melt_plugin_name, PLUGIN_FINISH_DECL, meltgc_finishdecl_callback, NULL); } else { /* This should never happen. The calling MELT code should test that the :sysdata_passexec_hook is either a closure or null. */ melt_fatal_error ("sysdata_finishdecl_hook has invalid kind magic #%d", melt_magic_discr ((melt_ptr_t)ftyhookv)); } #else /* GCC 4.6 */ { static int count; if (count++ == 0) error("GCC 4.6 don't have PLUGIN_FINISH_DECL for MELT %s", melt_version_str ()); } #endif /* if GCC 4.7 */ MELT_EXITFRAME (); #undef passxhv } /* Routine passed to walk_use_def_chains by meltgc_walk_use_def_chain below. */ static bool meltgc_usedef_internalfun(tree tr, gimple gi, void*data) { bool proceed = false; MELT_ENTERFRAME (3, NULL); #define closv meltfram__.mcfr_varptr[0] #define valv meltfram__.mcfr_varptr[1] #define resv meltfram__.mcfr_varptr[2] closv = ((melt_ptr_t*)data)[0]; valv = ((melt_ptr_t*)data)[1]; gcc_assert (melt_magic_discr ((melt_ptr_t) closv) == MELTOBMAG_CLOSURE); gcc_assert (tr != NULL); MELT_LOCATION_HERE ("meltgc_usedef_internalfun"); { union meltparam_un argtab[2]; memset (&argtab, 0, sizeof(argtab)); argtab[0].meltbp_tree = tr; argtab[1].meltbp_gimple = gi; MELT_CHECK_SIGNAL (); resv = melt_apply ((meltclosure_ptr_t) closv, (melt_ptr_t) valv, MELTBPARSTR_TREE MELTBPARSTR_GIMPLE, argtab, NULL, (union meltparam_un*)NULL); proceed = resv != NULL; } MELT_EXITFRAME (); return proceed; } /*** MELT interface to walk_use_def_chains; walk from trvar if it is an SSA-name and apply clos to val and the current tree & gimple stop when then clos returns NULL ****/ void meltgc_walk_use_def_chain (melt_ptr_t clos_p, melt_ptr_t val_p, tree trvar, bool depthfirstflag) { MELT_ENTERFRAME (2, NULL); /* we need closv & valv to be consecutive! */ #define closv meltfram__.mcfr_varptr[0] #define valv meltfram__.mcfr_varptr[1] MELT_LOCATION_HERE ("meltgc_walk_use_def_chain"); MELT_CHECK_SIGNAL (); closv = clos_p; valv = val_p; if (!trvar || TREE_CODE (trvar) != SSA_NAME) goto end; if (melt_magic_discr ((melt_ptr_t) closv) != MELTOBMAG_CLOSURE) goto end; walk_use_def_chains (trvar, meltgc_usedef_internalfun, &closv, depthfirstflag); valv = valv; /* So that valv is used here! */ end: MELT_EXITFRAME (); #undef closv #undef valv } /***************** gimple walkers ****************/ static tree meltgc_walkstmt_cb (gimple_stmt_iterator *, bool *, struct walk_stmt_info *); static tree meltgc_walktree_cb (tree*, int*, void*); enum { meltwgs_data, meltwgs_stmtclos, meltwgs_treeclos, meltwgs__LAST }; gimple meltgc_walk_gimple_seq (melt_ptr_t data_p, gimple_seq gseq, melt_ptr_t stmtclos_p, melt_ptr_t treeclos_p, bool uniquetreevisit) { struct walk_stmt_info wi; struct pointer_set_t *pvisitset = NULL; gimple gres = NULL; MELT_ENTERFRAME (meltwgs__LAST, NULL); #define datav meltfram__.mcfr_varptr[meltwgs_data] #define stmtclosv meltfram__.mcfr_varptr[meltwgs_stmtclos] #define treeclosv meltfram__.mcfr_varptr[meltwgs_treeclos] memset (&wi, 0, sizeof(wi)); wi.info = &meltfram__; if (uniquetreevisit) wi.pset = pvisitset = pointer_set_create (); datav = data_p; stmtclosv = stmtclos_p; treeclosv = treeclos_p; gres = walk_gimple_seq (gseq, (melt_magic_discr((melt_ptr_t)stmtclosv) == MELTOBMAG_CLOSURE) ? (&meltgc_walkstmt_cb) :NULL, (melt_magic_discr((melt_ptr_t)treeclosv) == MELTOBMAG_CLOSURE) ? (&meltgc_walktree_cb) :NULL, &wi); if (pvisitset) pointer_set_destroy (pvisitset); MELT_EXITFRAME(); #undef datav #undef stmtclosv #undef treeclosv return gres; } tree meltgc_walkstmt_cb (gimple_stmt_iterator *gsip, bool *okp, struct walk_stmt_info *wi) { tree restree = NULL; gimple gstmt = gsi_stmt (*gsip); MELT_ENTERFRAME (3, NULL); #define datav meltfram__.mcfr_varptr[0] #define closv meltfram__.mcfr_varptr[1] #define resv meltfram__.mcfr_varptr[2] datav = ((struct melt_callframe_st*)(wi->info))->mcfr_varptr[meltwgs_data]; closv = ((struct melt_callframe_st*)(wi->info))->mcfr_varptr[meltwgs_stmtclos]; gcc_assert (melt_magic_discr((melt_ptr_t)closv) == MELTOBMAG_CLOSURE); { union meltparam_un argtab[1]; union meltparam_un restab[1]; memset (argtab, 0, sizeof(argtab)); memset (restab, 0, sizeof(restab)); argtab[0].meltbp_gimple = gstmt; restab[0].meltbp_treeptr = &restree; MELT_LOCATION_HERE ("meltgc_walkstmt_cb from meltgc_walk_gimple_seq before apply"); resv = melt_apply ((meltclosure_ptr_t) closv, (melt_ptr_t) datav, MELTBPARSTR_GIMPLE, argtab, MELTBPARSTR_TREE, restab); if (resv && okp) *okp = TRUE; } MELT_EXITFRAME(); #undef datav #undef closv #undef resv return restree; } tree meltgc_walktree_cb (tree*ptree, int*walksubtrees, void*data) { tree restree = NULL; struct walk_stmt_info* wi = (struct walk_stmt_info*) data; MELT_ENTERFRAME (3, NULL); #define datav meltfram__.mcfr_varptr[0] #define closv meltfram__.mcfr_varptr[1] #define resv meltfram__.mcfr_varptr[2] datav = ((struct melt_callframe_st*)(wi->info))->mcfr_varptr[meltwgs_data]; closv = ((struct melt_callframe_st*)(wi->info))->mcfr_varptr[meltwgs_treeclos]; gcc_assert (melt_magic_discr((melt_ptr_t)closv) == MELTOBMAG_CLOSURE); { long seclng = -2; union meltparam_un argtab[1]; union meltparam_un restab[2]; memset (argtab, 0, sizeof(argtab)); memset (restab, 0, sizeof(restab)); argtab[0].meltbp_tree = ptree?(*ptree):NULL; restab[0].meltbp_longptr = &seclng; restab[1].meltbp_treeptr = &restree; MELT_LOCATION_HERE ("meltgc_walktree_cb from meltgc_walk_gimple_seq before apply"); resv = melt_apply ((meltclosure_ptr_t) closv, (melt_ptr_t) datav, MELTBPARSTR_TREE, argtab, MELTBPARSTR_LONG MELTBPARSTR_TREE, restab); if (seclng != -2 && walksubtrees) *walksubtrees = (int)seclng; } MELT_EXITFRAME(); #undef datav #undef closv #undef resv return restree; } /***** * called from handle_melt_attribute *****/ void melt_handle_melt_attribute (tree decl, tree name, const char *attrstr, location_t loch) { #if MELT_HAVE_DEBUG char curlocbuf[120]; #endif MELT_ENTERFRAME (4, NULL); #define seqv meltfram__.mcfr_varptr[0] #define declv meltfram__.mcfr_varptr[1] #define namev meltfram__.mcfr_varptr[2] #define atclov meltfram__.mcfr_varptr[3] if (!attrstr || !attrstr[0]) goto end; MELT_LOCATION_HERE ("melt_handle_melt_attribute"); MELT_CHECK_SIGNAL (); seqv = meltgc_read_from_rawstring (attrstr, "*melt-attr*", loch); atclov = melt_get_inisysdata (MELTFIELD_SYSDATA_MELTATTR_DEFINER); if (melt_magic_discr ((melt_ptr_t) atclov) == MELTOBMAG_CLOSURE) { union meltparam_un argtab[2]; MELT_LOCATION_HERE ("melt attribute definer"); declv = meltgc_new_tree ((meltobject_ptr_t) MELT_PREDEF (DISCR_TREE), decl); namev = meltgc_new_tree ((meltobject_ptr_t) MELT_PREDEF (DISCR_TREE), name); memset (argtab, 0, sizeof (argtab)); argtab[0].meltbp_aptr = (melt_ptr_t *) & namev; argtab[1].meltbp_aptr = (melt_ptr_t *) & seqv; MELT_LOCATION_HERE_PRINTF (curlocbuf, "melt_handle_melt_attribute %s before apply", attrstr); MELT_CHECK_SIGNAL (); (void) melt_apply ((meltclosure_ptr_t) atclov, (melt_ptr_t) declv, MELTBPARSTR_PTR MELTBPARSTR_PTR, argtab, "", NULL); MELT_LOCATION_HERE_PRINTF (curlocbuf, "melt_handle_melt_attribute %s after apply", attrstr); MELT_CHECK_SIGNAL (); } end: MELT_EXITFRAME (); #undef seqv #undef declv #undef namev #undef atclov } #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) { dbgprintf_raw ("@%s:%d: MELT sparebreakpoint_1 ptr=%p msg=%s\n", fil, lin, ptr, msg); melt_dbgshortbacktrace("melt_sparebreakpoint_1", 20); debugeprintf ("melt_sparebreakpoint_1_at msg %s", msg); } void melt_sparebreakpoint_2_at (const char*fil, int lin, void*ptr, const char*msg) { dbgprintf_raw ("@%s:%d: MELT sparebreakpoint_2 ptr=%p msg=%s\n", fil, lin, ptr, msg); melt_dbgshortbacktrace("melt_sparebreakpoint_2", 20); debugeprintf ("melt_sparebreakpoint_2_at msg %s", msg); } #endif /*ENABLE_CHECKING*/ /* poll the input bucket INBUCK_P with DELAYMS millisecond delay */ int meltgc_poll_inputs (melt_ptr_t inbuck_p, int delayms) { struct pollfd *fdtab = NULL; int nbfd = 0; unsigned buckcount = 0, ix = 0; int pollres = 0; #if MELT_HAVE_DEBUG char curlocbuf[120]; #endif MELT_ENTERFRAME (5, NULL); #define inbuckv meltfram__.mcfr_varptr[0] #define curhandv meltfram__.mcfr_varptr[1] #define sbufv meltfram__.mcfr_varptr[2] #define seqv meltfram__.mcfr_varptr[3] #define closv meltfram__.mcfr_varptr[4] MELT_LOCATION_HERE("meltgc_poll_inputs"); inbuckv = inbuck_p; if (melt_magic_discr ((melt_ptr_t) inbuckv) != MELTOBMAG_BUCKETLONGS) goto end; buckcount = melt_longsbucket_count ((melt_ptr_t) inbuckv); ix = 0; fdtab = (struct pollfd*) xcalloc (buckcount+1, sizeof(struct pollfd)); if (!fdtab) melt_fatal_error ("meltgc_poll_inputs cannot allocate %d polling slots - %m", (buckcount+1)); /* Fill fdtab with appropriate polling slots. */ for (ix = 0; ix < buckcount; ix++) { long curfd = ((struct meltbucketlongs_st*)inbuckv)->buckl_entab[ix].ebl_at; curhandv = ((struct meltbucketlongs_st*)inbuckv)->buckl_entab[ix].ebl_va; if (curfd < 0 || !curhandv) continue; if (!melt_is_instance_of ((melt_ptr_t) curhandv, (melt_ptr_t) MELT_PREDEF (CLASS_INPUT_CHANNEL_HANDLER))) continue; fdtab[nbfd].fd = (int) curfd; fdtab[nbfd].events = POLLIN; fdtab[nbfd].revents = 0; nbfd++; }; debugeprintf ("meltgc_poll_inputs polling nbfd %d delayms %d", nbfd, delayms); gcc_assert (nbfd >= 0); /* even when nbfd is null, we do call poll to sleep delayms */ pollres = poll (fdtab, nbfd, delayms); debugeprintf ("meltgc_poll_inputs pollres %d after poll nbfd=%d delayms=%d", pollres, nbfd, delayms); if (pollres > 0) { int ixfd = 0; for (ixfd = 0; ixfd < nbfd; ixfd++) { int rfd = fdtab[ixfd].fd; curhandv = melt_longsbucket_get ((melt_ptr_t) inbuckv, (long) rfd); debugeprintf ("meltgc_poll_inputs ixfd=%d rfd=%d curhandv=%p fdtab[%d].revents=%#x", ixfd, rfd, (void*) curhandv, ixfd, fdtab[ixfd].revents); /* curhandv is very often a valid input_channel_handler. It may not be if some previous channel handling invalidated it, which is very weird. We close the file descriptor and issue a warning in that unlikely case. */ if (!curhandv) { warning (0, "MELT polling, closing fd#%d without handler", rfd); (void) close (rfd); continue; } if (!melt_is_instance_of ((melt_ptr_t) curhandv, (melt_ptr_t) MELT_PREDEF (CLASS_INPUT_CHANNEL_HANDLER))) melt_fatal_error ("MELT polling, fd#%d with invalid handler", rfd); if (fdtab[ixfd].revents & POLLIN) { static char rbuf [MELT_BUFSIZE]; int rdcnt = 0; memset (rbuf, 0, sizeof (rbuf)); debugeprintf ("meltgc_poll_inputs ixfd=%d readable rfd=%d", ixfd, rfd); rdcnt = read (rfd, rbuf, sizeof(rbuf)); debugeprintf ("meltgc_poll_inputs rfd=%d rdcnt=%d", rfd, rdcnt); if (rdcnt == 0) goto end_of_input; else if (rdcnt > 0) { bool eaten = false; /* did read some bytes */ sbufv = melt_field_object ((melt_ptr_t) curhandv, MELTFIELD_INCH_SBUF); meltgc_add_out_raw_len ((melt_ptr_t) sbufv, rbuf, rdcnt); debugeprintf ("meltgc_poll_inputs rdcnt=%d rbuf=%s", rdcnt, rbuf); do { const char* bufdata = melt_strbuf_str ((melt_ptr_t) sbufv); char* buf2nl = bufdata ? CONST_CAST (char*, strstr(bufdata,"\n\n")) : NULL; eaten = false; debugeprintf ("meltgc_poll_inputs bufdata=%s buf2nl=%p", bufdata, (void*) buf2nl); if (bufdata && buf2nl) { union meltparam_un argtab[2]; int nbread = buf2nl - bufdata + 2; ((char*) buf2nl)[1] = '\0'; memset (argtab, 0, sizeof(argtab)); seqv = meltgc_read_from_rawstring (bufdata, NULL, UNKNOWN_LOCATION); melt_strbuf_consume ((melt_ptr_t) sbufv, nbread); closv = melt_field_object ((melt_ptr_t) curhandv, MELTFIELD_INCH_CLOS); MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_poll_inputs handle fd#%d", rfd); argtab[0].meltbp_aptr = (melt_ptr_t *) & seqv; debugeprintf ("meltgc_poll_inputs nbread=%d closv=%p seqv=%p before apply", nbread, (void*) closv, (void*) seqv); melt_apply((meltclosure_ptr_t) closv, (melt_ptr_t) curhandv, MELTBPARSTR_PTR, argtab, NULL, NULL); debugeprintf ("meltgc_poll_inputs after apply sbuf %p usedlen %d str:%s", (void*) sbufv, melt_strbuf_usedlength ((melt_ptr_t) sbufv), melt_strbuf_str ((melt_ptr_t) sbufv)); eaten = true; } debugeprintf ("meltgc_poll_inputs eaten is %s", eaten?"true":"false"); } while (eaten); } } else if ((fdtab[ixfd].revents & POLLHUP) #ifdef POLLRDHUP || (fdtab[ixfd].revents & POLLRDHUP) #endif ) { debugeprintf ("meltgc_poll_inputs ixfd=%d rfd=%d hangup", ixfd, rfd); goto end_of_input; } else if (fdtab[ixfd].revents & POLLERR) { debugeprintf ("meltgc_poll_inputs ixfd=%d rfd=%d error", ixfd, rfd); goto end_of_input; } else if (fdtab[ixfd].revents & POLLNVAL) { debugeprintf ("meltgc_poll_inputs ixfd=%d rfd=%d invalid", ixfd, rfd); goto end_of_input; } continue; end_of_input: { const char* bufdata = NULL; unsigned buflen = 0; union meltparam_un argtab[2]; sbufv = melt_field_object ((melt_ptr_t) curhandv, MELTFIELD_INCH_SBUF); closv = melt_field_object ((melt_ptr_t) curhandv, MELTFIELD_INCH_CLOS); bufdata = melt_strbuf_str ((melt_ptr_t) sbufv); buflen = melt_strbuf_usedlength ((melt_ptr_t) sbufv); memset (argtab, 0, sizeof(argtab)); debugeprintf ("meltgc_poll_inputs rfd=%d end of input buflen=%d bufdata:%s", rfd, buflen, bufdata); if (buflen > 0) { /* we have at most one request in the buffer; it might be incomplete if the probe crashed suddenly while sending it...; it could be empty or missing... */ memset (argtab, 0, sizeof(argtab)); seqv = meltgc_read_from_rawstring (bufdata, NULL, UNKNOWN_LOCATION); bufdata = NULL; /* a GC could have occurred and moved it */ melt_strbuf_consume ((melt_ptr_t) sbufv, buflen); closv = melt_field_object ((melt_ptr_t) curhandv, MELTFIELD_INCH_CLOS); MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_poll_inputs handle fd#%d end of input buflen=%d", rfd, buflen); argtab[0].meltbp_aptr = (melt_ptr_t *) & seqv; debugeprintf ("meltgc_poll_inputsclosv=%p seqv=%p before apply", (void*) closv, (void*) seqv); melt_apply ((meltclosure_ptr_t) closv, (melt_ptr_t) curhandv, MELTBPARSTR_PTR, argtab, NULL, NULL); debugeprintf ("meltgc_poll_inputs after end of input apply last sbuf %p", (void*) sbufv); }; /* notify the end of input with a null argument to the closure */ seqv = NULL; memset (argtab, 0, sizeof(argtab)); MELT_LOCATION_HERE_PRINTF (curlocbuf, "meltgc_poll_inputs handle fd#%d notifying end of input", rfd); argtab[0].meltbp_aptr = (melt_ptr_t *) & seqv; debugeprintf ("meltgc_poll_inputs closv=%p before apply for end of input", (void*) closv); melt_apply ((meltclosure_ptr_t) closv, (melt_ptr_t) curhandv, MELTBPARSTR_PTR, argtab, NULL, NULL); debugeprintf ("meltgc_poll_inputs after end of input apply closv %p", closv); /* replace the handler with :TRUE */ meltgc_longsbucket_replace ((melt_ptr_t) inbuckv, (long) rfd, (melt_ptr_t) MELT_PREDEF (TRUE)); debugeprintf ("meltgc_poll_inputs after end of input replaced rfd#%d", rfd); } } } end: debugeprintf ("meltgc_poll_inputs ended pollres=%d", pollres); if (fdtab) free(fdtab), fdtab = NULL; MELT_EXITFRAME (); return pollres; #undef inbuckv #undef curhandv #undef sbufv #undef closv } /* Real handling of SIGIO signals. Could be called from many places, when SIGIO signal received, thru melt_handle_signal via MELT_CHECK_SIGNAL macro. See field sysdata_inchannel_data of class_system_data in melt/warmelt-first.melt. */ #define MELT_POLL_DELAY_MILLISEC 10 static void meltgc_handle_sigio (void) { static long hdlcounter; bool gotdata = false; MELT_ENTERFRAME (1, NULL); MELT_LOCATION_HERE("meltgc_handle_sigio"); #define inbuckv meltfram__.mcfr_varptr[0] hdlcounter++; debugeprintf ("meltgc_handle_sigio #%ld", hdlcounter); do { gotdata = false; inbuckv = melt_get_inisysdata (MELTFIELD_SYSDATA_INCHANNEL_DATA); if (melt_magic_discr ((melt_ptr_t) inbuckv) == MELTOBMAG_BUCKETLONGS) gotdata = meltgc_poll_inputs ((melt_ptr_t) inbuckv, MELT_POLL_DELAY_MILLISEC) >0; } while (gotdata); goto end; end: MELT_EXITFRAME (); #undef inbuckv #undef curhandv } /* Real handling of SIGALRM & SIGVTALRM signals. Could be called from many places thru melt_handle_signal via MELT_CHECK_SIGNAL macro. */ static void meltgc_handle_sigalrm (void) { static long hdlcounter; MELT_ENTERFRAME (1, NULL); #define closv meltfram__.mcfr_varptr[0] MELT_LOCATION_HERE("meltgc_handle_sigalrm"); hdlcounter++; debugeprintf ("meltgc_handle_sigalrm #%ld", hdlcounter); if (hdlcounter<=0) /* only when we got 2^64 signals ! */ melt_fatal_error ("meltgc_handle_sigalarm got too many alarms %ld", hdlcounter); closv = melt_get_inisysdata (MELTFIELD_SYSDATA_ALARM_HOOK); if (melt_magic_discr ((melt_ptr_t) closv) == MELTOBMAG_CLOSURE) { (void) melt_apply ((meltclosure_ptr_t) closv, (melt_ptr_t) NULL, "", NULL, "", NULL); } MELT_EXITFRAME (); #undef closv } /* Real handling of SIGCHLD signal. Could be called from many places thru melt_handle_signal via MELT_CHECK_SIGNAL macro. */ static void meltgc_handle_sigchld (void) { static long hdlcounter; MELT_ENTERFRAME (1, NULL); #define closv meltfram__.mcfr_varptr[0] MELT_LOCATION_HERE("meltgc_handle_sigchld"); hdlcounter++; debugeprintf ("meltgc_handle_sigchld #%ld", hdlcounter); #if 0 closv = melt_get_inisysdata (MELTFIELD_SYSDATA_ALARM_HOOK); if (melt_magic_discr ((melt_ptr_t) closv) == MELTOBMAG_CLOSURE) { (void) melt_apply ((meltclosure_ptr_t) closv, (melt_ptr_t) NULL, "", NULL, "", NULL); } #endif MELT_EXITFRAME (); #undef closv } /* This meltgc_handle_signal routine is called thru the MELT_CHECK_SIGNAL macro, which is generated in many places in C code generated from MELT. The MELT_CHECK_SIGNAL macro is testing the volatile melt_signaled flag before calling this. Raw signal handlers (e.g. melt_raw_sigio_signal or melt_raw_sigalrm_signal) should set that flag (with perhaps others). */ void melt_handle_signal (void) { melt_signaled = 0; if (melt_got_sigio) { melt_got_sigio = 0; meltgc_handle_sigio (); } if (melt_got_sigalrm) { melt_got_sigalrm = 0; meltgc_handle_sigalrm (); } if (melt_got_sigchld) { melt_got_sigchld = 0; meltgc_handle_sigchld (); } } /* allocate e new empty longsbucket */ melt_ptr_t meltgc_new_longsbucket (meltobject_ptr_t discr_p, unsigned len) { unsigned lenix = 0; unsigned bucklen = 0; MELT_ENTERFRAME (2, NULL); #define discrv meltfram__.mcfr_varptr[0] #define buckv meltfram__.mcfr_varptr[1] discrv = discr_p; MELT_LOCATION_HERE ("meltgc_new_longsbucket"); if (!discrv) discrv = MELT_PREDEF (DISCR_BUCKET_LONGS); if (melt_magic_discr ((melt_ptr_t) (discrv)) != MELTOBMAG_OBJECT) goto end; if (((meltobject_ptr_t) (discrv))->meltobj_magic != MELTOBMAG_BUCKETLONGS) goto end; len += len/16 + 4; for (lenix = 2; (bucklen = melt_primtab[lenix]) != 0 && bucklen < len; lenix++) (void)0; if (bucklen == 0) melt_fatal_error("meltgc_new_longsbucket: too big bucket length %u", len); gcc_assert (lenix>0); buckv = meltgc_allocate (sizeof (struct meltbucketlongs_st), sizeof (struct melt_bucketlongentry_st)*bucklen); ((struct meltbucketlongs_st*)(buckv))->discr = (meltobject_ptr_t) discrv; ((struct meltbucketlongs_st*)(buckv))->buckl_aux = NULL; ((struct meltbucketlongs_st*)(buckv))->buckl_lenix = lenix; ((struct meltbucketlongs_st*)(buckv))->buckl_xnum = 0; ((struct meltbucketlongs_st*)(buckv))->buckl_ucount = 0; memset (((struct meltbucketlongs_st*)(buckv))->buckl_entab, 0, bucklen*sizeof(struct melt_bucketlongentry_st)); end: MELT_EXITFRAME (); return (melt_ptr_t) buckv; #undef buckv #undef valv } /* replace the value associated in a bucket of longs to a long key; don't do anything if the key was absent; return the old value associated to that key, or else NULL. */ melt_ptr_t meltgc_longsbucket_replace (melt_ptr_t bucket_p, long key, melt_ptr_t val_p) { struct meltbucketlongs_st*buck = NULL; unsigned len = 0; unsigned lo=0, hi=0, md=0, ucnt=0; MELT_ENTERFRAME (3, NULL); #define buckv meltfram__.mcfr_varptr[0] #define valv meltfram__.mcfr_varptr[1] #define resv meltfram__.mcfr_varptr[2] buckv = bucket_p; valv = val_p; if (melt_magic_discr ((melt_ptr_t) buckv) != MELTOBMAG_BUCKETLONGS || !valv) goto end; buck = (struct meltbucketlongs_st*)(buckv); len = melt_primtab[buck->buckl_lenix]; ucnt = buck->buckl_ucount; gcc_assert (ucnt <= len); if (ucnt == 0) goto end; lo = 0; hi = ucnt - 1; while (lo + 2 < hi) { long curk = 0; md = (lo + hi) / 2; curk = buck->buckl_entab[md].ebl_at; if (curk < key) lo = md; else hi = md; }; for (md = lo; md <= hi; md++) if (buck->buckl_entab[md].ebl_at == key) { resv = buck->buckl_entab[md].ebl_va; buck->buckl_entab[md].ebl_va = (melt_ptr_t) valv; meltgc_touch_dest ((melt_ptr_t)buckv, (melt_ptr_t)valv); goto end; } end: MELT_EXITFRAME (); return (melt_ptr_t) resv; #undef buckv #undef bu_buckv #undef valv #undef resv } /* put or replace the value associated in a bucket of longs; return the re-allocated bucket or the same one, or else NULL */ melt_ptr_t meltgc_longsbucket_put (melt_ptr_t bucket_p, long key, melt_ptr_t val_p) { struct meltbucketlongs_st*buck = NULL; int len = 0; int lo=0, hi=0, md=0, ucnt=0; MELT_ENTERFRAME (3, NULL); #define buckv meltfram__.mcfr_varptr[0] #define valv meltfram__.mcfr_varptr[1] #define resv meltfram__.mcfr_varptr[2] buckv = bucket_p; valv = val_p; MELT_LOCATION_HERE ("meltgc_longsbucket_put"); resv = NULL; if (melt_magic_discr ((melt_ptr_t) buckv) != MELTOBMAG_BUCKETLONGS || !valv) goto end; buck = (struct meltbucketlongs_st*)(buckv); len = melt_primtab[buck->buckl_lenix]; ucnt = buck->buckl_ucount; gcc_assert (ucnt <= len && len > 0); if (ucnt + 1 >= len) { /* buck is nearly full, allocate a bigger one. */ struct meltbucketlongs_st*oldbuck = NULL; unsigned newcnt = 0; int ix = 0; bool need_insert = true; MELT_LOCATION_HERE ("meltgc_longsbucket_put growing"); resv = meltgc_new_longsbucket (buck->discr, ucnt + ucnt/5 + 8); /* set again buck, because a GC could have occurred */ oldbuck = (struct meltbucketlongs_st*)(buckv); buck = (struct meltbucketlongs_st*)(resv); buck->buckl_aux = oldbuck->buckl_aux; buck->buckl_xnum = oldbuck->buckl_xnum; for (ix = 0; ix < ucnt; ix++) { long oldkey = oldbuck->buckl_entab[ix].ebl_at; if (oldkey < key) { buck->buckl_entab[newcnt] = oldbuck->buckl_entab[ix]; newcnt++; } else if (oldkey == key) { buck->buckl_entab[newcnt].ebl_at = key; buck->buckl_entab[newcnt].ebl_va = (melt_ptr_t) valv; need_insert = false; newcnt ++; } else { /* oldkey > key */ if (need_insert) { buck->buckl_entab[newcnt].ebl_at = key; buck->buckl_entab[newcnt].ebl_va = (melt_ptr_t) valv; need_insert = false; newcnt ++; }; buck->buckl_entab[newcnt] = oldbuck->buckl_entab[ix]; newcnt++; } }; if (need_insert) { buck->buckl_entab[newcnt].ebl_at = key; buck->buckl_entab[newcnt].ebl_va = (melt_ptr_t) valv; need_insert = false; newcnt ++; }; buck->buckl_ucount = newcnt; gcc_assert (newcnt >= (unsigned) ucnt && newcnt < melt_primtab[buck->buckl_lenix]); meltgc_touch_dest ((melt_ptr_t) buck, (melt_ptr_t) valv); } else if (ucnt == 0) { /* buck is empty, add first slot & keep it. */ resv = buckv; buck->buckl_entab[0].ebl_at = key; buck->buckl_entab[0].ebl_va = (melt_ptr_t) valv; buck->buckl_ucount = 1; meltgc_touch_dest ((melt_ptr_t) buck, (melt_ptr_t) valv); } else { /* buck is not full and non empty, keep it. */ resv = buckv; lo = 0; hi = ucnt - 1; while (lo + 2 < hi) { long curk = 0; md = (lo + hi) / 2; curk = buck->buckl_entab[md].ebl_at; if (curk < key) lo = md; else hi = md; }; for (md = lo; md <= hi; md++) { long curk = 0; curk = buck->buckl_entab[md].ebl_at; if (curk < key) continue; else if (curk == key) { buck->buckl_entab[md].ebl_va = (melt_ptr_t) valv; meltgc_touch_dest ((melt_ptr_t) buck, (melt_ptr_t) valv); goto end; } else { /* curk > key, so insert here by moving further slots downwards. */ int ix; for (ix = (int)ucnt; ix >= (int)md; ix--) buck->buckl_entab[ix+1] = buck->buckl_entab[ix]; buck->buckl_entab[md].ebl_at = key; buck->buckl_entab[md].ebl_va = (melt_ptr_t) valv; buck->buckl_ucount = ucnt+1; meltgc_touch_dest ((melt_ptr_t) buck, (melt_ptr_t) valv); goto end; } }; if (buck->buckl_entab[ucnt-1].ebl_at < key) { /* append new slot at end */ buck->buckl_entab[ucnt].ebl_at = key; buck->buckl_entab[ucnt].ebl_va = (melt_ptr_t) valv; buck->buckl_ucount = ucnt+1; meltgc_touch_dest ((melt_ptr_t) buck, (melt_ptr_t) valv); goto end; } } end: MELT_EXITFRAME (); return (melt_ptr_t) resv; #undef buckv #undef valv #undef resv } /* Remove the value associated in a bucket of longs; return the shrinked bucket or the same one, or else NULL */ melt_ptr_t meltgc_longsbucket_remove (melt_ptr_t bucket_p, long key) { struct meltbucketlongs_st*buck = NULL; int len = 0; int lo=0, hi=0, md=0, ucnt=0; MELT_ENTERFRAME (2, NULL); #define buckv meltfram__.mcfr_varptr[0] #define resv meltfram__.mcfr_varptr[1] buckv = bucket_p; resv = NULL; MELT_LOCATION_HERE ("meltgc_longsbucket_remove"); if (melt_magic_discr ((melt_ptr_t) buckv) != MELTOBMAG_BUCKETLONGS) goto end; buck = (struct meltbucketlongs_st*)(buckv); len = melt_primtab[buck->buckl_lenix]; ucnt = (int) buck->buckl_ucount; gcc_assert (ucnt <= len && len > 0); if (len > 10 && 2*ucnt + 3discr, ucnt + 1); /* set again buck, because a GC could have occurred */ oldbuck = (struct meltbucketlongs_st*)(buckv); buck = (struct meltbucketlongs_st*)(resv); buck->buckl_aux = oldbuck->buckl_aux; buck->buckl_xnum = oldbuck->buckl_xnum; for (ix = 0; ix < ucnt; ix++) { long oldkey = oldbuck->buckl_entab[ix].ebl_at; if (oldkey == key) continue; buck->buckl_entab[newcnt] = oldbuck->buckl_entab[ix]; newcnt++; } buck->buckl_ucount = newcnt; } else { /* keep the bucket */ resv = buckv; lo = 0; if (ucnt == 0) goto end; hi = ucnt - 1; while (lo + 2 < hi) { long curk = 0; md = (lo + hi) / 2; curk = buck->buckl_entab[md].ebl_at; if (curk < key) lo = md; else hi = md; }; for (md = lo; md <= hi; md++) { long curk = 0; int ix = 0; curk = buck->buckl_entab[md].ebl_at; if (curk != key) continue; for (ix = md+1; ixbuckl_entab[ix-1] = buck->buckl_entab[ix]; buck->buckl_entab[ucnt].ebl_at = 0; buck->buckl_entab[ucnt].ebl_va = NULL; buck->buckl_ucount = ucnt - 1; goto end; } } end: MELT_EXITFRAME (); return (melt_ptr_t) resv; #undef buckv #undef valv #undef resv } /* Set the auxiliary data in a longsbucket */ void meltgc_longsbucket_set_aux (melt_ptr_t bucket_p, melt_ptr_t aux_p) { struct meltbucketlongs_st*buck = NULL; MELT_ENTERFRAME (2, NULL); #define buckv meltfram__.mcfr_varptr[0] #define auxv meltfram__.mcfr_varptr[1] buckv = bucket_p; auxv = aux_p; MELT_LOCATION_HERE ("meltgc_longsbucket_set_aux"); if (melt_magic_discr ((melt_ptr_t) buckv) != MELTOBMAG_BUCKETLONGS || !auxv) goto end; buck = (struct meltbucketlongs_st*)(buckv); buck->buckl_aux = (melt_ptr_t) auxv; meltgc_touch_dest ((melt_ptr_t) buck, (melt_ptr_t) auxv); end: MELT_EXITFRAME (); #undef buckv #undef auxv } /*****************************************************************/ void melt_set_flag_debug (void) { time_t now; melt_flag_debug = 1; time (&now); debugeprintf(" melt_set_flag_debug forcibly set debug %s", ctime(&now)); } void melt_clear_flag_debug (void) { time_t now; time (&now); debugeprintf(" melt_clear_flag_debug forcibly clear debug %s", ctime(&now)); melt_flag_debug = 0; } /* With GCC 4.8, the gimple_seq are disappearing because they are the same as gimple (with file "coretypes.h" having the definition `typedef gimple gimple_seq;`), but our generated runtime support might still want their old marking routine. */ #if MELT_GCC_VERSION >= 4008 void melt_gt_ggc_mx_gimple_seq_d(void*p) { gt_ggc_mx_gimple_statement_d (p); } #endif /* GCC 4.8 */ /* eof $Id$ */