From c2e2171dc06d2f74c0c81ea64e596d2cf541d8ca Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Tue, 27 Dec 2011 12:36:52 +0100 Subject: [PATCH] Avoid recursive invocation of C1EXPR by allowing the C1 processors to act like macros, returning new forms to be processed. Remove also the CATCH for compiler errors, since we now rely on conditions for signal handling. --- src/cmp/cmpcall.lsp | 14 +++---- src/cmp/cmpclos.lsp | 4 +- src/cmp/cmpct.lsp | 8 ++-- src/cmp/cmpeval.lsp | 77 ++++++++++++++++++++------------------ src/cmp/cmpffi.lsp | 2 +- src/cmp/cmpfun.lsp | 4 +- src/cmp/cmpglobals.lsp | 3 -- src/cmp/cmpif.lsp | 4 +- src/cmp/cmpmain.lsp | 4 +- src/cmp/cmpmulti.lsp | 42 ++++++++++----------- src/cmp/cmpstack.lsp | 24 ++++++------ src/cmp/cmpstructures.lsp | 8 ++-- src/cmp/cmptop.lsp | 55 +++++++++++++-------------- src/cmp/cmptype-assert.lsp | 4 +- src/cmp/cmpvar.lsp | 4 +- 15 files changed, 128 insertions(+), 129 deletions(-) diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index 6fe158e1d..65a7a8cde 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -17,9 +17,9 @@ (defun unoptimized-long-call (fun arguments) (let ((frame (gensym))) - (c1expr `(with-stack ,frame - ,@(loop for i in arguments collect `(stack-push ,frame ,i)) - (si::apply-from-stack-frame ,frame ,fun))))) + `(with-stack ,frame + ,@(loop for i in arguments collect `(stack-push ,frame ,i)) + (si::apply-from-stack-frame ,frame ,fun)))) (defun unoptimized-funcall (fun arguments) (let ((l (length arguments))) @@ -36,12 +36,12 @@ (cond ;; (FUNCALL (LAMBDA ...) ...) ((and (consp fun) (eq (first fun) 'LAMBDA)) - (c1expr (optimize-funcall/apply-lambda (cdr fun) arguments nil))) + (optimize-funcall/apply-lambda (cdr fun) arguments nil)) ;; (FUNCALL (EXT::LAMBDA-BLOCK ...) ...) ((and (consp fun) (eq (first fun) 'EXT::LAMBDA-BLOCK)) (setf fun (macroexpand-1 fun)) - (c1expr (optimize-funcall/apply-lambda (cdr fun) arguments nil))) + (optimize-funcall/apply-lambda (cdr fun) arguments nil)) ;; (FUNCALL atomic-expression ...) ((atom fun) (unoptimized-funcall fun arguments)) @@ -60,11 +60,11 @@ (c1call fun arguments nil)) ;; (FUNCALL #'(LAMBDA ...) ...) ((and (consp fun) (eq (first fun) 'LAMBDA)) - (c1expr (optimize-funcall/apply-lambda (rest fun) arguments nil))) + (optimize-funcall/apply-lambda (rest fun) arguments nil)) ;; (FUNCALL #'(EXT::LAMBDA-BLOCK ...) ...) ((and (consp fun) (eq (first fun) 'EXT::LAMBDA-BLOCK)) (setf fun (macroexpand-1 fun)) - (c1expr (optimize-funcall/apply-lambda (rest fun) arguments nil))) + (optimize-funcall/apply-lambda (rest fun) arguments nil)) (t (cmperr "Malformed function name: ~A" fun))))) diff --git a/src/cmp/cmpclos.lsp b/src/cmp/cmpclos.lsp index cbee70f70..dd3285765 100644 --- a/src/cmp/cmpclos.lsp +++ b/src/cmp/cmpclos.lsp @@ -100,7 +100,7 @@ (let* ((slotd (clos:accessor-method-slot-definition reader)) (index (clos::safe-slot-definition-location slotd))) (when (si::fixnump index) - (c1expr `(clos::safe-instance-ref ,object ,index))))))))) + `(clos::safe-instance-ref ,object ,index)))))))) (defun try-optimize-slot-writer (orig-writers args) (let* ((c-args (mapcar #'c1expr args)) @@ -112,7 +112,7 @@ (let* ((slotd (clos:accessor-method-slot-definition writer)) (index (clos::safe-slot-definition-location slotd))) (when (si::fixnump index) - (c1expr `(si::instance-set ,(second args) ,index ,(first args)))))))))) + `(si::instance-set ,(second args) ,index ,(first args))))))))) (progn . #.(loop for var in '(clos::+standard-generic-function-slots+ diff --git a/src/cmp/cmpct.lsp b/src/cmp/cmpct.lsp index d5c65d5af..2c7922c1c 100644 --- a/src/cmp/cmpct.lsp +++ b/src/cmp/cmpct.lsp @@ -64,10 +64,10 @@ (single-float (values "_mm_castsi128_ps" :float-sse-pack)) (double-float (values "_mm_castsi128_pd" :double-sse-pack)) (otherwise (values "" :int-sse-pack))) - (c1expr `(c-inline () () ,rtype - ,(format nil "~A(_mm_setr_epi8(~{~A~^,~}))" - wrapper (coerce bytes 'list)) - :one-liner t :side-effects nil))))) + `(c-inline () () ,rtype + ,(format nil "~A(_mm_setr_epi8(~{~A~^,~}))" + wrapper (coerce bytes 'list)) + :one-liner t :side-effects nil)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index 7e50e8665..ebd30a77c 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -14,35 +14,41 @@ (in-package "COMPILER") +(defun c1expr-inner (form) + (declare (si::c-local)) + (cond ((symbolp form) + (setq form (chk-symbol-macrolet form)) + (cond ((not (symbolp form)) + form) + ((eq form nil) (c1nil)) + ((eq form t) (c1t)) + ((keywordp form) + (make-c1form* 'LOCATION :type (object-type form) + :args (add-symbol form))) + ((constantp form) + (or (c1constant-value (symbol-value form) :only-small-values t) + (c1var form))) + (t (c1var form)))) + ((consp form) + (cmpck (not (si::proper-list-p form)) + "Improper list found in lisp form~%~A" form) + (let ((fun (car form))) + (cond ((let ((fd (gethash fun *c1-dispatch-table*))) + (and fd (setf fun fd))) + (funcall fun (rest form))) + ((symbolp fun) + (c1call fun (cdr form) t)) + ((and (consp fun) (eq (car fun) 'LAMBDA)) + (c1funcall form)) + (t (cmperr "~s is not a legal function name." fun))))) + (t (c1constant-value form :always t)))) + (defun c1expr (form) (let ((*current-form* form)) - (setq form (catch *cmperr-tag* - (cond ((symbolp form) - (setq form (chk-symbol-macrolet form)) - (cond ((not (symbolp form)) - (c1expr form)) - ((eq form nil) (c1nil)) - ((eq form t) (c1t)) - ((keywordp form) - (make-c1form* 'LOCATION :type (object-type form) - :args (add-symbol form))) - ((constantp form) - (or (c1constant-value (symbol-value form) :only-small-values t) - (c1var form))) - (t (c1var form)))) - ((consp form) - (let ((fun (car form))) - (cond ((let ((fd (gethash fun *c1-dispatch-table*))) - (and fd (funcall fd (rest form))))) - ((symbolp fun) - (c1call fun (cdr form) t)) - ((and (consp fun) (eq (car fun) 'LAMBDA)) - (c1funcall form)) - (t (cmperr "~s is not a legal function name." fun))))) - (t (c1constant-value form :always t)))))) - (if (eq form '*cmperr-tag*) - (c1nil) - form)) + (loop + (setf form (c1expr-inner form)) + (when (c1form-p form) + (return form))))) (defvar *c1nil* (make-c1form* 'LOCATION :type (object-type nil) :args nil)) (defun c1nil () *c1nil*) @@ -57,16 +63,16 @@ (multiple-value-setq (fd success) (cmp-expand-compiler-macro fd fname args)) success)) - (c1expr fd)) + fd) ((and can-inline (progn (multiple-value-setq (fd success) (clos-compiler-macro-expand fname args)) success)) - (c1expr fd)) + fd) ((and macros-allowed (setq fd (cmp-macro-function fname))) - (c1expr (cmp-expand-macro fd (list* fname args)))) + (cmp-expand-macro fd (list* fname args))) ((and (setq can-inline (declared-inline-p fname)) (consp can-inline) (eq (first can-inline) 'function) @@ -74,7 +80,7 @@ (<= (cmp-env-optimization 'space) 1)) (let ((*inline-max-depth* (1- *inline-max-depth*))) (cmpnote "Inlining ~a" fname) - (c1expr `(funcall ,can-inline ,@args)))) + `(funcall ,can-inline ,@args))) (t (c1call-global fname args)))) (defun c1call-local (fname args) @@ -88,7 +94,7 @@ (plusp *inline-max-depth*)) (return-from c1call-local (let ((*inline-max-depth* (1- *inline-max-depth*))) - (c1expr `(funcall #',lambda ,@args)))))) + `(funcall #',lambda ,@args))))) (let* ((forms (c1args* args)) (return-type (or (get-local-return-type fun) 'T)) (arg-types (get-local-arg-types fun))) @@ -151,10 +157,9 @@ (push v all-values) (return nil)) finally - (let ((value (c1constant-value - (apply fname (nreverse all-values)) - :only-small-values nil))) - (return value))) + (return (c1constant-value + (apply fname (nreverse all-values)) + :only-small-values nil))) (error (c))))) (defun c2expr (form) diff --git a/src/cmp/cmpffi.lsp b/src/cmp/cmpffi.lsp index 4746ae8e3..69e9b4655 100755 --- a/src/cmp/cmpffi.lsp +++ b/src/cmp/cmpffi.lsp @@ -423,7 +423,7 @@ (unless (every #'stringp args) (cmperr "The argument to CLINES, ~s, is not a list of strings." args)) (setf *clines-string-list* (nconc *clines-string-list* (copy-list args))) - (c1expr '(progn))) + '(progn)) (defun output-clines (output-stream) (flet ((parse-one-string (s output-stream) diff --git a/src/cmp/cmpfun.lsp b/src/cmp/cmpfun.lsp index 750a0b7f4..c26a58173 100644 --- a/src/cmp/cmpfun.lsp +++ b/src/cmp/cmpfun.lsp @@ -21,11 +21,11 @@ (arguments (rest args))) (cond ((and (consp fun) (eq (first fun) 'LAMBDA)) - (c1expr (optimize-funcall/apply-lambda (cdr fun) arguments t))) + (optimize-funcall/apply-lambda (cdr fun) arguments t)) ((and (consp fun) (eq (first fun) 'EXT::LAMBDA-BLOCK)) (setf fun (macroexpand-1 fun)) - (c1expr (optimize-funcall/apply-lambda (cdr fun) arguments t))) + (optimize-funcall/apply-lambda (cdr fun) arguments t)) ((and (consp fun) (eq (first fun) 'FUNCTION) (consp (second fun)) diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index 757e9e233..97fa3b253 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -41,9 +41,6 @@ (defvar *current-c2form* nil) (defvar *compile-file-position* -1) (defvar *first-error* t) -(defconstant *cmperr-tag* (cons nil nil)) - -(defvar *active-handlers* nil) (defvar *active-protection* nil) (defvar *pending-actions* nil) diff --git a/src/cmp/cmpif.lsp b/src/cmp/cmpif.lsp index 1f5bb5259..10c3ac495 100644 --- a/src/cmp/cmpif.lsp +++ b/src/cmp/cmpif.lsp @@ -22,7 +22,7 @@ (c1form-constant-p test) (when constant-p (return-from c1if - (c1expr (if value (second args) (third args)))))) + (if value (second args) (third args))))) ;; Otherwise, normal IF form (let* ((true-branch (c1expr (second args))) (false-branch (c1expr (third args)))) @@ -39,7 +39,7 @@ (multiple-value-bind (constant-p value) (c1form-constant-p value) (when constant-p - (return-from c1not (c1expr (not value))))) + (return-from c1not (not value)))) (make-c1form* 'FMLA-NOT :type '(member t nil) :args value))) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index f45f93b2a..2cec69c07 100755 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -891,9 +891,7 @@ from the C language code. NIL means \"do not create the file\"." (with-open-file (*compiler-output2* h-pathname :direction :output :if-does-not-exist :create :if-exists :supersede) (wt-nl1 "#include " *cmpinclude*) - (catch *cmperr-tag* (ctop-write init-name - h-pathname - data-pathname)) + (ctop-write init-name h-pathname data-pathname) (terpri *compiler-output1*) (terpri *compiler-output2*)))) diff --git a/src/cmp/cmpmulti.lsp b/src/cmp/cmpmulti.lsp index 29992ab38..7189b5e62 100644 --- a/src/cmp/cmpmulti.lsp +++ b/src/cmp/cmpmulti.lsp @@ -21,7 +21,8 @@ (check-args-number 'MULTIPLE-VALUE-CALL args 1) (cond ;; (M-V-C #'FUNCTION) => (FUNCALL #'FUNCTION) - ((endp (rest args)) (c1funcall args)) + ((endp (rest args)) + (c1funcall args)) ;; (M-V-C #'FUNCTION (VALUES A ... Z)) => (FUNCALL #'FUNCTION A ... Z) ((and (= (length args) 2) (consp (setq forms (second args))) @@ -29,22 +30,21 @@ (c1funcall (list* (first args) (rest forms)))) ;; More complicated case. (t - (c1expr - (let ((function (gensym)) - (frame (gensym))) - `(with-stack ,frame - (let* ((,function ,(first args))) - ,@(loop for i in (rest args) - collect `(stack-push-values ,frame ,i)) - (si::apply-from-stack-frame ,frame ,function)))))))) + (let ((function (gensym)) + (frame (gensym))) + `(with-stack ,frame + (let* ((,function ,(first args))) + ,@(loop for i in (rest args) + collect `(stack-push-values ,frame ,i)) + (si::apply-from-stack-frame ,frame ,function))))))) (defun c1multiple-value-prog1 (args) (check-args-number 'MULTIPLE-VALUE-PROG1 args 1) - (c1expr (let ((frame (gensym))) - `(with-stack ,frame - (stack-push-values ,frame ,(first args)) - ,@(rest args) - (stack-pop ,frame))))) + (let ((frame (gensym))) + `(with-stack ,frame + (stack-push-values ,frame ,(first args)) + ,@(rest args) + (stack-pop ,frame)))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -132,13 +132,13 @@ (push `(setf ,var ,new-var) late-bindings))))) (let ((value (second args))) (cond (temp-vars - (c1expr `(let* (,@temp-vars) - (multiple-value-setq ,vars ,value) - ,@late-bindings))) + `(let* (,@temp-vars) + (multiple-value-setq ,vars ,value) + ,@late-bindings)) ((endp vars) - (c1expr `(values ,value))) + `(values ,value)) ((= (length vars) 1) - (c1expr `(setq ,(first vars) ,value))) + `(setq ,(first vars) ,value)) (t (setq value (c1expr value) vars (mapcar #'c1vref vars)) @@ -236,8 +236,8 @@ (init-form (pop args))) (when (= (length variables) 1) (return-from c1multiple-value-bind - (c1expr `(let* ((,(first variables) ,init-form)) - ,@args)))) + `(let* ((,(first variables) ,init-form)) + ,@args))) (multiple-value-bind (body ss ts is other-decls) (c1body args nil) (c1declare-specials ss) diff --git a/src/cmp/cmpstack.lsp b/src/cmp/cmpstack.lsp index 15bf1a072..2c972f5c0 100644 --- a/src/cmp/cmpstack.lsp +++ b/src/cmp/cmpstack.lsp @@ -47,14 +47,14 @@ (unwind-exit new-destination))) (defun c1innermost-stack-frame (args) - (c1expr `(c-inline () () :object ,+ecl-stack-frame-variable+ - :one-liner t :side-effects nil))) + `(c-inline () () :object ,+ecl-stack-frame-variable+ + :one-liner t :side-effects nil)) (defun c1stack-push (args) - (c1expr `(progn - (c-inline ,args (t t) :void "ecl_stack_frame_push(#0,#1)" - :one-liner t :side-effects t) - 1))) + `(progn + (c-inline ,args (t t) :void "ecl_stack_frame_push(#0,#1)" + :one-liner t :side-effects t) + 1)) (defun c1stack-push-values (args) (let ((frame-var (pop args)) @@ -71,11 +71,11 @@ (c2expr push-statement)) (defun c1stack-pop (args) - (c1expr `(c-inline ,args (t) (values &rest t) - "cl_env_copy->values[0]=ecl_stack_frame_pop_values(#0);" - :one-liner nil :side-effects t))) + `(c-inline ,args (t) (values &rest t) + "cl_env_copy->values[0]=ecl_stack_frame_pop_values(#0);" + :one-liner nil :side-effects t)) (defun c1apply-from-stack-frame (args) - (c1expr `(c-inline ,args (t t) (values &rest t) - "cl_env_copy->values[0]=ecl_apply_from_stack_frame(#0,#1);" - :one-liner nil :side-effects t))) + `(c-inline ,args (t t) (values &rest t) + "cl_env_copy->values[0]=ecl_apply_from_stack_frame(#0,#1);" + :one-liner nil :side-effects t)) diff --git a/src/cmp/cmpstructures.lsp b/src/cmp/cmpstructures.lsp index 3dab84260..f326b4e6a 100644 --- a/src/cmp/cmpstructures.lsp +++ b/src/cmp/cmpstructures.lsp @@ -51,13 +51,13 @@ (setf args (first args)) (cond ((eq structure-type 'list) - (c1expr `(elt ,args ,slot-index))) + `(elt ,args ,slot-index)) ((eq structure-type 'vector) - (c1expr `(svref ,args ,slot-index))) + `(svref ,args ,slot-index)) ((consp structure-type) - (c1expr `(aref (the ,structure-type ,args) ,slot-index))) + `(aref (the ,structure-type ,args) ,slot-index)) (t - (c1structure-ref `(,args ',structure-type ,slot-index)))))))) + `(,args ',structure-type ,slot-index))))))) (defun c1structure-ref (args) (check-args-number 'sys:structure-ref args 3) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index 1e12fa8ad..7b93f176c 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -29,34 +29,33 @@ (*current-form* form) (*first-error* t) (*setjmps* 0)) - (catch *cmperr-tag* - (when (consp form) - (let ((fun (car form)) (args (cdr form)) fd) - (when (member fun *toplevel-forms-to-print*) - (print-current-form)) - (cond - ((consp fun) (t1ordinary form)) - ((not (symbolp fun)) - (cmperr "~s is illegal function." fun)) - ((eq fun 'QUOTE) - (t1ordinary 'NIL)) - ((setq fd (gethash fun *t1-dispatch-table*)) - (funcall fd args)) - ((gethash fun *c1-dispatch-table*) - (t1ordinary form)) - ((and (setq fd (compiler-macro-function fun)) - (inline-possible fun) - (let ((success nil)) - (multiple-value-setq (fd success) - (cmp-expand-macro fd form)) - success)) - (push 'macroexpand *current-toplevel-form*) - (t1expr* fd)) - ((setq fd (cmp-macro-function fun)) - (push 'macroexpand *current-toplevel-form*) - (t1expr* (cmp-expand-macro fd form))) - (t (t1ordinary form)) - ))))) + (when (consp form) + (let ((fun (car form)) (args (cdr form)) fd) + (when (member fun *toplevel-forms-to-print*) + (print-current-form)) + (cond + ((consp fun) (t1ordinary form)) + ((not (symbolp fun)) + (cmperr "~s is illegal function." fun)) + ((eq fun 'QUOTE) + (t1ordinary 'NIL)) + ((setq fd (gethash fun *t1-dispatch-table*)) + (funcall fd args)) + ((gethash fun *c1-dispatch-table*) + (t1ordinary form)) + ((and (setq fd (compiler-macro-function fun)) + (inline-possible fun) + (let ((success nil)) + (multiple-value-setq (fd success) + (cmp-expand-macro fd form)) + success)) + (push 'macroexpand *current-toplevel-form*) + (t1expr* fd)) + ((setq fd (cmp-macro-function fun)) + (push 'macroexpand *current-toplevel-form*) + (t1expr* (cmp-expand-macro fd form))) + (t (t1ordinary form)) + )))) (defun t1/c1expr (form) (cond ((not *compile-toplevel*) diff --git a/src/cmp/cmptype-assert.lsp b/src/cmp/cmptype-assert.lsp index 5a90740c6..16de3a286 100644 --- a/src/cmp/cmptype-assert.lsp +++ b/src/cmp/cmptype-assert.lsp @@ -91,12 +91,12 @@ (type (pop args)) form form-type and-type) (cond ((or (trivial-type-p args) (not (policy-type-assertions))) - (c1expr value)) + value) ((and (policy-evaluate-forms) (constantp value)) (unless (typep (cmp-eval value) type) (cmpwarning "Failed type assertion for value ~A and type ~A" value type)) - (c1expr value)) + value) ;; Is the form type contained in the test? ((progn (setf form (c1expr value) diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp index 77fb1cffa..5341b6d61 100644 --- a/src/cmp/cmpvar.lsp +++ b/src/cmp/cmpvar.lsp @@ -351,7 +351,7 @@ (cmpck (constantp name) "The constant ~s is being assigned a value." name) (setq name (chk-symbol-macrolet name)) (unless (symbolp name) - (return-from c1setq1 (c1expr `(setf ,name ,form)))) + (return-from c1setq1 `(setf ,name ,form))) (let* ((name1 (c1vref name)) (form1 (c1expr form)) (v-type (var-type name1)) @@ -409,7 +409,7 @@ "The constant ~s is being assigned a value." var) (setq use-psetf t))) (when use-psetf - (return-from c1psetq (c1expr `(psetf ,@args)))) + (return-from c1psetq `(psetf ,@args))) (do ((l args (cddr l)) (vrefs '()) (forms '()))