From 7efb01d7d1307ba116c7db46552a8c85e91547e2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 12 May 2021 15:55:08 +0200 Subject: [PATCH] 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. --- src/cmp/cmpmain.lsp | 122 +++++++++++++++++++-------------------- src/cmp/cmppass2-top.lsp | 15 +---- src/cmp/cmpprop.lsp | 20 +++---- 3 files changed, 70 insertions(+), 87 deletions(-) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index 277e781f4..8b4e2e36b 100644 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -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) diff --git a/src/cmp/cmppass2-top.lsp b/src/cmp/cmppass2-top.lsp index a18bed257..e5ea55832 100644 --- a/src/cmp/cmppass2-top.lsp +++ b/src/cmp/cmppass2-top.lsp @@ -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*))) diff --git a/src/cmp/cmpprop.lsp b/src/cmp/cmpprop.lsp index 73d76b4ef..1ff327d6a 100644 --- a/src/cmp/cmpprop.lsp +++ b/src/cmp/cmpprop.lsp @@ -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)