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

@@ -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;

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],

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)},

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) ")")))))

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)

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
 ;;

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.