mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-25 14:01:07 -08:00
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.
This commit is contained in:
Daniel Kochmański
parent
8716c62f6d
commit
7efb01d7d1
3 changed files with 70 additions and 87 deletions
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue