From 5ac22ef3b8a1ad49a42a9b72e630c72240587339 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 19 Jan 2015 15:50:08 -0700
Subject: [PATCH] another GC backtrace repair

Special treatment of a "prefix" in a closure needs special
backtrace support.
---
 racket/src/racket/gc2/gc2.h           | 5 +++++
 racket/src/racket/gc2/newgc.c         | 7 +++++++
 racket/src/racket/src/eval.c          | 3 +++
 racket/src/racket/src/mzclpf_post.inc | 3 +++
 racket/src/racket/src/schpriv.h       | 3 +++
 5 files changed, 21 insertions(+)

diff --git a/racket/src/racket/gc2/gc2.h b/racket/src/racket/gc2/gc2.h
index ac3e2bdb05..887ff56c6d 100644
--- a/racket/src/racket/gc2/gc2.h
+++ b/racket/src/racket/gc2/gc2.h
@@ -571,6 +571,11 @@ GC2_EXTERN void GC_report_unsent_message_delta(intptr_t amt);
  is within a factor of 2 or so.
  */
 
+GC2_EXTERN void GC_set_backpointer_object(void *p);
+/*
+ Registers the current object for backpointers, which is used when backtrace
+ support is enabled.
+*/
 
 # ifdef __cplusplus
 };
diff --git a/racket/src/racket/gc2/newgc.c b/racket/src/racket/gc2/newgc.c
index 5a28e0986b..4494298cd9 100644
--- a/racket/src/racket/gc2/newgc.c
+++ b/racket/src/racket/gc2/newgc.c
@@ -2156,6 +2156,13 @@ static void *get_backtrace(mpage *page, void *ptr, int *kind)
 
 #define three_arg_no_op(a, b, c) /* */
 
+void GC_set_backpointer_object(void *p)
+{
+#ifdef MZ_GC_BACKTRACE
+  set_backtrace_source(GC_get_GC(), p, PAGE_TAGGED);
+#endif
+}
+
 /*****************************************************************************/
 /* Routines dealing with various runtime execution stacks                    */
 /*                                                                           */
diff --git a/racket/src/racket/src/eval.c b/racket/src/racket/src/eval.c
index c6fc48c7ef..c1488c1963 100644
--- a/racket/src/racket/src/eval.c
+++ b/racket/src/racket/src/eval.c
@@ -5816,6 +5816,9 @@ static void mark_pruned_prefixes(struct NewGC *gc) XFORM_SKIP_PROC
           use_bits[i] = 0;
         }
         /* Should mark/copy pf, but not trigger or require mark propagation: */
+#ifdef MZ_GC_BACKTRACE
+        GC_set_backpointer_object(pf->backpointer);
+#endif
         gcMARK(pf);
         pf = (Scheme_Prefix *)GC_resolve2(pf, gc);
         GC_retract_only_mark_stack_entry(pf, gc);
diff --git a/racket/src/racket/src/mzclpf_post.inc b/racket/src/racket/src/mzclpf_post.inc
index cf4392af4a..1de1e0009b 100644
--- a/racket/src/racket/src/mzclpf_post.inc
+++ b/racket/src/racket/src/mzclpf_post.inc
@@ -23,6 +23,9 @@
            all other marking: */
         pf->next_final = scheme_prefix_finalize;
         scheme_prefix_finalize = pf;
+#ifdef MZ_GC_BACKTRACE
+        pf->backpointer = (Scheme_Object *)c;
+#endif
       }
       mark_stxes = 0;
 
diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h
index 8c7495f629..f21352b5ad 100644
--- a/racket/src/racket/src/schpriv.h
+++ b/racket/src/racket/src/schpriv.h
@@ -2360,6 +2360,9 @@ typedef struct Scheme_Prefix
   Scheme_Object so; /* scheme_prefix_type */
   int num_slots, num_toplevels, num_stxes;
   struct Scheme_Prefix *next_final; /* for special GC handling */
+#ifdef MZ_GC_BACKTRACE
+  Scheme_Object *backpointer;
+#endif
   Scheme_Object *a[mzFLEX_ARRAY_DECL]; /* array of objects */
   /* followed by an array of `int's for tl_map uses */
 } Scheme_Prefix;