From 5d45d6dca29c58e5c5483aace3cb2eea5bdd1a14 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 9 Feb 2020 09:32:11 -0700
Subject: [PATCH] adjust event-detour path again to apply more often

Instead of constaining the use of event-detour so much, make it merely
unlikely that the detour will have to allocate when used in a loop
that otherwise doesn't allocate. We'll only have to allocate if the
available stack space turns out to be too small --- and if we do
allocate, it's not the end of the world.

original commit: f1dbed82df415c18c8304bedcee2ecf4912badc7
---
 c/schsig.c      | 19 ++++++++++---------
 s/cmacros.ss    |  4 ++++
 s/cpnanopass.ss |  2 +-
 s/prims.ss      | 10 ++++++++++
 4 files changed, 25 insertions(+), 10 deletions(-)

diff --git a/c/schsig.c b/c/schsig.c
index ac9303ed73..f99db7e93f 100644
--- a/c/schsig.c
+++ b/c/schsig.c
@@ -463,30 +463,31 @@ void S_handle_event_detour() {
     ptr tc = get_thread_context();
     ptr resume_proc = CP(tc);
     ptr resume_args = Snil;
-    iptr argcnt, i;
+    iptr argcnt, stack_avail, i;
 
     argcnt = (iptr)AC0(tc);
+    stack_avail = (((uptr)ESP(tc) - (uptr)SFP(tc)) >> log2_ptr_bytes) - 1;
 
-    if (argcnt < asm_arg_reg_cnt) {
-      /* Avoid allocation by passing arguments directly; this case
-         should always happen if the right number of arguments are
-         passed to a function, because the compiler will only use
-         `detour-event` when the expected number is small enough. */
+    if (argcnt < (stack_avail + asm_arg_reg_cnt)) {
+      /* Avoid allocation by passing arguments directly. The compiler
+         will only use `detour-event` when the expected number is
+         small enough to avoid allocation (unless the function expected
+         to allocate a list of arguments, anyway). */
       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. */
+      /* We're assuming that either at least one argument can go in a
+         register or stack slop will save us. */
       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;
+      AC0(tc) = (ptr)1;
     }
 }
 
diff --git a/s/cmacros.ss b/s/cmacros.ss
index e91af671db..5dbb0b2a58 100644
--- a/s/cmacros.ss
+++ b/s/cmacros.ss
@@ -1988,6 +1988,10 @@
 ;;; stack underflow/continuation invocation
 (define-constant underflow-limit (* (constant ptr-bytes) 16))
 
+;; Number of arguments (including procedure) that can be handled
+;; by `$event-and-resume` without allocating:
+(define-constant event-resume-max-preferred-arg-cnt 5)
+
 ;;; check assumptions
 (let ([x (fxsrl (constant type-char)
            (fx- (constant char-data-offset)
diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss
index 26f50e1943..0737b9bc4d 100644
--- a/s/cpnanopass.ss
+++ b/s/cpnanopass.ss
@@ -10884,7 +10884,7 @@
                                              (not (direct-call-label-referenced dcl))
                                              (nanopass-case (L11 CaseLambdaClause) cl
                                                [(clause (,x* ...) (,local1* ...) ,mcp ,interface ,tlbody)
-                                                (and (fx< -1 interface (constant asm-arg-reg-cnt))
+                                                (and (fx< interface (constant event-resume-max-preferred-arg-cnt))
                                                      (let loop ([tlbody tlbody])
                                                        (nanopass-case (L11 Tail) tlbody
                                                          [(seq (trap-check ,ioc) ,tlbody) #t]
diff --git a/s/prims.ss b/s/prims.ss
index b2494519aa..1dd0b45784 100644
--- a/s/prims.ss
+++ b/s/prims.ss
@@ -1583,6 +1583,16 @@
           ($event)
           (inc)
           (proc arg1 arg2)]
+         [(proc arg1 arg2 arg3)
+          ($event)
+          (inc)
+          (proc arg1 arg2 arg3)]
+         [(proc arg1 arg2 arg3 arg4)
+          ($event)
+          (inc)
+          (proc arg1 arg2 arg3 arg4)]
+         ;; Cases above should cover `event-resume-max-preferred-arg-cnt`,
+         ;; including `proc` in th count
          [(proc . args)
           ($event)
           (inc)