diff --git a/src/CHANGELOG b/src/CHANGELOG index 5e9fb5f13..fb4c2cb63 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -1466,6 +1466,14 @@ ECLS 0.9b - AND, OR and WHEN are now just macros, without any special treatment in the bytecodes compiler. + - To support a large number of arguments, when a function receives + more than 64 values they get stored in the stack of the lisp + interpreter, and general purpose routines are used to handle + them (cl_va_list, cl_va_arg, etc). Now, for functions which can + only receive up to 32 values (i.e. functions without &rest, + &key, and thess than 32 arguments including optionals), ECL + avoids using this overhead by using directly va_list and va_arg. + * Visible changes: - New special form C-INLINE, allows inserting C/C++ code in any diff --git a/src/c/dpp.c b/src/c/dpp.c index eaa1cc811..8b95c6ec1 100644 --- a/src/c/dpp.c +++ b/src/c/dpp.c @@ -608,6 +608,7 @@ put_fhead(void) put_declaration(void) { int i; + int simple_varargs; for (i = 0; i < nopt; i++) { put_lineno(); @@ -641,14 +642,19 @@ put_declaration(void) put_lineno(); fprintf(out, "\tif (narg!=%d) FEwrong_num_arguments(%s);\n", nreq, function_symbol); } else { + simple_varargs = !rest_flag && !key_flag && ((nreq + nopt) < 32); if (key_flag) { put_lineno(); fprintf(out, "\tcl_object KEY_VARS[%d];\n", 2*nkey); } put_lineno(); - fprintf(out, "\tcl_va_list %s;\n\tcl_va_start(%s, %s, narg, %d);\n", - rest_var, rest_var, ((nreq > 0) ? required[nreq-1] : "narg"), - nreq); + if (simple_varargs) + fprintf(out,"\tva_list %s;\n\tva_start(%s, %s);\n", + rest_var, rest_var, ((nreq > 0) ? required[nreq-1] : "narg")); + else + fprintf(out,"\tcl_va_list %s;\n\tcl_va_start(%s, %s, narg, %d);\n", + rest_var, rest_var, ((nreq > 0) ? required[nreq-1] : "narg"), + nreq); put_lineno(); fprintf(out, "\tif (narg < %d", nreq); if (nopt > 0 && !rest_flag && !key_flag) { @@ -659,7 +665,9 @@ put_declaration(void) put_lineno(); fprintf(out, "\tif (narg > %d) {\n", nreq+i, optional[i].o_var); put_lineno(); - fprintf(out, "\t\t%s = cl_va_arg(%s);\n", + fprintf(out, simple_varargs? + "\t\t%s = va_arg(%s,cl_object);\n": + "\t\t%s = cl_va_arg(%s);\n", optional[i].o_var, rest_var); if (optional[i].o_svar) { put_lineno(); diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index a234aa01c..5af5b4c71 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -100,7 +100,6 @@ (case (first funob) (GLOBAL (c2call-global form args loc t narg)) (LOCAL (c2call-local form args narg)) - (LAMBDA (c2call-lambda form args (fourth funob) narg)) (ORDINARY ;;; An ordinary expression. In this case, if ;;; arguments are already on VALUES, then ;;; LOC cannot be NIL. Callers of C2FUNCALL must be @@ -123,63 +122,6 @@ (otherwise (baboon)) )) -(defun c2call-lambda (lambda-expr args cfun &optional narg) - ;; ARGS is either the list of arguments or 'ARGS-PUSHED - ;; NARG is a location containing the number of ARGS-PUSHED - (let ((lambda-list (third lambda-expr)) - (args-pushed (eq 'ARGS-PUSHED args))) - (if (or (second lambda-list) ;;; Has optional? - (third lambda-list) ;;; Has rest? - (fourth lambda-list) ;;; Has key? - args-pushed ;;; Args already pushed? - ) - (let* ((requireds (first lambda-list)) - (nreq (length requireds)) - (nopt (if args-pushed narg (- (length args) nreq))) - (*unwind-exit* *unwind-exit*)) - (wt-nl "{ ") - (unless args-pushed - (setq narg (make-lcl-var :type :cl-index)) - (wt-nl "cl_index " narg "=0;")) - (when requireds - (wt-nl "cl_object ") - (do ((l requireds (cdr l))) - ((endp l)) - (setf (var-loc (first l)) (next-lcl)) - (unless (eq l requireds) - (wt ", ")) - (wt (first l))) - (wt ";")) - (wt-nl "int narg;") - (wt-nl "cl_va_list args;") - (cond (args-pushed - (wt-nl "args[0].sp=cl_stack_index()-" narg ";") - (wt-nl "args[0].narg=" narg ";") - (dolist (l requireds) - (wt-nl l "=cl_va_arg(args);"))) - (t - (dolist (l requireds) - (let ((*destination* l)) - (c2expr* (pop args)))) - (push (list STACK narg) *unwind-exit*) - (wt-nl "args[0].sp=cl_stack_index();") - (wt-nl "args[0].narg=" nopt ";") - (do* ((*inline-blocks* 0) - (vals (coerce-locs (inline-args args)) (cdr vals)) - (i 0 (1+ i))) - ((null vals) (close-inline-blocks)) - (declare (fixnum i)) - (wt-nl "cl_stack_push(" (first vals) ");") - (wt-nl narg "++;")) - (wt-nl "args[0].narg=" narg ";"))) - (wt "narg=" narg ";") - (c2lambda-expr lambda-list (third (cddr lambda-expr)) cfun - nil nil 'CALL-LAMBDA) - (unless args-pushed - (wt-nl "cl_stack_pop_n(" narg ");")) - (wt-nl "}")) - (c2let (first lambda-list) args (third (cddr lambda-expr)))))) - (defun maybe-push-args (args) (when (or (eq args 'ARGS-PUSHED) (< (length args) SI::C-ARGUMENTS-LIMIT)) @@ -414,7 +356,6 @@ (put-sysprop 'funcall 'C1 #'c1funcall) (put-sysprop 'funcall 'c2 #'c2funcall) -(put-sysprop 'call-lambda 'c2 #'c2call-lambda) (put-sysprop 'call-global 'c2 #'c2call-global) (put-sysprop 'CALL 'WT-LOC #'wt-call) diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index 6cad7dec1..59ed62ab4 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -170,12 +170,6 @@ |# (list 'CALL-GLOBAL info fname forms))))) -(defun c1call-lambda (lambda-expr args &aux (info (make-info :sp-change t))) - (setq args (c1args args info)) - (setq lambda-expr (c1lambda-expr lambda-expr)) - (add-info info (second lambda-expr)) - (list 'CALL-LAMBDA info lambda-expr args (next-cfun))) - (defun c2expr (form) (if (eq (car form) 'CALL-GLOBAL) ;;; ---------------------------------------------------------------------- diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index db12dc03c..0a224a599 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -129,24 +129,6 @@ doc body))) - -(defun c2lambda-expr (lambda-list body cfun fname - &optional closure-p call-lambda) - (let ((*tail-recursion-info* ;;; Tail recursion possible if - (and fname ;;; named function - ;;; no required appears in closure, - (dolist (var (car lambda-list) t) - (declare (type var var)) - (when (var-ref-ccb var) (return nil))) - (null (second lambda-list)) ;;; no optionals, - (null (third lambda-list)) ;;; no rest parameter, and - (null (fourth lambda-list)) ;;; no keywords. - (cons fname (car lambda-list))))) - (if (fourth lambda-list) - (c2lambda-expr-with-key lambda-list body closure-p call-lambda cfun) - (c2lambda-expr-without-key lambda-list body closure-p call-lambda))) - ) - #| Steps: 1. defun creates declarations for requireds + va_alist 2. c2lambda-expr adds declarations for: @@ -160,147 +142,8 @@ optionals, rest, keywords |# -(defun c2lambda-expr-without-key (lambda-list - body - closure-p - kind - &aux - (requireds (first lambda-list)) - (optionals (second lambda-list)) - (rest (third lambda-list)) rest-loc - (nreq (length requireds)) - (nopt (/ (length optionals) 3)) - (labels nil) - (*unwind-exit* *unwind-exit*) - (*env* *env*) - (block-p nil)) - (declare (fixnum nreq nopt)) - - ;; kind is either: - ;; 1. CALL-LAMBDA, for a lambda expression - ;; 2. LOCAL-ENTRY, for the local entry of a proclaimed function - ;; 3. NIL, otherwise - - (if (eq 'LOCAL-ENTRY kind) - - ;; for local entry functions arguments are processed by t3defun - (dolist (reqs requireds) - (bind (next-lcl) reqs)) - - ;; For each variable, set its var-loc. - ;; For optional parameters, and lexical variables which can be unboxed, - ;; this will be a new LCL. - ;; The bind step later will assign to such variable. - (let* ((req0 (if (eq 'CALL-LAMBDA kind) (- *lcl* nreq) *lcl*)) - (lcl (+ req0 nreq))) - (declare (fixnum lcl)) - - ;; check arguments - (when (or *safe-compile* *compiler-check-args*) - (cond ((or rest optionals) - (when requireds - (wt-nl "if(narg<" nreq ") FEwrong_num_arguments_anonym();")) - (unless rest - (wt-nl "if(narg>" (+ nreq nopt) - ") FEwrong_num_arguments_anonym();"))) - (t (wt-nl "check_arg(" nreq ");")))) - - ;; declare variables - (labels ((wt-decl (var) - (wt-nl) - (unless block-p - (wt "{") (setq block-p t)) - (wt *volatile* (register var) (rep-type-name (var-rep-type var)) " ") - (wt-lcl (incf lcl)) (wt ";") - `(LCL ,lcl)) - (do-decl (var) - (when (local var) ; no LCL needed for SPECIAL or LEX - (setf (var-loc var) (wt-decl var))))) - (do ((reqs requireds (cdr reqs)) - (reqi (1+ req0) (1+ reqi)) (var)) - ((endp reqs)) - (declare (fixnum reqi) (type cons reqs) (type var var)) - (setq var (first reqs)) - (when (unboxed var) - (setf (var-loc var) (wt-decl var)))) ; create unboxed variable - (when (and rest (< (var-ref rest) 1)) ; dont create rest if not used - (setq rest nil)) - (when (or optionals rest) ; rest necessary for CALL-LAMBDA - (unless block-p - (wt-nl "{") (setq block-p t)) - ;; count optionals - (wt "int i=" (if (eq 'CALL-LAMBDA kind) 0 nreq) ";")) - (do ((opt optionals (cdddr opt))) - ((endp opt)) - (do-decl (first opt)) - (when (third opt) (do-decl (third opt)))) - (when rest (setq rest-loc (wt-decl rest)))) - - (unless (eq 'CALL-LAMBDA kind) - (when (or optionals rest) - (unless block-p - (wt-nl "{") (setq block-p t)) - (wt-nl "cl_va_list args; cl_va_start(args," - (cond ((plusp nreq) (format nil "V~d" (+ req0 nreq))) - (closure-p "env0") - (t "narg")) - (format nil ",narg,~d);" nreq)))) - - ;; Bind required parameters. - (do ((reqs requireds (cdr reqs)) - (reqi (1+ req0) (1+ reqi))) - ((endp reqs)) - (declare (fixnum reqi) (type cons reqs)) - (bind `(LCL ,reqi) (first reqs))) - - (setq *lcl* lcl)) - ) - ;; Bind optional parameters as long as there remain arguments. - (when optionals - ;; When binding optional values, we use two calls to BIND. This means - ;; 'BDS-BIND is pushed twice on *unwind-exit*, which results in two calls - ;; to bds_unwind1, which is wrong. A possible fix is to save *unwind-exit* - (let ((*unwind-exit* *unwind-exit*) - (va-arg-loc 'VA-ARG)) - (do ((opt optionals (cdddr opt))) - ((endp opt)) - (push (next-label) labels) - (wt-nl "if (i==narg) ") (wt-go (car labels)) - (bind va-arg-loc (first opt)) - (when (third opt) (bind t (third opt))) - (wt-nl "i++;") - )) - (let ((label (next-label))) - (wt-nl) (wt-go label) - (setq labels (nreverse labels)) - ;;; Bind unspecified optional parameters. - (do ((opt optionals (cdddr opt))) - ((endp opt)) - (wt-label (car labels)) - (pop labels) - (bind-init (first opt) (second opt)) - (when (third opt) (bind nil (third opt)))) - (wt-label label)) - ) - (when rest - (if optionals - (wt-nl "narg -= i;") - (wt-nl "narg -=" nreq ";")) - (wt-nl rest-loc) - (wt "=cl_grab_rest_args(args);") - (bind rest-loc rest)) - - (when *tail-recursion-info* - (push 'TAIL-RECURSION-MARK *unwind-exit*) (wt-nl1 "TTL:")) - - ;;; Now the parameters are ready! - (c2expr body) - - (when block-p (wt-nl "}")) - ) - -(defun c2lambda-expr-with-key - (lambda-list body closure-p call-lambda cfun +(defun c2lambda-expr + (lambda-list body cfun fname &optional closure-p local-entry-p &aux (requireds (first lambda-list)) (optionals (second lambda-list)) (rest (third lambda-list)) rest-loc @@ -310,23 +153,52 @@ (nopt (/ (length optionals) 3)) (nkey (/ (length keywords) 4)) (labels nil) + (varargs (or optionals rest keywords allow-other-keys)) + simple-varargs + (*tail-recursion-info* nil) (*unwind-exit* *unwind-exit*) (*env* *env*) (block-p nil) (last-arg)) (declare (fixnum nreq nkey)) + (when (and fname ;; named function + ;; no required appears in closure, + (dolist (var (car lambda-list) t) + (declare (type var var)) + (when (var-ref-ccb var) (return nil))) + (null (second lambda-list)) ;; no optionals, + (null (third lambda-list)) ;; no rest parameter, and + (null (fourth lambda-list))) ;; no keywords. + (setf *tail-recursion-info* (cons fname (car lambda-list)))) + + ;; For local entry functions arguments are processed by t3defun. + ;; They must have a fixed number of arguments, no optionals, rest, etc. + (when (and local-entry-p varargs) + (baboon)) + + ;; check arguments + (unless (or local-entry-p (not (or *safe-compile* *compiler-check-args*))) + (setq block-p t) + (cond (varargs + (when requireds + (wt-nl "if(narg<" nreq ") FEwrong_num_arguments_anonym();")) + (unless (or rest keywords allow-other-keys) + (wt-nl "if(narg>" (+ nreq nopt) + ") FEwrong_num_arguments_anonym();"))) + (t + (wt-nl "check_arg(" nreq ");"))) + (wt-nl "{")) + ;; For each variable, set its var-loc. ;; For optional and keyword parameters, and lexical variables which ;; can be unboxed, this will be a new LCL. ;; The bind step later will assign to such variable. - (let* ((req0 (if call-lambda (- *lcl* nreq) *lcl*)) + (let* ((req0 *lcl*) (lcl (+ req0 nreq))) (declare (fixnum lcl)) (labels ((wt-decl (var) (wt-nl) - (unless block-p - (wt "{") (setq block-p t)) (wt *volatile* (register var) (rep-type-name (var-rep-type var)) " ") (wt-lcl (incf lcl)) (wt ";") `(LCL ,lcl)) @@ -338,15 +210,15 @@ ((endp reqs)) (declare (fixnum reqi) (type cons reqs) (type var var)) (setq var (first reqs)) - (if (unboxed var) - (setf (var-loc var) (wt-decl var)))) ; create unboxed variable + (cond (local-entry-p + (bind `(LCL ,reqi) var)) + ((unboxed var) ; create unboxed variable + (setf (var-loc var) (wt-decl var))))) (when (and rest (< (var-ref rest) 1)) ; dont create rest if not used (setq rest nil)) - (when (or optionals rest) ; rest necessary for CALL-LAMBDA - (unless block-p - (wt-nl "{") (setq block-p t)) + (when (or optionals rest) ;; count optionals - (wt "int i=" (if call-lambda 0 nreq) ";")) + (wt "int i=" nreq ";")) (do ((opt optionals (cdddr opt))) ((endp opt)) (do-decl (first opt)) @@ -357,23 +229,22 @@ (do-decl (second key)) (when (fourth key) (do-decl (fourth key))))) - (unless call-lambda - (unless block-p - (wt-nl "{") (setq block-p t)) - (wt-nl "cl_va_list args; cl_va_start(args, " - (cond ((plusp nreq) (format nil "V~d" (+ req0 nreq))) - (closure-p "env0") - (t "narg")) - (format nil ", narg, ~d);" nreq))) - - ;; check arguments - (when (and (or *safe-compile* *compiler-check-args*) requireds) - (wt-nl "if(narg<" nreq ") FEwrong_num_arguments_anonym();")) + (when varargs + (let ((first-arg (cond ((plusp nreq) (format nil "V~d" (+ req0 nreq))) + (closure-p "env0") + (t "narg")))) + (wt-nl + (format nil + (if (setq simple-varargs (and (not (or rest keywords allow-other-keys)) + (< (+ nreq nopt) 30))) + "va_list args; va_start(args,~a);" + "cl_va_list args; cl_va_start(args,~a,narg,~d);") + first-arg nreq)))) ;; Bind required parameters. (do ((reqs requireds (cdr reqs)) (reqi (1+ req0) (1+ reqi))) ; to allow concurrent compilations - ((endp reqs)) + ((or local-entry-p (endp reqs))) (declare (fixnum reqi) (type cons reqs)) (bind `(LCL ,reqi) (first reqs))) @@ -385,7 +256,7 @@ ;; 'BDS-BIND is pushed twice on *unwind-exit*, which results in two calls ;; to bds_unwind1, which is wrong. A possible fix is to save *unwind-exit* (let ((*unwind-exit* *unwind-exit*) - (va-arg-loc 'VA-ARG)) + (va-arg-loc (if simple-varargs 'VA-ARG 'CL-VA-ARG))) (do ((opt optionals (cdddr opt))) ((endp opt)) (push (next-label) labels) @@ -407,18 +278,21 @@ (wt-label label)) ) - (if optionals - (wt-nl "narg -= i;") - (wt-nl "narg -=" nreq ";")) - - (cond (keywords - (wt-nl "{ cl_object keyvars[" (* 2 nkey) "];") - (wt-nl "cl_parse_key(args," nkey ",L" cfun "keys,keyvars")) - (t - (wt-nl "cl_parse_key(args,0,NULL,NULL"))) - (if rest (wt ",&" rest-loc) (wt ",NULL")) - (wt (if allow-other-keys ",TRUE);" ",FALSE);")) - (when rest (bind rest-loc rest)) + (when (or rest keywords allow-other-keys) + (if optionals + (wt-nl "narg -= i;") + (wt-nl "narg -=" nreq ";")) + (cond ((not (or keywords allow-other-keys)) + (wt-nl rest-loc "=cl_grab_rest_args(args);")) + (t + (cond (keywords + (wt-nl "{ cl_object keyvars[" (* 2 nkey) "];") + (wt-nl "cl_parse_key(args," nkey ",L" cfun "keys,keyvars")) + (t + (wt-nl "cl_parse_key(args,0,NULL,NULL"))) + (if rest (wt ",&" rest-loc) (wt ",NULL")) + (wt (if allow-other-keys ",TRUE);" ",FALSE);")))) + (when rest (bind rest-loc rest))) ;;; Bind keywords. (do ((kwd keywords (cddddr kwd)) @@ -454,6 +328,10 @@ (setf (second KEYVARS[i]) (+ nkey i)) (bind KEYVARS[i] flag)))) + (when *tail-recursion-info* + (push 'TAIL-RECURSION-MARK *unwind-exit*) + (wt-nl1 "TTL:")) + ;;; Now the parameters are ready, after all! (c2expr body) diff --git a/src/cmp/cmploc.lsp b/src/cmp/cmploc.lsp index 98b7269dc..2937ff485 100644 --- a/src/cmp/cmploc.lsp +++ b/src/cmp/cmploc.lsp @@ -32,6 +32,8 @@ ;;; ( 'CHARACTER-VALUE' character-code ) ;;; ( 'LONG-FLOAT-VALUE' long-float-value vv ) ;;; ( 'SHORT-FLOAT-VALUE' short-float-value vv ) +;;; 'VA-ARG' +;;; 'CL-VA-ARG' ;;; Valid *DESTINATION* locations are: ;;; @@ -97,6 +99,8 @@ ((eq loc 'VALUES) (wt "VALUES(0)")) ((eq loc 'VA-ARG) + (wt "va_arg(args,cl_object)")) + ((eq loc 'CL-VA-ARG) (wt "cl_va_arg(args)")) ((var-p loc) (wt-var loc)) diff --git a/src/doc/help.lsp b/src/doc/help.lsp index 22655a562..794ad1f7d 100644 --- a/src/doc/help.lsp +++ b/src/doc/help.lsp @@ -889,6 +889,28 @@ COMMON is the type of all Common Lisp data objects.") (docfun commonp function (x) " Returns T if X is a Common Lisp object; NIL otherwise.") +(docfun compile function (name &optional definition) " +If DEFINITION is NIL, NAME must be the name of a not-yet-compiled function. +In this case, COMPILE compiles the function, installs the compiled function as +the global function definition of NAME, and returns NAME. If DEFINITION is +non-NIL, it must be a lambda expression and NAME must be a symbol. COMPILE +compiles the lambda expression, installs the compiled function as the function +definition of NAME, and returns NAME. There is only one exception for this: +If NAME is NIL, then the compiled function is not installed but is simply +returned as the value of COMPILE. In any case, COMPILE creates temporary +files, whose filenames begin with \"gazonk\", which are automatically deleted +after compilation.") + +(docfun compile-file function (input-pathname &key output-file (load nil) + (o-file t) (c-file nil) (h-file nil) (data-file nil)) " +Compiles the file specified by INPUT-PATHNAME and generates a fasl file +specified by OUTPUT-FILE. If the filetype is not specified in INPUT-PATHNAME, +then \".lsp\" is used as the default file type for the source file. LOAD +specifies whether to load the generated fasl file after compilation. The +:O-FILE, :C-FILE, :H-FILE, and :DATA-FILE keyword parameters allow you to +control the intermediate files generated by the ECL compiler.If the file was +compiled successfully, returns the pathname of the compiled file") + (doctype compiled-function " A compiled function is an object that is created by compiling a function. A compiled function is notated in either of the following formats: @@ -1128,6 +1150,16 @@ FILESPEC may be a symbol, a string, a pathname, or a file stream.") ECL specific. Returns T if the ARRAY is displaced to another array; NIL otherwise.") +(docfun disassemble function (&optional (thing nil) &key (h-file nil) (data-file nil)) " +Compiles the form specified by THING and prints the intermediate C language +code for that form. But does not install the result of compilation. If THING +is NIL, then the previously DISASSEMBLEd form is re-DISASSEMBLEd. If THING is +a symbol that names a function not yet compiled, the function definition is +disassembled. If THING is a lambda expression, it is disassembled as a +function definition. Otherwise, THING itself is disassembled as a top-level +form. H-FILE and DATA-FILE specify intermediate files to build a fasl file +from the C language code. NIL means \"do not create the file\".") + #+profile (docfun si::display-profile function () " ECL specific. diff --git a/src/h/config.h.in b/src/h/config.h.in index 3f1f4a1c7..11975ccf5 100644 --- a/src/h/config.h.in +++ b/src/h/config.h.in @@ -74,6 +74,7 @@ typedef unsigned @CL_FIXNUM_TYPE@ cl_hashkey; #define LAMBDA_PARAMETERS_LIMIT 64 /* Numb. of args. which can be passed using the C stack */ +/* See cmplam.lsp if you change this value */ #define C_ARGUMENTS_LIMIT 64 /* A setjmp that does not save signals */