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.