Merge branch 'fix-774' into 'develop'

Fix issue #774

Closes #774

See merge request embeddable-common-lisp/ecl!343

src/cmp/cmpbackend-cxx/cmppass2-call.lsp

@@ -27,7 +27,9 @@
 ;;;
 (defun c2fcall (c1form fun args fun-val call-type)
   (if (> (length args) si:c-arguments-limit)
-      (c2call-stack c1form fun args nil)
+      (ecase call-type
+        (:local (c2call-local-stack c1form fun-val args))
+        ((:global :unknown) (c2call-global-stack c1form fun args nil)))
       (with-inline-blocks ()
         (ecase call-type
           (:local (c2call-local c1form fun-val args))
@@ -36,16 +38,16 @@
 
 (defun c2mcall (c1form form args fun-val call-type)
   (declare (ignore fun-val call-type))
-  (c2call-stack c1form form args t))
+  (c2call-global-stack c1form form args t))
 
 ;;;
-;;; c2call-stack:
+;;; c2call-global-stack:
 ;;;
 ;;;   This is the most generic way of calling functions. First we push them on
 ;;;   the stack, and then we apply from the stack frame. Other variants call
 ;;;   inline-args and put results directly in the function call.
 ;;;
-(defun c2call-stack (c1form form args values-p)
+(defun c2call-global-stack (c1form form args values-p)
   (declare (ignore c1form))
   (with-stack-frame (frame)
     (let ((loc (emit-inline-form form args)))
@@ -55,7 +57,27 @@
           (if values-p
               (wt-nl "ecl_stack_frame_push_values(" frame ");")
               (wt-nl "ecl_stack_frame_push(" frame ",value0);"))))
-      (unwind-exit (call-stack-loc nil loc)))))
+      (unwind-exit (call-global-stack-loc nil loc)))))
+
+;;;
+;;; c2call-local-stack:
+;;;
+;;;   First push the arguments on the stack and then call the function
+;;;   directly. This is used for calls to local functions that take
+;;;   more arguments than C-ARGUMENTS-LIMIT.
+;;;
+(defun c2call-local-stack (c1form fun args)
+  (declare (type fun fun))
+  (with-stack-frame (frame)
+    (let ((evaluated-args (mapcar #'(lambda (arg)
+                                      (let ((*destination* (make-temp-var t)))
+                                        (c2expr* arg)
+                                        (wt-nl "ecl_stack_frame_push(" frame "," *destination* ");")
+                                        *destination*))
+                                  args)))
+      (unwind-exit (call-local-stack-loc fun
+                                         evaluated-args
+                                         (c1form-primary-type c1form))))))
 
 ;;;
 ;;; c2call-global:
@@ -139,13 +161,23 @@
 ;;;
 
 ;;;
-;;; call-stack-loc
+;;; call-global-stack-loc
 ;;;
 ;;;   FNAME: the name of the function or NIL
 ;;;   LOC: the location containing function
 ;;;
-(defun call-stack-loc (fname loc)
-  `(CALL-STACK ,loc ,fname))
+(defun call-global-stack-loc (fname loc)
+  `(CALL-GLOBAL-STACK ,loc ,fname))
+
+;;;
+;;; call-local-stack-loc
+;;;
+;;;   FUN: a function object
+;;;   ARGS: a list of INLINED-ARGs
+;;;   TYPE: the type to which the output is coerced
+;;;
+(defun call-local-stack-loc (fun args type)
+  `(CALL-LOCAL-STACK ,fun ,(coerce-args args) ,type))
 
 ;;;
 ;;; call-loc

src/cmp/cmpbackend-cxx/cmppass2-loc.lsp

@@ -110,11 +110,19 @@
     (when fname
       (wt-comment fname))))
 
-(defun wt-call-stack (loc fname)
+(defun wt-call-global-stack (loc fname)
   (wt "ecl_apply_from_stack_frame(_ecl_inner_frame," loc ")")
   (when fname
     (wt-comment fname)))
 
+(defun wt-call-local-stack (fun args type)
+  (wt "(cl_env_copy->stack_frame=_ecl_inner_frame,")
+  (wt-call-normal fun
+                  (subseq args 0 (min (length args) si::c-arguments-limit))
+                  type
+                  (length args))
+  (wt ")"))
+
 (defun wt-call-normal (fun args type &optional (narg (length args)))
   (declare (ignore type))
   (unless (fun-cfun fun)

src/cmp/cmplocs.lsp

@@ -109,7 +109,7 @@
            (global-var-p loc)
            (policy-global-var-checking))))
   (case (first loc)
-    ((CALL CALL-NORMAL CALL-INDIRECT CALL-STACK) T)
+    ((CALL CALL-NORMAL CALL-INDIRECT CALL-GLOBAL-STACK CALL-LOCAL-STACK) T)
     (CL:THE (loc-with-side-effects-p (third loc)))
     (CL:FDEFINITION (policy-global-function-checking))
     ;; Uses VALUES or has side effects.
@@ -142,7 +142,8 @@
 ;;;     ( FRAME ndx )                   variable in local frame stack
 ;;;     ( CALL-NORMAL fun locs 1st-type ) similar as CALL, but number of arguments is fixed
 ;;;     ( CALL-INDIRECT fun narg args)  similar as CALL, but unknown function
-;;;     ( CALL-STACK fun)  similar as CALL-INDIRECT, but args are on the stack
+;;;     ( CALL-LOCAL-STACK fun)  similar as CALL-NORMAL, but args are on the stack
+;;;     ( CALL-GLOBAL-STACK fun)  similar as CALL-INDIRECT, but args are on the stack
 ;;;     ( FFI:C-INLINE output-type fun/string locs side-effects output-var )
 ;;;     ( COERCE-LOC host-type location)
 ;;;     ( FDEFINITION vv-index )
@@ -184,7 +185,7 @@
 
 (defun uses-values (loc)
   (and (consp loc)
-       (or (member (car loc) '(CALL-NORMAL CALL-INDIRECT CALL-STACK) :test #'eq)
+       (or (member (car loc) '(CALL-NORMAL CALL-INDIRECT CALL-GLOBAL-STACK CALL-LOCAL-STACK) :test #'eq)
            (and (eq (car loc) 'ffi:C-INLINE)
                 (eq (sixth loc) 'cl:VALUES)))))
 

src/cmp/cmptables.lsp

@@ -164,7 +164,8 @@
 (defconstant +wt-loc-dispatch-alist+
   '((call-normal . wt-call-normal)
     (call-indirect . wt-call-indirect)
-    (call-stack . wt-call-stack)
+    (call-global-stack . wt-call-global-stack)
+    (call-local-stack . wt-call-local-stack)
     (ffi:c-inline . wt-c-inline-loc)
     (coerce-loc . wt-coerce-loc)
 

src/tests/normal-tests/compiler.lsp

@@ -2537,3 +2537,19 @@
      '(macrolet ((def-it (name)
                   `(defun test () ,(find-package name))))
        (def-it "COMMON-LISP")))))
+
+;;; Date 2025-04-05
+;;; URL: https://gitlab.com/embeddable-common-lisp/ecl/-/issues/774
+;;; Description
+;;;
+;;;     Calls to local functions with more arguments than
+;;;     si::c-arguments-limit did not work.
+;;;
+(test cmp.0108.local-number-of-arguments
+  (let* ((data1 (append (loop repeat (1+ si::c-arguments-limit) collect 0)))
+         (data2 (funcall (compile nil `(lambda ()
+                                         (flet ((f (&rest data)
+                                                  (make-array (length data) :initial-contents data)))
+                                           (f ,@data1)))))))
+    (is (equalp (make-array (length data1) :initial-contents data1)
+                data2))))