From bbc8b30478c0a22e1be10a189525bead45ca15fb Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Sun, 30 Jul 2023 11:40:24 +0200 Subject: [PATCH] cmp: faster function calls for functions with fixed number of arguments We now generate entrypoints for both fixed and variable number of arguments. The entrypoint with fixed number of arguments is used for direct C calls from the same file while the one with variable number of arguments for indirect calls from other files or via funcall. This approach is faster than using the wrapper functions in fixed_dispatch_table as we did previously for two reasons. First, it does not require a call to ecl_process_env() and second, it can use a direct jump to the fixed entrypoint once the number of arguments have been checked instead of an indirect call through a function pointer. --- src/c/cfun.d | 1 + src/c/read.d | 12 +-- src/c/symbols_list.h | 1 + src/cmp/cmpbackend-cxx/cmppass2-loc.lsp | 13 ++- src/cmp/cmpbackend-cxx/cmppass2-top.lsp | 110 ++++++++++++++++-------- src/cmp/cmpenv-optimize.lsp | 4 + src/cmp/cmprefs.lsp | 1 + 7 files changed, 98 insertions(+), 44 deletions(-) diff --git a/src/c/cfun.d b/src/c/cfun.d index 2013d2bb2..a519f39d5 100644 --- a/src/c/cfun.d +++ b/src/c/cfun.d @@ -29,6 +29,7 @@ ecl_make_cfun(cl_objectfn_fixed c_function, cl_object name, cl_object cblock, in : @"function requires too many arguments."); } + cf = ecl_alloc_object(t_cfunfixed); cf->cfunfixed.entry = fixed_dispatch_table[narg]; cf->cfunfixed.entry_fixed = c_function; diff --git a/src/c/read.d b/src/c/read.d index 36b41845b..519a1d846 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -2405,11 +2405,13 @@ ecl_init_module(cl_object block, void (*entry_point)(cl_object)) cl_index location = ecl_fixnum(prototype->name); cl_object position = prototype->file_position; int narg = prototype->narg; - VV[location] = narg<0? - ecl_make_cfun_va((cl_objectfn)prototype->entry, - fname, block, -narg - 1) : - ecl_make_cfun((cl_objectfn_fixed)prototype->entry, - fname, block, narg); + if (prototype->t == t_cfunfixed) { + VV[location] = ecl_make_cfun((cl_objectfn_fixed)prototype->entry, + fname, block, narg); + } else { + VV[location] = ecl_make_cfun_va((cl_objectfn)prototype->entry, + fname, block, narg); + } /* Add source file info */ if (position != ecl_make_fixnum(-1)) { ecl_set_function_source_file_info(VV[location], diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 86ebafde0..dcf51ec94 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -2353,6 +2353,7 @@ cl_symbols[] = { {EXT_ "USE-DIRECT-C-CALL" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, {EXT_ "INLINE-TYPE-CHECKS" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, {EXT_ "INLINE-SEQUENCE-FUNCTIONS" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, +{EXT_ "INLINE-NARGS-CHECK" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, {EXT_ "DEBUG-VARIABLE-BINDINGS" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, {EXT_ "DEBUG-IHS-FRAME" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, diff --git a/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp b/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp index 00a37f563..2015fc28c 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp @@ -180,18 +180,23 @@ (format nil "ecl_nthcdr(~D,~A)" (- *env* expected-env-size) env-var) env-var))) -(defun wt-make-closure (fun &aux (cfun (fun-cfun fun))) +(defun wt-make-closure (fun &aux (cfun (fun-cfun fun)) + (variadic-entrypoint (fun-variadic-entrypoint fun))) (declare (type fun fun)) (let* ((closure (fun-closure fun)) - narg) + (narg (fun-fixed-narg fun)) + (narg-fixed (min (fun-minarg fun) si:c-arguments-limit))) (cond ((eq closure 'CLOSURE) (wt "ecl_make_cclosure_va((cl_objectfn)" cfun "," (environment-accessor fun) ",Cblock," (min (fun-minarg fun) si:c-arguments-limit) ")")) ((eq closure 'LEXICAL) (baboon :format-control "wt-make-closure: lexical closure detected.")) - ((setf narg (fun-fixed-narg fun)) ; empty environment fixed number of args - (wt "ecl_make_cfun((cl_objectfn_fixed)" cfun ",ECL_NIL,Cblock," narg ")")) + (narg ; empty environment fixed number of args + (wt (if variadic-entrypoint + "ecl_make_cfun_va((cl_objectfn)" + "ecl_make_cfun((cl_objectfn_fixed)") + entrypoint ",ECL_NIL,Cblock," narg-fixed ")")) (t ; empty environment variable number of args (wt "ecl_make_cfun_va((cl_objectfn)" cfun ",ECL_NIL,Cblock," (min (fun-minarg fun) si:c-arguments-limit) ")"))))) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp index f61666228..f5b557293 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp @@ -332,7 +332,9 @@ (when (eq (fun-closure fun) 'CLOSURE) (t3function-closure-scan fun)) (write-sequence body *compiler-output1*) - (wt-nl-close-many-braces 0)))))) + (wt-nl-close-many-braces 0)) + (when (fun-variadic-entrypoint fun) + (t3function-variadic-entrypoint fun)))))) (defun t3function-body (fun) (let ((string (make-array 2048 :element-type 'character @@ -352,34 +354,53 @@ (fun-keyword-type-check-forms fun)))) string)) -(defun t3function-declaration (fun) - (declare (type fun fun)) - (wt-comment-nl (cond ((fun-global fun) "function definition for ~a") - ((eq (fun-closure fun) 'CLOSURE) "closure ~a") - (t "local function ~a")) - (or (fun-name fun) (fun-description fun) 'CLOSURE)) +;;; Variadic entrypoints +;;; +;;; For functions which only take required arguments, we can generate +;;; an entrypoint with variadic signature and narg parameter. This +;;; entrypoint checks the number of arguments and then calls the +;;; entrypoint without narg parameter. Callers using direct C calls +;;; can then skip the check for the number of parameters. If no direct +;;; C calls exist, the C compiler will usually inline the fixed +;;; entrypoint and thus optimize away the overhead that this method +;;; incurs over only generating a variadic entrypoint. +(defun fun-variadic-entrypoint (fun) + (let ((result (fun-variadic-entrypoint-cfun fun))) + (if (not (eq result :unknown)) + result + (setf (fun-variadic-entrypoint-cfun fun) + (and (policy-inline-nargs-check) + (not (fun-no-entry fun)) + (not (fun-needs-narg fun)) + ;; lexical closures will never be called via a + ;; variadic entrypoint, no need to create one + (not (eq (fun-closure fun) 'lexical)) + (concatenate 'string (fun-cfun fun) "_va")))))) + +(defun t3function-variadic-entrypoint (fun) + (t3function-header fun (fun-variadic-entrypoint-cfun fun) t) + (wt-nl-open-brace) + (wt-maybe-check-num-arguments t (fun-minarg fun) (fun-maxarg fun) (fun-name fun)) + (wt-nl "return ") + (wt-call (fun-cfun fun) (fun-required-lcls fun)) + (wt ";") + (wt-nl-close-many-braces 0)) + +(defun t3function-header (fun cfun needs-narg) (let* ((comma "") (lambda-expr (fun-lambda fun)) (lambda-list (c1form-arg 0 lambda-expr)) (requireds (loop - repeat si::c-arguments-limit - for arg in (car lambda-list) - collect (next-lcl (var-name arg)))) - (narg (fun-needs-narg fun))) - (let ((cmp-env (c1form-env lambda-expr))) - (wt-comment-nl "optimize speed ~D, debug ~D, space ~D, safety ~D " - (cmp-env-optimization 'speed cmp-env) - (cmp-env-optimization 'debug cmp-env) - (cmp-env-optimization 'space cmp-env) - (cmp-env-optimization 'safety cmp-env))) - (let ((cfun (fun-cfun fun))) - (cond ((fun-exported fun) - (wt-nl-h "ECL_DLLEXPORT cl_object " cfun "(") - (wt-nl "cl_object " cfun "(")) - (t - (wt-nl-h "static cl_object " cfun "(") - (wt-nl "static cl_object " cfun "(")))) - (when narg + repeat si::c-arguments-limit + for arg in (car lambda-list) + collect (next-lcl (var-name arg))))) + (cond ((fun-exported fun) + (wt-nl-h "ECL_DLLEXPORT cl_object " cfun "(") + (wt-nl "cl_object " cfun "(")) + (t + (wt-nl-h "static cl_object " cfun "(") + (wt-nl "static cl_object " cfun "("))) + (when needs-narg (wt-h *volatile* "cl_narg") (wt *volatile* "cl_narg narg") (setf comma ", ")) @@ -391,12 +412,28 @@ do (wt-h comma "cl_object " *volatile*) (wt comma "cl_object " *volatile* lcl) (setf comma ", ")) - (when narg + (when needs-narg (wt-h ", ...") (wt ", ...")) (wt-h ");") (wt ")"))) +(defun t3function-declaration (fun) + (declare (type fun fun)) + (wt-comment-nl (cond ((fun-global fun) "function definition for ~a") + ((eq (fun-closure fun) 'CLOSURE) "closure ~a") + (t "local function ~a")) + (or (fun-name fun) (fun-description fun) 'CLOSURE)) + (let* ((lambda-expr (fun-lambda fun)) + (cmp-env (c1form-env lambda-expr))) + (wt-comment-nl "optimize speed ~D, debug ~D, space ~D, safety ~D " + (cmp-env-optimization 'speed cmp-env) + (cmp-env-optimization 'debug cmp-env) + (cmp-env-optimization 'space cmp-env) + (cmp-env-optimization 'safety cmp-env)) + (t3function-header fun (fun-cfun fun) (fun-needs-narg fun))) + t) + (defun fun-closure-variables (fun) (sort (remove-if #'(lambda (x) @@ -449,18 +486,21 @@ (format stream "~%static const struct ecl_cfunfixed compiler_cfuns[] = {~ ~%~t/*t,m,narg,padding,name=function-location,block=name-location,entry,entry_fixed,file,file_position*/") (loop for (loc fname-loc fun) in (nreverse *global-cfuns-array*) - do (let* ((cfun (fun-cfun fun)) - (minarg (fun-minarg fun)) - (maxarg (fun-maxarg fun)) - (narg (if (and (= minarg maxarg) - (<= maxarg si:c-arguments-limit)) - maxarg - (1- (- (min minarg si:c-arguments-limit)))))) - (format stream "~%{0,0,~D,0,ecl_make_fixnum(~D),ecl_make_fixnum(~D),(cl_objectfn)~A,NULL,ECL_NIL,ecl_make_fixnum(~D)}," + do (let* ((variadic-entrypoint (fun-variadic-entrypoint-cfun fun)) + (cfun (or variadic-entrypoint (fun-cfun fun))) + (needs-narg (or variadic-entrypoint (fun-needs-narg fun))) + (narg (if needs-narg + (if variadic-entrypoint + 0 + (min (fun-minarg fun) si:c-arguments-limit)) + (fun-fixed-narg fun)))) + (format stream "~%{~A,0,~D,0,ecl_make_fixnum(~D),ecl_make_fixnum(~D),(cl_objectfn)~A,NULL,ECL_NIL,ecl_make_fixnum(~D)}," + (if needs-narg "t_cfun" "t_cfunfixed") narg (vv-location loc) (vv-location fname-loc) - cfun (fun-file-position fun)))) + cfun + (fun-file-position fun)))) (format stream "~%};"))))) (defun wt-install-function (fname fun macro-p) diff --git a/src/cmp/cmpenv-optimize.lsp b/src/cmp/cmpenv-optimize.lsp index 7ac1af9d7..82c0ebdc6 100644 --- a/src/cmp/cmpenv-optimize.lsp +++ b/src/cmp/cmpenv-optimize.lsp @@ -155,6 +155,10 @@ "Inline functions such as MAP, MEMBER, FIND, etc." (:off space 2)) +(define-policy ext:inline-nargs-check + "Inline checks for correct number of arguments for functions with fixed number of arguments." + (:off space 2)) + ;; ;; DEBUG POLICY ;; diff --git a/src/cmp/cmprefs.lsp b/src/cmp/cmprefs.lsp index 43686b377..eb05c5a4f 100644 --- a/src/cmp/cmprefs.lsp +++ b/src/cmp/cmprefs.lsp @@ -108,6 +108,7 @@ read-nodes ;;; Nodes (c1forms) in which the reference occurs. |# cfun ;;; The cfun for the function. + (variadic-entrypoint-cfun :unknown) ;;; The cfun for an entrypoint with variadic signature. (level 0) ;;; Level of lexical nesting for a function. (env 0) ;;; Size of env of closure. (global nil) ;;; Global lisp function.