From fb95debd4856a0077c9d3d2c7ce5ab85c86a92ed Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= <daniel@turtleware.eu>
Date: Thu, 15 Jun 2023 13:35:49 +0200
Subject: [PATCH] cmp: cmppass1-call: don't use with-stack for unoptimized long
 calls

WITH-STACK depends on FFI:C-INLINE so it can't be present in the first pass for
standard operators. As a bonus disassembled result is less obfuscated.
---
 src/cmp/cmpbackend-cxx/cmppass2-call.lsp | 17 ++++++++++++++++
 src/cmp/cmppass1-call.lsp                | 25 ++++++++----------------
 src/cmp/cmptables.lsp                    |  5 ++++-
 3 files changed, 29 insertions(+), 18 deletions(-)

diff --git a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp
index 9d828aa40..28bc441ea 100644
--- a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp
+++ b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp
@@ -40,6 +40,23 @@
     (unwind-exit (call-unknown-global-loc nil loc (inline-args args) function-p))
     (close-inline-blocks)))
 
+(defun c2fcall (c1form form args)
+  (declare (ignore c1form))
+  (let ((fun-var (make-temp-var)))
+    (wt-nl-open-brace)
+    (wt-nl "struct ecl_stack_frame _ecl_inner_frame_aux;")
+    (wt-nl *volatile* "cl_object _ecl_inner_frame = ecl_stack_frame_open(cl_env_copy,(cl_object)&_ecl_inner_frame_aux,0);")
+    (let ((*unwind-exit* `((STACK "_ecl_inner_frame") ,@*unwind-exit*)))
+      (let ((*destination* fun-var))
+        (c2expr* form))
+      (dolist (inlined-arg (inline-args args))
+        (wt-nl (produce-inline-loc (list inlined-arg) '(t) :void
+                                   "ecl_stack_frame_push(_ecl_inner_frame,#0);" t t)))
+      (wt-nl "cl_env_copy->values[0]=ecl_apply_from_stack_frame(_ecl_inner_frame," fun-var ");"))
+    (wt-nl "ecl_stack_frame_close(_ecl_inner_frame);")
+    (wt-nl-close-brace)
+    (unwind-exit 'values)))
+
 ;;;
 ;;; c2call-global:
 ;;;   ARGS is the list of arguments
diff --git a/src/cmp/cmppass1-call.lsp b/src/cmp/cmppass1-call.lsp
index 319af0b60..1b181bf68 100644
--- a/src/cmp/cmppass1-call.lsp
+++ b/src/cmp/cmppass1-call.lsp
@@ -9,20 +9,12 @@
 
 (in-package #:compiler)
 
-(defun unoptimized-long-call (fun arguments)
-  (let ((frame (gensym))
-        (f-arg (gensym)))
-    `(with-stack ,frame
-       (let ((,f-arg ,fun))
-         ,@(loop for i in arguments collect `(stack-push ,frame ,i))
-         (si::apply-from-stack-frame ,frame ,f-arg)))))
-
 (defun unoptimized-funcall (fun arguments)
-  (let ((l (length arguments)))
-    (if (<= l si:c-arguments-limit)
-        (make-c1form* 'CL:FUNCALL :sp-change t :side-effects t
-                                  :args (c1expr fun) (c1args* arguments))
-        (unoptimized-long-call fun arguments))))
+  (if (<= (length arguments) si:c-arguments-limit)
+      (make-c1form* 'CL:FUNCALL
+                    :sp-change t :side-effects t :args (c1expr fun) (c1args* arguments))
+      (make-c1form* 'FCALL
+                    :sp-change t :side-effects t :args (c1expr fun) (c1args* arguments))))
 
 (defun optimized-lambda-call (lambda-form arguments apply-p)
   (multiple-value-bind (bindings body)
@@ -125,13 +117,12 @@
               (default-apply fun arguments))))))
 
 (defun c1call (fname args macros-allowed &aux fd success can-inline)
-  (cond ((> (length args) si::c-arguments-limit)
+  ;; XXX: try to remove the first condition
+  (cond ((> (length args) si:c-arguments-limit)
          (if (and macros-allowed
                   (setf fd (cmp-macro-function fname)))
              (cmp-expand-macro fd (list* fname args))
-             ;; When it is a function and takes too many arguments, we need a
-             ;; special C form to call it with the stack (see with-stack).
-             (unoptimized-long-call `(function ,fname) args)))
+             (unoptimized-funcall `(function ,fname) args)))
         ((setq fd (local-function-ref fname))
          (c1call-local fname fd args))
         ((and macros-allowed            ; macrolet
diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp
index 155b05fc0..8b093c37b 100644
--- a/src/cmp/cmptables.lsp
+++ b/src/cmp/cmptables.lsp
@@ -33,6 +33,7 @@
     (CL:TAGBODY         tag-var tag-body :pure)
     (CL:RETURN-FROM     blk-var nonlocal value :side-effects)
     (CL:FUNCALL         fun-value (arg-value*) :side-effects)
+    (FCALL              fun-value (arg-value*) :side-effects)
     (CALL-LOCAL         obj-fun (arg-value*) :side-effects)
     (CALL-GLOBAL        fun-name (arg-value*))
     (CL:CATCH           catch-value body :side-effects)
@@ -216,6 +217,7 @@
   '((cl:block . c2block)
     (cl:return-from . c2return-from)
     (cl:funcall . c2funcall)
+    (fcall . c2fcall)
     (call-global . c2call-global)
     (cl:catch . c2catch)
     (cl:unwind-protect . c2unwind-protect)
@@ -272,6 +274,8 @@
 (defconstant +p1-dispatch-alist+
   '((cl:block . p1block)
     (cl:return-from . p1return-from)
+    (cl:funcall . p1trivial)
+    (fcall . p1trivial)
     (call-global . p1call-global)
     (call-local . p1call-local)
     (cl:catch . p1catch)
@@ -300,7 +304,6 @@
     (ffi:c-inline . p1trivial)
     (ffi:c-progn . p1trivial)
     (cl:function . p1trivial)
-    (cl:funcall . p1trivial)
     (cl:load-time-value . p1trivial)
     (make-form . p1trivial)
     (init-form . p1trivial)