PR guile/17146

	* acinclude.m4 (GDB_GUILE_PROGRAM_NAMES): New macro.
	(GDB_GUILD_TARGET_FLAG, GDB_TRY_GUILD): New macros.
	* configure.ac: Try to use guild to compile an scm file, if it fails
	then disable guile support.
	* configure: Regenerate.
	* data-directory/Makefile.in (GUILE_SOURCE_FILES): Renamed from
	GUILE_FILE_LIST.
	(GUILE_COMPILED_FILES): New variable.
	(GUILE_FILES) Update.
	(GUILD, GUILD_TARGET_FLAG, GUILD_COMPILE_FLAGS): New variables.
	(stamp-guile): Compile scm files.
	* guile/guile.c (boot_guile_support): New function.
	(standard_throw_args_p): New function.
	(print_standard_throw_error, print_throw_error): New functions.
	(handle_boot_error): New function.
	(initialize_scheme_side): Rewrite to call boot_guile_support.
	* guile/lib/gdb/boot.scm: Update %load-compiled-path.  Load gdb.go.
	* guile/lib/gdb/init.scm (%silence-compiler-warnings%): New function.

8 files changed, 334 insertions, 25 deletions

diff --git a/gdb/ChangeLog b/gdb/ChangeLog
index 3520177ebe7..69bac01494b 100644
--- a/gdb/ChangeLog
+++ b/gdb/ChangeLog
@@ -2,6 +2,29 @@
 	    Doug Evans  <xdje42@gmail.com>
 
 	PR guile/17146
+	* acinclude.m4 (GDB_GUILE_PROGRAM_NAMES): New macro.
+	(GDB_GUILD_TARGET_FLAG, GDB_TRY_GUILD): New macros.
+	* configure.ac: Try to use guild to compile an scm file, if it fails
+	then disable guile support.
+	* configure: Regenerate.
+	* data-directory/Makefile.in (GUILE_SOURCE_FILES): Renamed from
+	GUILE_FILE_LIST.
+	(GUILE_COMPILED_FILES): New variable.
+	(GUILE_FILES) Update.
+	(GUILD, GUILD_TARGET_FLAG, GUILD_COMPILE_FLAGS): New variables.
+	(stamp-guile): Compile scm files.
+	* guile/guile.c (boot_guile_support): New function.
+	(standard_throw_args_p): New function.
+	(print_standard_throw_error, print_throw_error): New functions.
+	(handle_boot_error): New function.
+	(initialize_scheme_side): Rewrite to call boot_guile_support.
+	* guile/lib/gdb/boot.scm: Update %load-compiled-path.  Load gdb.go.
+	* guile/lib/gdb/init.scm (%silence-compiler-warnings%): New function.
+
+2014-07-26  Ludovic Courtès  <ludo@gnu.org>
+	    Doug Evans  <xdje42@gmail.com>
+
+	PR guile/17146
 	* data-directory/Makefile.in (GUILE_FILES): Add support.scm.
 	* guile/lib/gdb/support.scm: New file.
 	* guile/guile.c (gdbscm_init_module_name): Change to "gdb".
diff --git a/gdb/acinclude.m4 b/gdb/acinclude.m4
index 01d0fd3dade..a3fb9e27ac6 100644
--- a/gdb/acinclude.m4
+++ b/gdb/acinclude.m4
@@ -473,3 +473,75 @@ AC_DEFUN([GDB_AC_CHECK_BFD], [
   CFLAGS=$OLD_CFLAGS
   LDFLAGS=$OLD_LDFLAGS
   LIBS=$OLD_LIBS])
+
+dnl GDB_GUILE_PROGRAM_NAMES([PKG-CONFIG], [VERSION])
+dnl
+dnl Define and substitute 'GUILD' to contain the absolute file name of
+dnl the 'guild' command for VERSION, using PKG-CONFIG.  (This is
+dnl similar to Guile's 'GUILE_PROGS' macro.)
+AC_DEFUN([GDB_GUILE_PROGRAM_NAMES], [
+  AC_CACHE_CHECK([for the absolute file name of the 'guild' command],
+    [ac_cv_guild_program_name],
+    [ac_cv_guild_program_name="`$1 $2 --variable guild`"
+
+     # In Guile up to 2.0.11 included, guile-2.0.pc would not define
+     # the 'guild' and 'bindir' variables.  In that case, try to guess
+     # what the program name is, at the risk of getting it wrong if
+     # Guile was configured with '--program-suffix' or similar.
+     if test "x$ac_cv_guild_program_name" = "x"; then
+       guile_exec_prefix="`$1 $2 --variable exec_prefix`"
+       ac_cv_guild_program_name="$guile_exec_prefix/bin/guild"
+     fi
+  ])
+
+  if ! "$ac_cv_guild_program_name" --version >&AS_MESSAGE_LOG_FD 2>&AS_MESSAGE_LOG_FD; then
+    AC_MSG_ERROR(['$ac_cv_guild_program_name' appears to be unusable])
+  fi
+
+  GUILD="$ac_cv_guild_program_name"
+  AC_SUBST([GUILD])
+])
+
+dnl GDB_GUILD_TARGET_FLAG
+dnl
+dnl Compute the value of GUILD_TARGET_FLAG.
+dnl For native builds this is empty.
+dnl For cross builds this is --target=<host>.
+AC_DEFUN([GDB_GUILD_TARGET_FLAG], [
+  if test "$cross_compiling" = no; then
+    GUILD_TARGET_FLAG=
+  else
+    GUILD_TARGET_FLAG="--target=$host"
+  fi
+  AC_SUBST(GUILD_TARGET_FLAG)
+])
+
+dnl GDB_TRY_GUILD([SRC-FILE])
+dnl
+dnl We precompile the .scm files and install them with gdb, so make sure
+dnl guild works for this host.
+dnl The .scm files are precompiled for several reasons:
+dnl 1) To silence Guile during gdb startup (Guile's auto-compilation output
+dnl    is unnecessarily verbose).
+dnl 2) Make gdb developers see compilation errors/warnings during the build,
+dnl    and not leave it to later when the user runs gdb.
+dnl 3) As a convenience for the user, so that one copy of the files is built
+dnl    instead of one copy per user.
+dnl
+dnl Make sure guild can handle this host by trying to compile SRC-FILE, and
+dnl setting ac_cv_guild_ok to yes or no.
+dnl Note that guild can handle cross-compilation.
+dnl It could happen that guild can't handle the host, but guile would still
+dnl work.  For the time being we're conservative, and if guild doesn't work
+dnl we punt.
+AC_DEFUN([GDB_TRY_GUILD], [
+  AC_REQUIRE([GDB_GUILD_TARGET_FLAG])
+  AC_CACHE_CHECK([whether guild supports this host],
+    [ac_cv_guild_ok],
+    [echo "$ac_cv_guild_program_name compile $GUILD_TARGET_FLAG -o conftest.go $1" >&AS_MESSAGE_LOG_FD
+     if "$ac_cv_guild_program_name" compile $GUILD_TARGET_FLAG -o conftest.go "$1" >&AS_MESSAGE_LOG_FD 2>&AS_MESSAGE_LOG_FD; then
+       ac_cv_guild_ok=yes
+     else
+       ac_cv_guild_ok=no
+     fi])
+])
diff --git a/gdb/configure b/gdb/configure
index 98f653a9e3f..809326a4939 100755
--- a/gdb/configure
+++ b/gdb/configure
@@ -662,6 +662,8 @@ HAVE_GUILE_FALSE
 HAVE_GUILE_TRUE
 GUILE_LIBS
 GUILE_CPPFLAGS
+GUILD_TARGET_FLAG
+GUILD
 pkg_config_prog_path
 HAVE_PYTHON_FALSE
 HAVE_PYTHON_TRUE
@@ -9081,6 +9083,68 @@ esac
 
 if test "${have_libguile}" != no; then
 
+  { $as_echo "$as_me:${as_lineno-$LINENO}: checking for the absolute file name of the 'guild' command" >&5
+$as_echo_n "checking for the absolute file name of the 'guild' command... " >&6; }
+if test "${ac_cv_guild_program_name+set}" = set; then :
+  $as_echo_n "(cached) " >&6
+else
+  ac_cv_guild_program_name="`"${pkg_config_prog_path}" "${guile_version}" --variable guild`"
+
+     # In Guile up to 2.0.11 included, guile-2.0.pc would not define
+     # the 'guild' and 'bindir' variables.  In that case, try to guess
+     # what the program name is, at the risk of getting it wrong if
+     # Guile was configured with '--program-suffix' or similar.
+     if test "x$ac_cv_guild_program_name" = "x"; then
+       guile_exec_prefix="`"${pkg_config_prog_path}" "${guile_version}" --variable exec_prefix`"
+       ac_cv_guild_program_name="$guile_exec_prefix/bin/guild"
+     fi
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_guild_program_name" >&5
+$as_echo "$ac_cv_guild_program_name" >&6; }
+
+  if ! "$ac_cv_guild_program_name" --version >&5 2>&5; then
+    as_fn_error "'$ac_cv_guild_program_name' appears to be unusable" "$LINENO" 5
+  fi
+
+  GUILD="$ac_cv_guild_program_name"
+
+
+
+
+  if test "$cross_compiling" = no; then
+    GUILD_TARGET_FLAG=
+  else
+    GUILD_TARGET_FLAG="--target=$host"
+  fi
+
+
+
+
+  { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether guild supports this host" >&5
+$as_echo_n "checking whether guild supports this host... " >&6; }
+if test "${ac_cv_guild_ok+set}" = set; then :
+  $as_echo_n "(cached) " >&6
+else
+  echo "$ac_cv_guild_program_name compile $GUILD_TARGET_FLAG -o conftest.go $srcdir/guile/lib/gdb/support.scm" >&5
+     if "$ac_cv_guild_program_name" compile $GUILD_TARGET_FLAG -o conftest.go "$srcdir/guile/lib/gdb/support.scm" >&5 2>&5; then
+       ac_cv_guild_ok=yes
+     else
+       ac_cv_guild_ok=no
+     fi
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_guild_ok" >&5
+$as_echo "$ac_cv_guild_ok" >&6; }
+
+    if test "$ac_cv_guild_ok" = no; then
+    have_libguile=no
+    { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: disabling guile support" >&5
+$as_echo "$as_me: WARNING: disabling guile support" >&2;}
+  fi
+fi
+
+if test "${have_libguile}" != no; then
+
 $as_echo "#define HAVE_GUILE 1" >>confdefs.h
 
   CONFIG_OBS="$CONFIG_OBS \$(SUBDIR_GUILE_OBS)"
diff --git a/gdb/configure.ac b/gdb/configure.ac
index 48b36157eab..70d09645248 100644
--- a/gdb/configure.ac
+++ b/gdb/configure.ac
@@ -1195,6 +1195,19 @@ yes)
 esac
 
 if test "${have_libguile}" != no; then
+  dnl Get the name of the 'guild' program.
+  GDB_GUILE_PROGRAM_NAMES(["${pkg_config_prog_path}"], ["${guile_version}"])
+
+  dnl Make sure guild can handle this host.
+  GDB_TRY_GUILD([$srcdir/guile/lib/gdb/support.scm])
+  dnl If not, disable guile support.
+  if test "$ac_cv_guild_ok" = no; then
+    have_libguile=no
+    AC_MSG_WARN(disabling guile support, $GUILD fails compiling for $host)
+  fi
+fi
+
+if test "${have_libguile}" != no; then
   AC_DEFINE(HAVE_GUILE, 1, [Define if Guile interpreter is being linked in.])
   CONFIG_OBS="$CONFIG_OBS \$(SUBDIR_GUILE_OBS)"
   CONFIG_DEPS="$CONFIG_DEPS \$(SUBDIR_GUILE_DEPS)"
diff --git a/gdb/data-directory/Makefile.in b/gdb/data-directory/Makefile.in
index b05dba55496..509f8885a92 100644
--- a/gdb/data-directory/Makefile.in
+++ b/gdb/data-directory/Makefile.in
@@ -80,7 +80,8 @@ PYTHON_FILE_LIST = \
 
 GUILE_DIR = guile
 GUILE_INSTALL_DIR = $(DESTDIR)$(GDB_DATADIR)/$(GUILE_DIR)
-GUILE_FILE_LIST = \
+
+GUILE_SOURCE_FILES = \
 	./gdb.scm \
 	gdb/boot.scm \
 	gdb/experimental.scm \
@@ -90,9 +91,31 @@ GUILE_FILE_LIST = \
 	gdb/support.scm \
 	gdb/types.scm
 
-@HAVE_GUILE_TRUE@GUILE_FILES = $(GUILE_FILE_LIST)
+GUILE_COMPILED_FILES = \
+	./gdb.go \
+	gdb/experimental.go \
+	gdb/iterator.go \
+	gdb/printing.go \
+	gdb/support.go \
+	gdb/types.go
+
+@HAVE_GUILE_TRUE@GUILE_FILES = $(GUILE_SOURCE_FILES) $(GUILE_COMPILED_FILES)
 @HAVE_GUILE_FALSE@GUILE_FILES =
 
+GUILD = @GUILD@
+GUILD_TARGET_FLAG = @GUILD_TARGET_FLAG@
+
+# Flags passed to 'guild compile'.
+# Note: We can't use -Wunbound-variable because all the variables
+# defined in C aren't visible when we compile.
+# Note: To work around a guile 2.0.5 issue (it can't find gdb/init.scm even if
+# we pass -L <dir>) we have to compile in the directory containing gdb.scm.
+# We still need to pass "-L ." so that other modules are found.
+GUILD_COMPILE_FLAGS = \
+	$(GUILD_TARGET_FLAG) \
+	-Warity-mismatch -Wformat -Wunused-toplevel \
+	-L .
+
 SYSTEM_GDBINIT_DIR = system-gdbinit
 SYSTEM_GDBINIT_INSTALL_DIR = $(DESTDIR)$(GDB_DATADIR)/$(SYSTEM_GDBINIT_DIR)
 SYSTEM_GDBINIT_FILES = \
@@ -222,15 +245,22 @@ uninstall-python:
 	  done ; \
 	fi
 
-stamp-guile: Makefile $(GUILE_FILES)
+stamp-guile: Makefile $(GUILE_SOURCE_FILES)
 	rm -rf ./$(GUILE_DIR)
-	files='$(GUILE_FILES)' ; \
-	if test "x$$files" != x ; then \
+	if test "x$(GUILE_FILES)" != x ; then \
+	  files='$(GUILE_SOURCE_FILES)' ; \
 	  for file in $$files ; do \
 	    dir=`echo "$$file" | sed 's,/[^/]*$$,,'` ; \
 	    $(INSTALL_DIR) ./$(GUILE_DIR)/$$dir ; \
 	    $(INSTALL_DATA) $(GUILE_SRCDIR)/$$file ./$(GUILE_DIR)/$$dir ; \
 	  done ; \
+	  files='$(GUILE_COMPILED_FILES)' ; \
+	  cd ./$(GUILE_DIR) ; \
+	  for go in $$files ; do \
+	    source="`echo $$go | sed 's/\.go$$/.scm/'`" ; \
+	    echo $(GUILD) compile $(GUILD_COMPILE_FLAGS) -o "$$go" "$$source" ; \
+	    $(GUILD) compile $(GUILD_COMPILE_FLAGS) -o "$$go" "$$source" || exit 1 ; \
+	  done ; \
 	fi
 	touch $@
 
diff --git a/gdb/guile/guile.c b/gdb/guile/guile.c
index e81cb4c8ea8..1c0923d8813 100644
--- a/gdb/guile/guile.c
+++ b/gdb/guile/guile.c
@@ -510,6 +510,111 @@ Return the name of the target configuration." },
   END_FUNCTIONS
 };
 
+/* Load BOOT_SCM_FILE, the first Scheme file that gets loaded.  */
+
+static SCM
+boot_guile_support (void *boot_scm_file)
+{
+  /* Load boot.scm without compiling it (there's no need to compile it).
+     The other files should have been compiled already, and boot.scm is
+     expected to adjust '%load-compiled-path' accordingly.  If they haven't
+     been compiled, Guile will auto-compile them. The important thing to keep
+     in mind is that there's a >= 100x speed difference between compiled and
+     non-compiled files.  */
+  return scm_c_primitive_load ((const char *) boot_scm_file);
+}
+
+/* Return non-zero if ARGS has the "standard" format for throw args.
+   The standard format is:
+   (function format-string (format-string-args-list) ...).
+   FUNCTION is #f if no function was recorded.  */
+
+static int
+standard_throw_args_p (SCM args)
+{
+  if (gdbscm_is_true (scm_list_p (args))
+      && scm_ilength (args) >= 3)
+    {
+      /* The function in which the error occurred.  */
+      SCM arg0 = scm_list_ref (args, scm_from_int (0));
+      /* The format string.  */
+      SCM arg1 = scm_list_ref (args, scm_from_int (1));
+      /* The arguments of the format string.  */
+      SCM arg2 = scm_list_ref (args, scm_from_int (2));
+
+      if ((scm_is_string (arg0) || gdbscm_is_false (arg0))
+	  && scm_is_string (arg1)
+	  && gdbscm_is_true (scm_list_p (arg2)))
+	return 1;
+    }
+
+  return 0;
+}
+
+/* Print the error recorded in a "standard" throw args.  */
+
+static void
+print_standard_throw_error (SCM args)
+{
+  /* The function in which the error occurred.  */
+  SCM arg0 = scm_list_ref (args, scm_from_int (0));
+  /* The format string.  */
+  SCM arg1 = scm_list_ref (args, scm_from_int (1));
+  /* The arguments of the format string.  */
+  SCM arg2 = scm_list_ref (args, scm_from_int (2));
+
+  /* ARG0 is #f if no function was recorded.  */
+  if (gdbscm_is_true (arg0))
+    {
+      scm_simple_format (scm_current_error_port (),
+			 scm_from_latin1_string (_("Error in function ~s:~%")),
+			 scm_list_1 (arg0));
+    }
+  scm_simple_format (scm_current_error_port (), arg1, arg2);
+}
+
+/* Print the error message recorded in KEY, ARGS, the arguments to throw.
+   Normally we let Scheme print the error message.
+   This function is used when Scheme initialization fails.
+   We can still use the Scheme C API though.  */
+
+static void
+print_throw_error (SCM key, SCM args)
+{
+  /* IWBN to call gdbscm_print_exception_with_stack here, but Guile didn't
+     boot successfully so play it safe and avoid it.  The "format string" and
+     its args are embedded in ARGS, but the content of ARGS depends on KEY.
+     Make sure ARGS has the expected canonical content before trying to use
+     it.  */
+  if (standard_throw_args_p (args))
+    print_standard_throw_error (args);
+  else
+    {
+      scm_simple_format (scm_current_error_port (),
+			 scm_from_latin1_string (_("Throw to key `~a' with args `~s'.~%")),
+			 scm_list_2 (key, args));
+    }
+}
+
+/* Handle an exception thrown while loading BOOT_SCM_FILE.  */
+
+static SCM
+handle_boot_error (void *boot_scm_file, SCM key, SCM args)
+{
+  fprintf_unfiltered (gdb_stderr, ("Exception caught while booting Guile.\n"));
+
+  print_throw_error (key, args);
+
+  fprintf_unfiltered (gdb_stderr, "\n");
+  warning (_("Could not complete Guile gdb module initialization from:\n"
+	     "%s.\n"
+	     "Limited Guile support is available.\n"
+	     "Suggest passing --data-directory=/path/to/gdb/data-directory.\n"),
+	   (const char *) boot_scm_file);
+
+  return SCM_UNSPECIFIED;
+}
+
 /* Load gdb/boot.scm, the Scheme side of GDB/Guile support.
    Note: This function assumes it's called within the gdb module.  */
 
@@ -523,23 +628,8 @@ initialize_scheme_side (void)
   boot_scm_path = concat (guile_datadir, SLASH_STRING, "gdb",
 			  SLASH_STRING, boot_scm_filename, NULL);
 
-  /* While scm_c_primitive_load works, the loaded code is not compiled,
-     instead it is left to be interpreted.  Eh?
-     Anyways, this causes a ~100x slowdown, so we only use it to load
-     gdb/boot.scm, and then let boot.scm do the rest.  */
-  msg = gdbscm_safe_source_script (boot_scm_path);
-
-  if (msg != NULL)
-    {
-      fprintf_filtered (gdb_stderr, "%s", msg);
-      xfree (msg);
-      warning (_("\n"
-		 "Could not complete Guile gdb module initialization from:\n"
-		 "%s.\n"
-		 "Limited Guile support is available.\n"
-		 "Suggest passing --data-directory=/path/to/gdb/data-directory.\n"),
-	       boot_scm_path);
-    }
+  scm_c_catch (SCM_BOOL_T, boot_guile_support, boot_scm_path,
+	       handle_boot_error, boot_scm_path, NULL, NULL);
 
   xfree (boot_scm_path);
 }
diff --git a/gdb/guile/lib/gdb/boot.scm b/gdb/guile/lib/gdb/boot.scm
index 6159354d209..9463f101638 100644
--- a/gdb/guile/lib/gdb/boot.scm
+++ b/gdb/guile/lib/gdb/boot.scm
@@ -21,9 +21,20 @@
 ;; loaded with it are not compiled.  So we do very little here, and do
 ;; most of the initialization elsewhere.
 
-;; guile-data-directory is provided by the C code.
-(add-to-load-path (guile-data-directory))
-(load-from-path "gdb.scm")
+;; Initialize the source and compiled file search paths.
+;; Note: 'guile-data-directory' is provided by the C code.
+(let ((module-dir (guile-data-directory)))
+  (set! %load-path (cons module-dir %load-path))
+  (set! %load-compiled-path (cons module-dir %load-compiled-path)))
+
+;; Load the (gdb) module.  This needs to be done here because C code relies on
+;; the availability of Scheme bindings such as '%print-exception-with-stack'.
+;; Note: as of Guile 2.0.11, 'primitive-load' evaluates the code and 'load'
+;; somehow ignores the '.go', hence 'load-compiled'.
+(let ((gdb-go-file (search-path %load-compiled-path "gdb.go")))
+  (if gdb-go-file
+      (load-compiled gdb-go-file)
+      (error "Unable to find gdb.go file.")))
 
 ;; Now that the Scheme side support is loaded, initialize it.
 (let ((init-proc (@@ (gdb) %initialize!)))
diff --git a/gdb/guile/lib/gdb/init.scm b/gdb/guile/lib/gdb/init.scm
index 98888ed3ac9..53cce2eddba 100644
--- a/gdb/guile/lib/gdb/init.scm
+++ b/gdb/guile/lib/gdb/init.scm
@@ -147,6 +147,12 @@
   (set! %orig-input-port (set-current-input-port (input-port)))
   (set! %orig-output-port (set-current-output-port (output-port)))
   (set! %orig-error-port (set-current-error-port (error-port))))
+
+;; Dummy routine to silence "possibly unused local top-level variable"
+;; warnings from the compiler.
+
+(define-public (%silence-compiler-warnings%)
+  (list %print-exception-with-stack %initialize!))
 
 ;; Public routines.