Commit c2e2171d authored by Juan Jose Garcia Ripoll's avatar Juan Jose Garcia Ripoll
Browse files

Avoid recursive invocation of C1EXPR by allowing the C1 processors to act like...

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.
parent 24c0b37d
......@@ -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)))))
......
......@@ -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+
......
......@@ -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))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
......
......@@ -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)
......
......@@ -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)
......
......@@ -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))
......
......@@ -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)
......
......@@ -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)))
......
......@@ -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*))))
......
......@@ -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)
......
......@@ -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))
......@@ -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)
......
......@@ -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*)
......
......@@ -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)
......
......@@ -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 '()))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment