Commit 7efb01d7 authored by Daniel Kochmański's avatar Daniel Kochmański
Browse files

cmp: separate type propagation pass

The type propagation is invoked with a function compiler-pass/propagate-types
before the compiler-pass2. Previously the type propagation was invoked in
ctop-write.
parent 8716c62f
......@@ -589,32 +589,32 @@ output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL);
#+dlopen
(apply #'builder :shared-library args))
(defun compile-file (input-pathname &rest args
&key
((:verbose *compile-verbose*) *compile-verbose*)
((:print *compile-print*) *compile-print*)
(source-truename nil)
(source-offset 0)
(c-file nil)
(h-file nil)
(data-file nil)
(system-p nil)
(load nil)
(external-format :default)
output-file
&aux (*standard-output* *standard-output*)
(*error-output* *error-output*)
(*compiler-in-use* *compiler-in-use*)
(*package* *package*)
(*readtable* *readtable*)
(*print-pretty* nil)
(*compile-file-pathname* nil)
(*compile-file-truename* nil)
(ext:*source-location* (cons source-truename 0))
(*suppress-compiler-messages*
(or *suppress-compiler-messages* (not *compile-verbose*)))
input-file
init-name)
(defun compile-file
(input-pathname &rest args
&key
((:verbose *compile-verbose*) *compile-verbose*)
((:print *compile-print*) *compile-print*)
(source-truename nil)
(source-offset 0)
(c-file nil)
(h-file nil)
(data-file nil)
(system-p nil)
(load nil)
(external-format :default)
output-file
&aux
(*standard-output* *standard-output*)
(*error-output* *error-output*)
(*compiler-in-use* *compiler-in-use*)
(*package* *package*)
(*readtable* *readtable*)
(*print-pretty* nil)
(*compile-file-pathname* nil)
(*compile-file-truename* nil)
(ext:*source-location* (cons source-truename 0))
(*suppress-compiler-messages* (or *suppress-compiler-messages*
(not *compile-verbose*))))
(declare (notinline compiler-cc))
"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,
......@@ -623,14 +623,12 @@ 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"
#-dlopen
(unless system-p
(format t "~%;;;~
~%;;; This system does not support loading dynamically linked libraries.~
~%;;; Therefore, COMPILE-FILE without :SYSTEM-P T is unsupported.~
~%;;;"))
(setq *compile-file-pathname* (pathname (merge-pathnames input-pathname)))
(unless (probe-file *compile-file-pathname*)
(if (pathname-type input-pathname)
......@@ -640,49 +638,40 @@ compiled successfully, returns the pathname of the compiled file"
(setq *compile-file-pathname* (make-pathname :type ext :defaults input-pathname))
(when (probe-file *compile-file-pathname*)
(return)))))
(setq input-file (truename *compile-file-pathname*)
*compile-file-truename* input-file)
(when (and system-p load)
(error "Cannot load system files."))
(cmpprogress "~&;;;~%;;; Compiling ~a." (namestring input-pathname))
(let* ((*compiler-in-use* *compiler-in-use*)
(let* ((input-file (truename *compile-file-pathname*))
(*compile-file-truename* input-file)
(*compiler-in-use* *compiler-in-use*)
(*load-time-values* nil) ;; Load time values are compiled
(output-file (apply #'compile-file-pathname input-file args))
(true-output-file nil) ;; Will be set at the end
(c-pathname (apply #'compile-file-pathname output-file :output-file c-file
:type :c args))
:type :c args))
(h-pathname (apply #'compile-file-pathname output-file :output-file h-file
:type :h args))
:type :h args))
(data-pathname (apply #'compile-file-pathname output-file
:output-file data-file :type :data args))
(compiler-conditions nil)
(to-delete (nconc (unless c-file (list c-pathname))
(unless h-file (list h-pathname))
(unless data-file (list data-pathname)))))
(unless data-file (list data-pathname))))
(init-name (compute-init-name output-file
:kind (if system-p :object :fasl))))
(with-compiler-env (compiler-conditions)
(print-compiler-info)
(when (probe-file "./cmpinit.lsp")
(load "./cmpinit.lsp" :verbose *compile-verbose*))
(with-open-file (stream *compile-file-pathname*
:external-format external-format)
(unless source-truename
(setf (car ext:*source-location*) *compile-file-pathname*))
(compiler-pass1 stream source-offset))
(setf init-name (compute-init-name output-file :kind
(if system-p :object :fasl)))
(compiler-pass/propagate-types)
(compiler-pass2 c-pathname h-pathname data-pathname init-name
:input-designator (namestring input-pathname))
(data-c-dump data-pathname)
(let ((o-pathname (if system-p
output-file
(compile-file-pathname output-file :type :object))))
......@@ -693,29 +682,24 @@ compiled successfully, returns the pathname of the compiled file"
(bundle-cc (si::coerce-to-filename output-file)
init-name
(list (si::coerce-to-filename o-pathname)))))
(if (setf true-output-file (probe-file output-file))
(cmpprogress "~&;;; Finished compiling ~a.~%;;;~%" (namestring input-pathname))
(cmpprogress "~&;;; Finished compiling ~a.~%;;;~%"
(namestring input-pathname))
(cmperr "The C compiler failed to compile the intermediate file."))
(mapc #'cmp-delete-file to-delete)
(when (and load true-output-file (not system-p))
(load true-output-file :verbose *compile-verbose*))
) ; with-compiler-env
(load true-output-file :verbose *compile-verbose*))) ; with-compiler-env
(compiler-output-values true-output-file compiler-conditions)))
(defun compiler-output-values (main-value conditions)
(loop for i in conditions
with warning-p = nil
with failure-p = nil
do (cond ((typep i 'style-warning)
(setf warning-p t))
((typep i '(or compiler-error warning))
(setf warning-p t failure-p t)))
finally (return (values main-value warning-p failure-p))))
with warning-p = nil
with failure-p = nil
do (cond ((typep i 'style-warning)
(setf warning-p t))
((typep i '(or compiler-error warning))
(setf warning-p t failure-p t)))
finally (return (values main-value warning-p failure-p))))
#-dlopen
(defun compile (name &optional (def nil supplied-p))
......@@ -793,6 +777,7 @@ after compilation."
(with-compiler-env (compiler-conditions)
(setf form (set-closure-env form lexenv *cmp-env-root*))
(compiler-pass1 form)
(compiler-pass/propagate-types)
(let (#+(or mingw32 msvc cygwin)(*self-destructing-fasl* t))
(compiler-pass2 c-pathname h-pathname data-pathname init-name
:input-designator (let* ((*print-circle* t)
......@@ -923,10 +908,23 @@ from the C language code. NIL means \"do not create the file\"."
(setf (cdr ext:*source-location*)
(+ source-offset *compile-file-position*))
(t1expr form)))
(t1expr object)))
(t1expr object))
(setq *top-level-forms* (nreverse *top-level-forms*))
(setq *make-forms* (nreverse *make-forms*)))
(defun compiler-pass/propagate-types ()
;; Type propagation phase
(when *do-type-propagation*
(setq *compiler-phase* 'p1propagate)
(dolist (form *top-level-forms*)
(p1propagate form nil))
(dolist (fun *local-funs*)
(p1propagate (fun-lambda fun) nil))))
(defun compiler-pass2 (c-pathname h-pathname data-pathname init-name
&key input-designator)
(setq *compiler-phase* 't2)
(with-open-file (*compiler-output1* c-pathname :direction :output
:if-does-not-exist :create
:if-exists :supersede)
......
......@@ -33,7 +33,6 @@
&aux def top-output-string
(*volatile* "volatile "))
(setq *top-level-forms* (nreverse *top-level-forms*))
(wt-nl "#include \"" (brief-namestring h-pathname) "\"")
;; VV might be needed by functions in CLINES.
......@@ -91,19 +90,7 @@
(wt-nl "ECL_DEFINE_SETF_FUNCTIONS")
;; Type propagation phase
(when *do-type-propagation*
(setq *compiler-phase* 'p1propagate)
(dolist (form *top-level-forms*)
(when form
(p1propagate form nil)))
(dolist (fun *local-funs*)
(p1propagate (fun-lambda fun) nil)))
(setq *compiler-phase* 't2)
(loop for form in (nconc (reverse *make-forms*) *top-level-forms*)
(loop for form in (nconc *make-forms* *top-level-forms*)
do (emit-toplevel-form form c-output-file))
(wt-nl-close-many-braces 0)
(setq top-output-string (get-output-stream-string *compiler-output1*)))
......
......@@ -15,7 +15,7 @@
(in-package "COMPILER")
(eval-when (:execute :compile-toplevel)
(eval-when (:execute :load-toplevel :compile-toplevel)
(defparameter *type-propagation-messages* nil)
(defmacro prop-message (string &rest args)
(when *type-propagation-messages*
......@@ -31,21 +31,19 @@
(unless form
(return-from p1propagate (values 'null assumptions)))
(when (c1form-p form)
(let* ((*cmp-env* (c1form-env form))
(*compile-file-pathname* (c1form-file form))
(*compile-file-position* (c1form-file-position form))
(*current-form* (c1form-form form))
(*current-toplevel-form* (c1form-toplevel-form form))
(name (c1form-name form))
(propagator (gethash name *p1-dispatch-table*)))
(when propagator
(let ((*cmp-env* (c1form-env form))
(*compile-file-pathname* (c1form-file form))
(*compile-file-position* (c1form-file-position form))
(*current-form* (c1form-form form))
(*current-toplevel-form* (c1form-toplevel-form form))
(name (c1form-name form)))
(when-let ((propagator (gethash name *p1-dispatch-table*)))
(prop-message "~&;;; Entering type propagation for ~A" name)
(multiple-value-bind (new-type assumptions)
(apply propagator form assumptions (c1form-args form))
(when assumptions
(baboon :format-control "Non-empty assumptions found in P1PROPAGATE"))
(prop-message "~&;;; Propagating ~A gives type ~A" name
new-type)
(prop-message "~&;;; Propagating ~A gives type ~A" name new-type)
(return-from p1propagate
(values (setf (c1form-type form)
(values-type-and (c1form-type form)
......
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