mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-03-15 17:30:37 -07:00
New special forms for handling the lisp stack. These constructions are used for function calls with too many arguments, multiple-value-prog1, unwind-protect, etc
This commit is contained in:
jgarcia
parent
18c22bd8b1
commit
20ab0394db
11 changed files with 240 additions and 204 deletions
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -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*
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
79
src/cmp/cmpstack.lsp
Normal file
79
src/cmp/cmpstack.lsp
Normal file
|
|
@ -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)
|
||||
|
|
@ -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"
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue