fix another(!) JIT bug related to the runstack pointer and GC --- this time when a jump to a native function has the wrong arity; more certificate-management shortcuts to avoid explosion of work for long expansion chains; changed scheme/base module-begin to not create long expansion chais in the first place

svn: r8880

collects/scheme/private/modbeg.ss

@@ -23,13 +23,22 @@
            "bad syntax" 
            stx)
           (void))
-      (datum->syntax
+      (let-values ([(l) (syntax->list stx)])
-       stx
+        (if l
-       (list (quote-syntax #%module-begin)
+            (void)
-             (cons (quote-syntax printing-module-begin)
+            (raise-syntax-error
-                   (cdr (syntax-e stx))))
+             #f
-       stx
+             "bad syntax (illegal use of `.')" 
-       stx)))
+             stx))
+        (datum->syntax
+         stx
+         (cons (quote-syntax #%module-begin)
+               (map (lambda (e)
+                      (list (quote-syntax printing-module-begin)
+                            e))
+                    (cdr l)))
+         stx
+         stx))))
 
   (define-syntaxes (printing-module-begin)
     (lambda (stx)
@@ -65,15 +74,18 @@
                               #f)
                           #f))
                     ;; splice `begin'
-                    (datum->syntax
+                    (let-values ([(l) (syntax->list e)])
-                     stx
+                      (datum->syntax
-                     (cons (quote-syntax printing-module-begin)
+                       stx
-                           (append (let-values ([(l) (syntax->list e)])
+                       (cons (car l)
-                                     (map (lambda (elem)
+                             (append
-                                            (syntax-track-origin elem e (car l)))
+                              (map (lambda (elem)
-                                          (cdr l)))
+                                     (list
-                                   (cdr r)))
+                                      (quote-syntax printing-module-begin)
-                     stx)
+                                      (syntax-track-origin elem e (car l))))
+                                   (cdr l))
+                              (cdr r)))
+                       stx))
                     ;; no need to splice
                     (let-values ([(wrap?)
                                   (let-values ([(e) (syntax-e e)])

src/mzscheme/src/jit.c

@@ -1638,6 +1638,10 @@ static int generate_tail_call(mz_jit_state *jitter, int num_rands, int direct_na
     mz_get_local_p(JIT_R1, JIT_LOCAL2);    
   }
   jit_movr_p(JIT_R2, JIT_RUNSTACK);
+  if (need_set_rs) {
+    /* In case arity check fails, need to update runstack now: */
+    JIT_UPDATE_THREAD_RSPTR();
+  }
   /* Now jump: */
   jit_jmpr(JIT_V1);
   CHECK_LIMIT();
@@ -1885,6 +1889,10 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc
       jit_ldxi_p(JIT_V1, JIT_V1, &((Scheme_Native_Closure_Data *)0x0)->u.tail_code);
     } else {
       jit_ldxi_p(JIT_V1, JIT_V1, &((Scheme_Native_Closure_Data *)0x0)->arity_code);
+      if (need_set_rs) {
+        /* In case arity check fails, need to update runstack now: */
+        JIT_UPDATE_THREAD_RSPTR();
+      }
     }
     jit_jmpr(JIT_V1); /* callee restores (copied) V registers, etc. */
     jit_patch_movi(refr, (_jit.x.pc));

src/mzscheme/src/stxobj.c

@@ -2300,7 +2300,7 @@ static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Obj
   Scheme_Cert *orig_certs, *cl, *now_certs, *next_certs;
   Scheme_Stx *stx = (Scheme_Stx *)o, *res;
   Scheme_Object *pr;
-  int copy_on_write;
+  int copy_on_write, shortcut;
 
   if (!stx->certs) {
     if (!certs)
@@ -2337,6 +2337,25 @@ static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Obj
     orig_certs = INACTIVE_CERTS(stx);
   now_certs = orig_certs;
 
+  shortcut = 0;
+  if (now_certs && certs && !use_key && CERT_NO_KEY(certs)) {
+    if (now_certs->depth < certs->depth) {
+      /* Maybe we can add now_certs onto certs, instead of the other
+         way around. */
+      for (next_certs = certs; next_certs; next_certs = next_certs->next) {
+        if (cert_in_chain(next_certs->mark, use_key, now_certs)) {
+          break;
+        }
+      }
+      if (!next_certs) {
+        /* Yes, we can take that shortcut. */
+        certs = append_certs(now_certs, certs);
+        now_certs = NULL;
+        shortcut = 1;
+      }
+    }
+  }
+
   for (; certs; certs = next_certs) {
     next_certs = certs->next;
     if (!cert_in_chain(certs->mark, use_key, now_certs)) {
@@ -2357,7 +2376,7 @@ static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Obj
 	stx = res;
 	copy_on_write = 0;
       }
-      if (!now_certs && !use_key && CERT_NO_KEY(certs)) {
+      if (!now_certs && !use_key && (shortcut || CERT_NO_KEY(certs))) {
         cl = certs;
         next_certs = NULL;
       } else {