mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-08 18:23:37 -08:00
Avoid using cl_va_list, cl_va_arg when the number of arguments is small (<32)
and we know that no value will be stored on the stack.
This commit is contained in:
jjgarcia
parent
7dd31cde83
commit
b133c36590
8 changed files with 129 additions and 263 deletions
|
|
@ -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
|
||||
|
|
|
|||
16
src/c/dpp.c
16
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();
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue