constrain smaller trap-check code to avoid allocation

Having the trap check allocate is questionable, since it can be
triggered during a loop that otherwise performs no allocation. Also,
on platforms where at most 1 argument is passed in a register, then
sending two arguments to the event handler could potentially need
stack space that isn't there. So, constrain the smaller trap-check
code to cases where no stack space is needed and where no allocation
happens unless the wrong number of arguments are provided.

original commit: 260a7ef5bc0bf851d9848587b0a78bdb4aab59f8

c/globals.h

@@ -118,6 +118,7 @@ EXTERN struct S_G_struct {
     ptr null_continuation_id;
     ptr collect_request_pending_id;
     ptr event_and_resume_id;
+    ptr event_and_resume_star_id;
 
   /* gc.c */
     ptr guardians[static_generation+1];

c/schsig.c

@@ -425,6 +425,7 @@ static void handle_call_error(tc, type, x) ptr tc; iptr type; ptr x; {
 void S_handle_docall_error() {
     ptr tc = get_thread_context();
 
+    AC0(tc) = (ptr)0;
     handle_call_error(tc, ERROR_CALL_NONPROCEDURE, CP(tc));
 }
 
@@ -465,14 +466,28 @@ void S_handle_event_detour() {
     iptr argcnt, i;
 
     argcnt = (iptr)AC0(tc);
-    for (i = argcnt; i > 0; i--) {
-      resume_args = Scons(S_get_scheme_arg(tc, i), resume_args);
-    }
 
-    CP(tc) = S_symbol_value(S_G.event_and_resume_id);
+    if (argcnt < asm_arg_reg_cnt) {
-    S_put_scheme_arg(tc, 1, resume_proc);
+      /* Avoid allocation by passing arguments directly; this case
-    S_put_scheme_arg(tc, 2, resume_args);
+         should always happen if the right number of arguments are
-    AC0(tc) = (ptr)2;
+         passed to a function, because the compiler will only use
+         `detour-event` when the expected number is small enough. */
+      for (i = argcnt; i > 0; i--)
+        S_put_scheme_arg(tc, i+1, S_get_scheme_arg(tc, i));
+      S_put_scheme_arg(tc, 1, resume_proc);
+      CP(tc) = S_symbol_value(S_G.event_and_resume_id);
+      AC0(tc) = (ptr)(argcnt+1);
+    } else {
+      /* At least one argument can go in a register, otherwise the
+         compiler would not use `detour-event` for any functions. */
+      for (i = argcnt; i > 0; i--)
+        resume_args = Scons(S_get_scheme_arg(tc, i), resume_args);
+      resume_args = Scons(resume_proc, resume_args);
+ 
+      CP(tc) = S_symbol_value(S_G.event_and_resume_star_id);
+      S_put_scheme_arg(tc, 1, resume_args);
+      AC0(tc) = (ptr)2;
+    }
 }
 
 static void keyboard_interrupt(ptr tc) {
@@ -712,6 +727,9 @@ void S_schsig_init() {
 
         S_protect(&S_G.event_and_resume_id);
         S_G.event_and_resume_id = S_intern((const unsigned char *)"$event-and-resume");
+
+        S_protect(&S_G.event_and_resume_star_id);
+        S_G.event_and_resume_star_id = S_intern((const unsigned char *)"$event-and-resume*");
     }
 
 

makefiles/Mf-install.in

@@ -62,7 +62,7 @@ InstallLZ4Target=
 #                 no changes should be needed below this point                #
 ###############################################################################
 
-Version=csv9.5.3.18
+Version=csv9.5.3.19
 Include=boot/$m
 PetiteBoot=boot/$m/petite.boot
 SchemeBoot=boot/$m/scheme.boot

s/cmacros.ss

@@ -328,7 +328,7 @@
                  [(_ foo e1 e2) e1] ...
                  [(_ bar e1 e2) e2]))))])))
 
-(define-constant scheme-version #x09050312)
+(define-constant scheme-version #x09050313)
 
 (define-syntax define-machine-types
   (lambda (x)

s/cpnanopass.ss

@@ -9807,6 +9807,8 @@
                    `(seq
                       (set! ,(ref-reg %trap) ,(build-unfix e))
                       ,t)))])
+        (define-inline 3 $get-timer
+          [() (build-fix (ref-reg %trap))])
         (define-inline 3 directory-separator?
           [(e) (if-feature windows
                  (bind #t (e)
@@ -10882,11 +10884,12 @@
                                              (not (direct-call-label-referenced dcl))
                                              (nanopass-case (L11 CaseLambdaClause) cl
                                                [(clause (,x* ...) (,local1* ...) ,mcp ,interface ,tlbody)
-                                                (let loop ([tlbody tlbody])
+                                                (and (fx< -1 interface (constant asm-arg-reg-cnt))
-                                                  (nanopass-case (L11 Tail) tlbody
+                                                     (let loop ([tlbody tlbody])
-                                                    [(seq (trap-check ,ioc) ,tlbody) #t]
+                                                       (nanopass-case (L11 Tail) tlbody
-                                                    [(seq (overflow-check) ,tlbody) (loop tlbody)]
+                                                         [(seq (trap-check ,ioc) ,tlbody) #t]
-                                                    [else #f]))])))
+                                                         [(seq (overflow-check) ,tlbody) (loop tlbody)]
+                                                         [else #f])))])))
                                           cl* (info-lambda-dcl* info)))])
            (let-values ([(local* tlbody) (flatten-clauses info cl* (info-lambda-dcl* info) detour-trap-check?)])
              (safe-assert (nodups local*))

s/primdata.ss

@@ -1875,6 +1875,7 @@
   ($error-handling-mode? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable])
   ($event [flags single-valued])
   ($event-and-resume [flags])
+  ($event-and-resume* [flags])
   ($exactnum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable])
   ($exactnum-imag-part [flags single-valued])
   ($exactnum-real-part [flags single-valued])
@@ -2081,6 +2082,7 @@
   ($generation [flags single-valued])
   ($gensym [sig [() (string) (string string) -> (gensym)]] [flags alloc]) ; needs immutable strings
   ($gensym->pretty-name [flags single-valued])
+  ($get-timer [flags single-valued])
   ($guard [flags])
   ($hand-coded [flags single-valued])
   ($hashtable-report [flags true])

s/prims.ss

@@ -598,6 +598,10 @@
          ($oops '$set-timer "~s is not a positive fixnum" ticks))
       ($set-timer ticks)))
 
+(define $get-timer
+  (lambda ()
+    ($get-timer)))
+
 (define $fx+?
    (lambda (x y)
       ($fx+? x y)))
@@ -1558,9 +1562,37 @@
 
 (define $event (lambda () ($event)))
 
-(define $event-and-resume (lambda (proc args)
+(let ()
-                            ($event)
+  (define (inc)
-                            (apply proc args)))
+    ;; make up for decrement that will happen immediately on retry:
+    (let ([t ($get-timer)])
+      (when (fx< t (most-positive-fixnum))
+        ($set-timer (fx+ t 1)))))
+
+  (set! $event-and-resume
+        (case-lambda
+         [(proc)
+          ($event)
+          (inc)
+          (proc)]
+         [(proc arg)
+          ($event)
+          (inc)
+          (proc arg)]
+         [(proc arg1 arg2)
+          ($event)
+          (inc)
+          (proc arg1 arg2)]
+         [(proc . args)
+          ($event)
+          (inc)
+          (apply proc args)]))
+
+  (set! $event-and-resume*
+        (lambda (proc+args)
+          ($event)
+          (inc)
+          (apply (car proc+args) (cdr proc+args)))))
 
 (define $tc (lambda () ($tc)))
 (define $thread-list (lambda () ($thread-list)))