add `identifier-prune-to-source-module' and use it in contract implementation

reduces DrRacket's initial footprint by 20-25% --- back to the v5.0 level

collects/racket/contract/private/provide.rkt

@@ -78,13 +78,14 @@
                         (with-syntax ([contract-id contract-id]
                                       [id id]
                                       [external-id external-id]
-                                      [pos-module-source pos-module-source])
+                                      [pos-module-source pos-module-source]
+                                      [loc-id (identifier-prune-to-source-module id)])
                           (syntax-local-introduce
                            (syntax-local-lift-expression
                             #`(contract contract-id
                                         id
                                         pos-module-source
-                                        (first-requiring-module (quote-syntax id) (quote-module-path))
+                                        (first-requiring-module (quote-syntax loc-id) (quote-module-path))
                                         'external-id
                                         (quote-srcloc id))))))])
                (when key

collects/scribblings/reference/stx-ops.scrbl

@@ -241,3 +241,10 @@ particular, transferring the lexical context via
 other than one in @scheme[syms] produces a identifier with no binding.
 
 See also @scheme[quote-syntax/prune].}
+
+@defproc[(identifier-prune-to-source-module [id-stx identifier?])
+         identifier?]{
+
+Returns an identifier with its lexical context minimized to that
+needed for @scheme[syntax-source-module]. The minimized lexical
+context does not include any bindings.}

collects/unstable/location.rkt

@@ -31,7 +31,9 @@
                          [pos (srcloc-position src)]
                          [span (srcloc-span src)])
              #'(make-srcloc 'src 'line 'col 'pos 'span)))]
-        [else #'(build-source-location (quote-syntax loc))]))]))
+        [else (with-syntax ([loc (identifier-prune-to-source-module
+                                  (datum->syntax #'loc 'loc #'loc #'loc))])
+                #'(build-source-location (quote-syntax loc)))]))]))
 
 (define-syntax-rule (define-quote-srcloc-accessors [name accessor] ...)
   (define-syntaxes [ name ... ]

src/racket/src/schminc.h

@@ -13,7 +13,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 996
+#define EXPECTED_PRIM_COUNT 997
 #define EXPECTED_UNSAFE_COUNT 66
 #define EXPECTED_FLFXNUM_COUNT 55
 

src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "5.0.0.2"
+#define MZSCHEME_VERSION "5.0.0.3"
 
 #define MZSCHEME_VERSION_X 5
 #define MZSCHEME_VERSION_Y 0
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 2
+#define MZSCHEME_VERSION_W 3
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

src/racket/src/stxobj.c

@@ -89,6 +89,7 @@ static Scheme_Object *module_trans_binding(int argc, Scheme_Object **argv);
 static Scheme_Object *module_templ_binding(int argc, Scheme_Object **argv);
 static Scheme_Object *module_label_binding(int argc, Scheme_Object **argv);
 static Scheme_Object *identifier_prune(int argc, Scheme_Object **argv);
+static Scheme_Object *identifier_prune_to_module(int argc, Scheme_Object **argv);
 static Scheme_Object *syntax_src_module(int argc, Scheme_Object **argv);
 
 static Scheme_Object *syntax_recertify(int argc, Scheme_Object **argv);
@@ -579,6 +580,11 @@ void scheme_init_stx(Scheme_Env *env)
 						    "identifier-prune-lexical-context",
 						    1, 2),
 			     env);
+  scheme_add_global_constant("identifier-prune-to-source-module", 
+			     scheme_make_immed_prim(identifier_prune_to_module,
+						    "identifier-prune-to-source-module",
+						    1, 1),
+			     env);
 
 
   scheme_add_global_constant("syntax-source-module", 
@@ -9131,6 +9137,45 @@ static Scheme_Object *identifier_prune(int argc, Scheme_Object **argv)
   return scheme_add_rename(a, p);
 }
 
+static Scheme_Object *identifier_prune_to_module(int argc, Scheme_Object **argv)
+{
+  WRAP_POS w;
+  Scheme_Stx *stx = (Scheme_Stx *)argv[0];
+  Scheme_Object *l = scheme_null;
+
+  if (!SCHEME_STXP(argv[0]) || !SCHEME_STX_SYMBOLP(argv[0]))
+    scheme_wrong_type("identifier-prune-to-source-module", "identifier syntax", 0, argc, argv);
+
+  /* Keep only redirecting phase shifts */
+
+  WRAP_POS_INIT(w, ((Scheme_Stx *)stx)->wraps);
+  while (!WRAP_POS_END_P(w)) {
+    if (SCHEME_BOXP(WRAP_POS_FIRST(w))) {
+      /* Phase shift:  */
+      Scheme_Object *vec, *dest, *src;
+
+      vec = SCHEME_PTR_VAL(WRAP_POS_FIRST(w));
+      
+      src = SCHEME_VEC_ELS(vec)[1];
+      dest = SCHEME_VEC_ELS(vec)[2];
+
+      /* If src is #f, shift is just for phase; no redirection */
+      if (!SCHEME_FALSEP(src)) {
+        l = scheme_make_pair(WRAP_POS_FIRST(w), l);
+      }
+    }
+
+    WRAP_POS_INC(w);
+  }
+
+  l = scheme_reverse(l);
+
+  stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props);
+  stx->wraps = l;
+
+  return (Scheme_Object *)stx;
+}
+
 static Scheme_Object *syntax_src_module(int argc, Scheme_Object **argv)
 {
   int source = 0;