From 7027a71f01514ccd38dd257b71ea80e8e7ca5e76 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 27 Jan 2019 12:04:14 -0700
Subject: [PATCH] fix string allocation for callable argument or foreign-call
 return

The `dofretu...*` intrinsics used %ac1 without declaring it as a used
registers, which effectively broke register allocation for handling
string/bytevector foreign-call results or callable arguments.

original commit: 993fb9036acad5445319f458fd971b1a1d8e9f84
---
 LOG             |  3 +++
 mats/foreign.ms | 23 +++++++++++++++++++++++
 mats/foreign2.c |  7 +++++++
 s/cpnanopass.ss |  7 +++----
 4 files changed, 36 insertions(+), 4 deletions(-)

diff --git a/LOG b/LOG
index 644f7bedc1..5a5c11371c 100644
--- a/LOG
+++ b/LOG
@@ -1042,3 +1042,6 @@
 - clarified required use of scheme-start to start an application
   packaged as a boot file and added a short "myecho" example.
     use.stex
+- fix allocation of string/bytevector for a foreign-callable argument
+  or foreign-call return
+    cpnanopass.ss, foreign.ms, foreign2.c
diff --git a/mats/foreign.ms b/mats/foreign.ms
index 3b34840cfd..7dc06569ab 100644
--- a/mats/foreign.ms
+++ b/mats/foreign.ms
@@ -2539,6 +2539,29 @@
      v)
    14995143)
 
+  ;; regression test related to saving registers that hold allocated
+  ;; callable argument
+  (let* ([call-with-many-args (foreign-procedure "call_with_many_args" (void*) boolean)]
+         [result #f]
+         [cb (foreign-callable
+              (lambda (i s1 s2 s3 s4 i2 s6 s7 i3)
+                (set! result
+                      (and (eqv? i 0)
+                           (equal? (string->utf8 "this") s1)
+                           (equal? (string->utf8 "is") s2)
+                           (equal? (string->utf8 "working") s3)
+                           (equal? (string->utf8 "just") s4)
+                           (eqv? i2 1)
+                           (equal? (string->utf8 "fine") s6)
+                           (equal? (string->utf8 "or does it?") s7)
+                           (eqv? i3 2))))
+              (int u8* u8* u8* u8* int u8* u8* int)
+              void)])
+    (lock-object cb)
+    (call-with-many-args (foreign-callable-entry-point cb))
+    (unlock-object cb)
+    result)
+
 )
 
 (machine-case
diff --git a/mats/foreign2.c b/mats/foreign2.c
index d69b4898ab..3e12cf1fff 100644
--- a/mats/foreign2.c
+++ b/mats/foreign2.c
@@ -443,3 +443,10 @@ EXPORT void call_many_times(void (*f)(iptr))
     j = k+2; k = l+2; l = m+2; m = m+2;
   }
 }
+
+typedef void (*many_arg_callback_t)(int i, const char* s1, const char* s2, const char* s3,
+                                    const char* s4, int i2, const char* s6, const char* s7, int i3);
+EXPORT void call_with_many_args(many_arg_callback_t callback)
+{
+    callback(0, "this", "is", "working", "just", 1, "fine", "or does it?", 2);
+}
diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss
index 310054441b..4d0a3869f4 100644
--- a/s/cpnanopass.ss
+++ b/s/cpnanopass.ss
@@ -898,9 +898,9 @@
       (constant-case ptr-bits
         [(32) (declare-intrinsic dofretuns64 dofretuns64 (%ts %td %xp) (%ac0 %ac1) (%ac0))]
         [(64) (declare-intrinsic dofretuns64 dofretuns64 (%ts %td %xp) (%ac0) (%ac0))])
-      (declare-intrinsic dofretu8* dofretu8* (%ac0 %ts %td %cp) (%ac0) (%xp))
-      (declare-intrinsic dofretu16* dofretu16* (%ac0 %ts %td %cp) (%ac0) (%xp))
-      (declare-intrinsic dofretu32* dofretu32* (%ac0 %ts %td %cp) (%ac0) (%xp))
+      (declare-intrinsic dofretu8* dofretu8* (%ac0 %ts %td %cp %ac1) (%ac0) (%xp))
+      (declare-intrinsic dofretu16* dofretu16* (%ac0 %ts %td %cp %ac1) (%ac0) (%xp))
+      (declare-intrinsic dofretu32* dofretu32* (%ac0 %ts %td %cp %ac1) (%ac0) (%xp))
       (declare-intrinsic get-room get-room () (%xp) (%xp))
       (declare-intrinsic scan-remembered-set scan-remembered-set () () ())
       (declare-intrinsic dooverflow dooverflow () () ())
@@ -11863,7 +11863,6 @@
                                          (set! ,%xp (literal ,(make-info-literal #f 'object #vu8() 0)))
                                          (asm-return ,return-live* ...))
                                       ,(%seq
-                                         ; TODO: avoid use of ac1 by insisting that get-room preserve ts & td
                                          (set! ,(ref-reg %ac1) ,%td)
                                          (set! ,%td ,(%inline + ,%td
                                                        (immediate