diff --git a/src/CHANGELOG b/src/CHANGELOG index 342b97f0e..a2ed5d0da 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -227,6 +227,11 @@ ECL 0.9i FOO shadows the global macro definition. If compiled, MACRO-FUNCTION was unable to detect the shadowing definition. (B. Spilsbury) + - The compilation of function calls with more than 64 arguments produced wrong + code in some cases. The code for this has been reworked and unified with + code for multiple value calls and other structures such as unwind-protect + forms. + * Documentation: - The HTML manuals now use CSS for a more appealing look. diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index 46f449389..4c2f0d0a9 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -47,7 +47,12 @@ ;; (FUNCALL lisp-expression ...) ((not (and (consp fun) (eq (first fun) 'FUNCTION))) - (make-c1form* 'FUNCALL :args (c1expr fun) (c1args* arguments))) + (let ((l (length args))) + (if (< (1- l) si::c-arguments-limit) + (make-c1form* 'FUNCALL :args (c1expr fun) (c1args* arguments)) + (c1expr `(with-stack + ,@(loop for i in (rest args) collect `(stack-push ,i)) + (apply-from-stack ,l ,(first args))))))) ;; (FUNCALL #'GENERALIZED-FUNCTION-NAME ...) ((si::valid-function-name-p (setq fun (second fun))) (or (c1call-local fun arguments) @@ -64,10 +69,8 @@ (defun c2funcall (form args &optional loc narg) ;; Usually, ARGS holds a list of forms, which are arguments to the - ;; function. If, however, the arguments are on VALUES, - ;; ARGS should be set to the symbol ARGS-PUSHED, and NARG to a location - ;; containing the number of arguments. - ;; LOC is the location of the function object (created by save-funob). + ;; function. LOC is the location of the function object (created by + ;; save-funob). (case (c1form-name form) (GLOBAL (c2call-global (c1form-arg 0 form) args loc t narg)) (LOCAL (c2call-local (c1form-arg 0 form) args narg)) @@ -79,70 +82,46 @@ (*temp* *temp*)) (unless loc (setf loc (maybe-save-value form args))) - (unwind-exit (call-unknown-global-loc nil loc narg - (if (eq args 'ARGS-PUSHED) - args - (inline-args args)))) + (unwind-exit (call-unknown-global-loc nil loc narg (inline-args args))) (close-inline-blocks))))) -(defun maybe-push-args (args) - (when (or (eq args 'ARGS-PUSHED) - (< (length args) SI::C-ARGUMENTS-LIMIT)) - (return-from maybe-push-args (values nil nil nil))) - (let* ((narg (make-lcl-var :type :cl-index))) - (wt-nl "{cl_index " narg "=0;") - (let* ((*temp* *temp*) - (temp (make-temp-var)) - (*destination* temp)) - (dolist (expr args) - (c2expr* expr) - (wt-nl "cl_stack_push(" temp "); " narg "++;"))) - (values `((STACK ,narg) ,@*unwind-exit*) 'ARGS-PUSHED narg))) - ;;; ;;; c2call-global: -;;; ARGS is either the list of arguments or 'ARGS-PUSHED +;;; ARGS is the list of arguments ;;; NARG is a location containing the number of ARGS-PUSHED ;;; LOC is either NIL or the location of the function object ;;; (defun c2call-global (fname args loc return-type &optional narg) - (multiple-value-bind (*unwind-exit* args narg) - (maybe-push-args args) - (when narg - (c2call-global fname args loc return-type narg) - (wt-nl "}") - (return-from c2call-global))) - (unless (eq 'ARGS-PUSHED args) - (case fname - (AREF - (let (etype (elttype (c1form-primary-type (car args)))) - (when (or (and (eq elttype 'STRING) - (setq elttype 'CHARACTER)) - (and (consp elttype) - (or (eq (car elttype) 'ARRAY) - (eq (car elttype) 'VECTOR)) - (setq elttype (second elttype)))) - (setq etype (type-and return-type elttype)) - (unless etype - (cmpwarn "Type mismatch found in AREF. Expected output type ~s, array element type ~s." return-type elttype) - (setq etype T)) ; assume no information - (setf return-type etype)))) - (SYS:ASET ; (sys:aset value array i0 ... in) - (let (etype - (valtype (c1form-primary-type (first args))) - (elttype (c1form-primary-type (second args)))) - (when (or (and (eq elttype 'STRING) - (setq elttype 'CHARACTER)) - (and (consp elttype) - (or (eq (car elttype) 'ARRAY) - (eq (car elttype) 'VECTOR)) - (setq elttype (second elttype)))) - (setq etype (type-and return-type (type-and valtype elttype))) - (unless etype - (cmpwarn "Type mismatch found in (SETF AREF). Expected output type ~s, array element type ~s, value type ~s." return-type elttype valtype) - (setq etype T)) - (setf return-type etype) - (setf (c1form-type (first args)) etype)))))) + (case fname + (AREF + (let (etype (elttype (c1form-primary-type (car args)))) + (when (or (and (eq elttype 'STRING) + (setq elttype 'CHARACTER)) + (and (consp elttype) + (or (eq (car elttype) 'ARRAY) + (eq (car elttype) 'VECTOR)) + (setq elttype (second elttype)))) + (setq etype (type-and return-type elttype)) + (unless etype + (cmpwarn "Type mismatch found in AREF. Expected output type ~s, array element type ~s." return-type elttype) + (setq etype T)) ; assume no information + (setf return-type etype)))) + (SYS:ASET ; (sys:aset value array i0 ... in) + (let (etype + (valtype (c1form-primary-type (first args))) + (elttype (c1form-primary-type (second args)))) + (when (or (and (eq elttype 'STRING) + (setq elttype 'CHARACTER)) + (and (consp elttype) + (or (eq (car elttype) 'ARRAY) + (eq (car elttype) 'VECTOR)) + (setq elttype (second elttype)))) + (setq etype (type-and return-type (type-and valtype elttype))) + (unless etype + (cmpwarn "Type mismatch found in (SETF AREF). Expected output type ~s, array element type ~s, value type ~s." return-type elttype valtype) + (setq etype T)) + (setf return-type etype) + (setf (c1form-type (first args)) etype))))) (when (null loc) (let ((fun (find fname *global-funs* :key #'fun-name :test #'same-fname-p))) (when fun @@ -150,9 +129,7 @@ (return-from c2call-global)) (setf loc fun)))) (let ((*inline-blocks* 0)) - (call-global fname loc - narg (if (eq args 'ARGS-PUSHED) args (inline-args args)) - return-type) + (call-global fname loc narg (inline-args args) return-type) (close-inline-blocks))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -168,7 +145,7 @@ ;;; FNAME: the name of the function ;;; LOC: either a function object or NIL ;;; NARG: a location containing the number of ARGS-PUSHED -;;; ARGS: 'ARGS-PUSHED or a list of typed locs with arguments +;;; ARGS: a list of typed locs with arguments ;;; RETURN-TYPE: the type to which the output is coerced ;;; (defun call-global-loc (fname loc narg args return-type &aux found fd minarg maxarg) @@ -180,8 +157,7 @@ (call-unknown-global-loc fname nil narg args))) ;; Open-codable function call. - ((and (not (eq 'ARGS-PUSHED args)) - (or (null loc) (fun-global loc)) + ((and (or (null loc) (fun-global loc)) (setq loc (inline-function fname args return-type))) loc) @@ -216,9 +192,7 @@ (t (call-unknown-global-loc fname loc narg args)))) (defun call-loc (fname loc narg args) - (if (eq args 'ARGS-PUSHED) - `(CALL-ARGS-PUSHED ,fname ,loc ,narg) - `(CALL-NORMAL ,loc ,(coerce-locs args)))) + `(CALL-NORMAL ,loc ,(coerce-locs args))) (defun call-linking-loc (fname narg args &aux i) (let ((fun (second (assoc fname *linking-calls*)))) @@ -262,7 +236,7 @@ ;;; ;;; call-unknown-global-loc ;;; LOC is NIL or location containing function -;;; ARGS is either the list of typed locations for arguments or 'ARGS-PUSHED +;;; ARGS is the list of typed locations for arguments ;;; NARG is a location containing the number of ARGS-PUSHED ;;; (defun call-unknown-global-loc (fname loc narg args) @@ -276,9 +250,7 @@ (progn (cmpnote "Emiting FDEFINITION for ~S" fname) (setq loc (list 'FDEFINITION fname)))))) - (if (eq args 'ARGS-PUSHED) - `(CALL "cl_apply_from_stack" (,narg ,loc) ,fname) - `(CALL "funcall" (,(1+ (length args)) ,loc ,@(coerce-locs args)) ,fname))) + `(CALL "funcall" (,(1+ (length args)) ,loc ,@(coerce-locs args)) ,fname)) ;;; Functions that use MAYBE-SAVE-VALUE should rebind *temp*. (defun maybe-save-value (value &optional (other-forms nil other-forms-flag)) @@ -344,23 +316,6 @@ (push narg args)) (wt-call fun-c-name args fun-lisp-name))) -(defun wt-call-args-pushed (fname fun narg) - (let* ((lex-lvl (fun-level fun)) - (fun-c-name (fun-cfun fun)) - (fun-lisp-name (fun-name fun))) - (when (fun-closure fun) - (error "WT-CALL-ARGS-PUSHED used with lexical closure.") - (when (fun-closure fun) - (wt "cl_stack_push(env~d" *env-lvl* ")," narg "++,")) - (dotimes (n lex-lvl) - (let ((j (- lex-lvl n 1))) - (wt "cl_stack_push(lex" j ")," narg "++,")))) - (if (fun-needs-narg fun) - (wt "APPLY(" narg "," fun-c-name "," `(STACK-POINTER ,narg) ")") - (wt "((" narg "!=" maxarg ")&&FEwrong_num_arguments_anonym()," - "APPLY_fixed(" narg "," fun-c-name "," `(STACK-POINTER ,narg) "))")) - (when fun-lisp-name (wt-comment fun-lisp-name)))) - ;;; ---------------------------------------------------------------------- (put-sysprop 'funcall 'C1 #'c1funcall) @@ -369,5 +324,3 @@ (put-sysprop 'CALL 'WT-LOC #'wt-call) (put-sysprop 'CALL-NORMAL 'WT-LOC #'wt-call-normal) -(put-sysprop 'CALL-ARGS-PUSHED 'WT-LOC #'wt-call-args-pushed) -(put-sysprop 'STACK-POINTER 'WT-LOC #'wt-stack-pointer) diff --git a/src/cmp/cmpcatch.lsp b/src/cmp/cmpcatch.lsp index 0b99e3f21..e4e5a67f4 100644 --- a/src/cmp/cmpcatch.lsp +++ b/src/cmp/cmpcatch.lsp @@ -56,33 +56,36 @@ :args form (c1progn (rest args))))) (defun c2unwind-protect (form body) - (wt-nl "{ volatile bool unwinding = FALSE;") - (wt-nl "ecl_frame_ptr next_fr; cl_object next_tag;") - ;; Here we compile the form which is protected. When this form - ;; is aborted, it continues at the frs_pop() with unwinding=TRUE. - (wt-nl "if (frs_push(ECL_PROTECT_TAG)) {") - (wt-nl "unwinding = TRUE; next_fr=cl_env.nlj_fr; } else {") - (let ((*unwind-exit* (cons 'FRAME *unwind-exit*)) - (*destination* 'VALUES)) - (c2expr* form)) - (wt-nl "}") - (wt-nl "frs_pop();") - ;; Here we save the values of the form which might have been - ;; aborted, and execute some cleanup code. This code may also - ;; be aborted by some control structure, but is not protected. - (let* ((nr (make-lcl-var :rep-type :cl-index)) - (*unwind-exit* `((STACK ,nr) ,@*unwind-exit*)) - (*destination* 'TRASH)) - (wt-nl "{cl_index " nr "=cl_stack_push_values();") - (c2expr* body) - (wt-nl "cl_stack_pop_values(" nr ");}")) - ;; Finally, if the protected form was aborted, jump to the - ;; next catch point... - (wt-nl "if (unwinding) unwind(next_fr);") - (wt-nl "else {") - ;; ... or simply return the values of the protected form. - (unwind-exit 'VALUES) - (wt "}}")) + (let* ((sp (make-lcl-var :rep-type :cl-index)) + (nargs (make-lcl-var :rep-type :cl-index)) + (*unwind-exit* `((STACK ,sp) ,@*unwind-exit*))) + (wt-nl "{") + (wt-nl "volatile bool unwinding = FALSE;") + (wt-nl "cl_index " sp "=cl_stack_index()," nargs ";") + (wt-nl "ecl_frame_ptr next_fr;") + ;; Here we compile the form which is protected. When this form + ;; is aborted, it continues at the frs_pop() with unwinding=TRUE. + (wt-nl "if (frs_push(ECL_PROTECT_TAG)) {") + (wt-nl " unwinding = TRUE; next_fr=cl_env.nlj_fr;") + (wt-nl "} else {") + (let ((*unwind-exit* (cons 'FRAME *unwind-exit*)) + (*destination* 'VALUES)) + (c2expr* form)) + (wt-nl "}") + (wt-nl "frs_pop();") + ;; Here we save the values of the form which might have been + ;; aborted, and execute some cleanup code. This code may also + ;; be aborted by some control structure, but is not protected. + (wt-nl nargs "=cl_stack_push_values();") + (let ((*destination* 'TRASH)) + (c2expr* body)) + (wt-nl "cl_stack_pop_values(" nargs ");") + ;; Finally, if the protected form was aborted, jump to the + ;; next catch point... + (wt-nl "if (unwinding) unwind(next_fr);") + ;; ... or simply return the values of the protected form. + (unwind-exit 'VALUES) + (wt "}"))) (defun c1throw (args) (check-args-number 'THROW args 2 2) diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index c8bc8f122..89445a4ce 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -82,6 +82,12 @@ (defun c1call-local (fname args) (let ((fun (local-function-ref fname))) (when fun + (let ((l (length args))) + (when (>= l si::c-arguments-limit) + (return-from c1call-local + (c1expr `(with-stack + ,@(loop for i in args collect `(stack-push ,i)) + (apply-from-stack ,l #',fname)))))) (let* ((forms (c1args* args)) (lambda-form (fun-lambda fun)) (return-type (or (get-local-return-type fun) 'T)) @@ -101,12 +107,17 @@ :args fun forms))))) (defun c1call-global (fname args) - (let* ((forms (c1args* args)) - (return-type (propagate-types fname forms args))) - (make-c1form* 'CALL-GLOBAL - :sp-change (function-may-change-sp fname) - :type return-type - :args fname forms))) + (let ((l (length args))) + (if (>= l si::c-arguments-limit) + (c1expr `(with-stack + ,@(loop for i in args collect `(stack-push ,i)) + (apply-from-stack ,l #',fname))) + (let* ((forms (c1args* args)) + (return-type (propagate-types fname forms args))) + (make-c1form* 'CALL-GLOBAL + :sp-change (function-may-change-sp fname) + :type return-type + :args fname forms))))) (defun c2expr (form &aux (name (c1form-name form)) (args (c1form-args form))) (if (eq name 'CALL-GLOBAL) diff --git a/src/cmp/cmpexit.lsp b/src/cmp/cmpexit.lsp index 401d60548..785ac2fcc 100644 --- a/src/cmp/cmpexit.lsp +++ b/src/cmp/cmpexit.lsp @@ -12,20 +12,17 @@ (in-package "COMPILER") -(defun unwind-bds (bds-lcl bds-bind stack-pop) +(defun unwind-bds (bds-lcl bds-bind stack-sp) (declare (fixnum bds-bind)) - (when stack-pop - (wt-nl "cl_stack_pop_n(" (car stack-pop)) - (dolist (f (cdr stack-pop)) - (wt "+" f)) - (wt ");")) - (when bds-lcl (wt-nl "bds_unwind(" bds-lcl ");")) + (when stack-sp + (wt-nl "cl_stack_set_index(" stack-sp ");")) + (when bds-lcl + (wt-nl "bds_unwind(" bds-lcl ");")) (if (< bds-bind 4) (dotimes (n bds-bind) (declare (fixnum n)) (wt-nl "bds_unwind1();")) (wt-nl "bds_unwind_n(" bds-bind ");"))) -(defun unwind-exit (loc &optional (jump-p nil) - &aux (bds-lcl nil) (bds-bind 0) (stack-pop nil)) +(defun unwind-exit (loc &optional (jump-p nil) &aux (bds-lcl nil) (bds-bind 0) (stack-sp nil)) (declare (fixnum bds-bind)) (when (consp *destination*) (case (car *destination*) @@ -40,7 +37,7 @@ (cond ((consp ue) ; ( label# . ref-flag )| (STACK n) |(LCL n) (cond ((eq (car ue) 'STACK) - (push (second ue) stack-pop)) + (setf stack-sp (second ue))) ((eq (car ue) 'LCL) (setq bds-lcl ue bds-bind 0)) ((eq ue *exit*) @@ -48,8 +45,8 @@ (cond ((and (consp *destination*) (or (eq (car *destination*) 'JUMP-TRUE) (eq (car *destination*) 'JUMP-FALSE))) - (unwind-bds bds-lcl bds-bind stack-pop)) - ((not (or bds-lcl (plusp bds-bind) stack-pop)) + (unwind-bds bds-lcl bds-bind stack-sp)) + ((not (or bds-lcl (plusp bds-bind) stack-sp)) (set-loc loc)) ;; Save the value if LOC may possibly refer ;; to special binding. @@ -59,11 +56,11 @@ (temp (make-temp-var))) (let ((*destination* temp)) (set-loc loc)) ; temp <- loc - (unwind-bds bds-lcl bds-bind stack-pop) + (unwind-bds bds-lcl bds-bind stack-sp) (set-loc temp))) ; *destination* <- temp (t (set-loc loc) - (unwind-bds bds-lcl bds-bind stack-pop))) + (unwind-bds bds-lcl bds-bind stack-sp))) (when jump-p (wt-nl) (wt-go *exit*)) (return)) (t (setq jump-p t)))) @@ -76,16 +73,16 @@ ;; *destination* must be either RETURN or TRASH. (cond ((eq loc 'VALUES) ;; from multiple-value-prog1 or values - (unwind-bds bds-lcl bds-bind stack-pop) + (unwind-bds bds-lcl bds-bind stack-sp) (wt-nl "return VALUES(0);")) ((eq loc 'RETURN) ;; from multiple-value-prog1 or values - (unwind-bds bds-lcl bds-bind stack-pop) + (unwind-bds bds-lcl bds-bind stack-sp) (wt-nl "return value0;")) (t (let* ((*destination* 'RETURN)) (set-loc loc)) - (unwind-bds bds-lcl bds-bind stack-pop) + (unwind-bds bds-lcl bds-bind stack-sp) (wt-nl "return value0;"))) (return)) ((RETURN-FIXNUM RETURN-CHARACTER RETURN-LONG-FLOAT @@ -103,7 +100,7 @@ (if (or bds-lcl (plusp bds-bind)) (let ((lcl (make-lcl-var :type (second loc)))) (wt-nl "{cl_fixnum " lcl "= " loc ";") - (unwind-bds bds-lcl bds-bind stack-pop) + (unwind-bds bds-lcl bds-bind stack-sp) (wt-nl "return(" lcl ");}")) (progn (wt-nl "return(" loc ");"))) @@ -119,22 +116,22 @@ ;;; Never reached ) -(defun unwind-no-exit (exit &aux (bds-lcl nil) (bds-bind 0) (stack-pop nil)) +(defun unwind-no-exit (exit &aux (bds-lcl nil) (bds-bind 0) (stack-sp nil)) (declare (fixnum bds-bind)) (dolist (ue *unwind-exit* (baboon)) (cond ((consp ue) (cond ((eq ue exit) - (unwind-bds bds-lcl bds-bind stack-pop) + (unwind-bds bds-lcl bds-bind stack-sp) (return)) ((eq (first ue) 'STACK) - (push (second ue) stack-pop)))) + (setf stack-sp (second ue))))) ((numberp ue) (setq bds-lcl ue bds-bind 0)) ((eq ue 'BDS-BIND) (incf bds-bind)) ((member ue '(RETURN RETURN-OBJECT RETURN-FIXNUM RETURN-CHARACTER RETURN-LONG-FLOAT RETURN-SHORT-FLOAT)) (if (eq exit ue) - (progn (unwind-bds bds-lcl bds-bind stack-pop) + (progn (unwind-bds bds-lcl bds-bind stack-sp) (return)) (baboon)) ;;; Never reached @@ -142,7 +139,7 @@ ((eq ue 'FRAME) (wt-nl "frs_pop();")) ((eq ue 'TAIL-RECURSION-MARK) (if (eq exit 'TAIL-RECURSION-MARK) - (progn (unwind-bds bds-lcl bds-bind stack-pop) + (progn (unwind-bds bds-lcl bds-bind stack-sp) (return)) (baboon)) ;;; Never reached @@ -176,8 +173,7 @@ (t (baboon))))) (defun c2try-tail-recursive-call (fun args) - (when (and (listp args) ;; ARGS can be also 'ARGS-PUSHED - *tail-recursion-info* + (when (and *tail-recursion-info* (eq fun (first *tail-recursion-info*)) (last-call-p) (tail-recursion-possible) diff --git a/src/cmp/cmpffi.lsp b/src/cmp/cmpffi.lsp index 64491f75a..1cdceb52d 100644 --- a/src/cmp/cmpffi.lsp +++ b/src/cmp/cmpffi.lsp @@ -275,6 +275,8 @@ (cond ((eq output-type ':void) (setf output-rep-type '() output-type 'NIL)) + ((equal output-type '(VALUES &REST t)) + (setf output-rep-type '(VALUES &REST t))) ((and (consp output-type) (eql (first output-type) 'VALUES)) (when one-liner (cmpwarn "A FFI:C-INLINE form cannot be :ONE-LINER and output more than one value: ~A" @@ -325,8 +327,9 @@ (when (null output-rep-type) (if side-effects (progn + (wt-nl) (wt-c-inline-loc output-rep-type c-expression coerced-arguments t nil) - (wt ";")) + (when one-liner (wt ";"))) (cmpwarn "Ignoring form ~S" c-expression)) (return-from produce-inline-loc NIL)) @@ -336,6 +339,12 @@ (return-from produce-inline-loc `(C-INLINE ,output-rep-type ,c-expression ,coerced-arguments ,side-effects NIL))) + ;; If the output is a in the VALUES vector, just write down the form and output + ;; the location of the data. + (when (equalp output-rep-type '(VALUES &REST T)) + (wt-c-inline-loc output-rep-type c-expression coerced-arguments side-effects 'VALUES) + (return-from produce-inline-loc 'VALUES)) + ;; Otherwise we have to set up variables for holding the output. (flet ((make-output-var (type) (let ((var (make-lcl-var :rep-type type))) @@ -405,12 +414,14 @@ (#\@ (let ((object (read s))) (cond ((and (consp object) (equal (first object) 'RETURN)) - (let ((ndx (or (second object) 0)) - (l (length output-vars))) - (if (< ndx l) - (wt (nth ndx output-vars)) - (cmperr "Used @(RETURN ~D) in a C-INLINE form with ~D output values" - ndx l)))) + (if (eq output-vars 'VALUES) + (cmperr "User @(RETURN ...) in a C-INLINE form with no output values") + (let ((ndx (or (second object) 0)) + (l (length output-vars))) + (if (< ndx l) + (wt (nth ndx output-vars)) + (cmperr "Used @(RETURN ~D) in a C-INLINE form with ~D output values" + ndx l))))) (t (when (and (consp object) (eq (first object) 'QUOTE)) (setq object (second object))) diff --git a/src/cmp/cmpflet.lsp b/src/cmp/cmpflet.lsp index 15bc61351..b880a334f 100644 --- a/src/cmp/cmpflet.lsp +++ b/src/cmp/cmpflet.lsp @@ -267,18 +267,9 @@ (defun c2call-local (fun args &optional narg) (declare (type fun fun)) - (multiple-value-bind (*unwind-exit* args narg) - (maybe-push-args args) - (when narg - (c2call-local fun args narg) - (wt-nl "}") - (return-from c2call-local))) (unless (c2try-tail-recursive-call fun args) (let ((*inline-blocks* 0)) - (unwind-exit - (if (eq args 'ARGS-PUSHED) - (list 'CALL-ARGS-PUSHED fun narg) - (list 'CALL-NORMAL fun (coerce-locs (inline-args args))))) + (unwind-exit (list 'CALL-NORMAL fun (coerce-locs (inline-args args)))) (close-inline-blocks)))) ;;; ---------------------------------------------------------------------- diff --git a/src/cmp/cmploc.lsp b/src/cmp/cmploc.lsp index 27d6b302d..b42653ff0 100644 --- a/src/cmp/cmploc.lsp +++ b/src/cmp/cmploc.lsp @@ -26,7 +26,6 @@ ;;; ( TEMP temp ) local variable, type object ;;; ( CALL c-fun-name args fname ) locs are locations containing the arguments ;;; ( CALL-NORMAL fun locs) similar as CALL, but number of arguments is fixed -;;; ( CALL-ARGS-PUSHED fun narg ) ;;; ( C-INLINE output-type fun/string locs side-effects output-var ) ;;; ( COERCE-LOC representation-type location) ;;; ( CAR lcl ) @@ -65,8 +64,7 @@ (defun set-loc (loc &aux fd (is-call (and (consp loc) - (member (car loc) '(CALL CALL-NORMAL CALL-ARGS-PUSHED) - :test #'eq)))) + (member (car loc) '(CALL CALL-NORMAL) :test #'eq)))) (when (eql *destination* loc) (return-from set-loc)) (case *destination* diff --git a/src/cmp/cmpmulti.lsp b/src/cmp/cmpmulti.lsp index 551f6158d..c4a759c0c 100644 --- a/src/cmp/cmpmulti.lsp +++ b/src/cmp/cmpmulti.lsp @@ -12,6 +12,9 @@ (in-package "COMPILER") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(progn (defun c1multiple-value-call (args &aux forms) (check-args-number 'MULTIPLE-VALUE-CALL args 1) (cond @@ -23,43 +26,28 @@ (eq 'VALUES (first forms))) (c1funcall (list* (first args) (rest forms)))) ;; More complicated case. - (t (let ((funob (c1expr (first args)))) - ;; FIXME! The type should be more precise - (make-c1form* 'MULTIPLE-VALUE-CALL :type T - :args funob (c1args* (rest args))))))) - -(defun c2multiple-value-call (funob forms) - (let* ((tot (make-lcl-var :rep-type :cl-index)) - (*temp* *temp*) - (loc (maybe-save-value funob forms))) - (wt-nl "{ cl_index " tot "=0;") - (let ((*unwind-exit* `((STACK ,tot) ,@*unwind-exit*))) - (let ((*destination* 'VALUES)) - (dolist (form forms) - (c2expr* form) - (wt-nl tot "+=cl_stack_push_values();"))) - (c2funcall funob 'ARGS-PUSHED loc tot)) - (wt "}")) - ) + (t + (c1expr + (let ((function (gensym)) + (nargs (gensym))) + `(with-stack + (let* ((,function ,(first args)) + (,nargs (+ ,@(loop for i in (rest args) + collect `(stack-push-values ,i))))) + (declare (fixnum ,nargs)) + (apply-from-stack ,nargs ,function)))))))) (defun c1multiple-value-prog1 (args) (check-args-number 'MULTIPLE-VALUE-PROG1 args 1) - (make-c1form* 'MULTIPLE-VALUE-PROG1 :args (c1expr (first args)) - (c1args* (rest args)))) + (c1expr (let ((l (gensym))) + `(with-stack + (let ((,l (stack-push-values ,(first args)))) + (declare (fixnum ,l)) + ,@(rest args) + (stack-pop ,l)))))) +) -(defun c2multiple-value-prog1 (form forms) - (if (eq 'TRASH *destination*) - ;; dont bother saving values - (c2progn (cons form forms)) - (let ((nr (make-lcl-var :type :cl-index))) - (let ((*destination* 'VALUES)) (c2expr* form)) - (wt-nl "{ cl_index " nr "=cl_stack_push_values();") - (let ((*destination* 'TRASH) - (*unwind-exit* `((STACK ,nr) ,@*unwind-exit*))) - (dolist (form forms) - (c2expr* form))) - (wt-nl "cl_stack_pop_values(" nr ");}") - (unwind-exit 'VALUES)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Beppe: ;;; this is the WRONG way to handle 1 value problem. diff --git a/src/cmp/cmpstack.lsp b/src/cmp/cmpstack.lsp new file mode 100644 index 000000000..34607c068 --- /dev/null +++ b/src/cmp/cmpstack.lsp @@ -0,0 +1,79 @@ +;;;; Copyright (c) 2006, Juan Jose Garcia-Ripoll +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +;;;; CMPSTACK Manipulation of the lisp stack from C code +;;;; +;;;; Following special forms are provided: +;;;; +;;;; (WITH-STACK {form}*) +;;;; Executes given forms, restoring the lisp stack on output. +;;;; (STACK-PUSH form) +;;;; (STACK-PUSH-VALUES form) +;;;; (STACK-POP nvalues) +;;;; + +(in-package "COMPILER") + +(defun c1with-stack (forms) + (let ((body (c1expr `(progn ,@forms)))) + (make-c1form* 'WITH-STACK :type (c1form-type body) + :args body))) + +(defun c2with-stack (body) + (let* ((new-destination (tmp-destination *destination*)) + (*temp* *temp*) + (sp (make-lcl-var :rep-type :cl-index))) + (wt-nl "{cl_index " sp "=cl_stack_index();") + (let* ((*destination* new-destination) + (*unwind-exit* `((STACK ,sp) ,@*unwind-exit*))) + (c2expr* body)) + (wt-nl "cl_stack_set_index(" sp ");}") + (unwind-exit new-destination))) + +(defun c1stack-push (args) + (c1expr `(progn + (c-inline ,args (t) :void "cl_stack_push(#0)" + :one-liner t :side-effects t) + 1))) + +(defun c1stack-push-values (args) + (make-c1form* 'STACK-PUSH-VALUES :type 'fixnum + :args (c1expr (first args)) + (c1expr `(c-inline () () fixnum "cl_stack_push_values()" + :one-liner t :side-effects t)))) + +(defun c2stack-push-values (form push-statement) + (let ((*destination* 'VALUES)) + (c2expr* form)) + (c2expr push-statement)) + +(defun c1stack-pop (args) + (let ((action (c1expr `(c-inline ,args (fixnum) :void + "cl_stack_pop_values(#0)" + :one-liner t + :side-effects t)))) + (make-c1form* 'STACK-POP :type t :args action))) + +(defun c2stack-pop (action) + (let ((*destination* 'TRASH)) + (c2expr* action)) + (unwind-exit 'VALUES)) + +(defun c1apply-from-stack (args) + (c1expr `(c-inline ,args (fixnum t) (values &rest t) "cl_apply_from_stack(#0,#1);" + :one-liner nil :side-effects t))) + +(put-sysprop 'with-stack 'C1 #'c1with-stack) +(put-sysprop 'with-stack 'c2 #'c2with-stack) +(put-sysprop 'stack-push 'C1 #'c1stack-push) +(put-sysprop 'stack-push-values 'C1 #'c1stack-push-values) +(put-sysprop 'stack-push-values 'C2 #'c2stack-push-values) +(put-sysprop 'stack-pop 'C1 #'c1stack-pop) +(put-sysprop 'stack-pop 'C2 #'c2stack-pop) +(put-sysprop 'apply-from-stack 'c1 #'c1apply-from-stack) \ No newline at end of file diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index 77c3a1131..6bd949954 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -20,6 +20,7 @@ "src:cmp;cmplet.lsp" "src:cmp;cmploc.lsp" "src:cmp;cmpmap.lsp" + "src:cmp;cmpstack.lsp" "src:cmp;cmpmulti.lsp" "src:cmp;cmpspecial.lsp" "src:cmp;cmptag.lsp"