propagate much more source info through compilation

* module/language/ghil/compile-glil.scm (codegen): Record source location
  for offset 0 into a lambda, if we can.

* module/language/scheme/compile-ghil.scm (translate-1)
  (define-scheme-translator): In the retrans procedures, propagate the
  location information from the enclosing expression if the subexpression
  has no location information. Gives source information to many more
  expressions.
  (location): Just propagate the source properties as they are, the
  glil->assembly compiler will interpret them.

* module/language/glil.scm (<glil>): Change glil-source to take "props"
  and not "loc", as it's the source properties that we're interested in.

* module/language/glil/compile-assembly.scm (limn-sources): New function,
  takes a list of addr-source property pairs and "compresses" them for
  serialization to disk.
  (glil->assembly): Limn the sources before writing them to disk. Avoid
  non-tail recursion when determining total byte length of code.

* module/system/vm/program.scm (source:file, source:line, source:column):
  Update for new source representation.
  (program-source): Export.
  (write-program): Nicer pretty-printing of anonymous procedures.

* libguile/backtrace.c (display_backtrace_get_file_line): Update for the
  new VM source representation.

* libguile/programs.h:
* libguile/programs.c (scm_program_sources): Update for the new
  serialized source representation, where the filename is not in the
  stream unless it changes.
  (scm_program_source): New exported function, looks up the source for a
  given ip offset.
  (scm_c_program_source): Update to return the last source information
  that was <= the given IP, because we only serialize source info when it
  changes.

3 files changed, 47 insertions, 16 deletions

diff --git a/libguile/backtrace.c b/libguile/backtrace.c
index 418b6d777..a8afcdf34 100644
--- a/libguile/backtrace.c
+++ b/libguile/backtrace.c
@@ -473,14 +473,14 @@ display_backtrace_get_file_line (SCM frame, SCM *file, SCM *line)
       *file = scm_source_property (source, scm_sym_filename);
       *line = scm_source_property (source, scm_sym_line);
     }
-  else if (scm_is_vector (source))
+  else if (scm_is_pair (source)
+           && scm_is_pair (scm_cdr (source))
+           && scm_is_pair (scm_cddr (source))
+           && !scm_is_pair (scm_cdddr (source)))
     {
-      /* #(line column file), from VM compilation */
-      size_t len = scm_c_vector_length (source);
-      if (len >= 3)
-        *file = scm_c_vector_ref (source, 2);
-      if (len >= 1)
-        *line = scm_c_vector_ref (source, 0);
+      /* (addr . (filename . (line . column))), from vm compilation */
+      *file = scm_cadr (source);
+      *line = scm_caddr (source);
     }
 }
 
diff --git a/libguile/programs.c b/libguile/programs.c
index b4d43bf6e..1c42e15d6 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -49,6 +49,7 @@
 #include "modules.h"
 #include "programs.h"
 #include "procprop.h" // scm_sym_name
+#include "srcprop.h" // scm_sym_filename
 #include "vm.h"
 
 
@@ -219,7 +220,7 @@ SCM_DEFINE (scm_program_sources, "program-sources", 1, 0, 0,
 	    "")
 #define FUNC_NAME s_scm_program_sources
 {
-  SCM meta;
+  SCM meta, sources, ret, filename;
   
   SCM_VALIDATE_PROGRAM (1, program);
 
@@ -227,7 +228,25 @@ SCM_DEFINE (scm_program_sources, "program-sources", 1, 0, 0,
   if (scm_is_false (meta))
     return SCM_EOL;
   
-  return scm_cadr (scm_call_0 (meta));
+  filename = SCM_BOOL_F;
+  ret = SCM_EOL;
+  for (sources = scm_cadr (scm_call_0 (meta)); !scm_is_null (sources);
+       sources = scm_cdr (sources))
+    {
+      SCM x = scm_car (sources);
+      if (scm_is_pair (x))
+        {
+          if (scm_is_number (scm_car (x)))
+            {
+              SCM addr = scm_car (x);
+              ret = scm_acons (addr, scm_cons (filename, scm_cdr (x)),
+                               ret);
+            }
+          else if (scm_is_eq (scm_car (x), scm_sym_filename))
+            filename = scm_cdr (x);
+        }
+    }
+  return scm_reverse_x (ret, SCM_UNDEFINED);
 }
 #undef FUNC_NAME
 
@@ -258,17 +277,28 @@ SCM_DEFINE (scm_program_name, "program-name", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_program_source, "program-source", 2, 0, 0,
+	    (SCM program, SCM ip),
+	    "")
+#define FUNC_NAME s_scm_program_source
+{
+  SCM_VALIDATE_PROGRAM (1, program);
+  return scm_c_program_source (program, scm_to_size_t (ip));
+}
+#undef FUNC_NAME
+    
 extern SCM
 scm_c_program_source (SCM program, size_t ip)
 {
-  SCM sources, source;
-
-  sources = scm_program_sources (program);
-  source = scm_assv (scm_from_size_t (ip), sources);
-  if (scm_is_false (source))
-    return SCM_BOOL_F;
+  SCM sources, source = SCM_BOOL_F;
 
-  return scm_cdr (source); /* a #(line column file) vector */
+  for (sources = scm_program_sources (program);
+       !scm_is_null (sources)
+         && scm_to_size_t (scm_caar (sources)) <= ip;
+       sources = scm_cdr (sources))
+    source = scm_car (sources);
+  
+  return source; /* (addr . (filename . (line . column))) */
 }
 
 SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0,
diff --git a/libguile/programs.h b/libguile/programs.h
index 263228bec..68a6936a2 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -71,6 +71,7 @@ extern SCM scm_program_arity (SCM program);
 extern SCM scm_program_meta (SCM program);
 extern SCM scm_program_bindings (SCM program);
 extern SCM scm_program_sources (SCM program);
+extern SCM scm_program_source (SCM program, SCM ip);
 extern SCM scm_program_properties (SCM program);
 extern SCM scm_program_name (SCM program);
 extern SCM scm_program_objects (SCM program);