diff --git a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp index aa9537782..5348293e0 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp +++ b/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 diff --git a/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp b/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp index 37d91cf20..69569b6d8 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp +++ b/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) diff --git a/src/cmp/cmplocs.lsp b/src/cmp/cmplocs.lsp index 8bba6ceff..b577fd8e1 100644 --- a/src/cmp/cmplocs.lsp +++ b/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))))) diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp index e0c7d7b65..931884ed4 100644 --- a/src/cmp/cmptables.lsp +++ b/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) diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index 93ae0085e..32d7d3b5c 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/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))))